Branch data Line data Source code
1 : : !!****m* ABINIT/m_numeric_tools
2 : : !! NAME
3 : : !! m_numeric_tools
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains basic tools for numeric computations.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2008-2026 ABINIT group (MG, GMR, MJV, XG, MVeithen, NH, FJ, MT, DCS, FrD, Olevano, Reining, Sottile, AL)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : MODULE m_numeric_tools
23 : :
24 : : use defs_basis
25 : : use m_errors
26 : : use m_abicore
27 : : use m_linalg_interfaces
28 : :
29 : : use m_fstrings, only : itoa, sjoin
30 : :
31 : : implicit none
32 : :
33 : : private
34 : :
35 : : public :: arth ! Return an arithmetic progression.
36 : : public :: linspace ! Similar to the above but with start, stop and num of division
37 : : public :: geop ! Return a geometric progression
38 : : public :: reverse ! Reverse a 1D array *IN PLACE*
39 : : public :: set2unit ! Set the matrix to be a unit matrix (if it is square)
40 : : public :: get_trace ! Calculate the trace of a square matrix
41 : : public :: get_diag ! Return the diagonal of a matrix as a vector
42 : : public :: isdiagmat ! True if matrix is diagonal
43 : : public :: l2int ! convert logical data to int array
44 : : public :: r2c, c2r ! Transfer complex data stored in a real array to a complex array and vice versa
45 : : public :: iseven ! True if int is even
46 : : public :: isinteger ! True if all elements of rr differ from an integer by less than tol
47 : : public :: is_zero ! True if all elements of rr differ from zero by less than tol
48 : : public :: inrange ! True if (int/float) is inside an interval.
49 : : public :: bisect ! Given a monotonic array A and x find j such that A(j)>x>A(j+1) using bisection
50 : : public :: imax_loc ! Index of maxloc on an array returned as scalar instead of array-valued quantity
51 : : public :: imin_loc ! Index of minloc on an array returned as scalar instead of array-valued quantity
52 : : public :: lfind ! Find the index of the first occurrence of .True. in a logical array.
53 : : public :: list2blocks ! Given a list of integers, find the number of contiguous groups of values.
54 : : public :: mask2blocks ! Find groups of .TRUE. elements in a logical mask.
55 : : public :: linfit ! Perform a linear fit, y = ax + b, of data
56 : : public :: llsfit_svd ! Linear least squares fit with SVD of an user-defined set of functions
57 : : public :: polyn_interp ! Polynomial interpolation with Nevilles"s algorithms, error estimate is reported
58 : : public :: polcoe ! Extract coefficients of polynomial interpolation (Numerical Recipes)
59 : : public :: quadrature ! Driver routine for performing quadratures in finite domains using different algorithms
60 : : public :: cspint ! Estimates the integral of a tabulated function.
61 : : public :: ctrap ! Corrected trapezoidal integral on uniform grid of spacing hh.
62 : : public :: coeffs_gausslegint ! Compute the coefficients (supports and weights) for Gauss-Legendre integration.
63 : : public :: simpson_cplx ! Integrate a complex function via extended Simpson's rule.
64 : : public :: hermitianize ! Force a square matrix to be hermitian
65 : : public :: mkherm ! Make the complex array(2,ndim,ndim) hermitian, by adding half of it to its hermitian conjugate.
66 : : public :: hermit ! Rdefine diagonal elements of packed matrix to impose Hermiticity.
67 : : public :: symmetrize ! Force a square matrix to be symmetric
68 : : public :: pack_matrix ! Packs a matrix into hermitian format
69 : : public :: check_vec_conjg ! Test whether two complex vectors are the conjugate of each other.
70 : : public :: print_arr ! Print a vector/array
71 : : public :: pade, dpade ! Functions for Pade approximation (complex case)
72 : : public :: newrap_step ! Apply single step Newton-Raphson method to find root of a complex function
73 : : public :: OPERATOR(.x.) ! Cross product of two 3D vectors
74 : : public :: l2norm ! Return the length (ordinary L2 norm) of a vector
75 : : public :: remove_copies ! Find the subset of inequivalent items in a list.
76 : : public :: denominator ! Return the denominator of a rational number.
77 : : public :: mincm ! Return the minimum common multiple of two integers.
78 : : public :: continued_fract ! Routine to calculate the continued fraction (see description).
79 : : public :: cmplx_sphcart ! Convert an array of cplx numbers from spherical to Cartesian coordinates or vice versa.
80 : : public :: pfactorize ! Factorize a number in terms of an user-specified set of prime factors.
81 : : public :: isordered ! Check the ordering of a sequence.
82 : : public :: wrap2_zero_one ! Transforms a real number in a reduced number in the interval [0,1[ ! where 1 is not included (tol12)
83 : : public :: wrap2_pmhalf ! Transforms a real number in areduced number in the interval ]-1/2,1/2] ! where -1/2 is not included (tol12)
84 : : public :: interpol1d ! Linear interpolation in 1D
85 : : public :: interpol1d_c ! Linear interpolation in 1D for complex data
86 : : public :: interpol3d_0d ! Linear interpolation in 3D
87 : : public :: interpol3d_1d ! Linear interpolation in 3D for an array
88 : : public :: interpol3d_indices ! Computes the indices in a cube which are neighbors to the point to be interpolated in interpol3d
89 : : public :: interpolate_denpot ! Liner interpolation of scalar field e.g. density of potential
90 : : public :: interpolate_ur ! Liner interpolation of complex wavefunctions (single and double precision version)
91 : : public :: simpson_int ! Simpson integral of a tabulated function. Returns arrays with integrated values
92 : : public :: simpson ! Simpson integral of a tabulated function. Returns scalar with the integral on the full mesh.
93 : : public :: rhophi ! Compute the phase and the module of a complex number.
94 : : public :: smooth ! Smooth data.
95 : : public :: nderiv ! Compute first or second derivative of input function y(x) on a regular grid.
96 : : public :: central_finite_diff ! Coefficients of the central differences, for several orders of accuracy.
97 : : public :: uniformrandom ! Returns a uniform random deviate between 0.0 and 1.0.
98 : : public :: findmin ! Compute the minimum of a function whose value and derivative are known at two points.
99 : : public :: kramerskronig ! check or apply the Kramers Kronig relation
100 : : public :: invcb ! Compute a set of inverse cubic roots as fast as possible.
101 : : public :: safe_div ! Performs 'save division' that is to prevent overflow, underflow, NaN or infinity errors
102 : : public :: bool2index ! Allocate and return array with the indices in the input boolean array that evaluates to .True.
103 : : public :: polynomial_regression ! Perform a polynomial regression on incoming data points
104 : : public :: blocked_loop ! Helper function to implement blocked algorithms inside do loops.
105 : : public :: geteuler ! Compute the Euler angles corresponding to the spin quantization axis
106 : : public :: euclid_div ! Compute the Euclidian integer division.
107 : :
108 : : !MG FIXME: deprecated: just to avoid updating refs while refactoring.
109 : : public :: dotproduct
110 : :
111 : : interface arth
112 : : module procedure arth_int
113 : : module procedure arth_rdp
114 : : end interface arth
115 : :
116 : : interface reverse
117 : : module procedure reverse_int
118 : : module procedure reverse_rdp
119 : : end interface reverse
120 : :
121 : : interface set2unit
122 : : module procedure unit_matrix_int
123 : : module procedure unit_matrix_rdp
124 : : module procedure unit_matrix_cdp
125 : : end interface set2unit
126 : :
127 : : interface get_trace
128 : : module procedure get_trace_int
129 : : module procedure get_trace_rdp
130 : : module procedure get_trace_cdp
131 : : end interface get_trace
132 : :
133 : : interface interpolate_ur
134 : : module procedure interpolate_ur_spc
135 : : module procedure interpolate_ur_dpc
136 : : end interface interpolate_ur
137 : :
138 : : !interface cart_prod33
139 : : ! module procedure cart_prod33_int
140 : : ! module procedure cart_prod33_rdp
141 : : ! module procedure cart_prod33_cdp
142 : : !end interface cart_prod33
143 : :
144 : : interface get_diag
145 : : module procedure get_diag_int
146 : : module procedure get_diag_rdp
147 : : module procedure get_diag_cdp
148 : : end interface get_diag
149 : :
150 : : interface isdiagmat
151 : : module procedure isdiagmat_int
152 : : module procedure isdiagmat_rdp
153 : : !module procedure isdiagmat_cdp
154 : : end interface isdiagmat
155 : :
156 : : interface inrange
157 : : module procedure inrange_int
158 : : module procedure inrange_dp
159 : : end interface inrange
160 : :
161 : : interface l2int
162 : : module procedure l2int_1D
163 : : module procedure l2int_2D
164 : : module procedure l2int_3D
165 : : end interface l2int
166 : :
167 : : interface r2c
168 : : module procedure rdp2cdp_0D
169 : : module procedure rdp2cdp_1D
170 : : module procedure rdp2cdp_2D
171 : : module procedure rdp2cdp_3D
172 : : module procedure rdp2cdp_4D
173 : : module procedure rdp2cdp_5D
174 : : module procedure rdp2cdp_6D
175 : : end interface r2c
176 : :
177 : : interface c2r
178 : : module procedure cdp2rdp_0D
179 : : module procedure cdp2rdp_1D
180 : : module procedure cdp2rdp_2D
181 : : module procedure cdp2rdp_3D
182 : : module procedure cdp2rdp_4D
183 : : module procedure cdp2rdp_5D
184 : : module procedure cdp2rdp_6D
185 : : end interface c2r
186 : :
187 : : interface isinteger
188 : : module procedure is_integer_0d
189 : : module procedure is_integer_1d
190 : : end interface isinteger
191 : :
192 : : interface is_zero
193 : : module procedure is_zero_rdp_0d
194 : : module procedure is_zero_rdp_1d
195 : : end interface is_zero
196 : :
197 : : interface bisect
198 : : module procedure bisect_rdp
199 : : module procedure bisect_int
200 : : end interface bisect
201 : :
202 : : interface imax_loc
203 : : module procedure imax_loc_int
204 : : module procedure imax_loc_rdp
205 : : end interface imax_loc
206 : :
207 : : interface imin_loc
208 : : module procedure imin_loc_int
209 : : module procedure imin_loc_rdp
210 : : end interface imin_loc
211 : :
212 : : interface linfit
213 : : module procedure linfit_rdp
214 : : module procedure linfit_spc
215 : : module procedure linfit_dpc
216 : : end interface linfit
217 : :
218 : : interface hermitianize
219 : : module procedure hermitianize_spc
220 : : module procedure hermitianize_dpc
221 : : end interface hermitianize
222 : :
223 : : interface symmetrize
224 : : module procedure symmetrize_spc
225 : : module procedure symmetrize_dpc
226 : : end interface symmetrize
227 : :
228 : : interface print_arr !TODO add prtm
229 : : module procedure print_arr1d_spc
230 : : module procedure print_arr1d_dpc
231 : : module procedure print_arr2d_spc
232 : : module procedure print_arr2d_dpc
233 : : end interface print_arr
234 : :
235 : : interface operator (.x.)
236 : : module procedure cross_product_int
237 : : module procedure cross_product_rdp
238 : : end interface
239 : :
240 : : interface l2norm
241 : : module procedure l2norm_rdp
242 : : end interface l2norm
243 : :
244 : : interface isordered
245 : : module procedure isordered_rdp
246 : : end interface isordered
247 : : !!***
248 : :
249 : : !----------------------------------------------------------------------
250 : :
251 : : !!****t* m_numeric_tools/stats_t
252 : : !! NAME
253 : : !! stats_t
254 : : !!
255 : : !! FUNCTION
256 : : !! Statistical parameters of a data distribution.
257 : : !!
258 : : !! SOURCE
259 : :
260 : : type, public :: stats_t
261 : : real(dp) :: mean
262 : : real(dp) :: stdev
263 : : real(dp) :: min
264 : : real(dp) :: max
265 : : end type stats_t
266 : :
267 : : public :: stats_eval ! Calculate statistical parameters of a data distribution.
268 : : !!***
269 : :
270 : : !----------------------------------------------------------------------
271 : :
272 : : !!****t* m_numeric_tools/vdiff_t
273 : : !! NAME
274 : : !! vdiff_t
275 : : !!
276 : : !! FUNCTION
277 : : !! Estimate the "distance" between two functions tabulated on a homogeneous grid.
278 : : !! Use `vidff` function to construct the object.
279 : : !!
280 : : !! SOURCE
281 : :
282 : : type,public :: vdiff_t
283 : :
284 : : real(dp) :: int_adiff = zero ! \int |f1-f2| dr
285 : : real(dp) :: mean_adiff = zero ! Mean {|f1-f2|}
286 : : real(dp) :: stdev_adiff = zero ! Standard deviation of {|f1-f2|}
287 : : real(dp) :: min_adiff = zero ! Min {|f1-f2|}
288 : : real(dp) :: max_adiff = zero ! Max {|f1-f2|}
289 : : real(dp) :: l1_rerr = zero ! (\int |f1-f2| dr) / (\int |f2| dr)
290 : :
291 : : contains
292 : :
293 : : procedure :: eval => vdiff_eval ! Estimate the "distance" between two functions tabulated on a homogeneous grid.
294 : : procedure :: print => vdiff_print ! Print vdiff_t to formatted file.
295 : :
296 : : end type vdiff_t
297 : :
298 : : !!***
299 : :
300 : : !===========================================================
301 : : ! A single non-empty bin
302 : : !===========================================================
303 : : type :: bin_t
304 : : integer :: npts = 0
305 : : real(dp) :: xmin = 0.0_dp
306 : : real(dp) :: xmax = 0.0_dp
307 : : integer, allocatable :: idx(:) ! indices into x(:)
308 : : !contains
309 : : ! procedure :: average => bin_average
310 : : ! procedure :: size => bin_size
311 : : end type bin_t
312 : :
313 : : !===========================================================
314 : : ! Bins container: only store non-empty bins
315 : : !===========================================================
316 : : type, public :: bins_t
317 : : real(dp), pointer :: xvals(:) => null()
318 : :
319 : : integer :: total_points = 0
320 : : integer :: nbins = 0 ! number of non-empty bins
321 : :
322 : : type(bin_t), allocatable :: bin(:)
323 : :
324 : : ! Binning metadata
325 : : real(dp) :: xmin = zero
326 : : real(dp) :: xmax = zero
327 : : real(dp) :: dx = zero
328 : : contains
329 : : procedure :: init => bins_init
330 : : !procedure :: free => bins_free
331 : : !procedure :: loop => bins_loop
332 : : end type bins_t
333 : : !!***
334 : :
335 : : contains !===========================================================
336 : : !!***
337 : :
338 : : !!****f* m_numeric_tools/arth_int
339 : : !! NAME
340 : : !! arth_int
341 : : !!
342 : : !! FUNCTION
343 : : !! Returns an array of length nn containing an arithmetic progression whose
344 : : !! starting value is start and whose step is step.
345 : : !!
346 : : !! INPUTS
347 : : !! start=initial point
348 : : !! step=the increment
349 : : !! nn=the number of points
350 : : !!
351 : : !! OUTPUT
352 : : !! arth(nn)=the progression
353 : : !!
354 : : !! SOURCE
355 : :
356 [ # # ]: 0 : pure function arth_int(start, step, nn)
357 : :
358 : : !Arguments ------------------------------------
359 : : !scalars
360 : : integer,intent(in) :: nn
361 : : integer,intent(in) :: start,step
362 : : integer :: arth_int(nn)
363 : :
364 : : !Local variables-------------------------------
365 : : integer :: ii
366 : : ! *********************************************************************
367 : :
368 : 0 : select case (nn)
369 : :
370 : : case (1:)
371 : 0 : arth_int(1)=start
372 [ # # ]: 0 : do ii=2,nn
373 : 0 : arth_int(ii)=arth_int(ii-1)+step
374 : : end do
375 : :
376 : : case (0)
377 [ # # ]: 0 : return
378 : : end select
379 : :
380 : : end function arth_int
381 : : !!***
382 : :
383 : : !----------------------------------------------------------------------
384 : :
385 : : !!****f* m_numeric_tools/arth_rdp
386 : : !! NAME
387 : : !! arth_rdp
388 : : !!
389 : : !! FUNCTION
390 : : !!
391 : : !! INPUTS
392 : : !!
393 : : !! OUTPUT
394 : : !!
395 : : !! SOURCE
396 : :
397 [ - + ]: 482596 : pure function arth_rdp(start, step, nn)
398 : :
399 : : !Arguments ------------------------------------
400 : : !scalars
401 : : integer,intent(in) :: nn
402 : : real(dp),intent(in) :: start,step
403 : : real(dp) :: arth_rdp(nn)
404 : :
405 : : !Local variables-------------------------------
406 : : integer :: ii
407 : : ! *********************************************************************
408 : :
409 : 482596 : select case (nn)
410 : : case (1:)
411 : 482596 : arth_rdp(1)=start
412 [ + + ]: 5049760 : do ii=2,nn
413 : 5049760 : arth_rdp(ii)=arth_rdp(ii-1)+step
414 : : end do
415 : :
416 : : case (0)
417 [ + - ]: 482596 : return
418 : : end select
419 : :
420 : : end function arth_rdp
421 : : !!***
422 : :
423 : : !----------------------------------------------------------------------
424 : :
425 : : !!****f* m_numeric_tools/linspace
426 : : !! NAME
427 : : !! linspace
428 : : !!
429 : : !! FUNCTION
430 : : !!
431 : : !! INPUTS
432 : : !!
433 : : !! OUTPUT
434 : : !!
435 : : !! SOURCE
436 : :
437 [ - + ]: 12520 : pure function linspace(start, stop, nn)
438 : :
439 : : !Arguments ------------------------------------
440 : : !scalars
441 : : integer,intent(in) :: nn
442 : : real(dp),intent(in) :: start, stop
443 : : real(dp) :: linspace(nn)
444 : :
445 : : !Local variables-------------------------------
446 : : real(dp) :: length
447 : : integer :: ii
448 : : ! *********************************************************************
449 : :
450 : 12520 : select case (nn)
451 : : case (1:)
452 : 12520 : length = stop - start
453 [ + + ]: 31953847 : do ii=1,nn
454 : 31953847 : linspace(ii) = start + length * (ii-1) / (nn-1)
455 : : end do
456 : :
457 : : case (0)
458 [ + - ]: 12520 : return
459 : : end select
460 : :
461 : : end function linspace
462 : : !!***
463 : :
464 : :
465 : : !----------------------------------------------------------------------
466 : :
467 : : !!****f* m_numeric_tools/geop
468 : : !! NAME
469 : : !! geop
470 : : !!
471 : : !! FUNCTION
472 : : !! Returns an array of length nn containing a geometric progression whose
473 : : !! starting value is start and whose factor is factor!
474 : : !!
475 : : !! INPUTS
476 : : !! start=initial point
477 : : !! factor=the factor of the geometric progression
478 : : !! nn=the number of points
479 : : !!
480 : : !! OUTPUT
481 : : !! geop(nn)=the progression
482 : : !!
483 : : !! SOURCE
484 : :
485 : :
486 [ # # ]: 0 : pure function geop(start,factor,nn) result(res)
487 : :
488 : : !Arguments ------------------------------------
489 : : !scalars
490 : : real(dp),intent(in) :: start,factor
491 : : integer,intent(in) :: nn
492 : : real(dp) :: res(nn)
493 : :
494 : : !Local variables-------------------------------
495 : : integer :: ii
496 : : ! *********************************************************************
497 : :
498 [ # # ]: 0 : if (nn>0) res(1)=start
499 [ # # ]: 0 : do ii=2,nn
500 : 0 : res(ii)=res(ii-1)*factor
501 : : end do
502 : :
503 : 0 : end function geop
504 : : !!***
505 : :
506 : : !----------------------------------------------------------------------
507 : :
508 : : !!****f* m_numeric_tools/reverse_int
509 : : !! NAME
510 : : !! reverse_int
511 : : !!
512 : : !! FUNCTION
513 : : !! Reverse a 1D array *IN PLACE*. Target: INT arrays
514 : : !!
515 : : !! SOURCE
516 : :
517 [ # # ]: 0 : subroutine reverse_int(arr)
518 : :
519 : : !Arguments ------------------------------------
520 : : !scalars
521 : : integer,intent(inout) :: arr(:)
522 : : !arrays
523 : : integer :: ii,nn,swap
524 : : ! *************************************************************************
525 : :
526 : 0 : nn = SIZE(arr)
527 [ # # ]: 0 : if (nn <= 1) return
528 : :
529 [ # # ]: 0 : do ii=1,nn/2
530 : 0 : swap = arr(ii)
531 : 0 : arr(ii) = arr(nn-ii+1)
532 : 0 : arr(nn-ii+1) = swap
533 : : end do
534 : :
535 : : end subroutine reverse_int
536 : : !!***
537 : :
538 : : !----------------------------------------------------------------------
539 : :
540 : : !!****f* m_numeric_tools/reverse_rdp
541 : : !! NAME
542 : : !! reverse_rdp
543 : : !!
544 : : !! FUNCTION
545 : : !! Reverse a 1D array *IN PLACE*. Target: DP arrays
546 : : !!
547 : : !! SOURCE
548 : :
549 [ # # ]: 0 : subroutine reverse_rdp(arr)
550 : :
551 : : !Arguments ------------------------------------
552 : : !scalars
553 : : real(dp),intent(inout) :: arr(:)
554 : : !arrays
555 : : integer :: ii,nn
556 : : real(dp) :: swap
557 : : ! *************************************************************************
558 : :
559 : 0 : nn = SIZE(arr)
560 [ # # ]: 0 : if (nn <= 1) return
561 : :
562 [ # # ]: 0 : do ii=1,nn/2
563 : 0 : swap = arr(ii)
564 : 0 : arr(ii) = arr(nn-ii+1)
565 : 0 : arr(nn-ii+1) = swap
566 : : end do
567 : :
568 : : end subroutine reverse_rdp
569 : : !!***
570 : :
571 : : !----------------------------------------------------------------------
572 : :
573 : : !!****f* m_numeric_tools/unit_matrix_int
574 : : !! NAME
575 : : !! unit_matrix_int
576 : : !!
577 : : !! FUNCTION
578 : : !! Set the matrix matrix to be a unit matrix (if it is square).
579 : : !!
580 : : !! SIDE EFFECTS
581 : : !! matrix(:,:)=set to unit on exit
582 : : !!
583 : : !! SOURCE
584 : :
585 [ - + ]: 17 : pure subroutine unit_matrix_int(matrix)
586 : :
587 : : !Arguments ------------------------------------
588 : : integer,intent(inout) :: matrix(:,:)
589 : :
590 : : !Local variables-------------------------------
591 : : !scalars
592 : : integer :: ii,nn
593 : : ! *********************************************************************
594 : :
595 : 17 : nn=MIN(SIZE(matrix,DIM=1),SIZE(matrix,DIM=2))
596 [ + + + + ]: 221 : matrix(:,:)=0
597 [ + + ]: 68 : do ii=1,nn
598 : 68 : matrix(ii,ii)=1
599 : : end do
600 : :
601 : 17 : end subroutine unit_matrix_int
602 : : !!***
603 : :
604 : : !----------------------------------------------------------------------
605 : :
606 : : !!****f* m_numeric_tools/unit_matrix_rdp
607 : : !! NAME
608 : : !! unit_matrix_rdp
609 : : !!
610 : : !! FUNCTION
611 : : !! Set the matrix matrix to be a unit matrix (if it is square).
612 : : !!
613 : : !! SIDE EFFECTS
614 : : !! matrix(:,:)=set to unit on exit
615 : : !!
616 : : !! SOURCE
617 : :
618 [ # # ]: 0 : pure subroutine unit_matrix_rdp(matrix)
619 : :
620 : : !Arguments ------------------------------------
621 : : real(dp),intent(inout) :: matrix(:,:)
622 : :
623 : : !Local variables-------------------------------
624 : : integer :: ii,nn
625 : : ! *********************************************************************
626 : :
627 : 0 : nn=MIN(SIZE(matrix,DIM=1),SIZE(matrix,DIM=2))
628 [ # # # # ]: 0 : matrix(:,:)=zero
629 [ # # ]: 0 : do ii=1,nn
630 : 0 : matrix(ii,ii)=one
631 : : end do
632 : :
633 : 0 : end subroutine unit_matrix_rdp
634 : : !!***
635 : :
636 : : !----------------------------------------------------------------------
637 : :
638 : : !!****f* m_numeric_tools/unit_matrix_cdp
639 : : !! NAME
640 : : !! unit_matrix_cdp
641 : : !!
642 : : !! FUNCTION
643 : : !! Set the matrix matrix to be a unit matrix (if it is square).
644 : : !!
645 : : !! SIDE EFFECTS
646 : : !! matrix(:,:)=set to unit on exit
647 : : !!
648 : : !! SOURCE
649 : :
650 [ # # ]: 0 : pure subroutine unit_matrix_cdp(matrix)
651 : :
652 : : !Arguments ------------------------------------
653 : : complex(dp),intent(inout) :: matrix(:,:)
654 : :
655 : : !Local variables-------------------------------
656 : : integer :: ii,nn
657 : : ! *********************************************************************
658 : :
659 : 0 : nn=MIN(SIZE(matrix,DIM=1),SIZE(matrix,DIM=2))
660 [ # # # # ]: 0 : matrix=czero
661 [ # # ]: 0 : do ii=1,nn
662 : 0 : matrix(ii,ii)=cone
663 : : end do
664 : :
665 : 0 : end subroutine unit_matrix_cdp
666 : : !!***
667 : :
668 : : !----------------------------------------------------------------------
669 : :
670 : : !!****f* m_numeric_tools/get_trace_int
671 : : !! NAME
672 : : !! get_trace_int
673 : : !!
674 : : !! FUNCTION
675 : : !! Calculate the trace of a square matrix
676 : : !!
677 : : !! INPUTS
678 : : !! matrix(:,:)
679 : : !!
680 : : !! OUTPUT
681 : : !! trace=the trace
682 : : !!
683 : : !! SOURCE
684 : :
685 [ # # ]: 0 : integer pure function get_trace_int(matrix) result(trace)
686 : :
687 : : !Arguments ------------------------------------
688 : : integer,intent(in) :: matrix(:,:)
689 : :
690 : : !Local variables-------------------------------
691 : : integer :: ii
692 : : ! *********************************************************************
693 : :
694 : 0 : trace=0
695 [ # # ]: 0 : do ii=1,size(matrix,dim=1)
696 : 0 : trace=trace+matrix(ii,ii)
697 : : end do
698 : :
699 : 0 : end function get_trace_int
700 : : !!***
701 : :
702 : : !----------------------------------------------------------------------
703 : :
704 : : !!****f* m_numeric_tools/get_trace_rdp
705 : : !! NAME
706 : : !! get_trace_int
707 : : !!
708 : : !! FUNCTION
709 : : !! Calculate the trace of a square matrix (real(dp) version)
710 : : !!
711 : : !! INPUTS
712 : : !! matrix(:,:)
713 : : !!
714 : : !! OUTPUT
715 : : !! trace=the trace
716 : : !!
717 : : !! SOURCE
718 : :
719 [ - + ]: 4974 : real(dp) pure function get_trace_rdp(matrix) result(trace)
720 : :
721 : : !Arguments ------------------------------------
722 : : real(dp),intent(in) :: matrix(:,:)
723 : :
724 : : !Local variables-------------------------------
725 : : integer :: ii
726 : : ! *********************************************************************
727 : :
728 : 4974 : trace=zero
729 [ + + ]: 19896 : do ii=1,size(matrix,dim=1)
730 : 19896 : trace=trace+matrix(ii,ii)
731 : : end do
732 : :
733 : 4974 : end function get_trace_rdp
734 : : !!***
735 : :
736 : : !----------------------------------------------------------------------
737 : :
738 : : !!****f* m_numeric_tools/get_trace_cdp
739 : : !! NAME
740 : : !! get_trace_cdp
741 : : !!
742 : : !! FUNCTION
743 : : !! Calculate the trace of a square matrix (complex(dp) version)
744 : : !!
745 : : !! INPUTS
746 : : !!
747 : : !! OUTPUT
748 : : !!
749 : : !! SOURCE
750 : :
751 [ # # ]: 0 : complex(dp) pure function get_trace_cdp(matrix) result(trace)
752 : :
753 : : !Arguments ------------------------------------
754 : : complex(dp),intent(in) :: matrix(:,:)
755 : :
756 : : !Local variables-------------------------------
757 : : integer :: ii
758 : : ! *********************************************************************
759 : :
760 : 0 : trace=czero
761 [ # # ]: 0 : do ii=1,size(matrix,dim=1)
762 : 0 : trace=trace+matrix(ii,ii)
763 : : end do
764 : :
765 : 0 : end function get_trace_cdp
766 : : !!***
767 : :
768 : : !!****f* m_numeric_tools/get_diag_int
769 : : !! NAME
770 : : !! get_diag_int
771 : : !!
772 : : !! FUNCTION
773 : : !! Return the diagonal of a square matrix as a vector
774 : : !!
775 : : !! INPUTS
776 : : !! matrix(:,:)
777 : : !!
778 : : !! OUTPUT
779 : : !! diag(:)=the diagonal
780 : : !!
781 : : !! SOURCE
782 : :
783 [ - + - + ]: 43 : function get_diag_int(mat) result(diag)
784 : :
785 : : !Arguments ------------------------------------
786 : : !scalars
787 : : integer,intent(in) :: mat(:,:)
788 : : integer :: diag(SIZE(mat,1))
789 : :
790 : : !Local variables-------------------------------
791 : : integer :: ii
792 : : ! *************************************************************************
793 : :
794 : 43 : ii = assert_eq(SIZE(mat,1),SIZE(mat,2),'Matrix not square',__FILE__,__LINE__)
795 : :
796 [ + + ]: 172 : do ii=1,SIZE(mat,1)
797 : 172 : diag(ii)=mat(ii,ii)
798 : : end do
799 : :
800 : 43 : end function get_diag_int
801 : : !!***
802 : :
803 : : !----------------------------------------------------------------------
804 : :
805 : : !!****f* m_numeric_tools/get_diag_rdp
806 : : !! NAME
807 : : !! get_diag_rdp
808 : : !!
809 : : !! FUNCTION
810 : : !! Return the diagonal of a square matrix as a vector
811 : : !!
812 : : !! INPUTS
813 : : !! matrix(:,:)
814 : : !!
815 : : !! OUTPUT
816 : : !! diag(:)=the diagonal
817 : : !!
818 : : !! SOURCE
819 : :
820 [ # # # # ]: 0 : function get_diag_rdp(mat) result(diag)
821 : :
822 : : !Arguments ------------------------------------
823 : : !scalars
824 : : real(dp),intent(in) :: mat(:,:)
825 : : real(dp) :: diag(SIZE(mat,1))
826 : :
827 : : !Local variables-------------------------------
828 : : integer :: ii
829 : : ! *************************************************************************
830 : :
831 [ # # ]: 0 : ABI_CHECK(SIZE(mat,1) == SIZE(mat,2), 'Matrix not square')
832 : :
833 [ # # ]: 0 : do ii=1,SIZE(mat,1)
834 : 0 : diag(ii) = mat(ii,ii)
835 : : end do
836 : :
837 : 0 : end function get_diag_rdp
838 : : !!***
839 : :
840 : : !----------------------------------------------------------------------
841 : :
842 : : !!****f* m_numeric_tools/get_diag_cdp
843 : : !! NAME
844 : : !! get_diag_cdp
845 : : !!
846 : : !! FUNCTION
847 : : !!
848 : : !! INPUTS
849 : : !!
850 : : !! OUTPUT
851 : : !!
852 : : !! SOURCE
853 : :
854 [ # # # # ]: 0 : function get_diag_cdp(cmat) result(cdiag)
855 : :
856 : : !Arguments ------------------------------------
857 : : !scalars
858 : : complex(dp),intent(in) :: cmat(:,:)
859 : : complex(dp) :: cdiag(SIZE(cmat,1))
860 : :
861 : : !Local variables-------------------------------
862 : : integer :: ii
863 : : ! *************************************************************************
864 : :
865 [ # # ]: 0 : ABI_CHECK(SIZE(cmat,1) == SIZE(cmat,2), 'Matrix not square')
866 : :
867 [ # # ]: 0 : do ii=1,SIZE(cmat,1)
868 : 0 : cdiag(ii)=cmat(ii,ii)
869 : : end do
870 : :
871 : 0 : end function get_diag_cdp
872 : : !!***
873 : :
874 : : !----------------------------------------------------------------------
875 : :
876 : : !!****f* m_numeric_tools/isdiagmat_int
877 : : !! NAME
878 : : !! isdiagmat_int
879 : : !!
880 : : !! FUNCTION
881 : : !! True if matrix mat is diagonal
882 : : !!
883 : : !! SOURCE
884 : :
885 [ - + ]: 11540 : pure logical function isdiagmat_int(mat) result(ans)
886 : :
887 : : !Arguments ------------------------------------
888 : : !scalars
889 : : integer,intent(in) :: mat(:,:)
890 : :
891 : : !Local variables-------------------------------
892 : : integer :: ii,jj
893 : : ! *************************************************************************
894 : :
895 : 11540 : ans = .True.
896 [ + + ]: 38234 : do jj=1,size(mat,dim=2)
897 [ + + ]: 121095 : do ii=1,size(mat,dim=1)
898 [ + + ]: 85514 : if (ii == jj) cycle
899 [ + + ]: 82867 : if (mat(ii,jj) /= 0) then
900 : 2653 : ans = .False.; return
901 : : end if
902 : : end do
903 : : end do
904 : :
905 : 8887 : end function isdiagmat_int
906 : : !!***
907 : :
908 : : !----------------------------------------------------------------------
909 : :
910 : : !!****f* m_numeric_tools/isdiagmat_rdp
911 : : !! NAME
912 : : !! isdiagmat_rdp
913 : : !!
914 : : !! FUNCTION
915 : : !! True if matrix mat is diagonal within the given absolute tolerance (default: tol12)
916 : : !!
917 : : !! SOURCE
918 : :
919 [ # # ]: 0 : pure logical function isdiagmat_rdp(mat, atol) result(ans)
920 : :
921 : : !Arguments ------------------------------------
922 : : !scalars
923 : : real(dp),intent(in) :: mat(:,:)
924 : : real(dp),optional,intent(in) :: atol
925 : :
926 : : !Local variables-------------------------------
927 : : integer :: ii,jj
928 : : real(dp) :: my_atol
929 : : ! *************************************************************************
930 : :
931 [ # # ]: 0 : my_atol = tol12; if (present(atol)) my_atol = atol
932 : :
933 : 0 : ans = .True.
934 [ # # ]: 0 : do jj=1,size(mat,dim=2)
935 [ # # ]: 0 : do ii=1,size(mat,dim=1)
936 [ # # ]: 0 : if (ii == jj) cycle
937 [ # # ]: 0 : if (abs(mat(ii,jj)) > my_atol) then
938 : 0 : ans = .False.; return
939 : : end if
940 : : end do
941 : : end do
942 : :
943 : 0 : end function isdiagmat_rdp
944 : : !!***
945 : :
946 : : !----------------------------------------------------------------------
947 : :
948 : : !!****f* m_numeric_tools/l2int_1D
949 : : !! NAME
950 : : !! l2int_1D
951 : : !!
952 : : !! FUNCTION
953 : : !! Convert a logical array into an int array (True --> 1, False --> 0)
954 : : !!
955 : : !! INPUTS
956 : : !! larr(:)=the input logical array
957 : : !!
958 : : !! SOURCE
959 : :
960 [ - + - + ]: 2 : pure function l2int_1D(larr) result(int_arr)
961 : :
962 : : !Arguments ------------------------------------
963 : : !scalars
964 : : logical,intent(in) :: larr(:)
965 : : integer :: int_arr(size(larr))
966 : :
967 : : ! *********************************************************************
968 : :
969 [ + + + + ]: 10 : where (larr)
970 : : int_arr = 1
971 : : elsewhere
972 : : int_arr = 0
973 : : end where
974 : :
975 : 2 : end function l2int_1D
976 : : !!***
977 : :
978 : : !----------------------------------------------------------------------
979 : :
980 : : !!****f* m_numeric_tools/l2int_2D
981 : : !! NAME
982 : : !! l2int_2D
983 : : !!
984 : : !! FUNCTION
985 : : !! Convert a logical array into an int array (True --> 1, False --> 0)
986 : : !!
987 : : !! INPUTS
988 : : !! larr(:)=the input logical array
989 : : !!
990 : : !! SOURCE
991 : :
992 [ - + - + ]: 15 : pure function l2int_2D(larr) result(int_arr)
993 : :
994 : : !Arguments ------------------------------------
995 : : !scalars
996 : : logical,intent(in) :: larr(:,:)
997 : : integer :: int_arr(size(larr,1), size(larr,2))
998 : : ! *********************************************************************
999 : :
1000 [ + + + + : 175 : where (larr)
+ + ]
1001 : : int_arr = 1
1002 : : elsewhere
1003 : : int_arr = 0
1004 : : end where
1005 : :
1006 : 15 : end function l2int_2D
1007 : : !!***
1008 : :
1009 : : !----------------------------------------------------------------------
1010 : :
1011 : : !!****f* m_numeric_tools/l2int_3D
1012 : : !! NAME
1013 : : !! l2int_3D
1014 : : !!
1015 : : !! FUNCTION
1016 : : !! Convert a logical array into an int array (True --> 1, False --> 0)
1017 : : !!
1018 : : !! INPUTS
1019 : : !! larr(:)=the input logical array
1020 : : !!
1021 : : !! SOURCE
1022 : :
1023 [ - + - + ]: 15 : pure function l2int_3D(larr) result(int_arr)
1024 : :
1025 : : !Arguments ------------------------------------
1026 : : !scalars
1027 : : logical,intent(in) :: larr(:,:,:)
1028 : : integer :: int_arr(size(larr,1), size(larr,2), size(larr,3))
1029 : : ! *********************************************************************
1030 : :
1031 [ + + + + : 7231 : where (larr)
+ + + + ]
1032 : : int_arr = 1
1033 : : elsewhere
1034 : : int_arr = 0
1035 : : end where
1036 : :
1037 : 15 : end function l2int_3D
1038 : : !!***
1039 : :
1040 : : !----------------------------------------------------------------------
1041 : :
1042 : : !!***!!****f* m_numeric_tools/rdp2cdp_0D
1043 : : !! NAME
1044 : : !! rdp2cdp_0D
1045 : : !!
1046 : : !! FUNCTION
1047 : : !! Create a complex number starting from a real array containing real and imaginary part
1048 : : !!
1049 : : !! INPUTS
1050 : : !! rr(:)=the real array
1051 : : !!
1052 : : !! OUTPUT
1053 : : !! cc(:)=the complex array
1054 : : !!
1055 : : !! SOURCE
1056 : :
1057 : 0 : pure function rdp2cdp_0D(rr) result(cc)
1058 : :
1059 : : !Arguments ------------------------------------
1060 : : !scalars
1061 : : real(dp),intent(in) :: rr(2)
1062 : : complex(dp) :: cc
1063 : : ! *********************************************************************
1064 : :
1065 : 0 : cc = CMPLX(rr(1), rr(2), kind=dp)
1066 : :
1067 : 0 : end function rdp2cdp_0D
1068 : : !!***
1069 : :
1070 : : !----------------------------------------------------------------------
1071 : :
1072 : : !!***!!****f* m_numeric_tools/rdp2cdp_1D
1073 : : !! NAME
1074 : : !! rdp2cdp_1D
1075 : : !!
1076 : : !! FUNCTION
1077 : : !! Create a complex array starting from a real array containing real and imaginary part
1078 : : !!
1079 : : !! INPUTS
1080 : : !! rr(:)=the real array
1081 : : !!
1082 : : !! OUTPUT
1083 : : !! cc(:)=the complex array
1084 : : !!
1085 : : !! SOURCE
1086 : :
1087 [ # # # # ]: 0 : pure function rdp2cdp_1D(rr) result(cc)
1088 : :
1089 : : !Arguments ------------------------------------
1090 : : !scalars
1091 : : real(dp),intent(in) :: rr(:,:)
1092 : : complex(dp) :: cc(SIZE(rr,2))
1093 : : ! *********************************************************************
1094 : :
1095 [ # # ]: 0 : cc(:)=CMPLX(rr(1,:),rr(2,:),kind=dp)
1096 : :
1097 : 0 : end function rdp2cdp_1D
1098 : : !!***
1099 : :
1100 : : !----------------------------------------------------------------------
1101 : :
1102 : : !!****f* m_numeric_tools/rdp2cdp_2D
1103 : : !! NAME
1104 : : !! rdp2cdp_2D
1105 : : !!
1106 : : !! FUNCTION
1107 : : !!
1108 : : !! INPUTS
1109 : : !!
1110 : : !! OUTPUT
1111 : : !!
1112 : : !! SOURCE
1113 : :
1114 [ # # # # ]: 0 : pure function rdp2cdp_2D(rr) result(cc)
1115 : :
1116 : : !Arguments ------------------------------------
1117 : : !scalars
1118 : : real(dp),intent(in) :: rr(:,:,:)
1119 : : complex(dp) :: cc(SIZE(rr,2),SIZE(rr,3))
1120 : : ! *********************************************************************
1121 : :
1122 [ # # # # ]: 0 : cc(:,:)=CMPLX(rr(1,:,:),rr(2,:,:), kind=dp)
1123 : :
1124 : 0 : end function rdp2cdp_2D
1125 : : !!***
1126 : :
1127 : : !----------------------------------------------------------------------
1128 : :
1129 : : !!****f* m_numeric_tools/rdp2cdp_3D
1130 : : !! NAME
1131 : : !! rdp2cdp_3D
1132 : : !!
1133 : : !! FUNCTION
1134 : : !!
1135 : : !! INPUTS
1136 : : !!
1137 : : !! OUTPUT
1138 : : !!
1139 : : !! SOURCE
1140 : :
1141 [ # # # # ]: 0 : pure function rdp2cdp_3D(rr) result(cc)
1142 : :
1143 : : !Arguments ------------------------------------
1144 : : !scalars
1145 : : real(dp),intent(in) :: rr(:,:,:,:)
1146 : : complex(dp) :: cc(SIZE(rr,2),SIZE(rr,3),SIZE(rr,4))
1147 : : ! *********************************************************************
1148 : :
1149 [ # # # # : 0 : cc(:,:,:)=CMPLX(rr(1,:,:,:),rr(2,:,:,:), kind=dp)
# # ]
1150 : :
1151 : 0 : end function rdp2cdp_3D
1152 : : !!***
1153 : :
1154 : : !----------------------------------------------------------------------
1155 : :
1156 : : !!****f* m_numeric_tools/rdp2cdp_4D
1157 : : !! NAME
1158 : : !! rdp2cdp_4D
1159 : : !!
1160 : : !! FUNCTION
1161 : : !!
1162 : : !! INPUTS
1163 : : !!
1164 : : !! OUTPUT
1165 : : !!
1166 : : !! SOURCE
1167 : :
1168 [ # # # # ]: 0 : pure function rdp2cdp_4D(rr) result(cc)
1169 : :
1170 : : !Arguments ------------------------------------
1171 : : !scalars
1172 : : real(dp),intent(in) :: rr(:,:,:,:,:)
1173 : : complex(dp) :: cc(SIZE(rr,2),SIZE(rr,3),SIZE(rr,4),SIZE(rr,5))
1174 : : ! *********************************************************************
1175 : :
1176 [ # # # # : 0 : cc(:,:,:,:)=CMPLX(rr(1,:,:,:,:),rr(2,:,:,:,:), kind=dp)
# # # # ]
1177 : :
1178 : 0 : end function rdp2cdp_4D
1179 : : !!***
1180 : :
1181 : : !----------------------------------------------------------------------
1182 : :
1183 : : !!****f* m_numeric_tools/rdp2cdp_5D
1184 : : !! NAME
1185 : : !! rdp2cdp_5D
1186 : : !!
1187 : : !! FUNCTION
1188 : : !!
1189 : : !! INPUTS
1190 : : !!
1191 : : !! OUTPUT
1192 : : !!
1193 : : !! SOURCE
1194 : :
1195 [ # # # # ]: 0 : pure function rdp2cdp_5D(rr) result(cc)
1196 : :
1197 : : !Arguments ------------------------------------
1198 : : !scalars
1199 : : real(dp),intent(in) :: rr(:,:,:,:,:,:)
1200 : : complex(dp) :: cc(SIZE(rr,2),SIZE(rr,3),SIZE(rr,4),SIZE(rr,5),SIZE(rr,6))
1201 : : ! *********************************************************************
1202 : :
1203 [ # # # # : 0 : cc(:,:,:,:,:)=CMPLX(rr(1,:,:,:,:,:),rr(2,:,:,:,:,:), kind=dp)
# # # # #
# ]
1204 : :
1205 : 0 : end function rdp2cdp_5D
1206 : : !!***
1207 : :
1208 : : !----------------------------------------------------------------------
1209 : :
1210 : : !!****f* m_numeric_tools/rdp2cdp_6D
1211 : : !! NAME
1212 : : !! rdp2cdp_6D
1213 : : !!
1214 : : !! FUNCTION
1215 : : !!
1216 : : !! INPUTS
1217 : : !!
1218 : : !! OUTPUT
1219 : : !!
1220 : : !! SOURCE
1221 : :
1222 [ # # # # ]: 0 : pure function rdp2cdp_6D(rr) result(cc)
1223 : :
1224 : : !Arguments ------------------------------------
1225 : : !scalars
1226 : : real(dp),intent(in) :: rr(:,:,:,:,:,:,:)
1227 : : complex(dp) :: cc(SIZE(rr,2),SIZE(rr,3),SIZE(rr,4),SIZE(rr,5),SIZE(rr,6),SIZE(rr,7))
1228 : : ! *********************************************************************
1229 : :
1230 [ # # # # : 0 : cc(:,:,:,:,:,:)=CMPLX(rr(1,:,:,:,:,:,:),rr(2,:,:,:,:,:,:), kind=dp)
# # # # #
# # # ]
1231 : :
1232 : 0 : end function rdp2cdp_6D
1233 : : !!***
1234 : :
1235 : :
1236 : : !----------------------------------------------------------------------
1237 : :
1238 : : !!****f* m_numeric_tools/cdp2rdp_0D
1239 : : !! NAME
1240 : : !! cdp2rdp_0D
1241 : : !!
1242 : : !! FUNCTION
1243 : : !! Create a real variable containing real and imaginary part starting from a complex array
1244 : : !!
1245 : : !! INPUTS
1246 : : !! cc=the input complex number
1247 : : !!
1248 : : !! OUTPUT
1249 : : !! rr(2=the real array
1250 : : !!
1251 : : !! SOURCE
1252 : :
1253 [ # # ]: 0 : pure function cdp2rdp_0D(cc) result(rr)
1254 : :
1255 : : !Arguments ------------------------------------
1256 : : !scalars
1257 : : complex(dp),intent(in) :: cc
1258 : : real(dp) :: rr(2)
1259 : : ! *********************************************************************
1260 : :
1261 : 0 : rr(1)=REAL (cc)
1262 : 0 : rr(2)=AIMAG(cc)
1263 : :
1264 : 0 : end function cdp2rdp_0D
1265 : : !!***
1266 : :
1267 : : !----------------------------------------------------------------------
1268 : :
1269 : : !!****f* m_numeric_tools/cdp2rdp_1D
1270 : : !! NAME
1271 : : !! cdp2rdp_1D
1272 : : !!
1273 : : !! FUNCTION
1274 : : !! Create a real array containing real and imaginary part starting from a complex array
1275 : : !!
1276 : : !! INPUTS
1277 : : !! cc(:)=the input complex array
1278 : : !!
1279 : : !! OUTPUT
1280 : : !! rr(2,:)=the real array
1281 : : !!
1282 : : !! SOURCE
1283 : :
1284 [ - + - + ]: 298 : pure function cdp2rdp_1D(cc) result(rr)
1285 : :
1286 : : !Arguments ------------------------------------
1287 : : complex(dp),intent(in) :: cc(:)
1288 : : real(dp) :: rr(2,SIZE(cc))
1289 : : ! *********************************************************************
1290 : :
1291 [ + + ]: 47994 : rr(1,:)=REAL (cc(:))
1292 [ + + ]: 47994 : rr(2,:)=AIMAG(cc(:))
1293 : :
1294 : 298 : end function cdp2rdp_1D
1295 : : !!***
1296 : :
1297 : : !----------------------------------------------------------------------
1298 : :
1299 : : !!****f* m_numeric_tools/cdp2rdp_2D
1300 : : !! NAME
1301 : : !! cdp2rdp_2D
1302 : : !!
1303 : : !! FUNCTION
1304 : : !! Create a real array containing real and imaginary part starting from a complex array
1305 : : !!
1306 : : !! SOURCE
1307 : :
1308 [ - + - + ]: 1480 : pure function cdp2rdp_2D(cc) result(rr)
1309 : :
1310 : : !Arguments ------------------------------------
1311 : : complex(dp),intent(in) :: cc(:,:)
1312 : : real(dp) :: rr(2,SIZE(cc,1),SIZE(cc,2))
1313 : : ! *********************************************************************
1314 : :
1315 [ + + + + ]: 29464 : rr(1,:,:)=REAL (cc(:,:))
1316 [ + + + + ]: 29464 : rr(2,:,:)=AIMAG(cc(:,:))
1317 : :
1318 : 1480 : end function cdp2rdp_2D
1319 : : !!***
1320 : :
1321 : : !----------------------------------------------------------------------
1322 : :
1323 : : !!****f* m_numeric_tools/cdp2rdp_3D
1324 : : !! NAME
1325 : : !! cdp2rdp_3D
1326 : : !!
1327 : : !! FUNCTION
1328 : : !! Create a real array containing real and imaginary part starting from a complex array
1329 : : !!
1330 : : !! SOURCE
1331 : :
1332 [ - + - + ]: 1133 : pure function cdp2rdp_3D(cc) result(rr)
1333 : :
1334 : : !Arguments ------------------------------------
1335 : : complex(dp),intent(in) :: cc(:,:,:)
1336 : : real(dp) :: rr(2,SIZE(cc,1),SIZE(cc,2),SIZE(cc,3))
1337 : : ! *********************************************************************
1338 : :
1339 [ + + + + : 197506 : rr(1,:,:,:)=REAL (cc(:,:,:))
+ + ]
1340 [ + + + + : 197506 : rr(2,:,:,:)=AIMAG(cc(:,:,:))
+ + ]
1341 : :
1342 : 1133 : end function cdp2rdp_3D
1343 : : !!***
1344 : :
1345 : : !----------------------------------------------------------------------
1346 : :
1347 : : !!****f* m_numeric_tools/cdp2rdp_4D
1348 : : !! NAME
1349 : : !! cdp2rdp_4D
1350 : : !!
1351 : : !! FUNCTION
1352 : : !! Create a real array containing real and imaginary part starting from a complex array
1353 : : !!
1354 : : !! SOURCE
1355 : :
1356 [ - + - + ]: 858 : pure function cdp2rdp_4D(cc) result(rr)
1357 : :
1358 : : !Arguments ------------------------------------
1359 : : complex(dp),intent(in) :: cc(:,:,:,:)
1360 : : real(dp) :: rr(2,SIZE(cc,1),SIZE(cc,2),SIZE(cc,3),SIZE(cc,4))
1361 : : ! *********************************************************************
1362 : :
1363 [ + + + + : 711440 : rr(1,:,:,:,:)=REAL (cc(:,:,:,:))
+ + + + ]
1364 [ + + + + : 711440 : rr(2,:,:,:,:)=AIMAG(cc(:,:,:,:))
+ + + + ]
1365 : :
1366 : 858 : end function cdp2rdp_4D
1367 : : !!***
1368 : :
1369 : : !----------------------------------------------------------------------
1370 : :
1371 : : !!****f* m_numeric_tools/cdp2rdp_5D
1372 : : !! NAME
1373 : : !! cdp2rdp_5D
1374 : : !!
1375 : : !! FUNCTION
1376 : : !! Create a real array containing real and imaginary part starting from a complex array
1377 : : !!
1378 : : !! SOURCE
1379 : :
1380 [ - + - + ]: 2 : pure function cdp2rdp_5D(cc) result(rr)
1381 : :
1382 : : !Arguments ------------------------------------
1383 : : complex(dp),intent(in) :: cc(:,:,:,:,:)
1384 : : real(dp) :: rr(2,SIZE(cc,1),SIZE(cc,2),SIZE(cc,3),SIZE(cc,4),SIZE(cc,5))
1385 : : ! *********************************************************************
1386 : :
1387 [ + + + + : 5496 : rr(1,:,:,:,:,:)=REAL (cc(:,:,:,:,:))
+ + + + +
+ ]
1388 [ + + + + : 5496 : rr(2,:,:,:,:,:)=AIMAG(cc(:,:,:,:,:))
+ + + + +
+ ]
1389 : :
1390 : 2 : end function cdp2rdp_5D
1391 : : !!***
1392 : :
1393 : : !!****f* m_numeric_tools/cdp2rdp_6D
1394 : : !! NAME
1395 : : !! cdp2rdp_6D
1396 : : !!
1397 : : !! FUNCTION
1398 : : !! Create a real array containing real and imaginary part starting from a complex array
1399 : : !!
1400 : : !! SOURCE
1401 : :
1402 [ # # # # ]: 0 : pure function cdp2rdp_6D(cc) result(rr)
1403 : :
1404 : : !Arguments ------------------------------------
1405 : : complex(dp),intent(in) :: cc(:,:,:,:,:,:)
1406 : : real(dp) :: rr(2,SIZE(cc,1),SIZE(cc,2),SIZE(cc,3),SIZE(cc,4),SIZE(cc,5),SIZE(cc,6))
1407 : : ! *********************************************************************
1408 : :
1409 [ # # # # : 0 : rr(1,:,:,:,:,:,:)=REAL (cc(:,:,:,:,:,:))
# # # # #
# # # ]
1410 [ # # # # : 0 : rr(2,:,:,:,:,:,:)=AIMAG(cc(:,:,:,:,:,:))
# # # # #
# # # ]
1411 : :
1412 : 0 : end function cdp2rdp_6D
1413 : : !!***
1414 : :
1415 : : !----------------------------------------------------------------------
1416 : :
1417 : : !!****f* m_numeric_tools/iseven
1418 : : !! NAME
1419 : : !! iseven
1420 : : !!
1421 : : !! FUNCTION
1422 : : !! Return .TRUE. if the given integer is even
1423 : : !!
1424 : : !! SOURCE
1425 : :
1426 : 27 : elemental function iseven(nn)
1427 : :
1428 : : !Arguments ------------------------------------
1429 : : !scalars
1430 : : integer,intent(in) :: nn
1431 : : logical :: iseven
1432 : : ! *********************************************************************
1433 : :
1434 : 27 : iseven = ((nn / 2) * 2 == nn)
1435 : :
1436 : 27 : end function iseven
1437 : : !!***
1438 : :
1439 : : !----------------------------------------------------------------------
1440 : :
1441 : : !!****f* m_numeric_tools/is_integer_0D
1442 : : !! NAME
1443 : : !! is_integer_0D
1444 : : !!
1445 : : !! FUNCTION
1446 : : !! Return .TRUE. if all elements differ from an integer by less that tol
1447 : : !!
1448 : : !! INPUTS
1449 : : !! rr=the set of real values to be checked
1450 : : !! tol=tolerance on the difference between real and integer
1451 : : !!
1452 : : !! SOURCE
1453 : :
1454 : 224215093 : pure function is_integer_0d(rr,tol) result(ans)
1455 : :
1456 : : !Arguments ------------------------------------
1457 : : !scalars
1458 : : real(dp),intent(in) :: tol
1459 : : logical :: ans
1460 : : !arrays
1461 : : real(dp),intent(in) :: rr
1462 : : ! *************************************************************************
1463 : :
1464 : 224215093 : ans=(ABS(rr-NINT(rr))<tol)
1465 : :
1466 : 224215093 : end function is_integer_0d
1467 : : !!***
1468 : :
1469 : : !----------------------------------------------------------------------
1470 : :
1471 : : !!****f* m_numeric_tools/is_integer_1D
1472 : : !! NAME
1473 : : !! is_integer_1D
1474 : : !!
1475 : : !! FUNCTION
1476 : : !!
1477 : : !! INPUTS
1478 : : !!
1479 : : !! OUTPUT
1480 : : !!
1481 : : !! SOURCE
1482 : :
1483 [ - + ]: 467347064 : pure function is_integer_1d(rr,tol) result(ans)
1484 : :
1485 : : !Arguments ------------------------------------
1486 : : !scalars
1487 : : real(dp),intent(in) :: tol
1488 : : logical :: ans
1489 : : !arrays
1490 : : real(dp),intent(in) :: rr(:)
1491 : : ! *************************************************************************
1492 : :
1493 [ + + + + ]: 542234552 : ans=ALL((ABS(rr-NINT(rr))<tol))
1494 : :
1495 : 467347064 : end function is_integer_1d
1496 : : !!***
1497 : :
1498 : : !----------------------------------------------------------------------
1499 : :
1500 : : !!****f* m_numeric_tools/is_zero_rdp_0D
1501 : : !! NAME
1502 : : !! is_zero_rdp_0D
1503 : : !!
1504 : : !! FUNCTION
1505 : : !! Return .TRUE. if all elements differ from zero by less that tol
1506 : : !!
1507 : : !! INPUTS
1508 : : !! rr=the set of real values to be checked
1509 : : !! tol=tolerance
1510 : : !!
1511 : : !! OUTPUT
1512 : : !!
1513 : : !! SOURCE
1514 : :
1515 : 0 : function is_zero_rdp_0d(rr,tol) result(ans)
1516 : :
1517 : : !Arguments ------------------------------------
1518 : : !scalars
1519 : : real(dp),intent(in) :: tol
1520 : : logical :: ans
1521 : : !arrays
1522 : : real(dp),intent(in) :: rr
1523 : : ! *************************************************************************
1524 : :
1525 : 0 : ans=(ABS(rr)<tol)
1526 : :
1527 : 0 : end function is_zero_rdp_0d
1528 : : !!***
1529 : :
1530 : : !----------------------------------------------------------------------
1531 : :
1532 : : !!****f* m_numeric_tools/is_zero_rdp_1d
1533 : : !! NAME
1534 : : !! is_zero_rdp_1d
1535 : : !!
1536 : : !! FUNCTION
1537 : : !!
1538 : : !! INPUTS
1539 : : !!
1540 : : !! OUTPUT
1541 : : !!
1542 : : !! SOURCE
1543 : :
1544 [ - + ]: 12257 : function is_zero_rdp_1d(rr,tol) result(ans)
1545 : :
1546 : : !Arguments ------------------------------------
1547 : : !scalars
1548 : : real(dp),intent(in) :: tol
1549 : : logical :: ans
1550 : : !arrays
1551 : : real(dp),intent(in) :: rr(:)
1552 : : ! *************************************************************************
1553 : :
1554 [ + + + + ]: 12844 : ans=ALL(ABS(rr(:))<tol)
1555 : :
1556 : 12257 : end function is_zero_rdp_1d
1557 : : !!***
1558 : :
1559 : : !----------------------------------------------------------------------
1560 : :
1561 : : !!****f* m_numeric_tools/inrange_int
1562 : : !! NAME
1563 : : !! inrange_int
1564 : : !!
1565 : : !! FUNCTION
1566 : : !! True if int `xval` is inside the interval [win(1), win(2)]
1567 : : !!
1568 : : !! SOURCE
1569 : :
1570 : 44 : pure logical function inrange_int(xval, win)
1571 : :
1572 : : !Arguments ------------------------------------
1573 : : !scalars
1574 : : integer,intent(in) :: xval,win(2)
1575 : : ! *************************************************************************
1576 : :
1577 [ + - - + ]: 44 : inrange_int = (xval >= win(1) .and. xval <= win(2))
1578 : :
1579 : 44 : end function inrange_int
1580 : : !!***
1581 : :
1582 : : !----------------------------------------------------------------------
1583 : :
1584 : : !!****f* m_numeric_tools/inrange_dp
1585 : : !! NAME
1586 : : !! inrange_dp
1587 : : !!
1588 : : !! FUNCTION
1589 : : !! True if float `xval` is inside the interval [win(1), win(2)]
1590 : : !!
1591 : : !! SOURCE
1592 : :
1593 : 0 : pure logical function inrange_dp(xval, win)
1594 : :
1595 : : !Arguments ------------------------------------
1596 : : !scalars
1597 : : real(dp),intent(in) :: xval, win(2)
1598 : : ! *************************************************************************
1599 : :
1600 [ # # # # ]: 0 : inrange_dp = (xval >= win(1) .and. xval <= win(2))
1601 : :
1602 : 0 : end function inrange_dp
1603 : : !!***
1604 : :
1605 : : !!****f* m_numeric_tools/bisect_rdp
1606 : : !! NAME
1607 : : !! bisect_rdp
1608 : : !!
1609 : : !! FUNCTION
1610 : : !! Given an array AA(1:N), and a value x, returns the index j such that AA(j) <= x <= AA(j + 1).
1611 : : !! AA must be monotonic, either increasing or decreasing. j=0 or
1612 : : !! j=N is returned to indicate that x is out of range.
1613 : : !!
1614 : : !! SOURCE
1615 : :
1616 [ - + ]: 6574571 : pure function bisect_rdp(AA, xx) result(loc)
1617 : :
1618 : : !Arguments ------------------------------------
1619 : : !scalars
1620 : : real(dp),intent(in) :: AA(:)
1621 : : real(dp),intent(in) :: xx
1622 : : integer :: loc
1623 : :
1624 : : !Local variables-------------------------------
1625 : : integer :: nn,jl,jm,ju
1626 : : logical :: ascnd
1627 : : ! *********************************************************************
1628 : :
1629 : 6574571 : nn=SIZE(AA); ascnd=(AA(nn)>=AA(1))
1630 : : !
1631 : : ! Initialize lower and upper limits
1632 : 6574571 : jl=0; ju=nn+1
1633 : : do
1634 [ + + ]: 42654025 : if (ju-jl<=1) EXIT
1635 : 36079454 : jm=(ju+jl)/2 ! Compute a midpoint,
1636 [ + + ]: 42654025 : if (ascnd.EQV.(xx>=AA(jm))) then
1637 : : jl=jm ! Replace lower limit
1638 : : else
1639 : 28414050 : ju=jm ! Replace upper limit
1640 : : end if
1641 : : end do
1642 : : !
1643 : : ! Set the output, being careful with the endpoints
1644 [ + + ]: 6574571 : if (xx==AA(1)) then
1645 : : loc=1
1646 [ + + ]: 6473249 : else if (xx==AA(nn)) then
1647 : 996 : loc=nn-1
1648 : : else
1649 : : loc=jl
1650 : : end if
1651 : :
1652 : 6574571 : end function bisect_rdp
1653 : : !!***
1654 : :
1655 : : !----------------------------------------------------------------------
1656 : :
1657 : : !!****f* m_numeric_tools/bisect_int
1658 : : !! NAME
1659 : : !! bisect_int
1660 : : !!
1661 : : !! FUNCTION
1662 : : !! Given an array AA(1:N), and a value x, returns the index j such that AA(j) <= x <= AA(j + 1).
1663 : : !! AA must be monotonic, either increasing or decreasing. j=0 or
1664 : : !! j=N is returned to indicate that x is out of range.
1665 : : !!
1666 : : !! INPUTS
1667 : : !!
1668 : : !! OUTPUT
1669 : : !!
1670 : : !! SOURCE
1671 [ # # ]: 0 : pure function bisect_int(AA,xx) result(loc)
1672 : :
1673 : : !Arguments ------------------------------------
1674 : : !scalars
1675 : : integer,intent(in) :: AA(:)
1676 : : integer,intent(in) :: xx
1677 : : integer :: loc
1678 : :
1679 : : !Local variables-------------------------------
1680 : : integer :: nn,jl,jm,ju
1681 : : logical :: ascnd
1682 : : ! *********************************************************************
1683 : :
1684 : 0 : nn=SIZE(AA) ; ascnd=(AA(nn)>=AA(1))
1685 : :
1686 : : ! Initialize lower and upper limits
1687 : 0 : jl=0 ; ju=nn+1
1688 : : do
1689 [ # # ]: 0 : if (ju-jl<=1) EXIT
1690 : 0 : jm=(ju+jl)/2 ! Compute a midpoint
1691 [ # # ]: 0 : if (ascnd.EQV.(xx>=AA(jm))) then
1692 : : jl=jm ! Replace lower limit
1693 : : else
1694 : 0 : ju=jm ! Replace upper limit
1695 : : end if
1696 : : end do
1697 : : !
1698 : : ! Set the output, being careful with the endpoints
1699 [ # # ]: 0 : if (xx==AA(1)) then
1700 : : loc=1
1701 [ # # ]: 0 : else if (xx==AA(nn)) then
1702 : 0 : loc=nn-1
1703 : : else
1704 : : loc=jl
1705 : : end if
1706 : :
1707 : 0 : end function bisect_int
1708 : : !!***
1709 : :
1710 : : !----------------------------------------------------------------------
1711 : :
1712 : : !!****f* m_numeric_tools/imax_loc_int
1713 : : !! NAME
1714 : : !! imax_loc_int
1715 : : !!
1716 : : !! FUNCTION
1717 : : !! Index of maxloc on an array returned as scalar instead of array-valued
1718 : : !!
1719 : : !! SOURCE
1720 : :
1721 [ - + - - : 3 : pure function imax_loc_int(iarr,mask)
- - - + ]
1722 : :
1723 : : !Arguments ------------------------------------
1724 : : !scalars
1725 : : integer :: imax_loc_int
1726 : : !arrays
1727 : : integer,intent(in) :: iarr(:)
1728 : : logical,optional,intent(in) :: mask(:)
1729 : :
1730 : : !Local variables-------------------------------
1731 : : integer :: imax(1)
1732 : : ! *************************************************************************
1733 : :
1734 [ - + ]: 3 : if (PRESENT(mask)) then
1735 [ # # # # : 0 : imax=MAXLOC(iarr,MASK=mask)
# # # # #
# # # ]
1736 : : else
1737 [ - + + + : 17 : imax=MAXLOC(iarr)
+ + + + ]
1738 : : end if
1739 : 3 : imax_loc_int=imax(1)
1740 : :
1741 : 3 : end function imax_loc_int
1742 : : !!***
1743 : :
1744 : : !----------------------------------------------------------------------
1745 : :
1746 : : !!****f* m_numeric_tools/imax_loc_rdp
1747 : : !! NAME
1748 : : !! imax_loc_rdp
1749 : : !!
1750 : : !! FUNCTION
1751 : : !!
1752 : : !! INPUTS
1753 : : !!
1754 : : !! OUTPUT
1755 : : !!
1756 : : !! SOURCE
1757 [ - + - - : 3662 : pure function imax_loc_rdp(arr,mask)
- - - + ]
1758 : :
1759 : : !Arguments ------------------------------------
1760 : : !scalars
1761 : : integer :: imax_loc_rdp
1762 : : !arrays
1763 : : real(dp),intent(in) :: arr(:)
1764 : : logical,optional,intent(in) :: mask(:)
1765 : :
1766 : : !Local variables-------------------------------
1767 : : integer :: imax(1)
1768 : : ! *************************************************************************
1769 : :
1770 [ + - ]: 3662 : if (PRESENT(mask)) then
1771 [ # # # # : 0 : imax=MAXLOC(arr,MASK=mask)
# # # # #
# # # # #
# # ]
1772 : : else
1773 [ + - + - : 46414 : imax=MAXLOC(arr)
- - + + +
+ + + ]
1774 : : end if
1775 : 3662 : imax_loc_rdp=imax(1)
1776 : :
1777 : 3662 : end function imax_loc_rdp
1778 : : !!***
1779 : :
1780 : : !----------------------------------------------------------------------
1781 : :
1782 : : !!****f* m_numeric_tools/imin_loc_int
1783 : : !! NAME
1784 : : !! imin_loc_int
1785 : : !!
1786 : : !! FUNCTION
1787 : : !! Index of minloc on an array returned as scalar instead of array-valued
1788 : : !!
1789 : : !! SOURCE
1790 : :
1791 [ + + + - : 131598 : pure function imin_loc_int(arr, mask)
- + - + ]
1792 : :
1793 : : !Arguments ------------------------------------
1794 : : !scalars
1795 : : integer :: imin_loc_int
1796 : : !arrays
1797 : : integer,intent(in) :: arr(:)
1798 : : logical,optional,intent(in) :: mask(:)
1799 : :
1800 : : !Local variables-------------------------------
1801 : : integer :: imin(1)
1802 : : ! *************************************************************************
1803 : :
1804 [ + + ]: 131598 : if (PRESENT(mask)) then
1805 [ + - + - : 699890 : imin=MINLOC(arr,MASK=mask)
+ + - + +
+ + + ]
1806 : : else
1807 [ - + + + : 12 : imin=MINLOC(arr)
+ + + + ]
1808 : : end if
1809 : 131598 : imin_loc_int=imin(1)
1810 : :
1811 : 131598 : end function imin_loc_int
1812 : : !!***
1813 : :
1814 : : !----------------------------------------------------------------------
1815 : :
1816 : : !!****f* m_numeric_tools/imin_loc_rdp
1817 : : !! NAME
1818 : : !! imin_loc_rdp
1819 : : !!
1820 : : !! FUNCTION
1821 : : !!
1822 : : !! INPUTS
1823 : : !!
1824 : : !! OUTPUT
1825 : : !!
1826 : : !! SOURCE
1827 : :
1828 [ - + - - : 126966 : pure function imin_loc_rdp(arr,mask)
- - - + ]
1829 : :
1830 : : !Arguments ------------------------------------
1831 : : !scalars
1832 : : integer :: imin_loc_rdp
1833 : : !arrays
1834 : : real(dp),intent(in) :: arr(:)
1835 : : logical,optional,intent(in) :: mask(:)
1836 : :
1837 : : !Local variables-------------------------------
1838 : : integer :: imin(1)
1839 : : ! *************************************************************************
1840 : :
1841 [ + - ]: 126966 : if (PRESENT(mask)) then
1842 [ # # # # : 0 : imin=MINLOC(arr,MASK=mask)
# # # # #
# # # # #
# # ]
1843 : : else
1844 [ + - + - : 1045274 : imin=MINLOC(arr)
- - + + +
+ + + ]
1845 : : end if
1846 : :
1847 : 126966 : imin_loc_rdp=imin(1)
1848 : :
1849 : 126966 : end function imin_loc_rdp
1850 : : !!***
1851 : :
1852 : : !----------------------------------------------------------------------
1853 : :
1854 : : !!****f* m_numeric_tools/lfind
1855 : : !! NAME
1856 : : !! lfind
1857 : : !!
1858 : : !! FUNCTION
1859 : : !! Find the index of the first occurrence of .True. in a logical array.
1860 : : !! Return -1 if not found. If back is True, the search starts from the
1861 : : !! last element of the array (default: False).
1862 : : !!
1863 : : !! INPUTS
1864 : : !! mask(:)=Input logical mask
1865 : : !!
1866 : : !! SOURCE
1867 : :
1868 [ # # ]: 0 : integer pure function lfind(mask, back)
1869 : :
1870 : : !Arguments ------------------------------------
1871 : : !scalars
1872 : : logical,intent(in) :: mask(:)
1873 : : logical,optional,intent(in) :: back
1874 : : !arrays
1875 : :
1876 : : !Local variables-------------------------------
1877 : : !scalars
1878 : : integer :: ii,nitems
1879 : : logical :: do_back
1880 : : !************************************************************************
1881 : :
1882 [ # # ]: 0 : do_back = .False.; if (present(back)) do_back = back
1883 [ # # ]: 0 : lfind = -1; nitems = size(mask); if (nitems == 0) return
1884 : :
1885 [ # # ]: 0 : if (do_back) then
1886 : : ! Backward search
1887 [ # # ]: 0 : do ii=nitems,1,-1
1888 [ # # ]: 0 : if (mask(ii)) then
1889 : 0 : lfind = ii; return
1890 : : end if
1891 : : end do
1892 : : else
1893 : : ! Forward search.
1894 [ # # ]: 0 : do ii=1,nitems
1895 [ # # ]: 0 : if (mask(ii)) then
1896 : 0 : lfind = ii; return
1897 : : end if
1898 : : end do
1899 : : end if
1900 : :
1901 : : end function lfind
1902 : : !!***
1903 : :
1904 : : !----------------------------------------------------------------------
1905 : :
1906 : : !!****f* m_numeric_tools/list2blocks
1907 : : !! NAME
1908 : : !! list2blocks
1909 : : !!
1910 : : !! FUNCTION
1911 : : !! Given a list of integers, find the number of contiguous groups of values.
1912 : : !! and returns the set of indices that can be used to loop over these groups
1913 : : !! Example list = [1,2,3,5,6] --> blocks = [[1,3], [4,5]]
1914 : : !!
1915 : : !! INPUTS
1916 : : !! list(:)=List of integers
1917 : : !!
1918 : : !! OUTPUTS
1919 : : !! nblocks=Number of blocks
1920 : : !! blocks(2,nblocks)=
1921 : : !! allocatable array in input
1922 : : !! in output:
1923 : : !! blocks(1,i) gives the start of the i-th block
1924 : : !! blocks(2,i) gives the end of the i-th block
1925 : : !!
1926 : : !! SOURCE
1927 : :
1928 [ - + ]: 30 : subroutine list2blocks(list,nblocks,blocks)
1929 : :
1930 : : !Arguments ------------------------------------
1931 : : !scalars
1932 : : integer,intent(out) :: nblocks
1933 : : integer,intent(in) :: list(:)
1934 : : !arrays
1935 : : integer,intent(out),allocatable :: blocks(:,:)
1936 : :
1937 : : !Local variables-------------------------------
1938 : : !scalars
1939 : : integer :: ii,nitems
1940 : : !arrays
1941 : 30 : integer :: work(2,size(list))
1942 : : !************************************************************************
1943 : :
1944 : 30 : nitems = size(list)
1945 : :
1946 : : ! Handle nitems == 1 case
1947 [ - + ]: 30 : if (nitems == 1) then
1948 [ # # # # ]: 0 : ABI_MALLOC(blocks, (2,1))
1949 [ # # # # ]: 0 : blocks = 1
1950 : : return
1951 : : end if
1952 : :
1953 : 30 : nblocks = 1; work(1,1) = 1
1954 : :
1955 [ + + ]: 240 : do ii=2,nitems
1956 [ - + ]: 240 : if (list(ii) /= (list(ii-1) + 1)) then
1957 : 0 : work(2,nblocks) = ii - 1
1958 : 0 : nblocks = nblocks + 1
1959 : 0 : work(1,nblocks) = ii
1960 : : end if
1961 : : end do
1962 : :
1963 : 30 : work(2,nblocks) = nitems
1964 : :
1965 [ - + + - : 90 : ABI_MALLOC(blocks, (2,nblocks))
+ - + - -
+ - + -
+ ]
1966 [ - + + + : 150 : blocks = work(:,1:nblocks)
+ + ]
1967 : :
1968 : : end subroutine list2blocks
1969 : : !!***
1970 : :
1971 : : !----------------------------------------------------------------------
1972 : :
1973 : : !!****f* m_numeric_tools/mask2blocks
1974 : : !! NAME
1975 : : !! mask2blocks
1976 : : !!
1977 : : !! FUNCTION
1978 : : !! Give a logical mask, find the number of contiguous groups of .TRUE. values.
1979 : : !! and return the set of indices that can be used to loop over these groups
1980 : : !!
1981 : : !! INPUTS
1982 : : !! mask(:)=Input logical mask
1983 : : !!
1984 : : !! OUTPUTS
1985 : : !! nblocks=Number of blocks
1986 : : !!
1987 : : !! SIDE EFFECTS
1988 : : !! blocks(:,:)= Null pointer in input. blocks(2,nblocks) in output where
1989 : : !! blocks(1,i) gives the start of the i-th block
1990 : : !! blocks(2,i) gives the end of the i-th block
1991 : : !!
1992 : : !! SOURCE
1993 : :
1994 [ # # ]: 0 : subroutine mask2blocks(mask,nblocks,blocks)
1995 : :
1996 : : !Arguments ------------------------------------
1997 : : !scalars
1998 : : integer,intent(out) :: nblocks
1999 : : logical,intent(in) :: mask(:)
2000 : : !arrays
2001 : : integer,allocatable :: blocks(:,:)
2002 : :
2003 : : !Local variables-------------------------------
2004 : : !scalars
2005 : : integer :: ii,nitems,start
2006 : : logical :: inblock
2007 : : !arrays
2008 : 0 : integer :: work(2,SIZE(mask))
2009 : : !************************************************************************
2010 : :
2011 : : ! Find first element.
2012 : 0 : nitems = size(mask); start = 0
2013 [ # # ]: 0 : do ii=1,nitems
2014 [ # # ]: 0 : if (mask(ii)) then
2015 : : start = ii
2016 : : exit
2017 : : end if
2018 : : end do
2019 : :
2020 : : ! Handle no true element or just one.
2021 [ # # ]: 0 : if (start == 0) then
2022 : 0 : nblocks = 0
2023 [ # # # # ]: 0 : ABI_MALLOC(blocks, (0,0))
2024 : : return
2025 : : end if
2026 [ # # ]: 0 : if (start /= 0 .and. nitems == 1) then
2027 : 0 : nblocks = 1
2028 [ # # # # ]: 0 : ABI_MALLOC(blocks, (2,1))
2029 [ # # ]: 0 : blocks(:,1) = [1,1]
2030 : : end if
2031 : :
2032 : 0 : nblocks = 1; work(1,1) = start; inblock = .True.
2033 : :
2034 [ # # ]: 0 : do ii=start+1,nitems
2035 [ # # ]: 0 : if (.not.mask(ii)) then
2036 [ # # ]: 0 : if (inblock) then
2037 : 0 : inblock = .False.
2038 : 0 : work(2,nblocks) = ii - 1
2039 : : end if
2040 : : else
2041 [ # # ]: 0 : if (.not. inblock) then
2042 : 0 : inblock = .True.
2043 : 0 : nblocks = nblocks + 1
2044 : 0 : work(1,nblocks) = ii
2045 : : end if
2046 : : end if
2047 : : end do
2048 : :
2049 [ # # # # ]: 0 : if (mask(nitems) .and. inblock) work(2,nblocks) = nitems
2050 : :
2051 [ # # # # : 0 : ABI_MALLOC(blocks, (2,nblocks))
# # # # #
# # # #
# ]
2052 [ # # # # : 0 : blocks = work(:,1:nblocks)
# # ]
2053 : :
2054 : : end subroutine mask2blocks
2055 : : !!***
2056 : :
2057 : : !----------------------------------------------------------------------
2058 : :
2059 : : !!****f* m_numeric_tools/linfit_rdp
2060 : : !! NAME
2061 : : !! linfit_rdp
2062 : : !!
2063 : : !! FUNCTION
2064 : : !! Perform a linear fit, y=ax+b, of data
2065 : : !!
2066 : : !! INPUTS
2067 : : !! xx(nn)=xx coordinates
2068 : : !! yy(nn)=yy coordinates
2069 : : !!
2070 : : !! OUTPUT
2071 : : !! aa=coefficient of linear term of fit
2072 : : !! bb=coefficient of constant term of fit
2073 : : !! res=root mean square of differences between data and fit
2074 : : !!
2075 : : !! SOURCE
2076 : :
2077 : 1818 : function linfit_rdp(nn,xx,yy,aa,bb) result(res)
2078 : :
2079 : : !Arguments ------------------------------------
2080 : : !scalars
2081 : : integer,intent(in) :: nn
2082 : : real(dp) :: res
2083 : : real(dp),intent(out) :: aa,bb
2084 : : !arrays
2085 : : real(dp),intent(in) :: xx(nn),yy(nn)
2086 : :
2087 : : !Local variables-------------------------------
2088 : : !scalars
2089 : : integer :: ii
2090 : : real(dp) :: msrt,sx2,sx,sxy,sy,tx,ty
2091 : : ! *************************************************************************
2092 : :
2093 : 1818 : sx=zero ; sy=zero ; sxy=zero ; sx2=zero
2094 [ + + ]: 23188 : do ii=1,nn
2095 : 21370 : tx=xx(ii)
2096 : 21370 : ty=yy(ii)
2097 : 21370 : sx=sx+tx
2098 : 21370 : sy=sy+ty
2099 : 21370 : sxy=sxy+tx*ty
2100 : 23188 : sx2=sx2+tx*tx
2101 : : end do
2102 : :
2103 : 1818 : aa=(nn*sxy-sx*sy)/(nn*sx2-sx*sx)
2104 : 1818 : bb=sy/nn-sx*aa/nn
2105 : :
2106 : 1818 : msrt=zero
2107 [ + + ]: 23188 : do ii=1,nn
2108 : 21370 : tx=xx(ii)
2109 : 21370 : ty=yy(ii)
2110 : 23188 : msrt=msrt+(ty-aa*tx-bb)**2
2111 : : end do
2112 : 1818 : msrt=SQRT(msrt/nn) ; res=msrt
2113 : :
2114 : 1818 : end function linfit_rdp
2115 : : !!***
2116 : :
2117 : : !----------------------------------------------------------------------
2118 : :
2119 : : !!****f* m_numeric_tools/linfit_spc
2120 : : !! NAME
2121 : : !! linfit_spc
2122 : : !!
2123 : : !! FUNCTION
2124 : : !! Perform a linear fit, y=ax+b, of data
2125 : : !!
2126 : : !! INPUTS
2127 : : !!
2128 : : !! OUTPUT
2129 : : !!
2130 : : !! SOURCE
2131 : :
2132 : 0 : function linfit_spc(nn,xx,zz,aa,bb) result(res)
2133 : :
2134 : : !Arguments ------------------------------------
2135 : : !scalars
2136 : : integer,intent(in) :: nn
2137 : : real(dp) :: res
2138 : : real(dp),intent(in) :: xx(nn)
2139 : : complex(sp),intent(in) :: zz(nn)
2140 : : complex(sp),intent(out) :: aa,bb
2141 : :
2142 : : !Local variables-------------------------------
2143 : : !scalars
2144 : : integer :: ii
2145 : : real(dp) :: sx,sx2,msrt
2146 : : complex(dp) :: sz,sxz
2147 : : ! *************************************************************************
2148 : :
2149 : 0 : sx=zero ; sx2=zero ; msrt=zero
2150 : 0 : sz=czero ; sxz=czero
2151 [ # # ]: 0 : do ii=1,nn
2152 : 0 : sx=sx+xx(ii)
2153 : 0 : sz=sz+zz(ii)
2154 : 0 : sxz=sxz+xx(ii)*zz(ii)
2155 : 0 : sx2=sx2+xx(ii)*xx(ii)
2156 : : end do
2157 : :
2158 : 0 : aa=CMPLX((nn*sxz-sx*sz)/(nn*sx2-sx*sx), kind=sp)
2159 : 0 : bb=CMPLX(sz/nn-sx*aa/nn, kind=sp)
2160 : :
2161 [ # # ]: 0 : do ii=1,nn
2162 : 0 : msrt=msrt+ABS(zz(ii)-aa*xx(ii)-bb)**2
2163 : : end do
2164 : 0 : msrt=SQRT(msrt) ; res=msrt
2165 : :
2166 : 0 : end function linfit_spc
2167 : : !!***
2168 : :
2169 : : !----------------------------------------------------------------------
2170 : :
2171 : : !!****f* m_numeric_tools/linfit_dpc
2172 : : !! NAME
2173 : : !! linfit_dpc
2174 : : !!
2175 : : !! FUNCTION
2176 : : !! Perform a linear fit, y=ax+b, of data
2177 : : !!
2178 : : !! INPUTS
2179 : : !!
2180 : : !! OUTPUT
2181 : : !!
2182 : : !! SOURCE
2183 : :
2184 : 0 : function linfit_dpc(nn,xx,zz,aa,bb) result(res)
2185 : :
2186 : : !Arguments ------------------------------------
2187 : : !scalars
2188 : : integer,intent(in) :: nn
2189 : : real(dp) :: res
2190 : : real(dp),intent(in) :: xx(nn)
2191 : : complex(dp),intent(in) :: zz(nn)
2192 : : complex(dp),intent(out) :: aa,bb
2193 : : !arrays
2194 : :
2195 : : !Local variables-------------------------------
2196 : : !scalars
2197 : : integer :: ii
2198 : : real(dp) :: sx,sx2,msrt
2199 : : complex(dp) :: sz,sxz
2200 : : ! *************************************************************************
2201 : :
2202 : 0 : sx=zero ; sx2=zero ; msrt=zero
2203 : 0 : sz=czero ; sxz=czero
2204 [ # # ]: 0 : do ii=1,nn
2205 : 0 : sx=sx+xx(ii)
2206 : 0 : sz=sz+zz(ii)
2207 : 0 : sxz=sxz+xx(ii)*zz(ii)
2208 : 0 : sx2=sx2+xx(ii)*xx(ii)
2209 : : end do
2210 : :
2211 : 0 : aa=(nn*sxz-sx*sz)/(nn*sx2-sx*sx)
2212 : 0 : bb=sz/nn-sx*aa/nn
2213 : :
2214 [ # # ]: 0 : do ii=1,nn
2215 : 0 : msrt=msrt+ABS(zz(ii)-aa*xx(ii)-bb)**2
2216 : : end do
2217 : 0 : msrt=SQRT(msrt) ; res=msrt
2218 : :
2219 : 0 : end function linfit_dpc
2220 : : !!***
2221 : :
2222 : : !----------------------------------------------------------------------
2223 : :
2224 : : !!****f* m_numeric_tools/llsfit_svd
2225 : : !! NAME
2226 : : !! llsfit_svd
2227 : : !!
2228 : : !! FUNCTION
2229 : : !! Given a set of N data points (x,y) with individual standard deviations sigma_i,
2230 : : !! use chi-square minimization to determine the M coefficients, par, of a function that
2231 : : !! depends linearly on nfuncs functions, i.e f(x) = \sum_i^{nfuncs} par_i * func_i(x).
2232 : : !! Solve the fitting equations using singular value decomposition of the design matrix as in Eq 14.3.17
2233 : : !! of Numerical Recipes. The program returns values for the M fit parameters par, and chi-square.
2234 : : !! The user supplies a subroutine funcs(x,nfuncs) that returns the M basis functions evaluated at xx.
2235 : : !!
2236 : : !! INPUTS
2237 : : !!
2238 : : !! OUTPUT
2239 : : !!
2240 : : !! SOURCE
2241 : :
2242 [ # # # # : 0 : subroutine llsfit_svd(xx,yy,sigma,nfuncs,funcs,chisq,par,var,cov,info)
# # ]
2243 : :
2244 : : !Arguments ------------------------------------
2245 : : !scalars
2246 : : integer,intent(in) :: nfuncs
2247 : : integer,intent(out) :: info
2248 : : real(dp),intent(out) :: chisq
2249 : : !arrays
2250 : : real(dp),intent(in) :: xx(:),yy(:),sigma(:)
2251 : : real(dp),intent(out) :: par(:),var(:),cov(:,:)
2252 : :
2253 : : interface
2254 : : function funcs(xx,nf)
2255 : : use defs_basis
2256 : : real(dp),intent(in) :: xx
2257 : : integer,intent(in) :: nf
2258 : : real(dp) :: funcs(nf)
2259 : : end function funcs
2260 : : end interface
2261 : :
2262 : : !Local variables-------------------------------
2263 : : integer,parameter :: PAD_=50
2264 : : integer :: ii,npts,lwork
2265 : : real(dp),parameter :: TOL_=1.0e-5_dp
2266 : : !arrays
2267 : 0 : real(dp),dimension(SIZE(xx)) :: bb,sigm1
2268 : 0 : real(dp),dimension(SIZE(xx),nfuncs) :: dmat,dmat_save
2269 : 0 : real(dp) :: tmp(nfuncs)
2270 : 0 : real(dp),allocatable :: work(:),Vt(:,:),U(:,:),S(:)
2271 : : ! *************************************************************************
2272 : :
2273 : 0 : npts = assert_eq(SIZE(xx),SIZE(yy),SIZE(sigma),'Wrong size in xx,yy,sigma', __FILE__, __LINE__)
2274 : 0 : call assert((npts>=nfuncs),'No. of functions must greater than no. of points', __FILE__, __LINE__)
2275 : 0 : ii = assert_eq(nfuncs,SIZE(cov,1),SIZE(cov,2),SIZE(var),'Wrong size in covariance', __FILE__, __LINE__)
2276 : :
2277 : : !
2278 : : ! === Calculate design matrix and b vector ===
2279 : : ! * dmat_ij=f_j(x_i)/sigma_i, b_i=y_i/sigma_i
2280 [ # # # # ]: 0 : sigm1(:)=one/sigma(:) ; bb(:)=yy(:)*sigm1(:)
2281 [ # # ]: 0 : do ii=1,npts
2282 [ # # # # ]: 0 : dmat_save(ii,:)=funcs(xx(ii),nfuncs)
2283 : : end do
2284 [ # # # # ]: 0 : dmat=dmat_save*SPREAD(sigm1,DIM=2,ncopies=nfuncs)
2285 [ # # # # ]: 0 : dmat_save(:,:)=dmat(:,:)
2286 : : !
2287 : : ! === Singular value decomposition ===
2288 : 0 : lwork=MAX(3*MIN(npts,nfuncs)+MAX(npts,nfuncs),5*MIN(npts,nfuncs)-4)+PAD_
2289 [ # # # # : 0 : ABI_MALLOC(work,(lwork))
# # # # #
# # # ]
2290 [ # # # # : 0 : ABI_MALLOC(U,(npts,npts))
# # # # #
# # # # #
# # ]
2291 [ # # # # : 0 : ABI_MALLOC(S,(nfuncs))
# # # # #
# # # ]
2292 [ # # # # : 0 : ABI_MALLOC(Vt,(nfuncs,nfuncs))
# # # # #
# # # # #
# # ]
2293 : :
2294 : 0 : call DGESVD('A','A',npts,nfuncs,dmat,npts,S,U,npts,Vt,nfuncs,work,lwork,info)
2295 [ # # ]: 0 : ABI_FREE(work)
2296 : : GOTO 10
2297 : : !
2298 : : ! === Set to zero small singular values according to TOL_ and find coefficients ===
2299 : : WHERE (S>TOL_*MAXVAL(S))
2300 : : tmp=MATMUL(bb,U)/S
2301 : : ELSEWHERE
2302 : : S =zero
2303 : : tmp=zero
2304 : : END WHERE
2305 : : par(:)=MATMUL(tmp,Vt)
2306 : : !
2307 : : ! === Evaluate chi-square ===
2308 : : chisq=l2norm(MATMUL(dmat_save,par)-bb)**2
2309 : : !
2310 : : ! === Calculate covariance and variance ===
2311 : : ! C_jk = V_ji V_ki / S_i^2
2312 : : WHERE (S/=zero) S=one/(S*S)
2313 : :
2314 : : ! check this but should be correct
2315 : : cov(:,:)=Vt*SPREAD(S,DIM=2,ncopies=nfuncs)
2316 : : cov(:,:)=MATMUL(TRANSPOSE(Vt),cov)
2317 : : var(:)=SQRT(get_diag(cov))
2318 : :
2319 : : 10 continue
2320 [ # # ]: 0 : ABI_FREE(U)
2321 [ # # ]: 0 : ABI_FREE(S)
2322 [ # # ]: 0 : ABI_FREE(Vt)
2323 : :
2324 : 0 : end subroutine llsfit_svd
2325 : : !!***
2326 : :
2327 : : !----------------------------------------------------------------------
2328 : :
2329 : : !!****f* m_numeric_tools/polyn_interp
2330 : : !! NAME
2331 : : !! polyn_interp
2332 : : !!
2333 : : !! FUNCTION
2334 : : !! Given arrays xa and ya of length N, and given a value x, return a value y, and an error estimate dy.
2335 : : !! If P(x) is the polynomial of degree N-1 such that P(xai)=yai, i=1,...,N, then the returned value y=P(x).
2336 : : !!
2337 : : !! INPUTS
2338 : : !! xa(:)=abscissas in ascending order
2339 : : !! ya(:)=ordinates
2340 : : !! x=the point where the set of data has to be interpolated
2341 : : !!
2342 : : !! OUTPUT
2343 : : !! y=the interpolated value
2344 : : !! dy=error estimate
2345 : : !!
2346 : : !! NOTES
2347 : : !! Based on the polint routine reported in Numerical Recipes
2348 : : !!
2349 : : !! SOURCE
2350 : :
2351 [ - + - + ]: 120544 : subroutine polyn_interp(xa,ya,x,y,dy)
2352 : :
2353 : : !Arguments ------------------------------------
2354 : : !scalars
2355 : : real(dp),intent(in) :: xa(:),ya(:)
2356 : : real(dp),intent(in) :: x
2357 : : real(dp),intent(out) :: y,dy
2358 : : !Local variables-------------------------------
2359 : : !scalars
2360 : : integer :: m,n,ns
2361 : : !arrays
2362 : 241088 : real(dp),dimension(SIZE(xa)) :: c,d,den,ho
2363 : : ! *************************************************************************
2364 : :
2365 : 120544 : n = assert_eq(SIZE(xa),SIZE(ya),'Different size in xa and ya',__FILE__,__LINE__)
2366 : :
2367 : : ! === Initialize the tables of c and d ===
2368 [ + + + + : 1928704 : c(:)=ya(:) ; d(:)=ya(:) ; ho(:)=xa(:)-x
+ + ]
2369 : : ! === Find closest table entry and initial approximation to y ===
2370 [ + - + + ]: 723264 : ns=imin_loc(ABS(x-xa)) ; y=ya(ns)
2371 : 120544 : ns=ns-1
2372 : : !
2373 : : ! === For each column of the tableau loop over current c and d and up-date them ===
2374 [ + + ]: 602720 : do m=1,n-1
2375 [ + + ]: 1687616 : den(1:n-m)=ho(1:n-m)-ho(1+m:n)
2376 [ + + + - : 1687616 : if (ANY(den(1:n-m)==zero)) then
- + ]
2377 : 0 : ABI_ERROR('Two input xa are identical')
2378 : : end if
2379 : :
2380 [ + + ]: 1687616 : den(1:n-m)=(c(2:n-m+1)-d(1:n-m))/den(1:n-m)
2381 [ + + ]: 1687616 : d(1:n-m)=ho(1+m:n)*den(1:n-m) ! Update c and d
2382 [ + + ]: 1687616 : c(1:n-m)=ho(1:n-m)*den(1:n-m)
2383 : :
2384 [ - + ]: 482176 : if (2*ns<n-m) then ! Now decide which correction, c or d, we want to add to the
2385 : 0 : dy=c(ns+1) ! accumulating value of y, The last dy added is the error indication.
2386 : : else
2387 : 482176 : dy=d(ns)
2388 : 482176 : ns=ns-1
2389 : : end if
2390 : :
2391 : 602720 : y=y+dy
2392 : : end do
2393 : :
2394 : 120544 : end subroutine polyn_interp
2395 : : !!***
2396 : :
2397 : : !----------------------------------------------------------------------
2398 : :
2399 : : !!****f* m_numeric_tools/polcoe
2400 : : !! NAME
2401 : : !! polcoe
2402 : : !!
2403 : : !! FUNCTION
2404 : : !! Given arrays x(1:n) and y(1:n) containing a tabulated function yi = f (xi ), this routine
2405 : : !! returns an array with the coefficients cof(1:n) of a polynomial interpolation.
2406 : : !!
2407 : : !! INPUTS
2408 : : !! x(n)=abscissas in ascending order
2409 : : !! y(n)=ordinates
2410 : : !! n=number of points given to start the interpolation
2411 : : !!
2412 : : !! OUTPUT
2413 : : !! cof(n)= coefficients array
2414 : : !!
2415 : : !! NOTES
2416 : : !! Based on the polcoe routine reported in Numerical Recipies
2417 : : !!
2418 : : !! SOURCE
2419 : :
2420 : 3248 : subroutine polcoe(x,y,n,cof)
2421 : :
2422 : : !Arguments ------------------------------------
2423 : : !scalars
2424 : : integer, intent(in) :: n
2425 : : !arrays
2426 : : real(dp), intent(in) :: x(n),y(n)
2427 : : real(dp), intent(out) :: cof(n)
2428 : : !Local variables ------------------------------
2429 : : !scalars
2430 : : integer, parameter :: NMAX=15
2431 : : integer :: i,j,k
2432 : : real(dp) :: b,ff,phi
2433 : : !arrays
2434 : : real(dp) :: s(NMAX)
2435 : : ! *************************************************************************
2436 : :
2437 [ + + ]: 9744 : do 11 i=1,n
2438 : 6496 : s(i)=0.
2439 : 6496 : cof(i)=0.
2440 : 3248 : 11 continue
2441 : 3248 : s(n)=-x(1)
2442 [ + + ]: 6496 : do 13 i=2,n
2443 [ + + ]: 6496 : do 12 j=n+1-i,n-1
2444 : 3248 : s(j)=s(j)-x(i)*s(j+1)
2445 : 3248 : 12 continue
2446 : 3248 : s(n)=s(n)-x(i)
2447 : 3248 : 13 continue
2448 [ + + ]: 9744 : do 16 j=1,n
2449 : 6496 : phi=n
2450 [ + + ]: 12992 : do 14 k=n-1,1,-1
2451 : 6496 : phi=k*s(k+1)+x(j)*phi
2452 : 6496 : 14 continue
2453 : 6496 : ff=y(j)/phi
2454 : 6496 : b=1.
2455 [ + + ]: 19488 : do 15 k=n,1,-1
2456 : 12992 : cof(k)=cof(k)+b*ff
2457 : 12992 : b=s(k)+x(j)*b
2458 : 6496 : 15 continue
2459 : 3248 : 16 continue
2460 : :
2461 : 3248 : end subroutine polcoe
2462 : : !!***
2463 : :
2464 : : !----------------------------------------------------------------------
2465 : :
2466 : : !!****f* m_numeric_tools/trapezoidal_
2467 : : !! NAME
2468 : : !! trapezoidal_ (PRIVATE)
2469 : : !!
2470 : : !! FUNCTION
2471 : : !! Compute the n-th stage of refinement of an extended trapezoidal rule
2472 : : !! adding 2^(n-2) additional interior point in the finite range of integration
2473 : : !!
2474 : : !! INPUTS
2475 : : !! func(external)=the name of the function to be integrated
2476 : : !! xmin,xmax=the limits of integration
2477 : : !! nn=integer defining the refinement of the mesh, each call adds 2^(n-2) additional interior points
2478 : : !!
2479 : : !! OUTPUT
2480 : : !! See SIDE EFFECTS
2481 : : !!
2482 : : !! SIDE EFFECTS
2483 : : !! quad=the integral at the n-th stage.
2484 : : !!
2485 : : !! NOTES
2486 : : !! When called with nn=1, the routine returns the crudest estimate of the integral
2487 : : !! Subsequent calls with nn=2,3,... (in that sequential order) will improve the accuracy
2488 : : !! by adding 2^(n-2) additional interior points. Note that quad should not be modified between sequential calls.
2489 : : !! Subroutine is defined as recursive to allow multi-dimensional integrations
2490 : : !!
2491 : : !! SOURCE
2492 : :
2493 : 0 : recursive subroutine trapezoidal_(func,nn,xmin,xmax,quad)
2494 : :
2495 : : !Arguments ------------------------------------
2496 : : !scalars
2497 : : integer,intent(in) :: nn
2498 : : !real(dp),external :: func
2499 : : real(dp),intent(in) :: xmin,xmax
2500 : : real(dp),intent(inout) :: quad
2501 : :
2502 : : interface
2503 : : function func(x)
2504 : : use defs_basis
2505 : : real(dp),intent(in) :: x
2506 : : real(dp) :: func
2507 : : end function func
2508 : : end interface
2509 : :
2510 : : !interface
2511 : : ! function func(x)
2512 : : ! use defs_basis
2513 : : ! real(dp),intent(in) :: x(:)
2514 : : ! real(dp) :: func(SIZE(x))
2515 : : ! end function func
2516 : : !end interface
2517 : :
2518 : : !Local variables-------------------------------
2519 : : !scalars
2520 : : integer :: npt,ix
2521 : : real(dp) :: space,new,yy
2522 : : character(len=500) :: msg
2523 : : !arrays
2524 : : !real(dp),allocatable :: xx(:)
2525 : : !************************************************************************
2526 : :
2527 : 0 : select case (nn)
2528 : :
2529 : : case (1)
2530 : : ! === Initial crude estimate (xmax-xmin)(f1+f2)/2 ===
2531 : : !quad=half*(xmax-xmin)*SUM(func((/xmin,xmax/)))
2532 : 0 : quad=half*(xmax-xmin)*(func(xmin)+func(xmax))
2533 : :
2534 : : case (2:)
2535 : : ! === Add npt interior points of spacing space ===
2536 [ # # ]: 0 : npt=2**(nn-2) ; space=(xmax-xmin)/npt
2537 : : ! === The new sum is combined with the old integral to give a refined integral ===
2538 : : !new=SUM(func(arth(xmin+half*space,space,npt))) !PARALLEL version
2539 : : !allocate(xx(npt))
2540 : : !xx(:)=arth(xmin+half*space,space,npt)
2541 : : !xx(1)=xmin+half*space
2542 : : !do ii=2,nn
2543 : : ! xx(ii)=xx(ii-1)+space
2544 : : !end do
2545 : 0 : new=zero
2546 : 0 : yy=xmin+half*space
2547 [ # # ]: 0 : do ix=1,npt
2548 : : !new=new+func(xx(ix))
2549 : 0 : new=new+func(yy)
2550 : 0 : yy=yy+space
2551 : : end do
2552 : : !deallocate(xx)
2553 : 0 : quad=half*(quad+space*new)
2554 : : !write(std_out,*) 'trapezoidal',quad
2555 : :
2556 : : case (:0)
2557 : 0 : write(msg,'(a,i3)')'Wrong value for nn ',nn
2558 [ # # # ]: 0 : ABI_BUG(msg)
2559 : : end select
2560 : :
2561 : 0 : end subroutine trapezoidal_
2562 : : !!***
2563 : :
2564 : : !----------------------------------------------------------------------
2565 : :
2566 : : !!****f* m_numeric_tools/midpoint_
2567 : : !! NAME
2568 : : !! midpoint_ (PRIVATE)
2569 : : !!
2570 : : !! FUNCTION
2571 : : !! This routine computes the n-th stage of refinement of an extended midpoint rule.
2572 : : !!
2573 : : !! INPUTS
2574 : : !! func(external)=the name of the function to be integrated
2575 : : !! xmin,xmax=the limits of integration
2576 : : !! nn=integer defining the refinement of the mesh, each call adds (2/3)*3n-1 additional
2577 : : !! interior points between xmin ans xmax
2578 : : !!
2579 : : !! OUTPUT
2580 : : !! See SIDE EFFECTS
2581 : : !!
2582 : : !! SIDE EFFECTS
2583 : : !! quad=the integral at the n-th stage.
2584 : : !!
2585 : : !! NOTES
2586 : : !! When called with nn=1, the routine returns as quad the crudest estimate of the integral
2587 : : !! Subsequent calls with nn=2,3,... (in that sequential order) will improve the accuracy of quad by adding
2588 : : !! (2/3)*3n-1 additional interior points. quad should not be modified between sequential calls.
2589 : : !! Subroutine is defined as recursive to allow multi-dimensional integrations
2590 : : !!
2591 : : !! SOURCE
2592 : :
2593 : 602608 : recursive subroutine midpoint_(func,nn,xmin,xmax,quad)
2594 : :
2595 : : !Arguments ------------------------------------
2596 : : !scalars
2597 : : integer,intent(in) :: nn
2598 : : !real(dp),external :: func
2599 : : real(dp),intent(in) :: xmin,xmax
2600 : : real(dp),intent(inout) :: quad
2601 : :
2602 : : interface
2603 : : function func(x)
2604 : : use defs_basis
2605 : : real(dp),intent(in) :: x
2606 : : real(dp) :: func
2607 : : end function func
2608 : : end interface
2609 : :
2610 : : !interface
2611 : : ! function func(x)
2612 : : ! use defs_basis
2613 : : ! real(dp),intent(in) :: x(:)
2614 : : ! real(dp) :: func(SIZE(x))
2615 : : ! end function func
2616 : : !end interface
2617 : :
2618 : : !Local variables-------------------------------
2619 : : !scalars
2620 : : integer :: npt,ix
2621 : : real(dp) :: space
2622 : : character(len=500) :: msg
2623 : : !arrays
2624 : 602608 : real(dp),allocatable :: xx(:)
2625 : : !************************************************************************
2626 : :
2627 : 723124 : select case (nn)
2628 : :
2629 : : case (1)
2630 : : ! === Initial crude estimate done at the middle of the interval
2631 : : !quad=(xmax-xmin)*SUM(func((/half*(xmin+xmax)/))) !PARALLEL version
2632 : 120516 : quad=(xmax-xmin)*func(half*(xmin+xmax))
2633 : :
2634 : : case (2:)
2635 : : ! === Add npt interior points, they alternate in spacing between space and 2*space ===
2636 [ + - - + : 1446276 : ABI_MALLOC(xx,(2*3**(nn-2)))
+ - + - +
- - + -
+ ]
2637 : 482092 : npt=3**(nn-2) ; space=(xmax-xmin)/(three*npt)
2638 [ + - + + ]: 5305000 : xx(1:2*npt-1:2)=arth(xmin+half*space,three*space,npt)
2639 [ + + ]: 5305000 : xx(2:2*npt:2)=xx(1:2*npt-1:2)+two*space
2640 : : ! === The new sum is combined with the old integral to give a refined integral ===
2641 : : !quad=quad/three+space*SUM(func(xx)) !PARALLEL version
2642 : 482092 : quad=quad/three
2643 [ + + ]: 10127908 : do ix=1,SIZE(xx)
2644 : 10127908 : quad=quad+space*func(xx(ix))
2645 : : end do
2646 [ - + ]: 482092 : ABI_FREE(xx)
2647 : :
2648 : : case (:0)
2649 : 0 : write(msg,'(a,i3)')' wrong value for nn ',nn
2650 [ + + - ]: 602608 : ABI_BUG('Wrong value for nn')
2651 : : end select
2652 : :
2653 : 602608 : end subroutine midpoint_
2654 : : !!***
2655 : :
2656 : : !----------------------------------------------------------------------
2657 : :
2658 : : !!****f* m_numeric_tools/quadrature
2659 : : !! NAME
2660 : : !! quadrature
2661 : : !!
2662 : : !! FUNCTION
2663 : : !! Driver routine to perform quadratures in finite domains using different techniques.
2664 : : !! The routine improves the resolution of the grid until a given accuracy is reached
2665 : : !!
2666 : : !! INPUTS
2667 : : !! func(external)=the function to be integrated
2668 : : !! xmin,xmax=the limits of integration
2669 : : !! npts=Initial number of points, only for Gauss-Legendre. At each step this number is doubled
2670 : : !! accuracy=fractional accuracy required
2671 : : !! ntrial=Max number of attempts
2672 : : !! qopt=integer flag defining the algorithm for the quadrature:
2673 : : !! 1 for Trapezoidal rule, closed, O(1/N^2)
2674 : : !! 2 for Simpson based on trapezoidal,closed, O(1/N^4)
2675 : : !! 3 for Midpoint rule, open, O(1/N^2)
2676 : : !! 4 for midpoint rule with cancellation of leading error, open, O(1/N^4)
2677 : : !! 5 for Romberg integration (closed form) and extrapolation for h-->0 (order 10 is hard-coded)
2678 : : !! 6 for Romberg integration with midpoint rule and extrapolation for h-->0 (order 10 is hard-coded)
2679 : : !! 7 for Gauss-Legendre
2680 : : !!
2681 : : !! OUTPUT
2682 : : !! quad=the integral
2683 : : !! ierr=0 if quadrature converged.
2684 : : !!
2685 : : !! SOURCE
2686 : :
2687 : 120516 : recursive subroutine quadrature(func,xmin,xmax,qopt,quad,ierr,ntrial,accuracy,npts)
2688 : :
2689 : : !Arguments ------------------------------------
2690 : : !scalars
2691 : : integer,intent(in) :: qopt
2692 : : integer,intent(out) :: ierr
2693 : : integer,optional,intent(in) :: ntrial,npts
2694 : : real(dp),intent(in) :: xmin,xmax
2695 : : real(dp),optional,intent(in) :: accuracy
2696 : : real(dp),intent(out) :: quad
2697 : :
2698 : : interface
2699 : : function func(x)
2700 : : use defs_basis
2701 : : real(dp),intent(in) :: x
2702 : : real(dp) :: func
2703 : : end function func
2704 : : end interface
2705 : :
2706 : : !interface
2707 : : ! function func(x)
2708 : : ! use defs_basis
2709 : : ! real(dp),intent(in) :: x(:)
2710 : : ! real(dp) :: func(SIZE(x))
2711 : : ! end function func
2712 : : !end interface
2713 : :
2714 : : !Local variables-------------------------------
2715 : : !scalars
2716 : : integer :: K,KM,NT,NX,NX0,it,ix
2717 : : real(dp) :: EPS,old_st,st,old_quad,dqromb
2718 : : real(dp) :: TOL
2719 : : character(len=500) :: msg
2720 : : !arrays
2721 : 120516 : real(dp),allocatable :: h(:),s(:), wx(:),xx(:)
2722 : : ! *************************************************************************
2723 : :
2724 : 120516 : ierr = 0
2725 : 120516 : TOL =tol12
2726 [ + - ]: 120516 : EPS =tol6 ; if (PRESENT(accuracy)) EPS=accuracy
2727 [ + - ]: 120516 : NT =20 ; if (PRESENT(ntrial )) NT=ntrial
2728 : 120516 : quad =zero
2729 : :
2730 : 120516 : select case (qopt)
2731 : :
2732 : : case (1)
2733 : : ! === Trapezoidal, closed form, O(1/N^2)
2734 [ # # ]: 0 : do it=1,NT
2735 : 0 : call trapezoidal_(func,it,xmin,xmax,quad)
2736 [ # # ]: 0 : if (it>5) then ! Avoid spurious early convergence
2737 [ # # # # : 0 : if (ABS(quad-old_quad)<EPS*ABS(old_quad).or.(ABS(quad)<TOL.and.ABS(old_quad)<TOL)) RETURN
# # ]
2738 : : end if
2739 : 0 : old_quad=quad
2740 : : end do
2741 : :
2742 : : case (2)
2743 : : ! === Extended Simpson rule based on trapezoidal O(1/N^4) ===
2744 [ # # ]: 0 : do it=1,NT
2745 : 0 : call trapezoidal_(func,it,xmin,xmax,st)
2746 [ # # ]: 0 : if (it==1) then
2747 : 0 : quad=st
2748 : : else
2749 : 0 : quad=(four*st-old_st)/three
2750 : : end if
2751 [ # # ]: 0 : if (it>5) then ! Avoid spurious early convergence
2752 [ # # # # : 0 : if (ABS(quad-old_quad)<EPS*ABS(old_quad).or.(ABS(quad)<TOL.and.ABS(old_quad)<TOL)) RETURN
# # ]
2753 : : end if
2754 : 0 : old_quad=quad
2755 : 0 : old_st=st
2756 : : end do
2757 : :
2758 : : case (3)
2759 : : ! === Midpoint rule, open form, O(1/N^2) ===
2760 [ # # ]: 0 : do it=1,NT
2761 : 0 : call midpoint_(func,it,xmin,xmax,quad)
2762 [ # # ]: 0 : if (it>4) then ! Avoid spurious early convergence
2763 [ # # # # : 0 : if (ABS(quad-old_quad)<EPS*ABS(old_quad).or.(ABS(quad)<TOL.and.ABS(old_quad)<TOL)) RETURN
# # ]
2764 : : end if
2765 : 0 : old_quad=quad
2766 : : end do
2767 : :
2768 : : case (4)
2769 : : ! === Midpoint rule with cancellation of leading 1/N^2 term, open form, O(1/N^4) ===
2770 [ # # ]: 0 : do it=1,NT
2771 : 0 : call midpoint_(func,it,xmin,xmax,st)
2772 [ # # ]: 0 : if (it==1) then
2773 : 0 : quad=st
2774 : : else
2775 : 0 : quad=(nine*st-old_st)/eight
2776 : : end if
2777 [ # # ]: 0 : if (it>4) then ! Avoid spurious early convergence
2778 [ # # # # : 0 : if (ABS(quad-old_quad)<EPS*ABS(old_quad).or.(ABS(quad)<TOL.and.ABS(old_quad)<TOL)) RETURN
# # ]
2779 : : end if
2780 : 0 : old_quad=quad
2781 : 0 : old_st=st
2782 : : end do
2783 : :
2784 : : case (5)
2785 : : ! === Romberg Integration, closed form ===
2786 : 0 : K=5 ; KM=K-1 ! Order 10
2787 [ # # # # : 0 : ABI_MALLOC(h,(NT+1))
# # # # #
# # # #
# ]
2788 [ # # # # : 0 : ABI_MALLOC(s,(NT+1))
# # # # ]
2789 [ # # ]: 0 : h=zero
2790 [ # # ]: 0 : s=zero
2791 : 0 : h(1)=one
2792 [ # # ]: 0 : do it=1,NT
2793 : 0 : call trapezoidal_(func,it,xmin,xmax,s(it))
2794 : : !write(std_out,*) ' romberg-trap at ',ncall,it,s(it)
2795 [ # # ]: 0 : if (it>=K) then
2796 : 0 : call polyn_interp(h(it-KM:it),s(it-KM:it),zero,quad,dqromb)
2797 [ # # ]: 0 : if (ABS(dqromb)<EPS*ABS(quad)) then
2798 : 0 : ABI_FREE(h)
2799 [ # # ]: 0 : ABI_FREE(s)
2800 : 0 : RETURN
2801 : : end if
2802 : : end if
2803 : 0 : s(it+1)=s(it)
2804 : 0 : h(it+1)=quarter*h(it) ! Quarter makes the extrapolation a polynomial in h^2,
2805 : : end do ! This is required to use the Euler-Maclaurin formula
2806 : 0 : ABI_FREE(h)
2807 [ # # ]: 0 : ABI_FREE(s)
2808 : :
2809 : : case (6)
2810 : : ! === Romberg Integration, closed form ===
2811 : 120516 : K=5 ; KM=K-1 ! Order 10
2812 [ + - - + : 361548 : ABI_MALLOC(h,(NT+1))
+ - + - +
- - + -
+ ]
2813 [ - + + - : 241032 : ABI_MALLOC(s,(NT+1))
- + - + ]
2814 [ + + ]: 3856512 : h=zero
2815 [ + + ]: 3856512 : s=zero
2816 : 120516 : h(1)=one
2817 [ + - ]: 602608 : do it=1,NT
2818 : 602608 : call midpoint_(func,it,xmin,xmax,s(it))
2819 [ + + ]: 602608 : if (it>=K) then
2820 : 120544 : call polyn_interp(h(it-KM:it),s(it-KM:it),zero,quad,dqromb)
2821 : : !write(std_out,*) quad,dqromb
2822 [ + + ]: 120544 : if (ABS(dqromb)<EPS*ABS(quad)) then
2823 : 120516 : ABI_FREE(h)
2824 [ - + ]: 120516 : ABI_FREE(s)
2825 : 120516 : RETURN
2826 : : end if
2827 : : end if
2828 : 482092 : s(it+1)=s(it)
2829 : 482092 : h(it+1)=ninth*h(it) ! factor is due to step tripling in midpoint and even error series
2830 : : end do
2831 : 0 : ABI_FREE(h)
2832 [ # # ]: 0 : ABI_FREE(s)
2833 : :
2834 : : case (7)
2835 : : ! === Gauss-Legendre ===
2836 [ # # ]: 0 : NX0=5 ; if (PRESENT(npts)) NX0=npts
2837 : 0 : NX=NX0
2838 [ # # ]: 0 : do it=1,NT
2839 [ # # # # : 0 : ABI_MALLOC(wx,(NX))
# # # # #
# # # ]
2840 [ # # # # : 0 : ABI_MALLOC(xx,(NX))
# # # # ]
2841 : 0 : call coeffs_gausslegint(xmin,xmax,xx,wx,NX)
2842 : 0 : quad=zero
2843 [ # # ]: 0 : do ix=1,NX
2844 : 0 : quad=quad+wx(ix)*func(xx(ix))
2845 : : end do
2846 [ # # ]: 0 : ABI_FREE(wx)
2847 [ # # ]: 0 : ABI_FREE(xx)
2848 [ # # ]: 0 : if (it>1) then
2849 : : !write(std_out,*) quad
2850 [ # # # # : 0 : if (ABS(quad-old_quad)<EPS*ABS(old_quad).or.(ABS(quad)<TOL.and.ABS(old_quad)<TOL)) RETURN
# # ]
2851 : : end if
2852 : 0 : old_quad=quad
2853 : 0 : NX=NX+NX0
2854 : : !NX=2*NX
2855 : : end do
2856 : :
2857 : : case default
2858 : 0 : write(msg,'(a,i3)')'Wrong value for qopt',qopt
2859 [ - - - - : 120516 : ABI_BUG(msg)
- + - - ]
2860 : : end select
2861 : :
2862 : : write(msg,'(a,i0,2(a,es14.6))')&
2863 : 0 : "Results are not converged within the given accuracy. ntrial= ",NT,"; EPS= ",EPS,"; TOL= ",TOL
2864 : 0 : ABI_WARNING(msg)
2865 : 0 : ierr = -1
2866 : :
2867 : : end subroutine quadrature
2868 : : !!***
2869 : :
2870 : : !!****f* m_numeric_tools/ctrap
2871 : : !! NAME
2872 : : !! ctrap
2873 : : !!
2874 : : !! FUNCTION
2875 : : !! Do corrected trapezoidal integral on uniform grid of spacing hh.
2876 : : !!
2877 : : !! INPUTS
2878 : : !! imax=highest index of grid=grid point number of upper limit
2879 : : !! ff(imax)=integrand values
2880 : : !! hh=spacing between x points
2881 : : !!
2882 : : !! OUTPUT
2883 : : !! ans=resulting integral by corrected trapezoid
2884 : : !!
2885 : : !! NOTES
2886 : : !!
2887 : : !! SOURCE
2888 : :
2889 : 15162820 : subroutine ctrap(imax,ff,hh,ans)
2890 : :
2891 : : !Arguments ------------------------------------
2892 : : !scalars
2893 : : integer,intent(in) :: imax
2894 : : real(dp),intent(in) :: hh
2895 : : real(dp),intent(out) :: ans
2896 : : !arrays
2897 : : real(dp),intent(in) :: ff(imax)
2898 : :
2899 : : !Local variables-------------------------------
2900 : : !scalars
2901 : : integer :: ir,ir2
2902 : : real(dp) :: endpt,sum
2903 : : ! *************************************************************************
2904 : :
2905 [ + + ]: 15162820 : if (imax>=10)then
2906 : :
2907 : : ! endpt=end point correction terms (low and high ends)
2908 : : endpt = (23.75d0*(ff(1)+ff(imax )) &
2909 : : & + 95.10d0*(ff(2)+ff(imax-1)) &
2910 : : & + 55.20d0*(ff(3)+ff(imax-2)) &
2911 : : & + 79.30d0*(ff(4)+ff(imax-3)) &
2912 : 15162804 : & + 70.65d0*(ff(5)+ff(imax-4)))/ 72.d0
2913 : 15162804 : ir2 = imax - 5
2914 : 15162804 : sum=0.00d0
2915 [ + + ]: 15162804 : if (ir2 > 5) then
2916 [ + + ]: 4480016062 : do ir=6,ir2
2917 : 4480016062 : sum = sum + ff(ir)
2918 : : end do
2919 : : end if
2920 : 15162804 : ans = (sum + endpt ) * hh
2921 : :
2922 [ + + ]: 16 : else if (imax>=8)then
2923 : : endpt = (17.0d0*(ff(1)+ff(imax )) &
2924 : : & + 59.0d0*(ff(2)+ff(imax-1)) &
2925 : : & + 43.0d0*(ff(3)+ff(imax-2)) &
2926 : 4 : & + 49.0d0*(ff(4)+ff(imax-3)) )/ 48.d0
2927 : 4 : sum=0.0d0
2928 [ + + ]: 4 : if(imax==9)sum=ff(5)
2929 : 4 : ans = (sum + endpt ) * hh
2930 : :
2931 : : else if (imax==7)then
2932 : : ans = (17.0d0*(ff(1)+ff(imax )) &
2933 : : & + 59.0d0*(ff(2)+ff(imax-1)) &
2934 : : & + 43.0d0*(ff(3)+ff(imax-2)) &
2935 : 2 : & + 50.0d0* ff(4) )/ 48.d0 *hh
2936 : :
2937 : : else if (imax==6)then
2938 : : ans = (17.0d0*(ff(1)+ff(imax )) &
2939 : : & + 59.0d0*(ff(2)+ff(imax-1)) &
2940 : 2 : & + 44.0d0*(ff(3)+ff(imax-2)) )/ 48.d0 *hh
2941 : :
2942 : : else if (imax==5)then
2943 : : ans = ( (ff(1)+ff(5)) &
2944 : : & + four*(ff(2)+ff(4)) &
2945 : 2 : & + two * ff(3) )/ three *hh
2946 : :
2947 : : else if (imax==4)then
2948 : : ans = (three*(ff(1)+ff(4)) &
2949 : 2 : & + nine *(ff(2)+ff(3)) )/ eight *hh
2950 : :
2951 : : else if (imax==3)then
2952 : : ans = ( (ff(1)+ff(3)) &
2953 : 2 : & + four* ff(2) )/ three *hh
2954 : :
2955 : : else if (imax==2)then
2956 : 2 : ans = (ff(1)+ff(2))/ two *hh
2957 : :
2958 : : else if (imax==1)then
2959 : 0 : ans = ff(1)*hh
2960 : :
2961 : : end if
2962 : :
2963 : 15162820 : end subroutine ctrap
2964 : : !!***
2965 : :
2966 : : !!****f* m_numeric_tools/cspint
2967 : : !! NAME
2968 : : !! cspint
2969 : : !!
2970 : : !! FUNCTION
2971 : : !! Estimates the integral of a tabulated function.
2972 : : !!
2973 : : !! INPUTS
2974 : : !!
2975 : : !! OUTPUT
2976 : : !!
2977 : : !! NOTES
2978 : : !!
2979 : : !! The routine is given the value of a function F(X) at a set of
2980 : : !! nodes XTAB, and estimates
2981 : : !!
2982 : : !! Integral ( A <= X <= B ) F(X) DX
2983 : : !!
2984 : : !! by computing the cubic natural spline S(X) that interpolates
2985 : : !! F(X) at the nodes, and then computing
2986 : : !!
2987 : : !! Integral ( A <= X <= B ) S(X) DX
2988 : : !!
2989 : : !! exactly.
2990 : : !!
2991 : : !! Other output from the program includes the definite integral
2992 : : !! from X(1) to X(I) of S(X), and the coefficients necessary for
2993 : : !! the user to evaluate the spline S(X) at any point.
2994 : : !!
2995 : : !! Modified:
2996 : : !!
2997 : : !! 30 October 2000
2998 : : !!
2999 : : !! Reference:
3000 : : !!
3001 : : !! Philip Davis and Philip Rabinowitz,
3002 : : !! Methods of Numerical Integration,
3003 : : !! Blaisdell Publishing, 1967.
3004 : : !!
3005 : : !! Parameters:
3006 : : !!
3007 : : !! Input, real (dp) FTAB(NTAB), contains the tabulated values of
3008 : : !! the function, FTAB(I) = F(XTAB(I)).
3009 : : !!
3010 : : !! Input, real (dp) XTAB(NTAB), contains the points at which the
3011 : : !! function was evaluated. The XTAB's must be distinct and
3012 : : !! in ascending order.
3013 : : !!
3014 : : !! Input, integer NTAB, the number of entries in FTAB and
3015 : : !! XTAB. NTAB must be at least 3.
3016 : : !!
3017 : : !! Input, real (dp) A, lower limit of integration.
3018 : : !!
3019 : : !! Input, real (dp) B, upper limit of integration.
3020 : : !!
3021 : : !! Output, real (dp) Y(3,NTAB), will contain the coefficients
3022 : : !! of the interpolating natural spline over each subinterval.
3023 : : !!
3024 : : !! For XTAB(I) <= X <= XTAB(I+1),
3025 : : !!
3026 : : !! S(X) = FTAB(I) + Y(1,I)*(X-XTAB(I))
3027 : : !! + Y(2,I)*(X-XTAB(I))**2
3028 : : !! + Y(3,I)*(X-XTAB(I))**3
3029 : : !!
3030 : : !! Output, real (dp) E(NTAB), E(I) = the definite integral from
3031 : : !! XTAB(1) to XTAB(I) of S(X).
3032 : : !!
3033 : : !! Workspace, real (dp) WORK(NTAB).
3034 : : !!
3035 : : !! Output, real (dp) RESULT, the estimated value of the integral.
3036 : : !!
3037 : : !!
3038 : : !! SOURCE
3039 : :
3040 : 0 : subroutine cspint ( ftab, xtab, ntab, a, b, y, e, work, result )
3041 : :
3042 : : !Arguments ------------------------------------
3043 : : !scalars
3044 : : integer, intent(in) :: ntab
3045 : : real(dp), intent(in) :: a
3046 : : real(dp), intent(in) :: b
3047 : : real(dp), intent(inout) :: e(ntab)
3048 : : real(dp), intent(in) :: ftab(ntab)
3049 : : real(dp), intent(inout) :: work(ntab)
3050 : : real(dp), intent(in) :: xtab(ntab)
3051 : : real(dp), intent(inout) :: y(3,ntab)
3052 : : real(dp), intent(out) :: result
3053 : :
3054 : : !Local variables ------------------------------
3055 : : !scalars
3056 : : integer :: i
3057 : : integer :: j
3058 : : real(dp) :: r
3059 : : real(dp) :: s
3060 : : real(dp) :: term
3061 : : real(dp) :: u
3062 : : !************************************************************************
3063 : :
3064 [ # # ]: 0 : if ( ntab < 3 ) then
3065 : 0 : write(std_out,'(a)' ) ' '
3066 : 0 : write(std_out,'(a)' ) 'CSPINT - Fatal error!'
3067 : 0 : write(std_out,'(a,i6)' ) ' NTAB must be at least 3, but input NTAB = ',ntab
3068 : 0 : ABI_ERROR("Aborting now")
3069 : : end if
3070 : :
3071 [ # # ]: 0 : do i = 1, ntab-1
3072 : :
3073 [ # # ]: 0 : if ( xtab(i+1) <= xtab(i) ) then
3074 : 0 : write(std_out,'(a)' ) ' '
3075 : 0 : write(std_out,'(a)' ) 'CSPINT - Fatal error!'
3076 : 0 : write(std_out,'(a)' ) ' Nodes not in strict increasing order.'
3077 : 0 : write(std_out,'(a,i6)' ) ' XTAB(I) <= XTAB(I-1) for I=',i
3078 : 0 : write(std_out,'(a,g14.6)' ) ' XTAB(I) = ',xtab(i)
3079 : 0 : write(std_out,'(a,g14.6)' ) ' XTAB(I-1) = ',xtab(i-1)
3080 : 0 : ABI_ERROR("Aborting now")
3081 : : end if
3082 : :
3083 : : end do
3084 : :
3085 : 0 : s = zero
3086 [ # # ]: 0 : do i = 1, ntab-1
3087 : 0 : r = ( ftab(i+1) - ftab(i) ) / ( xtab(i+1) - xtab(i) )
3088 : 0 : y(2,i) = r - s
3089 : 0 : s = r
3090 : : end do
3091 : :
3092 : 0 : result = zero
3093 : 0 : s = zero
3094 : 0 : r = zero
3095 : 0 : y(2,1) = zero
3096 : 0 : y(2,ntab) = zero
3097 : :
3098 [ # # ]: 0 : do i = 2, ntab-1
3099 : 0 : y(2,i) = y(2,i) + r * y(2,i-1)
3100 : 0 : work(i) = two * ( xtab(i-1) - xtab(i+1) ) - r * s
3101 : 0 : s = xtab(i+1) - xtab(i)
3102 : 0 : r = s / work(i)
3103 : : end do
3104 : :
3105 [ # # ]: 0 : do j = 2, ntab-1
3106 : 0 : i = ntab+1-j
3107 : 0 : y(2,i) = ( ( xtab(i+1) - xtab(i) ) * y(2,i+1) - y(2,i) ) / work(i)
3108 : : end do
3109 : :
3110 [ # # ]: 0 : do i = 1, ntab-1
3111 : 0 : s = xtab(i+1) - xtab(i)
3112 : 0 : r = y(2,i+1) - y(2,i)
3113 : 0 : y(3,i) = r / s
3114 : 0 : y(2,i) = three * y(2,i)
3115 : 0 : y(1,i) = ( ftab(i+1) - ftab(i) ) / s - ( y(2,i) + r ) * s
3116 : : end do
3117 : :
3118 : 0 : e(1) = 0.0D+00
3119 [ # # ]: 0 : do i = 1, ntab-1
3120 : 0 : s = xtab(i+1)-xtab(i)
3121 : : term = ((( y(3,i) * quarter * s + y(2,i) * third ) * s &
3122 : 0 : + y(1,i) * half ) * s + ftab(i) ) * s
3123 : 0 : e(i+1) = e(i) + term
3124 : : end do
3125 : : !
3126 : : ! Determine where the endpoints A and B lie in the mesh of XTAB's.
3127 : : !
3128 : 0 : r = a
3129 : 0 : u = one
3130 : :
3131 [ # # ]: 0 : do j = 1, 2
3132 : : !
3133 : : ! The endpoint is less than or equal to XTAB(1).
3134 : : !
3135 [ # # ]: 0 : if ( r <= xtab(1) ) then
3136 : 0 : result = result-u*((r-xtab(1))*y(1,1)*half +ftab(1))*(r-xtab(1))
3137 : : !
3138 : : ! The endpoint is greater than or equal to XTAB(NTAB).
3139 : : !
3140 [ # # ]: 0 : else if ( xtab(ntab) <= r ) then
3141 : :
3142 : : result = result -u * ( e(ntab) + ( r - xtab(ntab) ) &
3143 : : * ( ftab(ntab) + half * ( ftab(ntab-1) &
3144 : : + ( xtab(ntab) - xtab(ntab-1) ) * y(1,ntab-1) ) &
3145 : 0 : * ( r - xtab(ntab) )))
3146 : : !
3147 : : ! The endpoint is strictly between XTAB(1) and XTAB(NTAB).
3148 : : !
3149 : : else
3150 : :
3151 [ # # ]: 0 : do i = 1, ntab-1
3152 : :
3153 [ # # ]: 0 : if ( r <= xtab(i+1) ) then
3154 : 0 : r = r-xtab(i)
3155 : : result = result-u*(e(i)+(((y(3,i)*quarter*r+y(2,i)*third)*r &
3156 : 0 : +y(1,i)*half )*r+ftab(i))*r)
3157 : 0 : go to 120
3158 : : end if
3159 : :
3160 : : end do
3161 : :
3162 : : end if
3163 : :
3164 : : 120 continue
3165 : :
3166 : 0 : u = -one
3167 : 0 : r = b
3168 : :
3169 : : end do
3170 : :
3171 : 0 : end subroutine cspint
3172 : : !!***
3173 : :
3174 : : !!****f* m_numeric_tools/coeffs_gausslegint
3175 : : !! NAME
3176 : : !! coeffs_gausslegint
3177 : : !!
3178 : : !! FUNCTION
3179 : : !! Compute the coefficients (supports and weights) for Gauss-Legendre integration.
3180 : : !! Inspired by a routine due to G. Rybicki.
3181 : : !!
3182 : : !! INPUTS
3183 : : !! xmin=lower bound of integration
3184 : : !! xmax=upper bound of integration
3185 : : !! n=order of integration
3186 : : !!
3187 : : !! OUTPUT
3188 : : !! x(n)=array of support points
3189 : : !! weights(n)=array of integration weights
3190 : : !!
3191 : : !! SOURCE
3192 : :
3193 : 99 : subroutine coeffs_gausslegint(xmin,xmax,x,weights,n)
3194 : :
3195 : : !Arguments ------------------------------------
3196 : : !scalars
3197 : : integer,intent(in) :: n
3198 : : real(dp),intent(in) :: xmin,xmax
3199 : : real(dp),intent(out) :: x(n),weights(n)
3200 : :
3201 : : !Local variables ------------------------------
3202 : : !scalars
3203 : : integer :: i,j
3204 : : real(dp),parameter :: tol=1.d-13
3205 : : real(dp),parameter :: pi=4.d0*atan(1.d0)
3206 : : real(dp) :: z,z1,xmean,p1,p2,p3,pp,xl
3207 : : !************************************************************************
3208 : :
3209 : 99 : xl=(xmax-xmin)*0.5d0
3210 : 99 : xmean=(xmax+xmin)*0.5d0
3211 : :
3212 [ + + ]: 1602 : do i=1,(n+1)/2
3213 : 1503 : z=cos(pi*(i-0.25d0)/(n+0.5d0))
3214 : :
3215 : : do
3216 : 4600 : p1=1.d0
3217 : 4600 : p2=0.d0
3218 : :
3219 [ + + ]: 392997 : do j=1,n
3220 : 388397 : p3=p2
3221 : 388397 : p2=p1
3222 : 392997 : p1=((2.d0*j - 1.d0)*z*p2 - (j-1.d0)*p3)/j
3223 : : end do
3224 : :
3225 : 4600 : pp=n*(p2-z*p1)/(1.0d0-z**2)
3226 : 4600 : z1=z
3227 : 4600 : z=z1-p1/pp
3228 : :
3229 [ + + ]: 4600 : if(abs(z-z1) < tol) exit
3230 : : end do
3231 : :
3232 : 1503 : x(i)=xmean-xl*z
3233 : 1503 : x(n+1-i)=xmean+xl*z
3234 : 1503 : weights(i)=2.d0*xl/((1.d0-z**2)*pp**2)
3235 : 1602 : weights(n+1-i)=weights(i)
3236 : : end do
3237 : :
3238 : 99 : end subroutine coeffs_gausslegint
3239 : : !!***
3240 : :
3241 : : !----------------------------------------------------------------------
3242 : :
3243 : : !!****f* m_numeric_tools/simpson_cplx
3244 : : !! NAME
3245 : : !! simpson_cplx
3246 : : !!
3247 : : !! FUNCTION
3248 : : !! Integrate a complex function using extended Simpson's rule.
3249 : : !!
3250 : : !! INPUTS
3251 : : !! npts=Number of points.
3252 : : !! step=Step of the mesh.
3253 : : !! ff(npts)=Values of the integrand.
3254 : : !!
3255 : : !! OUTPUT
3256 : : !! simpson_cplx=Integral of ff.
3257 : : !!
3258 : : !! NOTES
3259 : : !! If npts is odd, the integration is done with the extended Simpson's rule (error = O^(step^4))
3260 : : !! If npts is even, the last 4 four points are integrated separately via Simpson's 3/8 rule. Error = O(step^5)
3261 : : !! while the first npts-3 points are integrared with the extended Simpson's rule.
3262 : : !!
3263 : : !! SOURCE
3264 : :
3265 : 42720 : function simpson_cplx(npts,step,ff)
3266 : :
3267 : : !Arguments ------------------------------------
3268 : : !scalars
3269 : : integer,intent(in) :: npts
3270 : : real(dp),intent(in) :: step
3271 : : complex(dp),intent(in) :: ff(npts)
3272 : : complex(dp) :: simpson_cplx
3273 : :
3274 : : !Local variables ------------------------------
3275 : : !scalars
3276 : : integer :: ii,my_n
3277 : : complex(dp) :: sum_even, sum_odd
3278 : : !************************************************************************
3279 : :
3280 [ - + ]: 42720 : my_n=npts; if ((npts/2)*2 == npts) my_n=npts-3
3281 : :
3282 [ - + ]: 42720 : if (my_n<2) then
3283 : 0 : ABI_ERROR("Too few points")
3284 : : end if
3285 : :
3286 : 42720 : sum_odd=czero
3287 [ + - ]: 42720 : do ii=2,my_n-1,2
3288 [ + + ]: 22929972 : sum_odd = sum_odd + ff(ii)
3289 : : end do
3290 : :
3291 : 42720 : sum_even=zero
3292 [ + - ]: 42720 : do ii=3,my_n-2,2
3293 [ + + ]: 22887252 : sum_even = sum_even + ff(ii)
3294 : : end do
3295 : :
3296 : : ! Eq 25.4.6 Abramowitz. Error is O(step^4)
3297 : 42720 : simpson_cplx = step/three * (ff(1) + four*sum_odd + two*sum_even + ff(my_n))
3298 : :
3299 [ - + ]: 42720 : if (my_n/=npts) then ! Simpson's 3/8 rule. Eq 25.4.13 Abramowitz. Error is O(step^5)
3300 : 0 : simpson_cplx = simpson_cplx + three*step/eight * (ff(npts-3) + 3*ff(npts-2) + 3*ff(npts-1) + ff(npts))
3301 : : end if
3302 : :
3303 : 42720 : end function simpson_cplx
3304 : : !!***
3305 : :
3306 : : !----------------------------------------------------------------------
3307 : :
3308 : : !!****f* m_numeric_tools/hermitianize_spc
3309 : : !! NAME
3310 : : !! hermitianize_spc
3311 : : !!
3312 : : !! FUNCTION
3313 : : !! Force a square matrix to be hermitian
3314 : : !!
3315 : : !! INPUTS
3316 : : !! uplo=String describing which part of the matrix has been calculated.
3317 : : !! Only the first character is tested (no case sensitive). Possible values are:
3318 : : !! "All"= Full matrix is supplied in input
3319 : : !! "Upper"=Upper triangle is in input. Lower triangle is reconstructed by symmetry.
3320 : : !! "Lower"=Lower triangle is in input. Upper triangle is reconstructed by symmetry.
3321 : : !!
3322 : : !! OUTPUT
3323 : : !! (see side effects)
3324 : : !!
3325 : : !! SIDE EFFECTS
3326 : : !! mat(:,:)=complex input matrix, hermitianized at output
3327 : : !!
3328 : : !! SOURCE
3329 : :
3330 [ # # ]: 0 : subroutine hermitianize_spc(mat,uplo)
3331 : :
3332 : : !Arguments ------------------------------------
3333 : : !scalars
3334 : : character(len=*),intent(in) :: uplo
3335 : : !arrays
3336 : : complex(sp),intent(inout) :: mat(:,:)
3337 : :
3338 : : !Local variables-------------------------------
3339 : : !scalars
3340 : : integer :: nn,ii,jj
3341 : : !arrays
3342 : 0 : complex(sp),allocatable :: tmp(:)
3343 : : ! *************************************************************************
3344 : :
3345 : 0 : nn = assert_eq(SIZE(mat,1),SIZE(mat,2),'Matrix not square',__FILE__,__LINE__)
3346 : :
3347 : 0 : select case (uplo(1:1))
3348 : :
3349 : : case ("A","a") ! Full matrix has been calculated.
3350 [ # # # # : 0 : ABI_MALLOC(tmp,(nn))
# # # # #
# # # ]
3351 [ # # ]: 0 : do ii=1,nn
3352 [ # # ]: 0 : do jj=ii,nn
3353 : : ! reference half constant is dp not sp
3354 : 0 : tmp(jj)=real(half)*(mat(ii,jj)+CONJG(mat(jj,ii)))
3355 : : end do
3356 [ # # ]: 0 : mat(ii,ii:nn)=tmp(ii:nn)
3357 [ # # ]: 0 : mat(ii:nn,ii)=CONJG(tmp(ii:nn))
3358 : : end do
3359 [ # # ]: 0 : ABI_FREE(tmp)
3360 : :
3361 : : case ("U","u") ! Only the upper triangle is used.
3362 [ # # ]: 0 : do jj=1,nn
3363 [ # # ]: 0 : do ii=1,jj
3364 [ # # ]: 0 : if (ii/=jj) then
3365 : 0 : mat(jj,ii) = CONJG(mat(ii,jj))
3366 : : else
3367 : 0 : mat(ii,ii) = CMPLX(REAL(mat(ii,ii)),0.0_sp)
3368 : : end if
3369 : : end do
3370 : : end do
3371 : :
3372 : : case ("L","l") ! Only the lower triangle is used.
3373 [ # # ]: 0 : do jj=1,nn
3374 [ # # ]: 0 : do ii=1,jj
3375 [ # # ]: 0 : if (ii/=jj) then
3376 : 0 : mat(ii,jj) = CONJG(mat(jj,ii))
3377 : : else
3378 : 0 : mat(ii,ii) = CMPLX(REAL(mat(ii,ii)),0.0_sp)
3379 : : end if
3380 : : end do
3381 : : end do
3382 : :
3383 : : case default
3384 [ # # # # : 0 : ABI_ERROR("Wrong uplo"//TRIM(uplo))
# # ]
3385 : : end select
3386 : :
3387 : 0 : end subroutine hermitianize_spc
3388 : : !!***
3389 : :
3390 : : !----------------------------------------------------------------------
3391 : :
3392 : : !!****f* m_numeric_tools/hermitianize_dpc
3393 : : !! NAME
3394 : : !! hermitianize_dpc
3395 : : !!
3396 : : !! FUNCTION
3397 : : !! Force a square matrix to be hermitian
3398 : : !!
3399 : : !! INPUTS
3400 : : !! uplo=String describing which part of the matrix has been calculated.
3401 : : !! Only the first character is tested (no case sensitive). Possible values are:
3402 : : !! "All"= Full matrix is supplied in input
3403 : : !! "Upper"=Upper triangle is in input. Lower triangle is reconstructed by symmetry.
3404 : : !! "Lower"=Lower triangle is in input. Upper triangle is reconstructed by symmetry.
3405 : : !!
3406 : : !! OUTPUT
3407 : : !! (see side effects)
3408 : : !!
3409 : : !! SIDE EFFECTS
3410 : : !! mat(:,:)=complex input matrix, hermitianized in output
3411 : : !!
3412 : : !! SOURCE
3413 : :
3414 [ - + ]: 435 : subroutine hermitianize_dpc(mat,uplo)
3415 : :
3416 : : !Arguments ------------------------------------
3417 : : !scalars
3418 : : character(len=*),intent(in) :: uplo
3419 : : !arrays
3420 : : complex(dp),intent(inout) :: mat(:,:)
3421 : :
3422 : : !Local variables-------------------------------
3423 : : !scalars
3424 : : integer :: nn,ii,jj
3425 : : !arrays
3426 : 435 : complex(dp),allocatable :: tmp(:)
3427 : : ! *************************************************************************
3428 : :
3429 : 435 : nn = assert_eq(SIZE(mat,1),SIZE(mat,2),'Matrix not square',__FILE__,__LINE__)
3430 : :
3431 : 32 : select case (uplo(1:1))
3432 : :
3433 : : case ("A","a") ! Full matrix has been calculated.
3434 [ - + + - : 96 : ABI_MALLOC(tmp,(nn))
+ - + - -
+ - + ]
3435 [ + + ]: 656 : do ii=1,nn
3436 [ + + ]: 7560 : do jj=ii,nn
3437 : 7560 : tmp(jj)=half*(mat(ii,jj)+DCONJG(mat(jj,ii)))
3438 : : end do
3439 [ + + ]: 7560 : mat(ii,ii:nn)=tmp(ii:nn)
3440 [ + + ]: 7592 : mat(ii:nn,ii)=DCONJG(tmp(ii:nn))
3441 : : end do
3442 [ - + ]: 32 : ABI_FREE(tmp)
3443 : :
3444 : : case ("U","u") ! Only the upper triangle is used.
3445 [ + + ]: 5219 : do jj=1,nn
3446 [ + + ]: 324591 : do ii=1,jj
3447 [ + + ]: 324188 : if (ii/=jj) then
3448 : 314556 : mat(jj,ii) = DCONJG(mat(ii,jj))
3449 : : else
3450 : 4816 : mat(ii,ii) = CMPLX(DBLE(mat(ii,ii)),zero, kind=dp)
3451 : : end if
3452 : : end do
3453 : : end do
3454 : :
3455 : : case ("L","l") ! Only the lower triangle is used.
3456 [ # # ]: 0 : do jj=1,nn
3457 [ # # ]: 0 : do ii=1,jj
3458 [ # # ]: 0 : if (ii/=jj) then
3459 : 0 : mat(ii,jj) = DCONJG(mat(jj,ii))
3460 : : else
3461 : 0 : mat(ii,ii) = CMPLX(REAL(mat(ii,ii)),zero, kind=dp)
3462 : : end if
3463 : : end do
3464 : : end do
3465 : :
3466 : : case default
3467 [ + - + - : 435 : ABI_ERROR("Wrong uplo"//TRIM(uplo))
- - ]
3468 : : end select
3469 : :
3470 : 435 : end subroutine hermitianize_dpc
3471 : : !!***
3472 : :
3473 : : !----------------------------------------------------------------------
3474 : :
3475 : : !!****f* m_numeric_tools/mkherm
3476 : : !! NAME
3477 : : !! mkherm
3478 : : !!
3479 : : !! FUNCTION
3480 : : !! Make the complex array(ndim,ndim) hermitian,
3481 : : !! by adding half of it to its hermitian conjugate.
3482 : : !!
3483 : : !! INPUTS
3484 : : !! ndim=dimension of the matrix
3485 : : !! array= complex matrix
3486 : : !!
3487 : : !! SIDE EFFECTS
3488 : : !! array= hermitian matrix made by adding half of array to its hermitian conjugate
3489 : : !!
3490 : : !! SOURCE
3491 : :
3492 : 771230 : pure subroutine mkherm(array,ndim)
3493 : :
3494 : : !Arguments -------------------------------
3495 : : !scalars
3496 : : integer,intent(in) :: ndim
3497 : : !arrays
3498 : : real(dp),intent(inout) :: array(2,ndim,ndim)
3499 : :
3500 : : !Local variables -------------------------
3501 : : !scalars
3502 : : integer :: i1,i2
3503 : : ! *********************************************************************
3504 : :
3505 [ + + ]: 4834607 : do i1=1,ndim
3506 [ + + ]: 20595431 : do i2=1,i1
3507 : 15760824 : array(1,i1,i2)=(array(1,i1,i2)+array(1,i2,i1))*half
3508 : 15760824 : array(2,i1,i2)=(array(2,i1,i2)-array(2,i2,i1))*half
3509 : 15760824 : array(1,i2,i1)=array(1,i1,i2)
3510 : 19824201 : array(2,i2,i1)=-array(2,i1,i2)
3511 : : end do
3512 : : end do
3513 : :
3514 : 771230 : end subroutine mkherm
3515 : : !!***
3516 : :
3517 : : !----------------------------------------------------------------------
3518 : :
3519 : : !!****f* m_numeric_tools/hermit
3520 : : !! NAME
3521 : : !! hermit
3522 : : !!
3523 : : !! FUNCTION
3524 : : !! Take a matrix in hermitian storage mode (lower triangle stored)
3525 : : !! and redefine diagonal elements to impose Hermiticity
3526 : : !! (diagonal terms have to be real).
3527 : : !! If abs(Im(H(i,i)))>4096*machine precision, print error warning.
3528 : : !! (Typical 64 bit machine precision is 2^-52 or 2.22e-16)
3529 : : !!
3530 : : !! INPUTS
3531 : : !! chmin(n*n+n)=complex hermitian matrix with numerical noise possibly
3532 : : !! rendering Im(diagonal elements) approximately 1e-15 or so
3533 : : !! ndim=size of complex hermitian matrix
3534 : : !!
3535 : : !! OUTPUT
3536 : : !! chmout(n*n+n)=redefined matrix with strictly real diagonal elements.
3537 : : !! May be same storage location as chmin.
3538 : : !! ierr=0 if no problem, 1 if the imaginary part of some element
3539 : : !! too large (at present, stop in this case).
3540 : : !!
3541 : : !! TODO
3542 : : !! Name is misleading, perhaps hermit_force_diago?
3543 : : !! Interface allows aliasing
3544 : : !!
3545 : : !! SOURCE
3546 : :
3547 : 447726 : subroutine hermit(chmin, chmout, ierr, ndim)
3548 : :
3549 : : !Arguments ------------------------------------
3550 : : !scalars
3551 : : integer,intent(in) :: ndim
3552 : : integer,intent(out) :: ierr
3553 : : !arrays
3554 : : real(dp),intent(inout) :: chmin(ndim*ndim+ndim)
3555 : : real(dp),intent(inout) :: chmout(ndim*ndim+ndim)
3556 : :
3557 : : !Local variables-------------------------------
3558 : : !scalars
3559 : : integer,save :: mmesgs=20,nmesgs=0
3560 : : integer :: idim,max_errors,nerrors
3561 : : real(dp),parameter :: eps=epsilon(0.0d0)
3562 : : real(dp) :: ch_im,ch_re,modules,tol
3563 : : character(len=500) :: msg
3564 : : ! *************************************************************************
3565 : :
3566 : 447726 : tol=4096.0d0*eps
3567 : :
3568 : 447726 : ierr=0
3569 : 447726 : max_errors=0
3570 : :
3571 : : !Copy matrix into possibly new location
3572 [ + + ]: 62759040 : chmout(:)=chmin(:)
3573 : :
3574 : : !Loop over diagonal elements of matrix (off-diag not altered)
3575 [ + + ]: 3670530 : do idim=1,ndim
3576 : :
3577 : 3222804 : ch_im=chmout(idim*idim+idim )
3578 : 3222804 : ch_re=chmout(idim*idim+idim-1)
3579 : :
3580 : : ! check for large absolute Im part and print warning when
3581 : : ! larger than (some factor)*(machine precision)
3582 : 3222804 : nerrors=0
3583 [ + - - - ]: 3222804 : if( abs(ch_im) > tol .and. abs(ch_im) > tol8*abs(ch_re)) nerrors=2
3584 [ + - - + ]: 3222804 : if( abs(ch_im) > tol .or. abs(ch_im) > tol8*abs(ch_re)) nerrors=1
3585 : :
3586 [ - + - - : 3222804 : if( (abs(ch_im) > tol .and. nmesgs<mmesgs) .or. nerrors==2)then
- + ]
3587 : : write(msg, '(3a,i0,a,es20.12,a,es20.12,a)' )&
3588 : 0 : ' Input Hermitian matrix has nonzero relative Im part on diagonal:',ch10,&
3589 : 0 : ' for component: ',idim,' Im part is: ',ch_im,', Re part is: ',ch_re,'.'
3590 : 0 : call wrtout(std_out,msg)
3591 : 0 : nmesgs=nmesgs+1
3592 : : end if
3593 : :
3594 [ - + - - : 3222804 : if( ( abs(ch_im) > tol8*abs(ch_re) .and. nmesgs<mmesgs) .or. nerrors==2)then
- + ]
3595 : : write(msg, '(3a,i0,a,es20.12,a,es20.12,a)' )&
3596 : 0 : ' Input Hermitian matrix has nonzero relative Im part on diagonal:',ch10,&
3597 : 0 : ' for component: ',idim,' Im part is',ch_im,', Re part is',ch_re,'.'
3598 : 0 : call wrtout(std_out,msg)
3599 : 0 : nmesgs=nmesgs+1
3600 : : end if
3601 : :
3602 : : ! compute modulus $= (\Re^2+\Im^2)^{1/2}$
3603 : 3222804 : modules=sqrt(ch_re**2+ch_im**2)
3604 : :
3605 : : ! set Re part to modulus with sign of original Re part
3606 : 3222804 : chmout(idim*idim+idim-1)=sign(modules,ch_re)
3607 : :
3608 : : ! set Im part to 0
3609 : 3222804 : chmout(idim*idim+idim)=zero
3610 : :
3611 : 3670530 : max_errors=max(max_errors,nerrors)
3612 : : end do
3613 : :
3614 [ - + ]: 447726 : if (max_errors==2)then
3615 : 0 : ierr=1
3616 : : write(msg, '(3a)' )&
3617 : 0 : 'Imaginary part(s) of diagonal Hermitian matrix element(s) is too large.',ch10,&
3618 : 0 : 'See previous messages.'
3619 : 0 : ABI_BUG(msg)
3620 : : end if
3621 : :
3622 : 447726 : end subroutine hermit
3623 : : !!***
3624 : :
3625 : : !----------------------------------------------------------------------
3626 : :
3627 : : !!****f* m_numeric_tools/symmetrize_spc
3628 : : !! NAME
3629 : : !! symmetrize_spc
3630 : : !!
3631 : : !! FUNCTION
3632 : : !! Force a square matrix to be symmetric.
3633 : : !!
3634 : : !! INPUTS
3635 : : !! uplo=String describing which part of the matrix has been calculated.
3636 : : !! Only the first character is tested (no case sensitive). Possible values are:
3637 : : !! "All"= Full matrix is supplied in input
3638 : : !! "Upper"=Upper triangle is in input. Lower triangle is reconstructed by symmetry.
3639 : : !! "Lower"=Lower triangle is in input. Upper triangle is reconstructed by symmetry.
3640 : : !!
3641 : : !! OUTPUT
3642 : : !! (see side effects)
3643 : : !!
3644 : : !! SIDE EFFECTS
3645 : : !! mat(:,:)=complex input matrix, symmetrized at output
3646 : : !!
3647 : : !! SOURCE
3648 : :
3649 [ # # ]: 0 : subroutine symmetrize_spc(mat,uplo)
3650 : :
3651 : : !Arguments ------------------------------------
3652 : : !scalars
3653 : : character(len=*),intent(in) :: uplo
3654 : : !arrays
3655 : : complex(sp),intent(inout) :: mat(:,:)
3656 : :
3657 : : !Local variables-------------------------------
3658 : : !scalars
3659 : : integer :: nn,ii,jj
3660 : : !arrays
3661 : 0 : complex(sp),allocatable :: tmp(:)
3662 : : ! *************************************************************************
3663 : :
3664 : 0 : nn = assert_eq(SIZE(mat,1),SIZE(mat,2),'Matrix not square',__FILE__,__LINE__)
3665 : :
3666 : 0 : select case (uplo(1:1))
3667 : :
3668 : : case ("A","a") ! Full matrix has been calculated.
3669 [ # # # # : 0 : ABI_MALLOC(tmp,(nn))
# # # # #
# # # ]
3670 [ # # ]: 0 : do ii=1,nn
3671 [ # # ]: 0 : do jj=ii,nn
3672 : 0 : tmp(jj)=REAL(half)*(mat(ii,jj)+mat(jj,ii))
3673 : : end do
3674 [ # # ]: 0 : mat(ii,ii:nn)=tmp(ii:nn)
3675 [ # # ]: 0 : mat(ii:nn,ii)=tmp(ii:nn)
3676 : : end do
3677 [ # # ]: 0 : ABI_FREE(tmp)
3678 : :
3679 : : case ("U","u") ! Only the upper triangle is used.
3680 [ # # ]: 0 : do jj=1,nn
3681 [ # # ]: 0 : do ii=1,jj-1
3682 : 0 : mat(jj,ii) = mat(ii,jj)
3683 : : end do
3684 : : end do
3685 : :
3686 : : case ("L","l") ! Only the lower triangle is used.
3687 [ # # ]: 0 : do jj=1,nn
3688 [ # # ]: 0 : do ii=1,jj-1
3689 : 0 : mat(ii,jj) = mat(jj,ii)
3690 : : end do
3691 : : end do
3692 : :
3693 : : case default
3694 [ # # # # : 0 : ABI_ERROR("Wrong uplo"//TRIM(uplo))
# # ]
3695 : : end select
3696 : :
3697 : 0 : end subroutine symmetrize_spc
3698 : : !!***
3699 : :
3700 : : !----------------------------------------------------------------------
3701 : :
3702 : : !!****f* m_numeric_tools/symmetrize_dpc
3703 : : !! NAME
3704 : : !! symmetrize_dpc
3705 : : !!
3706 : : !! FUNCTION
3707 : : !! Force a square matrix to be symmetric.
3708 : : !!
3709 : : !! INPUTS
3710 : : !! uplo=String describing which part of the matrix has been calculated.
3711 : : !! Only the first character is tested (no case sensitive). Possible values are:
3712 : : !! "All"= Full matrix is supplied in input
3713 : : !! "Upper"=Upper triangle is in input. Lower triangle is reconstructed by symmetry.
3714 : : !! "Lower"=Lower triangle is in input. Upper triangle is reconstructed by symmetry.
3715 : : !!
3716 : : !! OUTPUT
3717 : : !! (see side effects)
3718 : : !!
3719 : : !! SIDE EFFECTS
3720 : : !! mat(:,:)=complex input matrix, symmetrized in output
3721 : : !!
3722 : : !! SOURCE
3723 : :
3724 [ # # ]: 0 : subroutine symmetrize_dpc(mat, uplo)
3725 : :
3726 : : !Arguments ------------------------------------
3727 : : !scalars
3728 : : character(len=*),intent(in) :: uplo
3729 : : !arrays
3730 : : complex(dp),intent(inout) :: mat(:,:)
3731 : :
3732 : : !Local variables-------------------------------
3733 : : !scalars
3734 : : integer :: nn,ii,jj
3735 : : !arrays
3736 : 0 : complex(dp),allocatable :: tmp(:)
3737 : : ! *************************************************************************
3738 : :
3739 : 0 : nn = assert_eq(SIZE(mat,1),SIZE(mat,2),'Matrix not square',__FILE__,__LINE__)
3740 : :
3741 : 0 : select case (uplo(1:1))
3742 : : case ("A","a") ! Full matrix has been calculated.
3743 [ # # # # : 0 : ABI_MALLOC(tmp,(nn))
# # # # #
# # # ]
3744 [ # # ]: 0 : do ii=1,nn
3745 [ # # ]: 0 : do jj=ii,nn
3746 : 0 : tmp(jj)=half*(mat(ii,jj)+mat(jj,ii))
3747 : : end do
3748 [ # # ]: 0 : mat(ii,ii:nn)=tmp(ii:nn)
3749 [ # # ]: 0 : mat(ii:nn,ii)=tmp(ii:nn)
3750 : : end do
3751 [ # # ]: 0 : ABI_FREE(tmp)
3752 : :
3753 : : case ("U","u") ! Only the upper triangle is used.
3754 [ # # ]: 0 : do jj=1,nn
3755 [ # # ]: 0 : do ii=1,jj-1
3756 : 0 : mat(jj,ii) = mat(ii,jj)
3757 : : end do
3758 : : end do
3759 : :
3760 : : case ("L","l") ! Only the lower triangle is used.
3761 [ # # ]: 0 : do jj=1,nn
3762 [ # # ]: 0 : do ii=1,jj-1
3763 : 0 : mat(ii,jj) = mat(jj,ii)
3764 : : end do
3765 : : end do
3766 : :
3767 : : case default
3768 [ # # # # : 0 : ABI_ERROR("Wrong uplo"//TRIM(uplo))
# # ]
3769 : : end select
3770 : :
3771 : 0 : end subroutine symmetrize_dpc
3772 : : !!***
3773 : :
3774 : : !!****f* m_numeric_tools/pack_matrix
3775 : : !! NAME
3776 : : !! pack_matrix
3777 : : !!
3778 : : !! FUNCTION
3779 : : !! Packs a matrix into hermitian format
3780 : : !!
3781 : : !! INPUTS
3782 : : !! N: size of matrix
3783 : : !! cplx: 2 if matrix is complex, 1 for real matrix.
3784 : : !! mat_in(cplx, N*N)= matrix to be packed
3785 : : !!
3786 : : !! OUTPUT
3787 : : !! mat_out(cplx*N*N+1/2)= packed matrix (upper triangle)
3788 : : !!
3789 : : !! SOURCE
3790 : :
3791 : 593 : subroutine pack_matrix(mat_in, mat_out, N, cplx)
3792 : :
3793 : : !Arguments ------------------------------------
3794 : : !scalars
3795 : : integer, intent(in) :: N, cplx
3796 : : real(dp), intent(in) :: mat_in(cplx, N*N)
3797 : : real(dp), intent(out) :: mat_out(cplx*N*(N+1)/2)
3798 : :
3799 : : !Local variables-------------------------------
3800 : : integer :: isubh, i, j
3801 : : ! *************************************************************************
3802 : :
3803 : 593 : isubh = 1
3804 [ + + ]: 10173 : do j=1,N
3805 [ + + ]: 120111 : do i=1,j
3806 : 109938 : mat_out(isubh) = mat_in(1, (j-1)*N+i)
3807 : : ! bad for vectorization, but it's not performance critical, so ...
3808 [ + - ]: 109938 : if(cplx == 2) then
3809 : 109938 : mat_out(isubh+1) = mat_in(2, (j-1)*N+i)
3810 : : end if
3811 : 119518 : isubh=isubh+cplx
3812 : : end do
3813 : : end do
3814 : :
3815 : 593 : end subroutine pack_matrix
3816 : : !!***
3817 : :
3818 : :
3819 : : !!****f* m_numeric_tools/check_vec_conjg
3820 : : !! NAME
3821 : : !! check_vec_conjg
3822 : : !!
3823 : : !! FUNCTION
3824 : : !! Test whether two complex vectors `vec1` and `vec2` of size `nn` are conjugate of each other.
3825 : : !! within an optional tolerance abs_tol (default: 1e-6).
3826 : : !! Return max absolute difference for real and imag part in abs_diff(2) and exit status in ierr.
3827 : : !!
3828 : : !! SOURCE
3829 : :
3830 : 0 : integer function check_vec_conjg(nn, vec1, vec2, abs_diff, abs_tol) result(ierr)
3831 : :
3832 : : !Arguments ------------------------------------
3833 : : integer, intent(in) :: nn
3834 : : complex(dp), intent(in) :: vec1(nn), vec2(nn)
3835 : : real(dp),intent(out) :: abs_diff(2)
3836 : : real(dp),optional,intent(in) :: abs_tol
3837 : :
3838 : : !Local variables-------------------------------
3839 : : integer :: ii
3840 : : real(dp) :: my_abs_tol
3841 : : ! *************************************************************************
3842 : :
3843 : 0 : my_abs_tol = tol6; if (present(abs_tol)) my_abs_tol = abs_tol
3844 : 0 : ierr = 0
3845 : 0 : abs_diff = zero
3846 : :
3847 [ # # ]: 0 : do ii=1,nn
3848 : 0 : abs_diff(1) = max(abs_diff(1), abs(real(vec1(ii)) - real(vec2(ii))))
3849 : 0 : abs_diff(2) = max(abs_diff(2), abs(aimag(vec1(ii)) + aimag(vec2(ii))))
3850 : : end do
3851 : :
3852 [ # # # # : 0 : if (any(abs_diff > abs_tol)) ierr = 1
# # ]
3853 : :
3854 : 0 : end function check_vec_conjg
3855 : : !!***
3856 : :
3857 : : !----------------------------------------------------------------------
3858 : :
3859 : : !!****f* m_numeric_tools/print_arr1d_spc
3860 : : !! NAME
3861 : : !! print_arr1d_spc
3862 : : !!
3863 : : !! FUNCTION
3864 : : !! Print an array using a nice (?) format
3865 : : !!
3866 : : !! INPUTS
3867 : : !! arr(:)=vector/matrix to be printed
3868 : : !! units(:)=unit numbers
3869 : : !! max_r,max_c(optional)=Max number of rows and columns to be printed
3870 : : !! (DEFAULT is 9, output format assumes to be less that 99, but there might be
3871 : : !! problems with wrtout if message size exceeds 500 thus max number of elements should be ~60)
3872 : : !!
3873 : : !! OUTPUT
3874 : : !! (only printing)
3875 : : !!
3876 : : !! SOURCE
3877 : :
3878 [ # # # # ]: 0 : subroutine print_arr1d_spc(units, arr, max_r)
3879 : :
3880 : : !Arguments ------------------------------------
3881 : : !scalars
3882 : : integer,intent(in) :: units(:)
3883 : : integer,optional,intent(in) :: max_r
3884 : : !arrays
3885 : : complex(sp),intent(in) :: arr(:)
3886 : :
3887 : : !Local variables-------------------------------
3888 : : !scalars
3889 : : integer :: ii, nr, mr
3890 : : character(len=500) :: msg
3891 : : character(len=100) :: fmth,fmt1
3892 : : ! *************************************************************************
3893 : :
3894 [ # # ]: 0 : mr=15 ; if (PRESENT(max_r )) mr=max_r
3895 [ # # ]: 0 : nr=SIZE(arr,DIM=1); if (mr>nr) mr=nr
3896 : :
3897 : 0 : write(fmth,*)'(6x,',mr,'(i2,6x))'
3898 : 0 : write(fmt1,*)'(3x,',mr,'f8.3)'
3899 : :
3900 [ # # # # ]: 0 : write(msg,fmth)(ii,ii=1,mr)
3901 : 0 : call wrtout(units, msg) !header
3902 [ # # ]: 0 : write(msg,fmt1)REAL (arr(1:mr))
3903 : 0 : call wrtout(units, msg) !real part
3904 [ # # ]: 0 : write(msg,fmt1)AIMAG(arr(1:mr))
3905 : 0 : call wrtout(units, msg) !imag part
3906 : :
3907 : 0 : end subroutine print_arr1d_spc
3908 : : !!***
3909 : :
3910 : : !----------------------------------------------------------------------
3911 : :
3912 : : !!****f* m_numeric_tools/print_arr1d_dpc
3913 : : !! NAME
3914 : : !! print_arr1d_dpc
3915 : : !!
3916 : : !! FUNCTION
3917 : : !!
3918 : : !! INPUTS
3919 : : !!
3920 : : !! OUTPUT
3921 : : !!
3922 : : !! SOURCE
3923 : :
3924 [ - + - + ]: 1828 : subroutine print_arr1d_dpc(units, arr, max_r)
3925 : :
3926 : : !Arguments ------------------------------------
3927 : : !scalars
3928 : : integer,intent(in) :: units(:)
3929 : : integer,optional,intent(in) :: max_r
3930 : : !arrays
3931 : : complex(dp),intent(in) :: arr(:)
3932 : :
3933 : : !Local variables-------------------------------
3934 : : !scalars
3935 : : integer :: ii,nr,mr
3936 : : character(len=500) :: msg
3937 : : character(len=100) :: fmth,fmt1
3938 : : ! *************************************************************************
3939 : :
3940 [ + - ]: 1828 : mr=15 ; if (PRESENT(max_r )) mr=max_r
3941 : :
3942 : : ! Print out matrix.
3943 [ - + ]: 1828 : nr=SIZE(arr,DIM=1) ; if (mr>nr) mr=nr
3944 : :
3945 : 1828 : write(fmth,*)'(6x,',mr,'(i2,6x))'
3946 : 1828 : write(fmt1,*)'(3x,',mr,'f8.3)'
3947 : :
3948 [ + - + + ]: 18280 : write(msg,fmth)(ii,ii=1,mr)
3949 : 1828 : call wrtout(units, msg) ! header
3950 [ + + ]: 18280 : write(msg,fmt1)REAL (arr(1:mr))
3951 : 1828 : call wrtout(units, msg) !real part
3952 [ + + ]: 18280 : write(msg,fmt1)AIMAG(arr(1:mr))
3953 : 1828 : call wrtout(units, msg) !imag part
3954 : :
3955 : 1828 : end subroutine print_arr1d_dpc
3956 : : !!***
3957 : :
3958 : : !----------------------------------------------------------------------
3959 : :
3960 : : !!****f* m_numeric_tools/print_arr2d_spc
3961 : : !! NAME
3962 : : !! print_arr2d_spc
3963 : : !!
3964 : : !! FUNCTION
3965 : : !!
3966 : : !! INPUTS
3967 : : !!
3968 : : !! OUTPUT
3969 : : !!
3970 : : !! SOURCE
3971 : :
3972 [ # # # # ]: 0 : subroutine print_arr2d_spc(units, arr, max_r, max_c)
3973 : :
3974 : : !Arguments ------------------------------------
3975 : : !scalars
3976 : : integer,intent(in) :: units(:)
3977 : : integer,optional,intent(in) :: max_r, max_c
3978 : : !arrays
3979 : : complex(sp),intent(in) :: arr(:,:)
3980 : :
3981 : : !Local variables-------------------------------
3982 : : !scalars
3983 : : integer :: ii,jj,nc,nr,mc,mr
3984 : : character(len=500) :: msg
3985 : : character(len=100) :: fmth,fmt1,fmt2
3986 : : ! *************************************************************************
3987 : :
3988 [ # # ]: 0 : mc =9 ; if (PRESENT(max_c )) mc =max_c
3989 [ # # ]: 0 : mr =9 ; if (PRESENT(max_r )) mr =max_r
3990 : :
3991 : : ! === Print out matrix ===
3992 : 0 : nr=SIZE(arr,DIM=1); if (mr>nr) mr=nr
3993 [ # # ]: 0 : nc=SIZE(arr,DIM=2); if (mc>nc) mc=nc
3994 : :
3995 : 0 : write(fmth,*)'(6x,',mc,'(i2,6x))'
3996 : 0 : write(fmt1,*)'(3x,i2,',mc,'f8.3)'
3997 : 0 : write(fmt2,*)'(5x ,',mc,'f8.3,a)'
3998 : :
3999 [ # # # # ]: 0 : write(msg,fmth)(jj,jj=1,mc)
4000 : 0 : call wrtout(units, msg) !header
4001 [ # # ]: 0 : do ii=1,mr
4002 [ # # ]: 0 : write(msg,fmt1)ii,REAL(arr(ii,1:mc))
4003 : 0 : call wrtout(units, msg) !real part
4004 [ # # ]: 0 : write(msg,fmt2) AIMAG(arr(ii,1:mc)),ch10
4005 : 0 : call wrtout(units, msg) !imag part
4006 : : end do
4007 : :
4008 : 0 : end subroutine print_arr2d_spc
4009 : : !!***
4010 : :
4011 : : !----------------------------------------------------------------------
4012 : :
4013 : : !!****f* m_numeric_tools/print_arr2d_dpc
4014 : : !! NAME
4015 : : !! print_arr2d_dpc
4016 : : !!
4017 : : !! FUNCTION
4018 : : !!
4019 : : !! INPUTS
4020 : : !!
4021 : : !! OUTPUT
4022 : : !!
4023 : : !! SOURCE
4024 : :
4025 [ - + - + ]: 9326 : subroutine print_arr2d_dpc(units, arr, max_r, max_c)
4026 : :
4027 : : !Arguments ------------------------------------
4028 : : !scalars
4029 : : integer,intent(in) :: units(:)
4030 : : integer,optional,intent(in) :: max_r,max_c
4031 : : !arrays
4032 : : complex(dp),intent(in) :: arr(:,:)
4033 : :
4034 : : !Local variables-------------------------------
4035 : : !scalars
4036 : : integer :: ii,jj,nc,nr,mc,mr
4037 : : character(len=500) :: msg
4038 : : character(len=100) :: fmth,fmt1,fmt2
4039 : : ! *************************************************************************
4040 : :
4041 [ + + ]: 9326 : mc =9 ; if (PRESENT(max_c )) mc =max_c
4042 [ + + ]: 9326 : mr =9 ; if (PRESENT(max_r )) mr =max_r
4043 : :
4044 : : ! === Print out matrix ===
4045 : 9326 : nr=SIZE(arr,DIM=1); if (mr>nr) mr=nr
4046 [ - + ]: 9326 : nc=SIZE(arr,DIM=2); if (mc>nc) mc=nc
4047 : :
4048 : 9326 : write(fmth,*)'(6x,',mc,'(i2,6x))'
4049 : 9326 : write(fmt1,*)'(3x,i2,',mc,'f8.3)'
4050 : 9326 : write(fmt2,*)'(5x ,',mc,'f8.3,a)'
4051 : :
4052 [ + - + + ]: 93052 : write(msg,fmth)(jj,jj=1,mc)
4053 : 9326 : call wrtout(units, msg) ! header
4054 [ + + ]: 66402 : do ii=1,mr
4055 [ + + ]: 570304 : write(msg,fmt1)ii,REAL(arr(ii,1:mc))
4056 : 57076 : call wrtout(units, msg) ! real part
4057 [ + + ]: 570304 : write(msg,fmt2) AIMAG(arr(ii,1:mc)),ch10
4058 : 66402 : call wrtout(units, msg) ! imag part
4059 : : end do
4060 : :
4061 : 9326 : end subroutine print_arr2d_dpc
4062 : : !!***
4063 : :
4064 : : !----------------------------------------------------------------------
4065 : :
4066 : : !!****f* m_numeric_tools/pade
4067 : : !! NAME
4068 : : !! pade
4069 : : !!
4070 : : !! FUNCTION
4071 : : !! Calculate the pade approximant in zz of the function f calculated at the n points z
4072 : : !!
4073 : : !! SOURCE
4074 : :
4075 : 995 : function pade(n, z, f, zz)
4076 : :
4077 : : !Arguments ------------------------------------
4078 : : !scalars
4079 : : integer,intent(in) :: n
4080 : : complex(dp),intent(in) :: zz
4081 : : complex(dp) :: pade
4082 : : !arrays
4083 : : complex(dp),intent(in) :: z(n), f(n)
4084 : :
4085 : : !Local variables-------------------------------
4086 : : !scalars
4087 : : integer :: i
4088 : 1990 : complex(dp) :: a(n), Az(0:n), Bz(0:n)
4089 : : ! *************************************************************************
4090 : :
4091 : 995 : call calculate_pade_a(a, n, z, f)
4092 : :
4093 : 995 : Az(0)=czero
4094 : 995 : Az(1)=a(1)
4095 : 995 : Bz(0)=cone
4096 : 995 : Bz(1)=cone
4097 : :
4098 [ + + ]: 10330 : do i=1,n-1
4099 : 9335 : Az(i+1)=Az(i)+(zz-z(i))*a(i+1)*Az(i-1)
4100 : 10330 : Bz(i+1)=Bz(i)+(zz-z(i))*a(i+1)*Bz(i-1)
4101 : : end do
4102 : 995 : pade=Az(n)/Bz(n)
4103 : :
4104 : : !write(std_out,*) 'pade_approx ', pade
4105 : : !write(std_out,*) 'Bz(n)',Bz(n)
4106 : : !if (real(Bz(n))==zero .and. aimag(Bz(n))==zero) write(std_out,*) ' Bz(n) ',Bz(n)
4107 : :
4108 : 995 : end function pade
4109 : : !!***
4110 : :
4111 : : !----------------------------------------------------------------------
4112 : :
4113 : : !!****f* m_numeric_tools/dpade
4114 : : !! NAME
4115 : : !! dpade
4116 : : !!
4117 : : !! FUNCTION
4118 : : !! Calculate the derivative of the pade approximant in zz of the function f calculated at the n points z
4119 : : !!
4120 : : !! SOURCE
4121 : :
4122 : 245 : function dpade(n, z, f, zz)
4123 : :
4124 : : !Arguments ------------------------------------
4125 : : !scalars
4126 : : integer,intent(in) :: n
4127 : : complex(dp),intent(in) :: zz
4128 : : complex(dp) :: dpade
4129 : : !arrays
4130 : : complex(dp),intent(in) :: z(n),f(n)
4131 : :
4132 : : !Local variables-------------------------------
4133 : : !scalars
4134 : : integer :: i
4135 : : !arrays
4136 : 490 : complex(dp) :: a(n), Az(0:n), Bz(0:n), dAz(0:n), dBz(0:n)
4137 : : ! *************************************************************************
4138 : :
4139 : 245 : call calculate_pade_a(a, n, z, f)
4140 : :
4141 : 245 : Az(0)=czero
4142 : 245 : Az(1)=a(1)
4143 : 245 : Bz(0)=cone
4144 : 245 : Bz(1)=cone
4145 : 245 : dAz(0)=czero
4146 : 245 : dAz(1)=czero
4147 : 245 : dBz(0)=czero
4148 : 245 : dBz(1)=czero
4149 : :
4150 [ + + ]: 2830 : do i=1,n-1
4151 : 2585 : Az(i+1)=Az(i)+(zz-z(i))*a(i+1)*Az(i-1)
4152 : 2585 : Bz(i+1)=Bz(i)+(zz-z(i))*a(i+1)*Bz(i-1)
4153 : 2585 : dAz(i+1)=dAz(i)+a(i+1)*Az(i-1)+(zz-z(i))*a(i+1)*dAz(i-1)
4154 : 2830 : dBz(i+1)=dBz(i)+a(i+1)*Bz(i-1)+(zz-z(i))*a(i+1)*dBz(i-1)
4155 : : end do
4156 : : !write(std_out,*) 'Bz(n)', Bz(n)
4157 : : !if (REAL(Bz(n))==zero.and.AIMAG(Bz(n))==zero) write(std_out,*) 'Bz(n)',Bz(n)
4158 : : !pade_approx = Az(n) / Bz(n)
4159 : 245 : dpade=dAz(n)/Bz(n) -Az(n)*dBz(n)/(Bz(n)*Bz(n))
4160 : : !write(std_out,*) 'pade_approx ', pade_approx
4161 : :
4162 : 245 : end function dpade
4163 : : !!***
4164 : :
4165 : : !----------------------------------------------------------------------
4166 : :
4167 : : !!****f* m_numeric_tools/calculate_pade_a
4168 : : !! NAME
4169 : : !! calculate_pade_a
4170 : : !!
4171 : : !! FUNCTION
4172 : : !!
4173 : : !! INPUTS
4174 : : !!
4175 : : !! OUTPUT
4176 : : !!
4177 : : !! SOURCE
4178 : :
4179 : 1240 : subroutine calculate_pade_a(a, n, z, f)
4180 : :
4181 : : !Arguments ------------------------------------
4182 : : !scalars
4183 : : integer,intent(in) :: n
4184 : : complex(dp),intent(in) :: z(n),f(n)
4185 : : complex(dp),intent(out) :: a(n)
4186 : :
4187 : : !Local variables-------------------------------
4188 : : !scalars
4189 : : integer :: i,j
4190 : : !arrays
4191 : 1240 : complex(dp) :: g(n,n)
4192 : : ! *************************************************************************
4193 : :
4194 [ + + ]: 14400 : g(1,1:n)=f(1:n)
4195 : :
4196 [ + + ]: 13160 : do i=2,n
4197 [ + + ]: 79500 : do j=i,n
4198 : : ! if (REAL(g(i-1,j))==zero.and.AIMAG(g(i-1,j))==zero) write(std_out,*) 'g_i(z_j)',i,j,g(i,j)
4199 : 78260 : g(i,j)=(g(i-1,i-1)-g(i-1,j)) / ((z(j)-z(i-1))*g(i-1,j))
4200 : : !write(std_out,*) 'g_i(z_j)',i,j,g(i,j)
4201 : : end do
4202 : : end do
4203 [ + + ]: 14400 : do i=1,n
4204 : 14400 : a(i)=g(i,i)
4205 : : end do
4206 : : !write(std_out,*) 'a ',a(:)
4207 : :
4208 : 1240 : end subroutine calculate_pade_a
4209 : : !!***
4210 : :
4211 : : !----------------------------------------------------------------------
4212 : :
4213 : : !!****f* m_numeric_tools/newrap_step
4214 : : !! NAME
4215 : : !! newrap_step
4216 : : !!
4217 : : !! FUNCTION
4218 : : !! Apply single step newton-raphson method to find the root of a complex function
4219 : : !! z_k+1 = z_k - f(z_k) / (df/dz(z_k))
4220 : : !!
4221 : : !! SOURCE
4222 : :
4223 : 127 : complex(dp) function newrap_step(z, f, df)
4224 : :
4225 : : !Arguments ------------------------------------
4226 : : !scalars
4227 : : complex(dp),intent(in) :: z,f,df
4228 : :
4229 : : !Local variables-------------------------------
4230 : : real(dp) :: dfm2
4231 : : ! *************************************************************************
4232 : :
4233 : 127 : dfm2=ABS(df)*ABS(df)
4234 : :
4235 : 127 : newrap_step = z - (f*CONJG(df))/dfm2
4236 : : !& z-one/(ABS(df)*ABS(df)) * CMPLX( REAL(f)*REAL(df)+AIMAG(f)*AIMAG(df), -REAL(f)*AIMAG(df)+AIMAG(f)*EAL(df) )
4237 : :
4238 : 127 : end function newrap_step
4239 : : !!***
4240 : :
4241 : : !----------------------------------------------------------------------
4242 : :
4243 : : !!****f* m_numeric_tools/cross_product_int
4244 : : !! NAME
4245 : : !! cross_product_int
4246 : : !!
4247 : : !! FUNCTION
4248 : : !! Return the cross product of two vectors with integer components.
4249 : : !!
4250 [ - + ]: 3650 : pure function cross_product_int(vec1,vec2) result(res)
4251 : :
4252 : : !Arguments ------------------------------------
4253 : : integer,intent(in) :: vec1(3),vec2(3)
4254 : : integer :: res(3)
4255 : : ! *************************************************************************
4256 : :
4257 : 3650 : res(1)=vec1(2)*vec2(3)-vec1(3)*vec2(2)
4258 : 3650 : res(2)=vec1(3)*vec2(1)-vec1(1)*vec2(3)
4259 : 3650 : res(3)=vec1(1)*vec2(2)-vec1(2)*vec2(1)
4260 : :
4261 : 3650 : end function cross_product_int
4262 : : !!***
4263 : :
4264 : : !----------------------------------------------------------------------
4265 : :
4266 : : !!****f* m_numeric_tools/cross_product_rdp
4267 : : !! NAME
4268 : : !! cross_product_rdp
4269 : : !!
4270 : : !! FUNCTION
4271 : : !! Return the cross product of two vectors with real double precision components.
4272 : : !!
4273 [ - + ]: 1 : pure function cross_product_rdp(vec1,vec2) result(res)
4274 : :
4275 : : !Arguments ------------------------------------
4276 : : real(dp),intent(in) :: vec1(3),vec2(3)
4277 : : real(dp) :: res(3)
4278 : : ! *************************************************************************
4279 : :
4280 : 1 : res(1)=vec1(2)*vec2(3)-vec1(3)*vec2(2)
4281 : 1 : res(2)=vec1(3)*vec2(1)-vec1(1)*vec2(3)
4282 : 1 : res(3)=vec1(1)*vec2(2)-vec1(2)*vec2(1)
4283 : :
4284 : 1 : end function cross_product_rdp
4285 : : !!***
4286 : :
4287 : : !----------------------------------------------------------------------
4288 : :
4289 : : !!****f* m_numeric_tools/l2norm_rdp
4290 : : !! NAME
4291 : : !! l2norm_rdp
4292 : : !!
4293 : : !! FUNCTION
4294 : : !! Return the length (ordinary L2 norm) of a vector.
4295 : : !!
4296 : :
4297 [ - + ]: 1 : pure function l2norm_rdp(vec) result(res)
4298 : :
4299 : : !Arguments ------------------------------------
4300 : : real(dp),intent(in) :: vec(:)
4301 : : real(dp) :: res
4302 : : ! *************************************************************************
4303 : :
4304 [ + + ]: 4 : res=SQRT(DOT_PRODUCT(vec,vec))
4305 : :
4306 : 1 : end function l2norm_rdp
4307 : : !!***
4308 : :
4309 : : !----------------------------------------------------------------------
4310 : :
4311 : : !!****f* m_numeric_tools/remove_copies
4312 : : !! NAME
4313 : : !! remove_copies
4314 : : !!
4315 : : !! FUNCTION
4316 : : !! Given an initial set of elements, set_in, return the subset of inequivalent items
4317 : : !! packed in the first n_out positions of set_in. Use the logical function is_equal
4318 : : !! to define whether two items are equivalent.
4319 : : !!
4320 : : !! INPUTS
4321 : : !! n_in=Initial number of elements.
4322 : : !! is_equal=logical function used to discern if two items are equal.
4323 : : !!
4324 : : !! OUTPUT
4325 : : !! n_out=Number of inequivalent items found.
4326 : : !!
4327 : : !! SIDE EFFECTS
4328 : : !! set_in(3,n_in)=
4329 : : !! In input the initial set of n_in elements
4330 : : !! In output set_in(3,1:n_out) contains the inequivalent elements found.
4331 : : !!
4332 : : !! NOTES
4333 : : !! The routines only deals with arrays of 3D-vectors although generalizing the
4334 : : !! algorithm to nD-space is straightforward.
4335 : : !!
4336 : : !! SOURCE
4337 : :
4338 : 3 : subroutine remove_copies(n_in, set_in, n_out, is_equal)
4339 : :
4340 : : !Arguments ------------------------------------
4341 : : !scalars
4342 : : integer,intent(in) :: n_in
4343 : : integer,intent(out) :: n_out
4344 : : !arrays
4345 : : real(dp),target,intent(inout) :: set_in(3,n_in)
4346 : :
4347 : : interface
4348 : : function is_equal(k1,k2)
4349 : : use defs_basis
4350 : : real(dp),intent(in) :: k1(3),k2(3)
4351 : : logical :: is_equal
4352 : : end function is_equal
4353 : : end interface
4354 : :
4355 : : !Local variables-------------------------------
4356 : : !scalars
4357 : : integer :: ii,jj
4358 : : logical :: isnew
4359 : : !arrays
4360 : : type rdp1d_pt
4361 : : integer :: idx
4362 : : real(dp),pointer :: rpt(:)
4363 : : end type rdp1d_pt
4364 : 3 : type(rdp1d_pt),allocatable :: Ap(:)
4365 : : ! *************************************************************************
4366 : :
4367 [ - + + - : 9 : ABI_MALLOC(Ap,(n_in))
+ - + - -
+ - + ]
4368 : 3 : Ap(1)%idx = 1
4369 : 3 : Ap(1)%rpt => set_in(:,1)
4370 : :
4371 : 3 : n_out=1
4372 [ + + ]: 21 : do ii=2,n_in
4373 : :
4374 : 18 : isnew=.TRUE.
4375 [ + + ]: 75 : do jj=1,n_out
4376 [ - + - - : 75 : if (is_equal(set_in(:,ii),Ap(jj)%rpt(:))) then
- - - + +
+ ]
4377 : 3 : isnew=.FALSE.
4378 : : exit
4379 : : end if
4380 : : end do
4381 : :
4382 : 3 : if (isnew) then
4383 : 15 : n_out=n_out+1
4384 : 15 : Ap(n_out)%rpt => set_in(:,ii)
4385 : 15 : Ap(n_out)%idx = ii
4386 : : end if
4387 : : end do
4388 : :
4389 : : ! The n_out inequivalent items are packed first.
4390 [ + + ]: 3 : if (n_out/=n_in) then
4391 [ + + ]: 7 : do ii=1,n_out
4392 : 6 : jj=Ap(ii)%idx
4393 [ + + ]: 25 : set_in(:,ii) = set_in(:,jj)
4394 : : !write(std_out,*) Ap(ii)%idx,Ap(ii)%rpt(:)
4395 : : end do
4396 : : end if
4397 : :
4398 : 3 : ABI_FREE(Ap)
4399 : :
4400 : 3 : end subroutine remove_copies
4401 : : !!***
4402 : :
4403 : : !----------------------------------------------------------------------
4404 : :
4405 : : !!****f* m_numeric_tools/denominator
4406 : : !! NAME
4407 : : !! denominator
4408 : : !!
4409 : : !! FUNCTION
4410 : : !! Return the denominator of the rational number dd, sign is not considered.
4411 : : !!
4412 : : !! INPUTS
4413 : : !! dd=The rational number
4414 : : !! tolerance=Absolute tolerance
4415 : : !!
4416 : : !! OUTPUT
4417 : : !! ierr=If /=0 the input number is not rational within the given tolerance.
4418 : : !!
4419 : : !! SOURCE
4420 : :
4421 : 72804 : integer function denominator(dd,ierr,tolerance)
4422 : :
4423 : : !Arguments ------------------------------------
4424 : : !scalars
4425 : : integer,intent(out) :: ierr
4426 : : real(dp),intent(in) :: dd
4427 : : real(dp),optional,intent(in) :: tolerance
4428 : :
4429 : : !Local variables ------------------------------
4430 : : !scalars
4431 : : integer,parameter :: largest_integer = HUGE(1)
4432 : : integer :: ii
4433 : : real(dp) :: my_tol
4434 : : !************************************************************************
4435 : :
4436 : 72804 : ii=1
4437 [ - + ]: 72804 : my_tol=0.0001 ; if (PRESENT(tolerance)) my_tol=ABS(tolerance)
4438 : 84652 : do
4439 [ + + ]: 157456 : if (ABS(dd*ii-NINT(dd*ii))<my_tol) then
4440 : 72804 : denominator=ii
4441 : 72804 : ierr=0
4442 : 72804 : RETURN
4443 : : end if
4444 : : ! Handle the case in which dd is not rational within my_tol.
4445 [ - + ]: 84652 : if (ii==largest_integer) then
4446 : 0 : denominator=ii
4447 : 0 : ierr=-1
4448 : 0 : RETURN
4449 : : end if
4450 : 84652 : ii=ii+1
4451 : : end do
4452 : :
4453 : : end function denominator
4454 : : !!***
4455 : :
4456 : : !----------------------------------------------------------------------
4457 : :
4458 : : !!****f* m_numeric_tools/mincm
4459 : : !! NAME
4460 : : !! mincm
4461 : : !!
4462 : : !! FUNCTION
4463 : : !! Return the minimum common multiple of ii and jj.
4464 : : !!
4465 : : !! SOURCE
4466 : :
4467 : 1261 : integer function mincm(ii,jj)
4468 : :
4469 : : !Arguments ------------------------------------
4470 : : !scalars
4471 : : integer,intent(in) :: ii,jj
4472 : : !************************************************************************
4473 : :
4474 [ + - - + ]: 1261 : if (ii==0.or.jj==0) then
4475 : 0 : ABI_BUG('ii==0 or jj==0')
4476 : : end if
4477 : :
4478 : 1261 : mincm=MAX(ii,jj)
4479 : 0 : do
4480 [ + - + - ]: 1261 : if ( ((mincm/ii)*ii)==mincm .and. ((mincm/jj)*jj)==mincm ) RETURN
4481 : 0 : mincm=mincm+1
4482 : : end do
4483 : :
4484 : : end function mincm
4485 : : !!***
4486 : :
4487 : : !----------------------------------------------------------------------
4488 : :
4489 : : !!****f* m_numeric_tools/continued_fract
4490 : : !! NAME
4491 : : !! continued_fract
4492 : : !!
4493 : : !! FUNCTION
4494 : : !! This routine calculates the continued fraction:
4495 : : !!
4496 : : !! 1
4497 : : !! f(z) = _______________________________
4498 : : !! z - a1 - b1^2
4499 : : !! _____________________
4500 : : !! z - a2 - b2^2
4501 : : !! ___________
4502 : : !! z -a3 - ........
4503 : : !!
4504 : : !! INPUTS
4505 : : !! nlev=Number of "levels" in the continued fraction.
4506 : : !! term_type=Type of the terminator.
4507 : : !! 0 --> No terminator.
4508 : : !! -1 --> Assume constant coefficients for a_i and b_i for i>nlev with a_inf = a(nlev) and b_inf = b(nleb)
4509 : : !! 1 --> Same as above but a_inf and b_inf are obtained by averaging over the nlev values.
4510 : : !! aa(nlev)=Set of a_i coefficients.
4511 : : !! bb(nlev)=Set of b_i coefficients.
4512 : : !! nz=Number of points on the z-mesh.
4513 : : !! zpts(nz)=z-mesh.
4514 : : !!
4515 : : !! OUTPUT
4516 : : !! spectrum(nz)=Contains f(z) on the input mesh.
4517 : : !!
4518 : : !! SOURCE
4519 : :
4520 : 9677 : subroutine continued_fract(nlev,term_type,aa,bb,nz,zpts,spectrum)
4521 : :
4522 : : !Arguments ------------------------------------
4523 : : !scalars
4524 : : integer,intent(in) :: nlev,term_type,nz
4525 : : !arrays
4526 : : real(dp),intent(in) :: bb(nlev)
4527 : : complex(dp),intent(in) :: aa(nlev)
4528 : : complex(dp),intent(in) :: zpts(nz)
4529 : : complex(dp),intent(out) :: spectrum(nz)
4530 : :
4531 : : !Local variables ------------------------------
4532 : : !scalars
4533 : : integer :: it
4534 : : real(dp) :: bb_inf,bg,bup,swap
4535 : : complex(dp) :: aa_inf
4536 : : character(len=500) :: msg
4537 : : !arrays
4538 : 9677 : complex(dp),allocatable :: div(:),den(:)
4539 : : !************************************************************************
4540 : :
4541 [ - + + - : 29031 : ABI_MALLOC(div,(nz))
+ - + - -
+ - + ]
4542 [ - + + - : 19354 : ABI_MALLOC(den,(nz))
- + - + ]
4543 : :
4544 : 9677 : select case (term_type)
4545 : : case (0) ! No terminator.
4546 [ + + ]: 806995 : div=czero
4547 : : case (-1,1)
4548 [ - + ]: 3370 : if (term_type==-1) then
4549 : 0 : bb_inf=bb(nlev)
4550 : 0 : aa_inf=aa(nlev)
4551 : : else
4552 [ + + ]: 89850 : bb_inf=SUM(bb)/nlev
4553 [ + + ]: 89850 : aa_inf=SUM(aa)/nlev
4554 : : end if
4555 : : ! Be careful with the sign of the SQRT.
4556 [ + + ]: 2032110 : div(:) = half*(bb(nlev)/(bb_inf))**2 * ( zpts-aa_inf - SQRT((zpts-aa_inf)**2 - four*bb_inf**2) )
4557 : : case (2)
4558 : 0 : ABI_ERROR("To be tested")
4559 [ # # ]: 0 : div = zero
4560 [ # # ]: 0 : if (nlev>4) then
4561 : 0 : bg=zero; bup=zero
4562 [ # # ]: 0 : do it=1,nlev,2
4563 [ # # ]: 0 : if (it+2<nlev) bg = bg + bb(it+2)
4564 [ # # ]: 0 : bup = bup + bb(it)
4565 : : end do
4566 : 0 : bg = bg/(nlev/2+MOD(nlev,2))
4567 : 0 : bup = bg/((nlev+1)/2)
4568 : : !if (iseven(nlev)) then
4569 [ # # ]: 0 : if (.not.iseven(nlev)) then
4570 : 0 : swap = bg
4571 : 0 : bg = bup
4572 : 0 : bup = bg
4573 : : end if
4574 : : !write(std_out,*)nlev,bg,bup
4575 : : !Here be careful with the sign of SQRT
4576 [ # # ]: 0 : do it=1,nz
4577 : : div(it) = half/zpts(it) * (bb(nlev)/bup)**2 * &
4578 : 0 : ( (zpts(it)**2 +bup**2 -bg**2) - SQRT( (zpts(it)**2+bup**2-bg**2)**2 -four*(zpts(it)*bup)**2) )
4579 : : end do
4580 : : end if
4581 : :
4582 : : case default
4583 : 0 : write(msg,'(a,i0)')" Wrong value for term_type : ",term_type
4584 [ + + - - ]: 9677 : ABI_ERROR(msg)
4585 : : end select
4586 : :
4587 [ + + ]: 612093 : do it=nlev,2,-1
4588 [ + + ]: 113281512 : den(:) = zpts(:) - aa(it) - div(:)
4589 [ + + ]: 113291189 : div(:) = (bb(it-1)**2 )/ den(:)
4590 : : end do
4591 : :
4592 [ - + + + ]: 2848782 : den = zpts(:) - aa(1) - div(:)
4593 [ - + + + ]: 2848782 : div = one/den(:)
4594 : :
4595 [ + + ]: 2839105 : spectrum = div
4596 [ - + ]: 9677 : ABI_FREE(div)
4597 [ - + ]: 9677 : ABI_FREE(den)
4598 : :
4599 : 9677 : end subroutine continued_fract
4600 : : !!***
4601 : :
4602 : : !----------------------------------------------------------------------
4603 : :
4604 : : !!****f* m_numeric_tools/cmplx_sphcart
4605 : : !! NAME
4606 : : !! cmplx_sphcart
4607 : : !!
4608 : : !! FUNCTION
4609 : : !! Convert an array of complex values stored in spherical coordinates
4610 : : !! to Cartesian coordinates with real and imaginary part or vice versa.
4611 : : !!
4612 : : !! INPUTS
4613 : : !! from=Option specifying the format used to store the complex values. See below.
4614 : : !! [units]=Option to specify if angles are given in "Radians" (default) or "Degrees".
4615 : : !!
4616 : : !! SIDE EFFECTS
4617 : : !! carr(:,:):
4618 : : !! input: array with complex values in Cartesian form if from="C" or spherical form if from="S"
4619 : : !! output: array with values converted to the new representation.
4620 : : !!
4621 : : !! SOURCE
4622 : :
4623 [ # # ]: 0 : subroutine cmplx_sphcart(carr, from, units)
4624 : :
4625 : : !Arguments ------------------------------------
4626 : : !scalars
4627 : : character(len=*),intent(in) :: from
4628 : : character(len=*),optional,intent(in) :: units
4629 : : !arrays
4630 : : complex(dp),intent(inout) :: carr(:,:)
4631 : :
4632 : : !Local variables-------------------------------
4633 : : !scalars
4634 : : integer :: jj,ii
4635 : : real(dp) :: rho,theta,fact
4636 : : character(len=500) :: msg
4637 : : ! *************************************************************************
4638 : :
4639 : 0 : select case (from(1:1))
4640 : :
4641 : : case ("S","s") ! Spherical --> Cartesian
4642 : :
4643 : 0 : fact = one
4644 [ # # ]: 0 : if (PRESENT(units)) then
4645 [ # # ]: 0 : if (units(1:1) == "D" .or. units(1:1) == "d") fact = two_pi/360_dp
4646 : : end if
4647 : :
4648 [ # # ]: 0 : do jj=1,SIZE(carr,DIM=2)
4649 [ # # ]: 0 : do ii=1,SIZE(carr,DIM=1)
4650 : 0 : rho = DBLE(carr(ii,jj))
4651 : 0 : theta= AIMAG(carr(ii,jj)) * fact
4652 : 0 : carr(ii,jj) = CMPLX(rho*DCOS(theta), rho*DSIN(theta), kind=dp)
4653 : : end do
4654 : : end do
4655 : :
4656 : : case ("C","c") ! Cartesian --> Spherical \theta = 2 arctan(y/(rho+x))
4657 : :
4658 : 0 : fact = one
4659 [ # # ]: 0 : if (PRESENT(units)) then
4660 [ # # ]: 0 : if (units(1:1) == "D" .or. units(1:1) == "d") fact = 360_dp/two_pi
4661 : : end if
4662 : :
4663 [ # # ]: 0 : do jj=1,SIZE(carr,DIM=2)
4664 [ # # ]: 0 : do ii=1,SIZE(carr,DIM=1)
4665 : 0 : rho = SQRT(ABS(carr(ii,jj)))
4666 [ # # ]: 0 : if (rho > tol16) then
4667 : 0 : theta= two * ATAN( AIMAG(carr(ii,jj)) / (DBLE(carr(ii,jj)) + rho) )
4668 : : else
4669 : : theta= zero
4670 : : end if
4671 : 0 : carr(ii,jj) = CMPLX(rho, theta*fact, kind=dp)
4672 : : end do
4673 : : end do
4674 : :
4675 : : case default
4676 [ # # ]: 0 : msg = " Wrong value for from: "//TRIM(from)
4677 [ # # # ]: 0 : ABI_BUG(msg)
4678 : : end select
4679 : :
4680 : 0 : end subroutine cmplx_sphcart
4681 : : !!***
4682 : :
4683 : : !----------------------------------------------------------------------
4684 : :
4685 : : !!****f* m_numeric_tools/pfactorize
4686 : : !! NAME
4687 : : !! pfactorize
4688 : : !!
4689 : : !! FUNCTION
4690 : : !! Factorize a number in terms of an user-specified set of prime factors
4691 : : !! nn = alpha * Prod_i p^i 1)
4692 : : !!
4693 : : !! INPUTS
4694 : : !! nn=The number to be factorized.
4695 : : !! nfactors=The number of factors
4696 : : !! pfactors(nfactors)=The list of prime number e.g. (/ 2, 3, 5, 7, 11 /)
4697 : : !!
4698 : : !! OUTPUT
4699 : : !! powers(nfactors+1)=
4700 : : !! The first nfactors entries are the powers i in Eq.1. powers(nfactors+1) is alpha.
4701 : : !!
4702 : : !! SOURCE
4703 : :
4704 : 0 : subroutine pfactorize(nn,nfactors,pfactors,powers)
4705 : :
4706 : : !Arguments ------------------------------------
4707 : : !scalars
4708 : : integer,intent(in) :: nn,nfactors
4709 : : integer,intent(in) :: pfactors(nfactors)
4710 : : integer,intent(out) :: powers (nfactors+1)
4711 : :
4712 : : !Local variables ------------------------------
4713 : : !scalars
4714 : : integer :: tnn,ifc,fact,ipow,maxpwr
4715 : : ! *************************************************************************
4716 : :
4717 [ # # ]: 0 : powers=0; tnn=nn
4718 : :
4719 [ # # ]: 0 : fact_loop: do ifc=1,nfactors
4720 : 0 : fact = pfactors (ifc)
4721 : 0 : maxpwr = NINT ( LOG(DBLE(tnn))/LOG(DBLE(fact) ) ) + 1
4722 [ # # ]: 0 : do ipow=1,maxpwr
4723 [ # # ]: 0 : if (tnn==1) EXIT fact_loop
4724 [ # # ]: 0 : if ( MOD(tnn,fact)==0 ) then
4725 : 0 : tnn=tnn/fact
4726 : 0 : powers(ifc)=powers(ifc) + 1
4727 : : end if
4728 : : end do
4729 : : end do fact_loop
4730 : :
4731 [ # # # # ]: 0 : if ( nn /= tnn * PRODUCT( pfactors**powers(1:nfactors)) ) then
4732 : 0 : ABI_BUG('nn/=tnn!')
4733 : : end if
4734 : :
4735 : 0 : powers(nfactors+1) = tnn
4736 : :
4737 : 0 : end subroutine pfactorize
4738 : : !!***
4739 : :
4740 : : !----------------------------------------------------------------------
4741 : :
4742 : : !!****f* m_numeric_tools/isordered
4743 : : !! NAME
4744 : : !! isordered
4745 : : !!
4746 : : !! FUNCTION
4747 : : !! Return .TRUE. if values in array arr are ordered.
4748 : : !! Consider that two double precision numbers within tolerance tol are equal.
4749 : : !!
4750 : : !! INPUTS
4751 : : !! nn=Size of arr.
4752 : : !! arr(nn)=The array with real values to be tested.
4753 : : !! direction= ">" for ascending numerical order.
4754 : : !! ">" for decreasing numerical order.
4755 : : !!
4756 : : !! SOURCE
4757 : :
4758 : 64 : function isordered_rdp(nn,arr,direction,tol) result(isord)
4759 : :
4760 : : !Arguments ------------------------------------
4761 : : !scalars
4762 : : integer,intent(in) :: nn
4763 : : real(dp),intent(in) :: tol
4764 : : logical :: isord
4765 : : character(len=*),intent(in) :: direction
4766 : : !arrays
4767 : : real(dp),intent(in) :: arr(nn)
4768 : :
4769 : : !Local variables ------------------------------
4770 : : !scalars
4771 : : integer :: ii
4772 : : real(dp) :: prev
4773 : : character(len=500) :: msg
4774 : : ! *************************************************************************
4775 : :
4776 : 64 : prev = arr(1); isord =.TRUE.
4777 : :
4778 : : SELECT CASE (direction(1:1))
4779 : : CASE(">")
4780 : : ii=2;
4781 [ + + + + ]: 611 : do while (ii<=nn .and. isord)
4782 [ + - ]: 547 : if (ABS(arr(ii)-prev) > tol) isord = (arr(ii) >= prev)
4783 : 547 : prev = arr(ii)
4784 : 611 : ii = ii +1
4785 : : end do
4786 : :
4787 : : CASE("<")
4788 : : ii=2;
4789 [ # # # # ]: 0 : do while (ii<=nn .and. isord)
4790 [ # # ]: 0 : if (ABS(arr(ii)-prev) > tol) isord = (arr(ii) <= prev)
4791 : 0 : prev = arr(ii)
4792 : 0 : ii = ii +1
4793 : : end do
4794 : :
4795 : : CASE DEFAULT
4796 [ # # ]: 0 : msg = "Wrong direction: "//TRIM(direction)
4797 [ + - - ]: 64 : ABI_ERROR(msg)
4798 : : END SELECT
4799 : :
4800 : 64 : end function isordered_rdp
4801 : : !!***
4802 : :
4803 : : !----------------------------------------------------------------------
4804 : :
4805 : : !!****f* m_numeric_tools/stats_eval
4806 : : !! NAME
4807 : : !! stats_eval
4808 : : !!
4809 : : !! FUNCTION
4810 : : !! Helper function used to calculate the statistical parameters of a dataset.
4811 : : !!
4812 : : !! INPUT
4813 : : !! arr(:)=Array with the values.
4814 : : !!
4815 : : !! OUTPUT
4816 : : !! stats<stats_t>=Data type storing the parameters of the data set.
4817 : : !!
4818 : : !! SOURCE
4819 : :
4820 [ - + ]: 1507 : pure function stats_eval(arr) result(stats)
4821 : :
4822 : : !Arguments ------------------------------------
4823 : : !scalars
4824 : : type(stats_t) :: stats
4825 : : !arrays
4826 : : real(dp),intent(in) :: arr(:)
4827 : :
4828 : : !Local variables ------------------------------
4829 : : !scalars
4830 : : integer :: ii,nn
4831 : : real(dp) :: xx,x2_sum
4832 : : ! *************************************************************************
4833 : :
4834 : 1507 : stats%min = +HUGE(one)
4835 : 1507 : stats%max = -HUGE(one)
4836 : 1507 : stats%mean = zero
4837 : :
4838 : 1507 : nn = SIZE(arr)
4839 [ + + ]: 21341 : do ii=1,nn
4840 : 19834 : xx = arr(ii)
4841 : 19834 : stats%min = MIN(stats%min, xx)
4842 : 19834 : stats%max = MAX(stats%max, xx)
4843 : 21341 : stats%mean = stats%mean + xx
4844 : : end do
4845 : :
4846 : 1507 : stats%mean = stats%mean/nn
4847 : :
4848 : : ! Two-pass algorithm for the variance (more stable than the single-pass one).
4849 : 1507 : x2_sum = zero
4850 [ + + ]: 21341 : do ii=1,nn
4851 : 19834 : xx = arr(ii)
4852 : 21341 : x2_sum = x2_sum + (xx - stats%mean)*(xx - stats%mean)
4853 : : end do
4854 : :
4855 [ + - ]: 1507 : if (nn > 1) then
4856 : 1507 : stats%stdev = x2_sum/(nn-1)
4857 : 1507 : stats%stdev = SQRT(ABS(stats%stdev))
4858 : : else
4859 : : stats%stdev = zero
4860 : : end if
4861 : :
4862 : 1507 : end function stats_eval
4863 : : !!***
4864 : :
4865 : : !----------------------------------------------------------------------
4866 : :
4867 : : !!****f* m_numeric_tools/wrap2_zero_one
4868 : : !! NAME
4869 : : !! wrap2_zero_one
4870 : : !!
4871 : : !! FUNCTION
4872 : : !! Transforms a real number (num) in its corresponding reduced number
4873 : : !! (red) in the interval [0,1[ where 1 is not included (tol12)
4874 : : !! num=red+shift
4875 : : !!
4876 : : !! INPUTS
4877 : : !! num=real number
4878 : : !!
4879 : : !! OUTPUT
4880 : : !! red=reduced number of num in the interval [0,1[ where 1 is not included
4881 : : !! shift=num-red
4882 : : !!
4883 : : !! SOURCE
4884 : :
4885 : 152865 : elemental subroutine wrap2_zero_one(num, red, shift)
4886 : :
4887 : : !Arguments ------------------------------------
4888 : : !scalars
4889 : : real(dp),intent(in) :: num
4890 : : real(dp),intent(out) :: red,shift
4891 : : ! *************************************************************************
4892 : :
4893 [ + + ]: 152865 : if (num>zero) then
4894 : 74953 : red=mod((num+tol12),one)-tol12
4895 : : else
4896 : 77912 : red=-mod(-(num-one+tol12),one)+one-tol12
4897 : : end if
4898 [ + + ]: 152865 : if(abs(red)<tol12)red=0.0_dp
4899 : 152865 : shift=num-red
4900 : :
4901 : 152865 : end subroutine wrap2_zero_one
4902 : : !!***
4903 : :
4904 : : !----------------------------------------------------------------------
4905 : :
4906 : : !!****f* m_numeric_tools/wrap2_pmhalf
4907 : : !! NAME
4908 : : !! wrap2_pmhalf
4909 : : !!
4910 : : !! FUNCTION
4911 : : !! Transforms a real number (num) in its corresponding reduced number
4912 : : !! (red) in the interval ]-1/2,1/2] where -1/2 is not included (tol12)
4913 : : !! num=red+shift
4914 : : !!
4915 : : !! INPUTS
4916 : : !! num=real number
4917 : : !!
4918 : : !! OUTPUT
4919 : : !! red=reduced number of num in the interval ]-1/2,1/2] where -1/2 is not included
4920 : : !! shift=num-red
4921 : : !!
4922 : : !! SOURCE
4923 : :
4924 : 352765200 : elemental subroutine wrap2_pmhalf(num,red,shift)
4925 : :
4926 : : !Arguments -------------------------------
4927 : : !scalars
4928 : : real(dp),intent(in) :: num
4929 : : real(dp),intent(out) :: red,shift
4930 : :
4931 : : ! *********************************************************************
4932 : :
4933 [ + + ]: 352765200 : if (num>zero) then
4934 : 164732130 : red=mod((num+half-tol12),one)-half+tol12
4935 : : else
4936 : 188033070 : red=-mod(-(num-half-tol12),one)+half+tol12
4937 : : end if
4938 [ + + ]: 352765200 : if(abs(red)<tol12)red=0.0d0
4939 : 352765200 : shift=num-red
4940 : :
4941 : 352765200 : end subroutine wrap2_pmhalf
4942 : : !!***
4943 : :
4944 : : !----------------------------------------------------------------------
4945 : :
4946 : : !!***
4947 : : !!****f* m_numeric_tools/linear_interpolation
4948 : : !! NAME
4949 : : !! interpol1d
4950 : : !!
4951 : : !! FUNCTION
4952 : : !! Perform linear interpolation of a set of points pts_o with values val_o
4953 : : !! The points pts_o and pts_i are assumed to be ascending ordered arrays.
4954 : : !!
4955 : : !! INPUTS
4956 : : !! npts_o=Number of points in the original array.
4957 : : !! npts_i=Number of points in the interpolated array.
4958 : : !! pts_o(npts_o)=Points in the original array.
4959 : : !! pts_i(npts_i)=Points in the interpolated array.
4960 : : !! val_o(npts_o)=Values at the points pts_o.
4961 : : !!
4962 : : !! OUTPUT
4963 : : !! res(npts_i)=Interpolated values at the points pts_i.
4964 : : !!
4965 : : !! SOURCE
4966 [ # # ]: 0 : pure function interpol1d(npts_o,npts_i,pts_o,pts_i,val_o) result(res)
4967 : : !Arguments ------------------------------------
4968 : : !arrays
4969 : : integer,intent(in) :: npts_o, npts_i
4970 : : real(dp),intent(in) :: pts_o(npts_o), pts_i(npts_i)
4971 : : real(dp),intent(in) :: val_o(npts_o)
4972 : : real(dp) :: res(npts_i)
4973 : : !Local variables-------------------------------
4974 : : !scalars
4975 : : integer :: ii, jj
4976 : : real(dp) :: x1, x2, y1, y2, slope
4977 : : ! *************************************************************************
4978 : :
4979 [ # # ]: 0 : res = zero
4980 : :
4981 [ # # ]: 0 : do ii = 1, npts_i
4982 [ # # ]: 0 : do jj = 1, npts_o + 1
4983 [ # # # # ]: 0 : if (jj == npts_o + 1 .or. pts_i(ii) < pts_o(jj)) exit
4984 : : end do
4985 [ # # ]: 0 : if (jj == 1) then
4986 : 0 : res(ii) = val_o(1)
4987 [ # # ]: 0 : else if (jj == npts_o + 1) then
4988 : 0 : res(ii) = val_o(npts_o)
4989 : : else
4990 : 0 : x1 = pts_o(jj - 1)
4991 : 0 : x2 = pts_o(jj)
4992 : 0 : y1 = val_o(jj - 1)
4993 : 0 : y2 = val_o(jj)
4994 : :
4995 [ # # ]: 0 : if (x2 == x1) then
4996 : 0 : res(ii) = (y1 + y2)/2.0_dp
4997 : : else
4998 : 0 : slope = (y2 - y1) / (x2 - x1)
4999 : 0 : res(ii) = y1 + slope * (pts_i(ii) - x1)
5000 : : end if
5001 : : end if
5002 : : end do
5003 : :
5004 : 0 : end function interpol1d
5005 : : !!***
5006 : :
5007 [ # # ]: 0 : pure function interpol1d_c(npts_o,npts_i,pts_o,pts_i,val_o) result(res)
5008 : : !Arguments ------------------------------------
5009 : : !arrays
5010 : : integer,intent(in) :: npts_o, npts_i
5011 : : real(dp),intent(in) :: pts_o(npts_o), pts_i(npts_i)
5012 : : complex(dp),intent(in) :: val_o(npts_o)
5013 : : complex(dp) :: res(npts_i)
5014 : : !Local variables-------------------------------
5015 : 0 : real(dp) :: val_o_r(npts_o), val_o_i(npts_o), res_r(npts_i), res_i(npts_i)
5016 : : ! *************************************************************************
5017 : :
5018 : : ! Split the complex values into real and imaginary parts.
5019 [ # # ]: 0 : val_o_r = REAL(val_o, kind=dp)
5020 [ # # ]: 0 : val_o_i = AIMAG(val_o)
5021 : :
5022 : : ! Interpolate the real part.
5023 : 0 : res_r = interpol1d(npts_o, npts_i, pts_o, pts_i, val_o_r)
5024 : :
5025 : : ! Interpolate the imaginary part.
5026 : 0 : res_i = interpol1d(npts_o, npts_i, pts_o, pts_i, val_o_i)
5027 : :
5028 : : ! Combine the results back into complex form.
5029 [ # # ]: 0 : res = CMPLX(res_r, res_i, kind=dp)
5030 : 0 : end function interpol1d_c
5031 : :
5032 : : !!----------------------------------------------------------------------
5033 : : !!****f* m_numeric_tools/interpol3d_0d
5034 : : !! NAME
5035 : : !! interpol3d_0d
5036 : : !!
5037 : : !! FUNCTION
5038 : : !! Computes the value at any point r by linear interpolation
5039 : : !! inside the eight vertices of the surrounding cube
5040 : : !! r is presumed to be normalized, in a unit cube for the full grid
5041 : : !!
5042 : : !! INPUTS
5043 : : !! r(3)=point coordinate
5044 : : !! nr1=grid size along x
5045 : : !! nr2=grid size along y
5046 : : !! nr3=grid size along z
5047 : : !! grid(nr1,nr2,nr3)=grid matrix
5048 : : !!
5049 : : !! OUTPUT
5050 : : !! res=Interpolated value
5051 : : !!
5052 : : !! SOURCE
5053 : :
5054 : 2042 : pure function interpol3d_0d(rr, nr1, nr2, nr3, grid) result(res)
5055 : :
5056 : : !Arguments-------------------------------------------------------------
5057 : : !scalars
5058 : : integer,intent(in) :: nr1, nr2, nr3
5059 : : real(dp) :: res
5060 : : !arrays
5061 : : real(dp),intent(in) :: grid(nr1,nr2,nr3),rr(3)
5062 : :
5063 : : !Local variables--------------------------------------------------------
5064 : : integer :: ir1,ir2,ir3,pr1,pr2,pr3
5065 : : real(dp) :: res1,res2,res3,res4,res5,res6,res7,res8, x1,x2,x3
5066 : : ! *************************************************************************
5067 : :
5068 : 2042 : call interpol3d_indices(rr, nr1, nr2, nr3, ir1, ir2, ir3, pr1, pr2, pr3)
5069 : :
5070 : : ! weight
5071 : 2042 : x1=one+rr(1)*nr1-real(ir1)
5072 : 2042 : x2=one+rr(2)*nr2-real(ir2)
5073 : 2042 : x3=one+rr(3)*nr3-real(ir3)
5074 : :
5075 : : !calculation of the density value
5076 : 2042 : res1=grid(ir1, ir2, ir3) * (one-x1)*(one-x2)*(one-x3)
5077 : 2042 : res2=grid(pr1, ir2, ir3) * x1*(one-x2)*(one-x3)
5078 : 2042 : res3=grid(ir1, pr2, ir3) * (one-x1)*x2*(one-x3)
5079 : 2042 : res4=grid(ir1, ir2, pr3) * (one-x1)*(one-x2)*x3
5080 : 2042 : res5=grid(pr1, pr2, ir3) * x1*x2*(one-x3)
5081 : 2042 : res6=grid(ir1, pr2, pr3) * (one-x1)*x2*x3
5082 : 2042 : res7=grid(pr1, ir2, pr3) * x1*(one-x2)*x3
5083 : 2042 : res8=grid(pr1, pr2, pr3) * x1*x2*x3
5084 : 2042 : res=res1+res2+res3+res4+res5+res6+res7+res8
5085 : :
5086 : 2042 : end function interpol3d_0d
5087 : : !!***
5088 : :
5089 : : !----------------------------------------------------------------------
5090 : :
5091 : : !!****f* m_numeric_tools/interpol3d_1d
5092 : : !! NAME
5093 : : !! interpol3d_1d
5094 : : !!
5095 : : !! FUNCTION
5096 : : !! Computes the value at any point r by linear interpolation
5097 : : !! inside the eight vertices of the surrounding cube
5098 : : !! r is presumed to be normalized, in a unit cube for the full grid
5099 : : !!
5100 : : !! INPUTS
5101 : : !! r(3)=point coordinate
5102 : : !! nr1=grid size along x
5103 : : !! nr2=grid size along y
5104 : : !! nr3=grid size along z
5105 : : !! grid(cplex,nr1,nr2,nr3)=grid matrix
5106 : : !!
5107 : : !! OUTPUT
5108 : : !! res(cplex)=Interpolated value
5109 : : !!
5110 : : !! SOURCE
5111 : :
5112 [ - + ]: 223896 : pure function interpol3d_1d(rr, nr1, nr2, nr3, grid, cplex) result(res)
5113 : :
5114 : : !Arguments-------------------------------------------------------------
5115 : : !scalars
5116 : : integer,intent(in) :: nr1, nr2, nr3, cplex
5117 : : real(dp) :: res(cplex)
5118 : : !arrays
5119 : : real(dp),intent(in) :: grid(cplex, nr1, nr2, nr3), rr(3)
5120 : :
5121 : : !Local variables--------------------------------------------------------
5122 : : !scalars
5123 : : integer :: id,ir1,ir2,ir3,pr1,pr2,pr3
5124 : : real(dp) :: res1,res2,res3,res4,res5,res6,res7,res8,x1,x2,x3
5125 : : ! *************************************************************************
5126 : :
5127 : 223896 : call interpol3d_indices(rr, nr1, nr2, nr3, ir1, ir2, ir3, pr1, pr2, pr3)
5128 : :
5129 : : ! weight
5130 : 223896 : x1 = one + rr(1)*nr1 -real(ir1)
5131 : 223896 : x2 = one + rr(2)*nr2 -real(ir2)
5132 : 223896 : x3 = one + rr(3)*nr3 -real(ir3)
5133 : :
5134 : : ! calculation of the density value
5135 [ + + ]: 447792 : do id=1,cplex
5136 : 223896 : res1 = grid(id,ir1, ir2, ir3) * (one-x1)*(one-x2)*(one-x3)
5137 : 223896 : res2 = grid(id,pr1, ir2, ir3) * x1*(one-x2)*(one-x3)
5138 : 223896 : res3 = grid(id,ir1, pr2, ir3) * (one-x1)*x2*(one-x3)
5139 : 223896 : res4 = grid(id,ir1, ir2, pr3) * (one-x1)*(one-x2)*x3
5140 : 223896 : res5 = grid(id,pr1, pr2, ir3) * x1*x2*(one-x3)
5141 : 223896 : res6 = grid(id,ir1, pr2, pr3) * (one-x1)*x2*x3
5142 : 223896 : res7 = grid(id,pr1, ir2, pr3) * x1*(one-x2)*x3
5143 : 223896 : res8 = grid(id,pr1, pr2, pr3) * x1*x2*x3
5144 : 447792 : res(id) = res1+res2+res3+res4+res5+res6+res7+res8
5145 : : end do
5146 : :
5147 : 223896 : end function interpol3d_1d
5148 : : !!***
5149 : :
5150 : : !----------------------------------------------------------------------
5151 : :
5152 : : !!****f* m_numeric_tools/interpol3d_indices
5153 : : !! NAME
5154 : : !! interpol3d_indices
5155 : : !!
5156 : : !! FUNCTION
5157 : : !! Computes the indices in a cube which are neighbors to the point to be
5158 : : !! interpolated in interpol3d
5159 : : !!
5160 : : !! INPUTS
5161 : : !! rr(3)=point coordinate
5162 : : !! nr1=grid size along x
5163 : : !! nr2=grid size along y
5164 : : !! nr3=grid size along z
5165 : : !!
5166 : : !! OUTPUT
5167 : : !! ir1,ir2,ir3 = bottom left neighbor
5168 : : !! pr1,pr2,pr3 = top right neighbor
5169 : : !!
5170 : : !! SOURCE
5171 : :
5172 : 518537 : pure subroutine interpol3d_indices(rr,nr1,nr2,nr3,ir1,ir2,ir3,pr1,pr2,pr3)
5173 : :
5174 : : !Arguments-------------------------------------------------------------
5175 : : !scalars
5176 : : integer,intent(in) :: nr1, nr2, nr3
5177 : : integer,intent(out) :: ir1, ir2, ir3, pr1, pr2, pr3
5178 : : !arrays
5179 : : real(dp),intent(in) :: rr(3)
5180 : :
5181 : : !Local variables-------------------------------
5182 : : real(dp) :: d1,d2,d3
5183 : : ! *************************************************************************
5184 : :
5185 : : !grid density
5186 : 518537 : d1=one/nr1
5187 : 518537 : d2=one/nr2
5188 : 518537 : d3=one/nr3
5189 : :
5190 : : !lower left
5191 : 518537 : ir1=int(rr(1)/d1)+1
5192 : 518537 : ir2=int(rr(2)/d2)+1
5193 : 518537 : ir3=int(rr(3)/d3)+1
5194 : :
5195 : : !upper right
5196 : 518537 : pr1=mod(ir1+1,nr1)
5197 : 518537 : pr2=mod(ir2+1,nr2)
5198 : 518537 : pr3=mod(ir3+1,nr3)
5199 : :
5200 [ - + ]: 518537 : if(ir1==0) ir1=nr1
5201 [ - + ]: 518537 : if(ir2==0) ir2=nr2
5202 [ - + ]: 518537 : if(ir3==0) ir3=nr3
5203 : :
5204 [ - + ]: 518537 : if(ir1>nr1) ir1=ir1-nr1
5205 [ - + ]: 518537 : if(ir2>nr2) ir2=ir2-nr2
5206 [ - + ]: 518537 : if(ir3>nr3) ir3=ir3-nr3
5207 : :
5208 [ + + ]: 518537 : if(pr1==0) pr1=nr1
5209 [ + + ]: 518537 : if(pr2==0) pr2=nr2
5210 [ + + ]: 518537 : if(pr3==0) pr3=nr3
5211 : :
5212 : 518537 : end subroutine interpol3d_indices
5213 : : !!***
5214 : :
5215 : : !----------------------------------------------------------------------
5216 : :
5217 : : !!****f* m_numeric_tools/interpolate_denpot
5218 : : !! NAME
5219 : : !! interpolate_denpot
5220 : : !!
5221 : : !! FUNCTION
5222 : : !! Linear interpolation of density/potential given on the real space FFT mesh.
5223 : : !! Assumes array on full mesh i.e. no MPI-FFT.
5224 : : !!
5225 : : !! INPUTS
5226 : : !! cplex=1 for real, 2 for complex data.
5227 : : !! in_ngfft(3)=Mesh divisions of input array
5228 : : !! nspden=Number of density components.
5229 : : !! in_rhor(cplex * in_nfftot * nspden)=Input array
5230 : : !! out_ngfft(3)=Mesh divisions of output array
5231 : : !!
5232 : : !! OUTPUT
5233 : : !! outrhor(cplex * out_nfftot * nspden)=Output array with interpolated data.
5234 : : !!
5235 : : !! SOURCE
5236 : :
5237 [ + + + + ]: 119 : subroutine interpolate_denpot(cplex, in_ngfft, nspden, in_rhor, out_ngfft, out_rhor)
5238 : :
5239 : : !Arguments-------------------------------------------------------------
5240 : : !scalars
5241 : : integer,intent(in) :: cplex,nspden
5242 : : !arrays
5243 : : integer,intent(in) :: in_ngfft(3), out_ngfft(3)
5244 : : real(dp),intent(in) :: in_rhor(cplex, product(in_ngfft), nspden)
5245 : : real(dp),intent(out) :: out_rhor(cplex, product(out_ngfft), nspden)
5246 : :
5247 : : !Local variables--------------------------------------------------------
5248 : : !scalars
5249 : : integer :: ispden, ir1, ir2, ir3, ifft
5250 : : real(dp) :: rr(3)
5251 : : ! *************************************************************************
5252 : :
5253 : : ! Linear interpolation.
5254 [ + + ]: 34 : do ispden=1,nspden
5255 [ + + ]: 376 : do ir3=0,out_ngfft(3) - 1
5256 : 342 : rr(3) = dble(ir3) / out_ngfft(3)
5257 [ + + ]: 8275 : do ir2=0,out_ngfft(2) - 1
5258 : 7916 : rr(2) = dble(ir2) / out_ngfft(2)
5259 [ + + ]: 232154 : do ir1=0,out_ngfft(1) - 1
5260 : 223896 : rr(1) = dble(ir1) / out_ngfft(1)
5261 : 223896 : ifft = 1 + ir1 + ir2*out_ngfft(1) + ir3*out_ngfft(1)*out_ngfft(2)
5262 : 231812 : out_rhor(1:cplex, ifft, ispden) = interpol3d_1d(rr, in_ngfft(1), in_ngfft(2), in_ngfft(3), in_rhor(:,:,ispden), cplex)
5263 : : end do
5264 : : end do
5265 : : end do
5266 : : end do
5267 : :
5268 : 17 : end subroutine interpolate_denpot
5269 : : !!***
5270 : :
5271 : :
5272 : : !!****f* m_numeric_tools/interpolate_ur_spc
5273 : : !! NAME
5274 : : !! interpolate_ur_spc
5275 : : !!
5276 : : !! FUNCTION
5277 : : !! Linear interpolation of complex wavefunctions given on the real space FFT mesh.
5278 : : !! Assumes array on full mesh i.e. no MPI-FFT.
5279 : : !! Single precision version
5280 : : !!
5281 : : !! INPUTS
5282 : : !! in_ngfft(3)=Mesh divisions of input array
5283 : : !! ndat=Number of wavefunctions.
5284 : : !! in_ur(in_nfftot * ndat)=Input array
5285 : : !! out_ngfft(3)=Mesh divisions of output array
5286 : : !!
5287 : : !! OUTPUT
5288 : : !! out_ur(out_nfftot,ndata)=Output array with interpolated data.
5289 : : !!
5290 : : !! SOURCE
5291 : :
5292 [ # # # # : 0 : subroutine interpolate_ur_spc(in_ngfft, ndat, in_ur, out_ngfft, out_ur)
# # # # ]
5293 : :
5294 : : !Arguments-------------------------------------------------------------
5295 : : !scalars
5296 : : integer,intent(in) :: ndat
5297 : : !arrays
5298 : : integer,intent(in) :: in_ngfft(:), out_ngfft(:)
5299 : : complex(sp),intent(in) :: in_ur(product(in_ngfft(1:3)), ndat)
5300 : : complex(sp),intent(out) :: out_ur(product(out_ngfft(1:3)), ndat)
5301 : :
5302 : : !Local variables--------------------------------------------------------
5303 : : !scalars
5304 : : integer :: idat, ir1, ir2, ir3, ifft
5305 : : real(dp) :: rr(3)
5306 : : ! *************************************************************************
5307 : :
5308 : : ! Linear interpolation.
5309 [ # # ]: 0 : do idat=1,ndat
5310 [ # # ]: 0 : do ir3=0,out_ngfft(3) - 1
5311 : 0 : rr(3) = dble(ir3) / out_ngfft(3)
5312 [ # # ]: 0 : do ir2=0,out_ngfft(2) - 1
5313 : 0 : rr(2) = dble(ir2) / out_ngfft(2)
5314 [ # # ]: 0 : do ir1=0,out_ngfft(1) - 1
5315 : 0 : rr(1) = dble(ir1) / out_ngfft(1)
5316 : 0 : ifft = 1 + ir1 + ir2*out_ngfft(1) + ir3*out_ngfft(1)*out_ngfft(2)
5317 : 0 : out_ur(ifft, idat) = interpol3d_1d_spc(rr, in_ngfft(1), in_ngfft(2), in_ngfft(3), in_ur(:,idat))
5318 : : end do
5319 : : end do
5320 : : end do
5321 : : end do
5322 : :
5323 : 0 : end subroutine interpolate_ur_spc
5324 : : !!***
5325 : :
5326 : : !----------------------------------------------------------------------
5327 : :
5328 : : !!****f* m_numeric_tools/interpol3d_1d_spc
5329 : : !! NAME
5330 : : !! interpol3d_1d_spc
5331 : : !!
5332 : : !! FUNCTION
5333 : : !! Computes the value at any point r by linear interpolation
5334 : : !! inside the eight vertices of the surrounding cube
5335 : : !! r is presumed to be normalized, in a unit cube for the full grid
5336 : : !!
5337 : : !! INPUTS
5338 : : !! r(3)=point coordinate
5339 : : !! nr1=grid size along x
5340 : : !! nr2=grid size along y
5341 : : !! nr3=grid size along z
5342 : : !! grid(nr1,nr2,nr3)=grid matrix
5343 : : !!
5344 : : !! OUTPUT
5345 : : !! resInterpolated value
5346 : : !!
5347 : : !! SOURCE
5348 : :
5349 : 0 : pure complex(sp) function interpol3d_1d_spc(rr, nr1, nr2, nr3, grid) result(res)
5350 : :
5351 : : !Arguments-------------------------------------------------------------
5352 : : !scalars
5353 : : integer,intent(in) :: nr1, nr2, nr3
5354 : : !arrays
5355 : : real(dp),intent(in) :: rr(3)
5356 : : complex(sp),intent(in) :: grid(nr1, nr2, nr3)
5357 : :
5358 : : !Local variables--------------------------------------------------------
5359 : : !scalars
5360 : : integer :: ir1,ir2,ir3,pr1,pr2,pr3
5361 : : complex(sp) :: res1,res2,res3,res4,res5,res6,res7,res8,x1,x2,x3
5362 : : ! *************************************************************************
5363 : :
5364 : 0 : call interpol3d_indices(rr, nr1, nr2, nr3, ir1, ir2, ir3, pr1, pr2, pr3)
5365 : :
5366 : : ! weight
5367 : 0 : x1 = one + rr(1)*nr1 -real(ir1)
5368 : 0 : x2 = one + rr(2)*nr2 -real(ir2)
5369 : 0 : x3 = one + rr(3)*nr3 -real(ir3)
5370 : :
5371 : : ! calculation of the density value
5372 : 0 : res1 = grid(ir1, ir2, ir3) * (one-x1)*(one-x2)*(one-x3)
5373 : 0 : res2 = grid(pr1, ir2, ir3) * x1*(one-x2)*(one-x3)
5374 : 0 : res3 = grid(ir1, pr2, ir3) * (one-x1)*x2*(one-x3)
5375 : 0 : res4 = grid(ir1, ir2, pr3) * (one-x1)*(one-x2)*x3
5376 : 0 : res5 = grid(pr1, pr2, ir3) * x1*x2*(one-x3)
5377 : 0 : res6 = grid(ir1, pr2, pr3) * (one-x1)*x2*x3
5378 : 0 : res7 = grid(pr1, ir2, pr3) * x1*(one-x2)*x3
5379 : 0 : res8 = grid(pr1, pr2, pr3) * x1*x2*x3
5380 : 0 : res = res1+res2+res3+res4+res5+res6+res7+res8
5381 : :
5382 : 0 : end function interpol3d_1d_spc
5383 : : !!***
5384 : :
5385 : : !!****f* m_numeric_tools/interpolate_ur_dpc
5386 : : !! NAME
5387 : : !! interpolate_ur_dpc
5388 : : !!
5389 : : !! FUNCTION
5390 : : !! Linear interpolation of complex wavefunctions given on the real space FFT mesh.
5391 : : !! Assumes array on full mesh i.e. no MPI-FFT.
5392 : : !! Double precision version
5393 : : !!
5394 : : !! INPUTS
5395 : : !! in_ngfft(3)=Mesh divisions of input array
5396 : : !! ndat=Number of wavefunctions.
5397 : : !! in_ur(in_nfftot * ndat)=Input array
5398 : : !! out_ngfft(3)=Mesh divisions of output array
5399 : : !!
5400 : : !! OUTPUT
5401 : : !! out_ur(out_nfftot,ndata)=Output array with interpolated data.
5402 : : !!
5403 : : !! SOURCE
5404 : :
5405 [ - + - + : 1190 : subroutine interpolate_ur_dpc(in_ngfft, ndat, in_ur, out_ngfft, out_ur)
+ + + + ]
5406 : :
5407 : : !Arguments-------------------------------------------------------------
5408 : : !scalars
5409 : : integer,intent(in) :: ndat
5410 : : !arrays
5411 : : integer,intent(in) :: in_ngfft(:), out_ngfft(:)
5412 : : complex(dp),intent(in) :: in_ur(product(in_ngfft(1:3)), ndat)
5413 : : complex(dp),intent(out) :: out_ur(product(out_ngfft(1:3)), ndat)
5414 : :
5415 : : !Local variables--------------------------------------------------------
5416 : : !scalars
5417 : : integer :: idat, ir1, ir2, ir3, ifft
5418 : : real(dp) :: rr(3)
5419 : : ! *************************************************************************
5420 : :
5421 : : ! Linear interpolation.
5422 [ + + ]: 340 : do idat=1,ndat
5423 [ + + ]: 2089 : do ir3=0,out_ngfft(3) - 1
5424 : 1749 : rr(3) = dble(ir3) / out_ngfft(3)
5425 [ + + ]: 23348 : do ir2=0,out_ngfft(2) - 1
5426 : 21429 : rr(2) = dble(ir2) / out_ngfft(2)
5427 [ + + ]: 315777 : do ir1=0,out_ngfft(1) - 1
5428 : 292599 : rr(1) = dble(ir1) / out_ngfft(1)
5429 : 292599 : ifft = 1 + ir1 + ir2*out_ngfft(1) + ir3*out_ngfft(1)*out_ngfft(2)
5430 : 314028 : out_ur(ifft, idat) = interpol3d_1d_dpc(rr, in_ngfft(1), in_ngfft(2), in_ngfft(3), in_ur(:,idat))
5431 : : end do
5432 : : end do
5433 : : end do
5434 : : end do
5435 : :
5436 : 170 : end subroutine interpolate_ur_dpc
5437 : : !!***
5438 : :
5439 : : !----------------------------------------------------------------------
5440 : :
5441 : : !!****f* m_numeric_tools/interpol3d_1d_dpc
5442 : : !! NAME
5443 : : !! interpol3d_1d_dpc
5444 : : !!
5445 : : !! FUNCTION
5446 : : !! Computes the value at any point r by linear interpolation
5447 : : !! inside the eight vertices of the surrounding cube
5448 : : !! r is presumed to be normalized, in a unit cube for the full grid
5449 : : !!
5450 : : !! INPUTS
5451 : : !! r(3)=point coordinate
5452 : : !! nr1=grid size along x
5453 : : !! nr2=grid size along y
5454 : : !! nr3=grid size along z
5455 : : !! grid(nr1,nr2,nr3)=grid matrix
5456 : : !!
5457 : : !! OUTPUT
5458 : : !! resInterpolated value
5459 : : !!
5460 : : !! SOURCE
5461 : :
5462 : 292599 : pure complex(dp) function interpol3d_1d_dpc(rr, nr1, nr2, nr3, grid) result(res)
5463 : :
5464 : : !Arguments-------------------------------------------------------------
5465 : : !scalars
5466 : : integer,intent(in) :: nr1, nr2, nr3
5467 : : !arrays
5468 : : real(dp),intent(in) :: rr(3)
5469 : : complex(dp),intent(in) :: grid(nr1, nr2, nr3)
5470 : :
5471 : : !Local variables--------------------------------------------------------
5472 : : !scalars
5473 : : integer :: ir1,ir2,ir3,pr1,pr2,pr3
5474 : : complex(dp) :: res1,res2,res3,res4,res5,res6,res7,res8,x1,x2,x3
5475 : : ! *************************************************************************
5476 : :
5477 : 292599 : call interpol3d_indices(rr, nr1, nr2, nr3, ir1, ir2, ir3, pr1, pr2, pr3)
5478 : :
5479 : : ! weight
5480 : 292599 : x1 = one + rr(1)*nr1 -real(ir1)
5481 : 292599 : x2 = one + rr(2)*nr2 -real(ir2)
5482 : 292599 : x3 = one + rr(3)*nr3 -real(ir3)
5483 : :
5484 : : ! calculation of the density value
5485 : 292599 : res1 = grid(ir1, ir2, ir3) * (one-x1)*(one-x2)*(one-x3)
5486 : 292599 : res2 = grid(pr1, ir2, ir3) * x1*(one-x2)*(one-x3)
5487 : 292599 : res3 = grid(ir1, pr2, ir3) * (one-x1)*x2*(one-x3)
5488 : 292599 : res4 = grid(ir1, ir2, pr3) * (one-x1)*(one-x2)*x3
5489 : 292599 : res5 = grid(pr1, pr2, ir3) * x1*x2*(one-x3)
5490 : 292599 : res6 = grid(ir1, pr2, pr3) * (one-x1)*x2*x3
5491 : 292599 : res7 = grid(pr1, ir2, pr3) * x1*(one-x2)*x3
5492 : 292599 : res8 = grid(pr1, pr2, pr3) * x1*x2*x3
5493 : 292599 : res = res1+res2+res3+res4+res5+res6+res7+res8
5494 : :
5495 : 292599 : end function interpol3d_1d_dpc
5496 : : !!***
5497 : :
5498 : : !----------------------------------------------------------------------
5499 : :
5500 : : !!****f* m_numeric_tools/simpson_int
5501 : : !! NAME
5502 : : !! simpson_int
5503 : : !!
5504 : : !! FUNCTION
5505 : : !! Simpson integral of input function
5506 : : !!
5507 : : !! INPUTS
5508 : : !! npts=max number of points on grid for integral
5509 : : !! step = space between integral arguments
5510 : : !! values(npts)=integrand function.
5511 : : !!
5512 : : !! OUTPUT
5513 : : !! int_values(npts)=integral of values.
5514 : : !!
5515 : : !! SOURCE
5516 : :
5517 : 3221203 : subroutine simpson_int(npts, step, values, int_values)
5518 : :
5519 : : !Arguments ------------------------------------
5520 : : !scalars
5521 : : integer,intent(in) :: npts
5522 : : real(dp),intent(in) :: step
5523 : : !arrays
5524 : : real(dp),intent(in) :: values(npts)
5525 : : real(dp),intent(out) :: int_values(npts)
5526 : :
5527 : : !Local variables -------------------------
5528 : : !scalars
5529 : : integer :: ii
5530 : : real(dp),parameter :: coef1 = 0.375_dp !9.0_dp / 24.0_dp
5531 : : real(dp),parameter :: coef2 = 1.166666666666666666666666667_dp !28.0_dp / 24.0_dp
5532 : : real(dp),parameter :: coef3 = 0.958333333333333333333333333_dp !23.0_dp / 24.0_dp
5533 : : character(len=500) :: msg
5534 : : ! *********************************************************************
5535 : :
5536 [ - + ]: 3221203 : if (npts < 6) then
5537 : 0 : write(msg,"(a,i0)")"Number of points in integrand function must be >=6 while it is: ",npts
5538 : 0 : ABI_ERROR(msg)
5539 : : end if
5540 : :
5541 : : !-----------------------------------------------------------------
5542 : : !Simpson integral of input function
5543 : : !-----------------------------------------------------------------
5544 : :
5545 : : !first point is 0: don t store it
5546 : : !do integration equivalent to Simpson O(1/N^4) from NumRec in C p 134 NumRec in Fortran p 128
5547 : 3221203 : int_values(1) = coef1*values(1)
5548 : 3221203 : int_values(2) = int_values(1) + coef2*values(2)
5549 : 3221203 : int_values(3) = int_values(2) + coef3*values(3)
5550 : :
5551 [ + + ]: 3294225581 : do ii=4,npts-3
5552 : 3294225581 : int_values(ii) = int_values(ii-1) + values(ii)
5553 : : end do
5554 : :
5555 : 3221203 : int_values(npts-2) = int_values(npts-3) + coef3*values(npts-2)
5556 : 3221203 : int_values(npts-1) = int_values(npts-2) + coef2*values(npts-1)
5557 : 3221203 : int_values(npts ) = int_values(npts-1) + coef1*values(npts )
5558 : :
5559 [ + + ]: 3313552799 : int_values(:) = int_values(:) * step
5560 : :
5561 : 3221203 : end subroutine simpson_int
5562 : : !!***
5563 : :
5564 : : !----------------------------------------------------------------------
5565 : :
5566 : : !!****f* m_numeric_tools/simpson
5567 : : !! NAME
5568 : : !! simpson
5569 : : !!
5570 : : !! FUNCTION
5571 : : !! Simpson integral of input function
5572 : : !!
5573 : : !! INPUTS
5574 : : !! step = space between integral arguments
5575 : : !! values(npts)=integrand function.
5576 : : !!
5577 : : !! OUTPUT
5578 : : !! integral of values on the full mesh.
5579 : : !!
5580 : : !! SOURCE
5581 : :
5582 [ - + ]: 796771 : function simpson(step, values) result(res)
5583 : :
5584 : : !Arguments ------------------------------------
5585 : : !scalars
5586 : : real(dp),intent(in) :: step
5587 : : real(dp) :: res
5588 : : !arrays
5589 : : real(dp),intent(in) :: values(:)
5590 : :
5591 : : !Local variables -------------------------
5592 : 1593542 : real(dp) :: int_values(size(values))
5593 : : ! *********************************************************************
5594 : :
5595 [ - + - - : 796771 : call simpson_int(size(values),step,values,int_values)
- - - + ]
5596 : 796771 : res = int_values(size(values))
5597 : :
5598 : 796771 : end function simpson
5599 : : !!***
5600 : :
5601 : : !----------------------------------------------------------------------
5602 : :
5603 : : !!****f* m_numeric_tools/rhophi
5604 : : !! NAME
5605 : : !! rhophi
5606 : : !!
5607 : : !! FUNCTION
5608 : : !! Compute the phase and the module of a complex number.
5609 : : !! The phase angle is fold into the interval [-pi,pi]
5610 : : !!
5611 : : !! INPUTS
5612 : : !! cx(2) = complex number
5613 : : !!
5614 : : !! OUTPUT
5615 : : !! phi = phase of cx fold into [-pi,pi]
5616 : : !! rho = module of cx
5617 : : !!
5618 : : !! SOURCE
5619 : :
5620 : 290969874 : pure subroutine rhophi(cx, phi, rho)
5621 : :
5622 : : !Arguments ------------------------------------
5623 : : !scalars
5624 : : real(dp),intent(out) :: phi,rho
5625 : : !arrays
5626 : : real(dp),intent(in) :: cx(2)
5627 : : ! ***********************************************************************
5628 : :
5629 : 290969874 : rho = sqrt(cx(1)*cx(1) + cx(2)*cx(2))
5630 : :
5631 [ + + ]: 290969874 : if (abs(cx(1)) > tol8) then
5632 : 290958544 : phi = atan(cx(2)/cx(1))
5633 : :
5634 : : ! phi is an element of [-pi,pi]
5635 [ + + ]: 290958544 : if (cx(1) < zero) then
5636 [ + + ]: 143840488 : if (phi < zero) then
5637 : 73801918 : phi = phi + pi
5638 : : else
5639 : 70038570 : phi = phi - pi
5640 : : end if
5641 : : end if
5642 : :
5643 : : else
5644 : :
5645 [ + + ]: 11330 : if (cx(2) > tol8) then
5646 : 2985 : phi = pi*half
5647 [ + - ]: 8345 : else if (cx(2) < tol8) then
5648 : 8345 : phi = -pi*half
5649 : : else
5650 : 0 : phi = zero
5651 : : end if
5652 : :
5653 : : end if
5654 : :
5655 : 290969874 : end subroutine rhophi
5656 : : !!***
5657 : :
5658 : : !----------------------------------------------------------------------
5659 : :
5660 : : !!****f* m_numeric_tools/vdiff_eval
5661 : : !! NAME
5662 : : !! vdiff_eval
5663 : : !!
5664 : : !! FUNCTION
5665 : : !! Estimate the "distance" between two functions tabulated on a homogeneous grid.
5666 : : !! See vdiff_t
5667 : : !!
5668 : : !! INPUTS
5669 : : !! cplex=1 if f1 and f2 are real, 2 for complex.
5670 : : !! nr=Number of points in the mesh.
5671 : : !! f1(cplex,nr), f2(cplex,nr)=Vectors with values
5672 : : !! [vd_max]= Compute max value of the different entries.
5673 : : !!
5674 : : !! OUTPUT
5675 : : !! vdiff_t object
5676 : : !!
5677 : : !! SOURCE
5678 : :
5679 : 0 : subroutine vdiff_eval(vd, cplex, nr, f1, f2, volume, vd_max, unit)
5680 : :
5681 : : !Arguments ------------------------------------
5682 : : !scalars
5683 : : class(vdiff_t),intent(out) :: vd
5684 : : integer,intent(in) :: cplex,nr
5685 : : real(dp),intent(in) :: volume
5686 : : type(vdiff_t),optional,intent(inout) :: vd_max
5687 : : integer,optional,intent(in) :: unit
5688 : : !arrays
5689 : : real(dp),intent(in) :: f1(cplex,nr),f2(cplex,nr)
5690 : :
5691 : : !Local variables-------------------------------
5692 : : !scalars
5693 : : integer :: ir
5694 : : real(dp) :: num,den,dr
5695 : : type(stats_t) :: stats
5696 : : !arrays
5697 [ # # ]: 0 : real(dp) :: abs_diff(nr)
5698 : : ! *********************************************************************
5699 : :
5700 : 0 : dr = volume / nr
5701 : :
5702 [ # # ]: 0 : if (cplex == 1) then
5703 [ # # ]: 0 : abs_diff = abs(f1(1,:) - f2(1,:))
5704 [ # # ]: 0 : num = sum(abs_diff)
5705 [ # # ]: 0 : den = sum(abs(f2(1,:)))
5706 : :
5707 [ # # ]: 0 : else if (cplex == 2) then
5708 [ # # ]: 0 : do ir=1,nr
5709 : 0 : abs_diff(ir) = sqrt((f1(1,ir) - f2(1,ir))**2 + (f1(2,ir) - f2(2,ir))**2)
5710 : : end do
5711 [ # # ]: 0 : num = sum(abs_diff)
5712 : 0 : den = zero
5713 [ # # ]: 0 : do ir=1,nr
5714 : 0 : den = den + sqrt(f2(1,ir)**2 + f2(2,ir)**2)
5715 : : end do
5716 : : end if
5717 : :
5718 : 0 : vd%int_adiff = num * dr
5719 : 0 : call safe_div(num,den,zero,vd%l1_rerr)
5720 : :
5721 : 0 : stats = stats_eval(abs_diff)
5722 : 0 : vd%mean_adiff = stats%mean
5723 : 0 : vd%stdev_adiff = stats%stdev
5724 : 0 : vd%min_adiff = stats%min
5725 : 0 : vd%max_adiff = stats%max
5726 : :
5727 [ # # ]: 0 : if (present(vd_max)) then
5728 : 0 : vd_max%int_adiff = max(vd_max%int_adiff, vd%int_adiff)
5729 : 0 : vd_max%mean_adiff = max(vd_max%mean_adiff, vd%mean_adiff)
5730 : 0 : vd_max%stdev_adiff = max(vd_max%stdev_adiff, vd%stdev_adiff)
5731 : 0 : vd_max%min_adiff = max(vd_max%min_adiff, vd%min_adiff)
5732 : 0 : vd_max%max_adiff = max(vd_max%max_adiff, vd%max_adiff)
5733 : 0 : vd_max%l1_rerr = max(vd_max%l1_rerr, vd%L1_rerr)
5734 : : end if
5735 : :
5736 [ # # ]: 0 : if (present(unit)) call vd%print(unit=unit)
5737 : :
5738 : 0 : end subroutine vdiff_eval
5739 : : !!***
5740 : :
5741 : : !----------------------------------------------------------------------
5742 : :
5743 : : !!****f* m_numeric_tools/vdiff_print
5744 : : !! NAME
5745 : : !! vdiff_print
5746 : : !!
5747 : : !! FUNCTION
5748 : : !! Print vdiff_t to unit
5749 : : !!
5750 : : !! SOURCE
5751 : :
5752 : 0 : subroutine vdiff_print(vd, unit)
5753 : :
5754 : : !Arguments ------------------------------------
5755 : : !scalars
5756 : : class(vdiff_t),intent(in) :: vd
5757 : : integer,optional,intent(in) :: unit
5758 : :
5759 : : !Local variables-------------------------------
5760 : : integer :: unt
5761 : : ! *********************************************************************
5762 : :
5763 [ # # ]: 0 : unt = std_out; if (present(unit)) unt = unit
5764 : 0 : write(unt,"(a,es10.3,a)")" L1_rerr: ", vd%l1_rerr, ","
5765 : 0 : write(unt,"(a,es10.3,a)")" 'Integral |f1-f2|dr': ", vd%int_adiff, ","
5766 : 0 : write(unt,"(a,es10.3,a)")" 'min {|f1-f2|}': ", vd%min_adiff, ","
5767 : 0 : write(unt,"(a,es10.3,a)")" 'Max {|f1-f2|}': ", vd%max_adiff, ","
5768 : 0 : write(unt,"(a,es10.3,a)")" 'mean {|f1-f2|}': ", vd%mean_adiff, ","
5769 : 0 : write(unt,"(a,es10.3,a)")" 'stdev {|f1-f2|}': ", vd%stdev_adiff, ","
5770 : :
5771 : 0 : end subroutine vdiff_print
5772 : : !!***
5773 : :
5774 : : !!****f* m_numeric_tools/smooth
5775 : : !! NAME
5776 : : !! smooth data.
5777 : : !!
5778 : : !! FUNCTION
5779 : : !! smooth
5780 : : !!
5781 : : !! INPUTS
5782 : : !! mesh=Number of points.
5783 : : !! it=Number of iterations. <= 0 to return a unchanged.
5784 : : !!
5785 : : !! SIDE EFFECTS
5786 : : !! a(mesh)=Input values, smoothed in output
5787 : : !!
5788 : : !! SOURCE
5789 : :
5790 : 142 : pure subroutine smooth(a, mesh, it)
5791 : :
5792 : : !Arguments ------------------------------------
5793 : : !scalars
5794 : : integer, intent(in) :: it,mesh
5795 : : real(dp), intent(inout) :: a(mesh)
5796 : : !Local variables-------------------------------
5797 : : integer :: i,k
5798 : 284 : real(dp) :: asm(mesh)
5799 : : ! *********************************************************************
5800 : :
5801 [ + + ]: 1172 : do k=1,it
5802 : 1030 : asm(1)=1.0d0/3.0d0*(a(1)+a(2)+a(3))
5803 : 1030 : asm(2)=0.25d0*(a(1)+a(2)+a(3)+a(4))
5804 : 1030 : asm(3)=0.2d0*(a(1)+a(2)+a(3)+a(4)+a(5))
5805 : 1030 : asm(4)=0.2d0*(a(2)+a(3)+a(4)+a(5)+a(6))
5806 : 1030 : asm(5)=0.2d0*(a(3)+a(4)+a(5)+a(6)+a(7))
5807 : : asm(mesh-4)=0.2d0*(a(mesh-2)+a(mesh-3)+a(mesh-4)+&
5808 : 1030 : & a(mesh-5)+a(mesh-6))
5809 : : asm(mesh-3)=0.2d0*(a(mesh-1)+a(mesh-2)+a(mesh-3)+&
5810 : 1030 : & a(mesh-4)+a(mesh-5))
5811 : : asm(mesh-2)=0.2d0*(a(mesh)+a(mesh-1)+a(mesh-2)+&
5812 : 1030 : & a(mesh-3)+a(mesh-4))
5813 : 1030 : asm(mesh-1)=0.25d0*(a(mesh)+a(mesh-1)+a(mesh-2)+a(mesh-3))
5814 : 1030 : asm(mesh)=1.0d0/3.0d0*(a(mesh)+a(mesh-1)+a(mesh-2))
5815 : :
5816 [ + + ]: 2509730 : do i=6,mesh-5
5817 : : asm(i)=0.1d0*a(i)+0.1d0*(a(i+1)+a(i-1))+&
5818 : : & 0.1d0*(a(i+2)+a(i-2))+&
5819 : : & 0.1d0*(a(i+3)+a(i-3))+&
5820 : : & 0.1d0*(a(i+4)+a(i-4))+&
5821 : 2509730 : & 0.05d0*(a(i+5)+a(i-5))
5822 : : end do
5823 : :
5824 [ + + ]: 2520172 : do i=1,mesh
5825 : 2520030 : a(i)=asm(i)
5826 : : end do
5827 : : end do
5828 : :
5829 : 142 : end subroutine smooth
5830 : : !!***
5831 : :
5832 : : !!****f* m_numeric_tools/nderiv
5833 : : !! NAME
5834 : : !! nderiv
5835 : : !!
5836 : : !! FUNCTION
5837 : : !! Given an input function y(x) on a regular grid,
5838 : : !! compute its first or second derivative.
5839 : : !!
5840 : : !! INPUTS
5841 : : !! hh= radial step
5842 : : !! ndim= radial mesh size
5843 : : !! yy(ndim)= input function
5844 : : !! norder= order of derivation (1 or 2)
5845 : : !!
5846 : : !! OUTPUT
5847 : : !! zz(ndim)= first or second derivative of y
5848 : : !!
5849 : : !! SOURCE
5850 : :
5851 : 42 : pure subroutine nderiv(hh,yy,zz,ndim,norder)
5852 : :
5853 : : !Arguments ---------------------------------------------
5854 : : !scalars
5855 : : integer,intent(in) :: ndim,norder
5856 : : real(dp),intent(in) :: hh
5857 : : !arrays
5858 : : real(dp),intent(in) :: yy(ndim)
5859 : : real(dp),intent(out) :: zz(ndim)
5860 : :
5861 : : !Local variables ---------------------------------------
5862 : : !scalars
5863 : : integer :: ier,ii
5864 : : real(dp) :: aa,bb,cc,h1,y1
5865 : : ! *********************************************************************
5866 : :
5867 : : !Initialization (common to 1st and 2nd derivative)
5868 : 42 : h1=one/(12.d0*hh)
5869 : 42 : y1=yy(ndim-4)
5870 : :
5871 : : !FIRST DERIVATIVE
5872 : : !================
5873 [ + - ]: 42 : if (norder==1) then
5874 : :
5875 : : ! Prepare differentiation loop
5876 : 42 : bb=h1*(-25.d0*yy(1)+48.d0*yy(2)-36.d0*yy(3)+16.d0*yy(4)-3.d0*yy(5))
5877 : 42 : cc=h1*(-3.d0*yy(1)-10.d0*yy(2)+18.d0*yy(3)-6.d0*yy(4)+yy(5))
5878 : : ! Start differentiation loop
5879 [ + + ]: 58938 : do ii=5,ndim
5880 : 58896 : aa=bb;bb=cc
5881 : 58896 : cc=h1*(yy(ii-4)-yy(ii)+8.d0*(yy(ii-1)-yy(ii-3)))
5882 : 58938 : zz(ii-4)=aa
5883 : : end do
5884 : : ! Normal exit
5885 : 42 : ier=0
5886 : 42 : aa=h1*(-y1+6.d0*yy(ndim-3)-18.d0*yy(ndim-2)+10.d0*yy(ndim-1)+3.d0*yy(ndim))
5887 : 42 : zz(ndim)=h1*(3.d0*y1-16.d0*yy(ndim-3)+36.d0*yy(ndim-2) -48.d0*yy(ndim-1)+25.d0*yy(ndim))
5888 : 42 : zz(ndim-1)=aa
5889 : 42 : zz(ndim-2)=cc
5890 : 42 : zz(ndim-3)=bb
5891 : :
5892 : : ! SECOND DERIVATIVE
5893 : : ! =================
5894 : : else
5895 : 0 : h1=h1/hh
5896 : : ! Prepare differentiation loop
5897 : 0 : bb=h1*(35.d0*yy(1)-104.d0*yy(2)+114.d0*yy(3)-56.d0*yy(4)+11.d0*yy(5))
5898 : 0 : cc=h1*(11.d0*yy(1)-20.d0*yy(2)+6.d0*yy(3)+4.d0*yy(4)-yy(5))
5899 : : ! Start differentiation loop
5900 [ # # ]: 0 : do ii=5,ndim
5901 : 0 : aa=bb;bb=cc
5902 : 0 : cc=h1*(-yy(ii-4)-yy(ii)+16.d0*(yy(ii-1)+yy(ii-3))-30.d0*yy(ii-2))
5903 : 0 : zz(ii-4)=aa
5904 : : end do
5905 : : ! Normal exit
5906 : 0 : ier=0
5907 : 0 : aa=h1*(-y1+4.d0*yy(ndim-3)+6.d0*yy(ndim-2)-20.d0*yy(ndim-1)+11.d0*yy(ndim))
5908 : 0 : zz(ndim)=h1*(11.d0*y1-56.d0*yy(ndim-3)+114.d0*yy(ndim-2) -104.d0*yy(ndim-1)+35.d0*yy(ndim))
5909 : 0 : zz(ndim-1)=aa
5910 : 0 : zz(ndim-2)=cc
5911 : 0 : zz(ndim-3)=bb
5912 : :
5913 : : end if !norder
5914 : :
5915 : 42 : end subroutine nderiv
5916 : : !!***
5917 : :
5918 : : !----------------------------------------------------------------------
5919 : :
5920 : : !!****f* m_numeric_tools/central_finite_diff
5921 : : !! NAME
5922 : : !! central_finite_diff
5923 : : !!
5924 : : !! FUNCTION
5925 : : !! Coefficients of the central differences, for several orders of accuracy.
5926 : : !! See: https://en.wikipedia.org/wiki/Finite_difference_coefficient
5927 : : !!
5928 : : !! INPUTS
5929 : : !! order=Derivative order.
5930 : : !! ipos=Index of the point must be in [1,npts]
5931 : : !! npts=Number of points used in finite difference, origin at npts/2 + 1
5932 : : !!
5933 : : !! OUTPUT
5934 : : !! coefficients for central finite difference
5935 : : !!
5936 : : !! SOURCE
5937 : :
5938 : 684 : real(dp) function central_finite_diff(order, ipos, npts) result(fact)
5939 : :
5940 : : !Arguments ---------------------------------------------
5941 : : !scalars
5942 : : integer,intent(in) :: ipos,order,npts
5943 : :
5944 : : !Local variables ---------------------------------------
5945 : : !scalars
5946 : : real(dp),parameter :: empty=huge(one)
5947 : : ! 1st derivative.
5948 : : real(dp),parameter :: d1(9,4) = reshape([ &
5949 : : [-1/2._dp, 0._dp, 1/2._dp, empty, empty, empty, empty, empty, empty], &
5950 : : [ 1/12._dp, -2/3._dp, 0._dp, 2/3._dp, -1/12._dp, empty, empty, empty, empty], &
5951 : : [-1/60._dp, 3/20._dp, -3/4._dp, 0._dp, 3/4._dp, -3/20._dp, 1/60._dp, empty, empty], &
5952 : : [ 1/280._dp, -4/105._dp, 1/5._dp, -4/5._dp, 0._dp, 4/5._dp, -1/5._dp, 4/105._dp, -1/280._dp]], [9,4])
5953 : : ! 2nd derivative.
5954 : : real(dp),parameter :: d2(9,4) = reshape([ &
5955 : : [ 1._dp, -2._dp, 1._dp, empty, empty, empty, empty, empty, empty], &
5956 : : [-1/12._dp, 4/3._dp, -5/2._dp, 4/3._dp, -1/12._dp, empty, empty, empty, empty], &
5957 : : [ 1/90._dp, -3/20._dp, 3/2._dp, -49/18._dp, 3/2._dp, -3/20._dp, 1/90._dp, empty, empty], &
5958 : : [-1/560._dp, 8/315._dp, -1/5._dp, 8/5._dp, -205/72._dp, 8/5._dp, -1/5._dp, 8/315._dp, -1/560._dp]], [9,4])
5959 : : ! 3th derivative.
5960 : : real(dp),parameter :: d3(9,3) = reshape([ &
5961 : : [-1/2._dp, 1._dp, 0._dp, -1._dp, 1/2._dp, empty, empty, empty, empty], &
5962 : : [ 1/8._dp, -1._dp, 13/8._dp, 0._dp, -13/8._dp, 1._dp, -1/8._dp, empty, empty], &
5963 : : [ -7/240._dp, 3/10._dp, -169/120._dp, 61/30._dp, 0._dp, -61/30._dp, 169/120._dp, -3/10._dp, 7/240._dp]], &
5964 : : [9,3])
5965 : : ! 4th derivative.
5966 : : real(dp),parameter :: d4(9,3) = reshape([ &
5967 : : [ 1._dp, -4._dp, 6._dp, -4._dp, 1._dp, empty, empty, empty, empty], &
5968 : : [ -1/6._dp, 2._dp, -13/2._dp, 28/3._dp, -13/2._dp, 2._dp, -1/6._dp, empty, empty], &
5969 : : [ 7/240._dp, -2/5._dp, 169/60._dp, -122/15._dp, 91/8._dp, -122/15._dp, 169/60._dp, -2/5._dp, 7/240._dp]], [9,3])
5970 : : ! 5th derivative.
5971 : : real(dp),parameter :: d5(7) = [ -1/2._dp, 2._dp, -5/2._dp, 0._dp, 5/2._dp, -2._dp, 1/2._dp]
5972 : : ! 6th derivative.
5973 : : real(dp),parameter :: d6(7) = [ 1._dp, -6._dp, 15._dp, -20._dp, 15._dp, -6._dp, 1._dp]
5974 : : ! *********************************************************************
5975 : :
5976 : 1368 : select case (order)
5977 : : case (1)
5978 [ + - - + : 684 : if (ipos < 1 .or. ipos > 9 .or. npts < 1 .or. npts > 9) goto 10
- + ]
5979 : 684 : fact = d1(ipos, npts/2)
5980 : : case (2)
5981 [ # # # # : 0 : if (ipos < 1 .or. ipos > 9 .or. npts < 1 .or. npts > 9) goto 10
# # ]
5982 : 0 : fact = d2(ipos, npts/2)
5983 : : case (3)
5984 [ # # # # : 0 : if (ipos < 1 .or. ipos > 9 .or. npts < 1 .or. npts > 9) goto 10
# # ]
5985 : 0 : fact = d3(ipos, npts/2)
5986 : : case (4)
5987 [ # # # # : 0 : if (ipos < 1 .or. ipos > 9 .or. npts < 1 .or. npts > 9) goto 10
# # ]
5988 : 0 : fact = d4(ipos, npts/2 - 1)
5989 : : case (5)
5990 [ # # # # ]: 0 : if (ipos < 1 .or. ipos > 7 .or. npts /= 7) goto 10
5991 : 0 : fact = d5(ipos)
5992 : : case (6)
5993 [ # # # # ]: 0 : if (ipos < 1 .or. ipos > 7 .or. npts /= 7) goto 10
5994 : 0 : fact = d6(ipos)
5995 : : case default
5996 [ + - - - : 684 : ABI_ERROR(sjoin("No entry for ipos:",itoa(ipos),"order", itoa(order), "npts", itoa(npts)))
- - - ]
5997 : : end select
5998 : :
5999 [ - + ]: 684 : if (fact == empty) then
6000 : 0 : ABI_ERROR(sjoin("Invalid ipos:",itoa(ipos),"for order", itoa(order), "npts", itoa(npts)))
6001 : : end if
6002 : 0 : return
6003 : :
6004 : 0 : 10 ABI_ERROR(sjoin("No entry for ipos:",itoa(ipos),"order", itoa(order), "npts", itoa(npts)))
6005 : :
6006 : 0 : end function central_finite_diff
6007 : : !!***
6008 : :
6009 : : !!****f* m_numeric_tools/uniformrandom
6010 : : !! NAME
6011 : : !! uniformrandom
6012 : : !!
6013 : : !! FUNCTION
6014 : : !! Returns a uniform random deviate between 0.0 and 1.0.
6015 : : !! Set seed to any value < 0 to initialize or reinitialize sequence.
6016 : : !! Parameters are chosen from integer overflow=2**23 (conservative).
6017 : : !! For some documentation, see Numerical Recipes, 1986, p196.
6018 : : !!
6019 : : !! INPUTS
6020 : : !!
6021 : : !! OUTPUT
6022 : : !!
6023 : : !! NOTES
6024 : : !!
6025 : : !! SOURCE
6026 : :
6027 : 1393623 : function uniformrandom(seed)
6028 : :
6029 : : !Arguments ------------------------------------
6030 : : !scalars
6031 : : real(dp) :: uniformrandom
6032 : : integer,intent(inout) :: seed
6033 : :
6034 : : !Local variables ---------------------------------------
6035 : : integer, parameter :: im1=11979,ia1= 430,ic1=2531
6036 : : integer, parameter :: im2= 6655,ia2= 936,ic2=1399
6037 : : integer, parameter :: im3= 6075,ia3=1366,ic3=1283
6038 : : integer, save :: init=0
6039 : : integer, save :: ii1,ii2,ii3
6040 : : integer :: kk
6041 : : real(dp) :: im1inv,im2inv
6042 : : real(dp), save :: table(97)
6043 : : character(len=500) :: msg
6044 : : ! *********************************************************************
6045 : :
6046 : 1393623 : im1inv=1.0d0/im1 ; im2inv=1.0d0/im2
6047 : :
6048 : : !Initialize on first call or when seed<0:
6049 [ + + + + ]: 1393623 : if (seed<0.or.init==0) then
6050 : 598 : seed=-abs(seed)
6051 : :
6052 : : ! First generator
6053 : 598 : ii1=mod(ic1-seed,im1)
6054 : 598 : ii1=mod(ia1*ii1+ic1,im1)
6055 : : ! Second generator
6056 : 598 : ii2=mod(ii1,im2)
6057 : 598 : ii1=mod(ia1*ii1+ic1,im1)
6058 : : ! Third generator
6059 : 598 : ii3=mod(ii1,im3)
6060 : :
6061 : : ! Fill table
6062 [ + + ]: 58604 : do kk=1,97
6063 : 58006 : ii1=mod(ia1*ii1+ic1,im1)
6064 : 58006 : ii2=mod(ia2*ii2+ic2,im2)
6065 : 58604 : table(kk)=(dble(ii1)+dble(ii2)*im2inv)*im1inv
6066 : : enddo
6067 : :
6068 : 598 : init=1 ; seed=1
6069 : : end if
6070 : :
6071 : : !Third generator gives index
6072 : 1393623 : ii3=mod(ia3*ii3+ic3,im3)
6073 : 1393623 : kk=1+(97*ii3)/im3
6074 [ - + ]: 1393623 : if (kk<1.or.kk>97) then
6075 : 0 : write(msg,'(a,2i0,a)' ) ' trouble in uniformrandom; ii3,kk=',ii3,kk,' =>stop'
6076 : 0 : ABI_ERROR(msg)
6077 : : end if
6078 : 1393623 : uniformrandom=table(kk)
6079 : :
6080 : : !Replace old value, based on generators 1 and 2
6081 : 1393623 : ii1=mod(ia1*ii1+ic1,im1)
6082 : 1393623 : ii2=mod(ia2*ii2+ic2,im2)
6083 : 1393623 : table(kk)=(dble(ii1)+dble(ii2)*im2inv)*im1inv
6084 : :
6085 : 1393623 : end function uniformrandom
6086 : : !!***
6087 : :
6088 : : !!****f* m_numeric_tools/findmin
6089 : : !!
6090 : : !! NAME
6091 : : !! findmin
6092 : : !!
6093 : : !! FUNCTION
6094 : : !! Compute the minimum of a function whose value and derivative are known at two points.
6095 : : !! Also deduce different quantities at this predicted point, and at the two other points
6096 : : !! It uses a quartic interpolation, with the supplementary
6097 : : !! condition that the second derivative vanishes at one and
6098 : : !! only one point. See Schlegel, J. Comp. Chem. 3, 214 (1982) [[cite:Schlegel1982]].
6099 : : !! For this option, lambda_1 must be 1 (new point),
6100 : : !! and lambda_2 must be 0 (old point).
6101 : : !! Also, if the derivative at the new point is more negative
6102 : : !! than the derivative at the old point, the predicted
6103 : : !! point cannot correspond to a minimum, but will be lambda=2.5_dp,
6104 : : !! if the energy of the second point is lower than the energy
6105 : : !! of the first point.
6106 : : !!
6107 : : !! INPUTS
6108 : : !! etotal_1=first value of the function
6109 : : !! etotal_2=second value of the function
6110 : : !! dedv_1=first value of the derivative
6111 : : !! dedv_2=second value of the derivative
6112 : : !! lambda_1=first value of the argument
6113 : : !! lambda_2=second value of the argument
6114 : : !!
6115 : : !! OUTPUT
6116 : : !! dedv_predict=predicted value of the derivative (usually zero,
6117 : : !! except if choice=4, if it happens that a minimum cannot be located,
6118 : : !! and a trial step is taken)
6119 : : !! d2edv2_predict=predicted value of the second derivative (not if choice=4)
6120 : : !! d2edv2_1=first value of the second derivative (not if choice=4)
6121 : : !! d2edv2_2=second value of the second derivative (not if choice=4)
6122 : : !! etotal_predict=predicted value of the function
6123 : : !! lambda_predict=predicted value of the argument
6124 : : !! status= 0 if everything went normally ;
6125 : : !! 1 if negative second derivative
6126 : : !! 2 if some other problem
6127 : : !!
6128 : : !! SOURCE
6129 : :
6130 : 247 : subroutine findmin(dedv_1,dedv_2,dedv_predict,&
6131 : : & d2edv2_1,d2edv2_2,d2edv2_predict,&
6132 : : & etotal_1,etotal_2,etotal_predict,&
6133 : : & lambda_1,lambda_2,lambda_predict,status)
6134 : :
6135 : : !Arguments ------------------------------------
6136 : : !scalars
6137 : : integer,intent(out) :: status
6138 : : real(dp),intent(in) :: dedv_1,dedv_2,etotal_1,etotal_2,lambda_1,lambda_2
6139 : : real(dp),intent(out) :: d2edv2_1,d2edv2_2,d2edv2_predict,dedv_predict
6140 : : real(dp),intent(out) :: etotal_predict,lambda_predict
6141 : :
6142 : : !Local variables-------------------------------
6143 : : !scalars
6144 : : real(dp) :: aa,bb,bbp,cc,ccp,d_lambda,dd
6145 : : real(dp) :: discr,ee,eep,lambda_shift,sum1,sum2,sum3,uu
6146 : : real(dp) :: uu3,vv,vv3
6147 : : character(len=500) :: msg
6148 : : ! *************************************************************************
6149 : :
6150 : : !write(std_out,*)' findmin : enter'
6151 : : !write(std_out,*)' choice,lambda_1,lambda_2=',choice,lambda_1,lambda_2
6152 : :
6153 : 247 : status=0
6154 : 247 : d_lambda=lambda_1-lambda_2
6155 : :
6156 : : !DEBUG
6157 : : !do choice=3,1,-1
6158 : : !ENDDEBUG
6159 : :
6160 [ + - - + ]: 247 : if(abs(lambda_1-1.0_dp)>tol12 .or. abs(lambda_2)>tol12) then
6161 : 0 : ABI_BUG('For choice=4, lambda_1 must be 1 and lambda_2 must be 0.')
6162 : : end if
6163 : :
6164 : : !Evaluate quartic interpolation
6165 : : !etotal = aa + bb * lambda + cc * lambda**2 + dd * lambda**3 + ee * lambda**4
6166 : : !Impose positive second derivative everywhere, with
6167 : : !one point where it vanishes : 3*dd**2=8*cc*ee
6168 : 247 : aa=etotal_2
6169 : 247 : bb=dedv_2
6170 : 247 : sum1=etotal_1-aa-bb
6171 : 247 : sum2=dedv_1-bb
6172 : 247 : sum3=sum2-2.0_dp*sum1
6173 : :
6174 : : !Build the discriminant of the associated 2nd degree equation
6175 : 247 : discr=sum2**2-3.0_dp*sum3**2
6176 [ + + + + ]: 247 : if(discr<0.0_dp .or. sum2<0.0_dp)then
6177 : :
6178 : : ! jmb init
6179 : 37 : d2edv2_2=0.0
6180 : 37 : d2edv2_1=0.0
6181 : 37 : d2edv2_predict=0.0
6182 : :
6183 : : ! Even if there is a problem, try to keep going ...
6184 : 37 : ABI_WARNING('The 2nd degree equation has no positive root (choice=4).')
6185 : 37 : status=2
6186 [ + - ]: 37 : if(etotal_1<etotal_2)then
6187 : : write(msg, '(a,a,a)' )&
6188 : 37 : 'Will continue, since the new total energy is lower',ch10,&
6189 : 74 : 'than the old. Take a larger step in the same direction.'
6190 : 37 : ABI_COMMENT(msg)
6191 : 37 : lambda_predict=2.5_dp
6192 : : else
6193 : : write(msg, '(a,a,a,a,a)' )&
6194 : 0 : 'There is a problem, since the new total energy is larger',ch10,&
6195 : 0 : 'than the old (choice=4).',ch10,&
6196 : 0 : 'I take a point between the old and new, close to the old .'
6197 : 0 : ABI_COMMENT(msg)
6198 : 0 : lambda_predict=0.25_dp
6199 : : end if
6200 : : ! Mimic a zero-gradient lambda, in order to avoid spurious
6201 : : ! action of the inverse hessian (the next line would be a realistic estimation)
6202 : 37 : dedv_predict=0.0_dp
6203 : : ! dedv_predict=dedv_2+lambda_predict*(dedv_1-dedv_2)
6204 : : ! Uses the energies, and the gradient at lambda_2
6205 : : etotal_predict=etotal_2+dedv_2*lambda_predict&
6206 : 37 : & +(etotal_1-etotal_2-dedv_2)*lambda_predict**2
6207 : :
6208 : : else
6209 : :
6210 : : ! Here, there is an acceptable solution to the 2nd degree equation
6211 : 210 : discr=sqrt(discr)
6212 : : ! The root that gives the smallest ee corresponds to -discr
6213 : : ! This is the one to be used: one aims at modelling the
6214 : : ! behaviour of the function as much as possible with the
6215 : : ! lowest orders of the polynomial, not the quartic term.
6216 : 210 : ee=(sum2-discr)*0.5_dp
6217 : 210 : dd=sum3-2.0_dp*ee
6218 : 210 : cc=sum1-dd-ee
6219 : :
6220 : : ! DEBUG
6221 : : ! write(std_out,*)'aa,bb,cc,dd,ee',aa,bb,cc,dd,ee
6222 : : ! ENDDEBUG
6223 : :
6224 : : ! Now, must find the unique root of
6225 : : ! 0 = bb + 2*cc * lambda + 3*dd * lambda^2 + 4*ee * lambda^3
6226 : : ! This root is unique because it was imposed that the second derivative
6227 : : ! of the quartic polynomial is everywhere positive.
6228 : : ! First, remove the quadratic term, by a shift of lambda
6229 : : ! lambdap=lambda-lambda_shift
6230 : : ! 0 = bbp + ccp * lambdap + eep * lambdap^3
6231 : 210 : eep=4.0_dp*ee
6232 : 210 : lambda_shift=-dd/(4.0_dp*ee)
6233 : 210 : ccp=2.0_dp*cc-12.0_dp*ee*lambda_shift**2
6234 : 210 : bbp=bb+ccp*lambda_shift+eep*lambda_shift**3
6235 : :
6236 : : ! DEBUG
6237 : : ! write(std_out,*)'bbp,ccp,eep,lambda_shift',bbp,ccp,eep,lambda_shift
6238 : : ! ENDDEBUG
6239 : :
6240 : : ! The solution of a cubic polynomial equation is as follows :
6241 : 210 : discr=(bbp/eep)**2+(4.0_dp/27.0_dp)*(ccp/eep)**3
6242 : : ! In the present case, discr will always be positive
6243 : 210 : discr=sqrt(discr)
6244 : 210 : uu3=0.5_dp*(-bbp/eep+discr) ; uu=sign((abs(uu3))**(1.0_dp/3.0_dp),uu3)
6245 : 210 : vv3=0.5_dp*(-bbp/eep-discr) ; vv=sign((abs(vv3))**(1.0_dp/3.0_dp),vv3)
6246 : 210 : lambda_predict=uu+vv
6247 : :
6248 : : ! Restore the shift
6249 : 210 : lambda_predict=lambda_predict+lambda_shift
6250 : : etotal_predict=aa+bb*lambda_predict+cc*lambda_predict**2+&
6251 : 210 : & dd*lambda_predict**3+ee*lambda_predict**4
6252 : : dedv_predict=bb+2.0_dp*cc*lambda_predict+3.0_dp*dd*lambda_predict**2+&
6253 : 210 : & 4.0_dp*ee*lambda_predict**3
6254 : 210 : d2edv2_1=2*cc+6*dd*lambda_1+12*ee*lambda_1**2
6255 : 210 : d2edv2_2=2*cc+6*dd*lambda_2+12*ee*lambda_2**2
6256 : 210 : d2edv2_predict=2*cc+6*dd*lambda_predict+12*ee*lambda_predict**2
6257 : :
6258 : : end if
6259 : :
6260 : 247 : write(msg, '(a,i3)' )' line minimization, algorithm ',4
6261 : 247 : call wrtout(std_out,msg,'COLL')
6262 : 247 : write(msg, '(a,a)' )' lambda etotal ',' dedv d2edv2 '
6263 : 247 : call wrtout(std_out,msg,'COLL')
6264 : 247 : write(msg, '(a,es12.4,es18.10,2es12.4)' )' old point :',lambda_2,etotal_2,dedv_2,d2edv2_2
6265 : 247 : call wrtout(std_out,msg,'COLL')
6266 : 247 : write(msg, '(a,es12.4,es18.10,2es12.4)' )' new point :',lambda_1,etotal_1,dedv_1,d2edv2_1
6267 : 247 : call wrtout(std_out,msg,'COLL')
6268 : 247 : write(msg, '(a,es12.4,es18.10,2es12.4)' )' predicted point :',lambda_predict,etotal_predict,dedv_predict,d2edv2_predict
6269 : 247 : call wrtout(std_out,msg,'COLL')
6270 : 247 : write(msg, '(a)' ) ' '
6271 : 247 : call wrtout(std_out,msg,'COLL')
6272 : :
6273 : 247 : end subroutine findmin
6274 : : !!***
6275 : :
6276 : : !!****f* m_numeric_tools/kramerskronig
6277 : : !! NAME
6278 : : !! kramerskronig
6279 : : !!
6280 : : !! FUNCTION
6281 : : !! check or apply the Kramers Kronig relation:
6282 : : !! Re \epsilon(\omega) = 1 + \frac{2}{\pi}
6283 : : !! \int_0^\infty d\omega' frac{\omega'}{\omega'^2 - \omega^2} Im \epsilon(\omega')
6284 : : !!
6285 : : !! INPUTS
6286 : : !! nomega=number of real frequencies
6287 : : !! omega(nomega)= real frequencies
6288 : : !! eps(nomega)= function on the frequency grid (both real and imaginary part)
6289 : : !! real part can be used to check whether the K-K relation is satisfied or not
6290 : : !! method=method used to perform the integration
6291 : : !! 0= naive integration
6292 : : !! 1=simpson rule
6293 : : !! only_check= if /=0 the real part of eps is checked against the imaginary part,
6294 : : !! a final report in written but the array eps is not modified
6295 : : !! if ==0 the real part of eps is overwritten using the
6296 : : !! results obtained using the Kramers-Kronig relation
6297 : : !!
6298 : : !! OUTPUT
6299 : : !!
6300 : : !! NOTES
6301 : : !! Inspired to check_kramerskronig of the DP code
6302 : : !!
6303 : : !! SOURCE
6304 : :
6305 : 0 : subroutine kramerskronig(nomega,omega,eps,method,only_check)
6306 : :
6307 : : !Arguments ------------------------------------
6308 : : !scalars
6309 : : integer,intent(in) :: method,nomega,only_check
6310 : : !arrays
6311 : : real(dp),intent(in) :: omega(nomega)
6312 : : complex(dp),intent(inout) :: eps(nomega)
6313 : :
6314 : : !Local variables-------------------------------
6315 : : !scalars
6316 : : integer,save :: enough=0
6317 : : integer :: ii,ip
6318 : : real(dp) :: acc,domega,eav,kkdif,kkrms,ww,wwp
6319 : : character(len=500) :: msg
6320 : : !arrays
6321 : 0 : real(dp) :: e1kk(nomega),intkk(nomega),kk(nomega)
6322 : : ! *************************************************************************
6323 : :
6324 : : !Check whether the frequency grid is linear or not
6325 : 0 : domega = (omega(nomega) - omega(1)) / (nomega-1)
6326 [ # # ]: 0 : do ii=2,nomega
6327 [ # # ]: 0 : if (ABS(domega-(omega(ii)-omega(ii-1))) > 0.001) then
6328 [ # # ]: 0 : if (only_check/=1) then
6329 : 0 : ABI_WARNING("Check cannot be performed since the frequency step is not constant")
6330 : 0 : RETURN
6331 : : else
6332 : 0 : ABI_ERROR('Cannot perform integration since frequency step is not constant')
6333 : : end if
6334 : : end if
6335 : : end do
6336 : :
6337 : : !Check whether omega(1) is small or not
6338 [ # # ]: 0 : if (omega(1) > 0.1/Ha_eV) then
6339 [ # # ]: 0 : if (only_check/=1) then
6340 : 0 : ABI_WARNING('Check cannot be performed since first frequency on the grid > 0.1 eV')
6341 : 0 : RETURN
6342 : : else
6343 : 0 : ABI_ERROR('Cannot perform integration since first frequency on the grid > 0.1 eV')
6344 : : end if
6345 : : end if
6346 : :
6347 : : !If eps(nomega) is not 0 warn
6348 [ # # # # ]: 0 : if (AIMAG(eps(nomega)) > 0.1 .and. enough<50) then
6349 : 0 : enough=enough+1
6350 : : write(msg,'(a,f8.4,3a,f8.2,2a)')&
6351 : 0 : & 'Im epsilon for omega = ',omega(nomega)*Ha_eV,' eV',ch10,&
6352 : 0 : & 'is not yet zero, epsilon_2 = ',AIMAG(eps(nomega)),ch10,&
6353 : 0 : & 'Kramers Kronig could give wrong results'
6354 : 0 : ABI_WARNING(msg)
6355 [ # # ]: 0 : if (enough==50) then
6356 : 0 : write(msg,'(3a)')' sufficient number of WARNINGS-',ch10,' stop writing '
6357 : 0 : call wrtout(std_out,msg,'COLL')
6358 : : end if
6359 : : end if
6360 : :
6361 : : !Perform Kramers-Kronig using naive integration
6362 : 0 : select case (method)
6363 : : case (0)
6364 : :
6365 [ # # ]: 0 : do ii=1,nomega
6366 : 0 : ww = omega(ii)
6367 : 0 : acc = 0.0_dp
6368 [ # # ]: 0 : do ip=1,nomega
6369 [ # # ]: 0 : if (ip == ii) CYCLE
6370 : 0 : wwp = omega(ip)
6371 : 0 : acc = acc + wwp/(wwp**2-ww**2) *AIMAG(eps(ip))
6372 : : end do
6373 : 0 : e1kk(ii) = one + two/pi*domega* acc
6374 : : end do
6375 : :
6376 : : ! Perform Kramers-Kronig using Simpson integration
6377 : : ! Simpson O(1/N^4), from NumRec in C p 134 NumRec in Fortran p 128
6378 : : case (1)
6379 : :
6380 [ # # ]: 0 : kk=zero
6381 : :
6382 [ # # ]: 0 : do ii=1,nomega
6383 : 0 : ww=omega(ii)
6384 [ # # ]: 0 : do ip=1,nomega
6385 [ # # ]: 0 : if (ip == ii) CYCLE
6386 : 0 : wwp = omega(ip)
6387 : 0 : kk(ip) = wwp/(wwp**2-ww**2) *AIMAG(eps(ip))
6388 : : end do
6389 : 0 : call simpson_int(nomega,domega,kk,intkk)
6390 : 0 : e1kk(ii) = one + two/pi * intkk(nomega)
6391 : : end do
6392 : :
6393 : : case default
6394 : 0 : write(msg,'(a,i0)')' Wrong value for method ',method
6395 [ # # # ]: 0 : ABI_BUG(msg)
6396 : : end select
6397 : :
6398 : : !at this point real part is in e1kk, need to put it into eps
6399 [ # # ]: 0 : do ii=1,nomega
6400 : 0 : eps(ii)=CMPLX(e1kk(ii),AIMAG(eps(ii)), kind=dp)
6401 : : end do
6402 : :
6403 : : !Verify Kramers-Kronig
6404 : : eav = zero
6405 : : kkdif = zero
6406 : : kkrms = zero
6407 : :
6408 : : do ii=1,nomega
6409 : : kkdif = kkdif + ABS(REAL(eps(ii)) - e1kk(ii))
6410 : : kkrms = kkrms + (REAL(eps(ii)) - e1kk(ii))*(REAL(eps(ii)) - e1kk(ii))
6411 : : eav = eav + ABS(REAL(eps(ii)))
6412 : : end do
6413 : :
6414 : 0 : eav = eav/nomega
6415 : 0 : kkdif = (kkdif/nomega) / eav
6416 : 0 : kkrms = (kkrms/nomega) / (eav*eav)
6417 : :
6418 [ # # ]: 0 : kk = ABS(REAL(eps(1)) - e1kk(1)) / REAL(eps(1))
6419 : :
6420 : : !Write data
6421 [ # # # # : 0 : write(msg,'(a,f7.2,a)')' Kramers-Kronig transform is verified within ',MAXVAL(kk)*100,"%"
# # # # ]
6422 : 0 : call wrtout(std_out,msg,'COLL')
6423 : :
6424 : : end subroutine kramerskronig
6425 : : !!***
6426 : :
6427 : : !!****f* ABINIT/dotproduct
6428 : : !! NAME
6429 : : !! dotproduct
6430 : : !!
6431 : : !! FUNCTION
6432 : : !! scalar product of two vectors
6433 : : !!
6434 : : !! INPUTS
6435 : : !! v1 and v2: two real(dp) vectors
6436 : : !!
6437 : : !! OUTPUT
6438 : : !! scalar product of the two vectors
6439 : : !!
6440 : : !! WARNINGS
6441 : : !! vector size is not checked
6442 : : !!
6443 : : !! NOTES
6444 : : !! I've benchmarked this to be speedier than the intrinsic dot_product even on
6445 : : !! big vectors. The point is that less check is performed.
6446 : : !!
6447 : : !! MG: FIXME: Well, optized blas1 is for sure better than what you wrote!
6448 : : !! Now I don't have time to update ref files
6449 : : !!
6450 : : !! SOURCE
6451 : :
6452 : 8555 : function dotproduct(nv1,nv2,v1,v2)
6453 : :
6454 : : !Arguments ------------------------------------
6455 : : !scalars
6456 : : integer,intent(in) :: nv1,nv2
6457 : : real(dp) :: dotproduct
6458 : : !arrays
6459 : : real(dp),intent(in) :: v1(nv1,nv2),v2(nv1,nv2)
6460 : :
6461 : : !Local variables-------------------------------
6462 : : !scalars
6463 : : integer :: i,j
6464 : : ! *************************************************************************
6465 : :
6466 : 8555 : dotproduct=zero
6467 [ + + ]: 17110 : do j=1,nv2
6468 [ + + ]: 85567110 : do i=1,nv1
6469 : 85558555 : dotproduct=dotproduct+v1(i,j)*v2(i,j)
6470 : : end do
6471 : : end do
6472 : :
6473 : 8555 : end function dotproduct
6474 : : !!***
6475 : :
6476 : : !!****f* m_numeric_tools/invcb
6477 : : !! NAME
6478 : : !! invcb
6479 : : !!
6480 : : !! FUNCTION
6481 : : !! Compute a set of inverse cubic roots as fast as possible:
6482 : : !! rspts(:)=rhoarr(:)$^\frac{-1}{3}$
6483 : : !!
6484 : : !! INPUTS
6485 : : !! npts=number of real space points on which density is provided
6486 : : !! rhoarr(npts)=input data
6487 : : !!
6488 : : !! OUTPUT
6489 : : !! rspts(npts)=inverse cubic root of rhoarr
6490 : : !!
6491 : : !! SOURCE
6492 : :
6493 : 1284254 : subroutine invcb(rhoarr,rspts,npts)
6494 : :
6495 : : !Arguments ------------------------------------
6496 : : !scalars
6497 : : integer,intent(in) :: npts
6498 : : !arrays
6499 : : real(dp),intent(in) :: rhoarr(npts)
6500 : : real(dp),intent(out) :: rspts(npts)
6501 : :
6502 : : !Local variables-------------------------------
6503 : : !scalars
6504 : : integer :: ii,ipts
6505 : : real(dp),parameter :: c2_27=2.0e0_dp/27.0e0_dp,c5_9=5.0e0_dp/9.0e0_dp
6506 : : real(dp),parameter :: c8_9=8.0e0_dp/9.0e0_dp,m1thrd=-third
6507 : : real(dp) :: del,prod,rho,rhom1,rhomtrd
6508 : : logical :: test
6509 : : !character(len=500) :: message
6510 : : ! *************************************************************************
6511 : :
6512 : : !Loop over points : here, brute force algorithm
6513 : : !do ipts=1,npts
6514 : : !rspts(ipts)=sign( (abs(rhoarr(ipts)))**m1thrd,rhoarr(ipts))
6515 : : !end do
6516 : :
6517 : 1284254 : rhomtrd=sign( (abs(rhoarr(1)))**m1thrd, rhoarr(1) )
6518 : 1284254 : rhom1=one/rhoarr(1)
6519 : 1284254 : rspts(1)=rhomtrd
6520 [ + + ]: 2294010153 : do ipts=2,npts
6521 : 2292725899 : rho=rhoarr(ipts)
6522 : 2292725899 : prod=rho*rhom1
6523 : : ! If the previous point is too far ...
6524 [ + + + + ]: 2292725899 : if(prod < 0.01_dp .or. prod > 10._dp )then
6525 : 9296719 : rhomtrd=sign( (abs(rho))**m1thrd , rho )
6526 : 9296719 : rhom1=one/rho
6527 : : else
6528 : 2283429180 : del=prod-one
6529 [ + - ]: 3821396454 : do ii=1,5
6530 : : ! Choose one of the two next lines, the last one is more accurate
6531 : : ! rhomtrd=((one+third*del)/(one+two_thirds*del))*rhomtrd
6532 : 3821396454 : rhomtrd=((one+c5_9*del)/(one+del*(c8_9+c2_27*del)))*rhomtrd
6533 : 3821396454 : rhom1=rhomtrd*rhomtrd*rhomtrd
6534 : 3821396454 : del=rho*rhom1-one
6535 : : ! write(std_out,*)rhomtrd,del
6536 : 3821396454 : test = del*del < 1.0e-24_dp
6537 [ + + ]: 3821396454 : if(test) exit
6538 : : end do
6539 [ - + ]: 2283429180 : if( .not. test) then
6540 : 0 : rhomtrd=sign( (abs(rho))**m1thrd , rho )
6541 : : end if
6542 : : end if
6543 : 2294010153 : rspts(ipts)=rhomtrd
6544 : : end do
6545 : :
6546 : 1284254 : end subroutine invcb
6547 : : !!***
6548 : :
6549 : : !!****f* ABINIT/safe_div
6550 : : !! NAME
6551 : : !! safe_div
6552 : : !!
6553 : : !! FUNCTION
6554 : : !! Subroutine safe_div performs "safe division", that is to prevent overflow,
6555 : : !! underflow, NaN, or infinity errors. An alternate value is returned if the
6556 : : !! division cannot be performed. (bmy, 2/26/08)
6557 : : !!
6558 : : !! For more information, see the discussion on:
6559 : : !! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/8b367f44c419fa1d/
6560 : : !!
6561 : : !! Taken by HM from:
6562 : : !! http://wiki.seas.harvard.edu/geos-chem/index.php/Floating_point_math_issues#Safe_floating-point_division
6563 : : !!
6564 : : !! INPUTS
6565 : : !! n : Numerator for the division
6566 : : !! d : Divisor for the division
6567 : : !! altv : Alternate value to be returned if the division can't be done
6568 : : !!
6569 : : !! OUTPUT
6570 : : !!
6571 : : !! SOURCE
6572 : :
6573 : 896914 : elemental subroutine safe_div(n, d, altv, q)
6574 : :
6575 : : !Arguments ----------------------------------------------
6576 : : !scalars
6577 : : real(dp),intent(in) :: n, d, altv
6578 : : real(dp),intent(out) :: q
6579 : : ! *********************************************************************
6580 : :
6581 [ + - + - : 896914 : if ( exponent(n) - exponent(d) >= maxexponent(n) .or. d == zero) then
+ - + + ]
6582 : 659320 : q = altv
6583 : : else
6584 : 237594 : q = n / d
6585 : : endif
6586 : :
6587 : 896914 : end subroutine safe_div
6588 : : !!***
6589 : :
6590 : : !!****f* ABINIT/bool2index
6591 : : !! NAME
6592 : : !! bool2index
6593 : : !!
6594 : : !! FUNCTION
6595 : : !! Allocate and return array with the indices in the input boolean array `bool_list` that evaluates to .True.
6596 : : !!
6597 : : !! SOURCE
6598 : :
6599 [ # # ]: 0 : subroutine bool2index(bool_list, out_index)
6600 : :
6601 : : !Arguments ----------------------------------------------
6602 : : !scalars
6603 : : logical,intent(in) :: bool_list(:)
6604 : : integer,allocatable,intent(inout) :: out_index(:)
6605 : :
6606 : : !Local variables-------------------------------
6607 : : integer :: ii, cnt
6608 : : ! *********************************************************************
6609 : :
6610 [ # # # # ]: 0 : cnt = count(bool_list)
6611 [ # # # # : 0 : ABI_REMALLOC(out_index, (cnt))
# # # # #
# # # # #
# # ]
6612 : 0 : cnt = 0
6613 [ # # ]: 0 : do ii=1,size(bool_list)
6614 [ # # ]: 0 : if (bool_list(ii)) then
6615 : 0 : cnt = cnt + 1
6616 : 0 : out_index(cnt) = ii
6617 : : end if
6618 : : end do
6619 : :
6620 : 0 : end subroutine bool2index
6621 : : !!***
6622 : :
6623 : : !----------------------------------------------------------------------
6624 : : !!****f* ABINIT/polynomial_regression
6625 : : !! NAME
6626 : : !! polynomial_regression
6627 : : !!
6628 : : !! FUNCTION
6629 : : !! Perform a polynomial regression on incoming data points, the
6630 : : !! x-values of which are stored in array xvals and the y-values
6631 : : !! stored in array yvals. Returns a one dimensional array with
6632 : : !! fit coefficients (coeffs) and the unbiased RMS error of the
6633 : : !! fit as a scalar (RMSerr).
6634 : : !!
6635 : : !! INPUTS
6636 : : !! degree = order of the polynomial
6637 : : !! npts = number of data points
6638 : : !! xvals(npts) = x-values of those data points
6639 : : !! yvals(npts) = y-values of those data points
6640 : : !!
6641 : : !! OUTPUT
6642 : : !! coeffs(degree+1) = coefficients of the polynomial regression
6643 : : !! RMSerr = unbiased RMS error on the fit
6644 : : !! RMSerr=\sqrt{\frac{1}{npts-1}*
6645 : : !! \sum_i^npts{(fitval-yvals(i))**2}}
6646 : : !!
6647 : : !! SOURCE
6648 : : !!
6649 : :
6650 : 12 : subroutine polynomial_regression(degree,npts,xvals,yvals,coeffs,RMSerr)
6651 : :
6652 : : !Arguments ------------------------------------
6653 : : !scalars
6654 : : integer :: degree,npts
6655 : : real(dp),intent(out) :: RMSerr
6656 : : !arrays
6657 : : real(dp),intent(in) :: xvals(1:npts),yvals(1:npts)
6658 : : real(dp),intent(out) :: coeffs(degree+1)
6659 : :
6660 : : !Local variables-------------------------------
6661 : : !scalars
6662 : : integer :: ncoeffs,icoeff,ipoint,info
6663 : : real(dp) :: residual,fitval
6664 : : !arrays
6665 : 12 : integer,allocatable :: tmp(:)
6666 : 12 : real(dp),allocatable :: tmptwo(:), A(:,:),ATA(:,:)
6667 : :
6668 : : !####################################################################
6669 : : !##################### Get Polynomial Fit #########################
6670 : :
6671 : 12 : ncoeffs=degree+1
6672 : :
6673 [ - + + - : 36 : ABI_MALLOC(tmp,(ncoeffs))
+ - + - -
+ - + ]
6674 [ - + + - : 36 : ABI_MALLOC(tmptwo,(ncoeffs))
+ - + - -
+ - + ]
6675 [ - + + - : 48 : ABI_MALLOC(A,(npts,ncoeffs))
- + + - +
- + - - +
- + ]
6676 [ - + + - : 48 : ABI_MALLOC(ATA,(ncoeffs,ncoeffs))
- + + - +
- + - - +
- + ]
6677 : :
6678 : : !Construct a polynomial for all input xvalues
6679 [ + + ]: 48 : do icoeff=1,ncoeffs
6680 [ + + ]: 246 : do ipoint=1,npts
6681 [ + + + + ]: 234 : if (icoeff==1.and.xvals(ipoint)==0.0) then
6682 : 12 : A(ipoint,icoeff) = 1.0
6683 : : else
6684 : 186 : A(ipoint,icoeff) = xvals(ipoint)**(icoeff-1)
6685 : : end if
6686 : : end do
6687 : : end do
6688 : :
6689 : : !Get matrix product of transpose of A and A
6690 [ + - - + : 954 : ATA = matmul(transpose(A),A)
- - - - -
- - - - -
- - - - -
- - - + +
+ + + + +
+ + + ]
6691 : :
6692 : : !Compute LU factorization of ATA
6693 : 12 : call DGETRF(ncoeffs,ncoeffs,ATA,ncoeffs,tmp,info)
6694 [ - + ]: 12 : ABI_CHECK(info == 0, sjoin('LAPACK DGETRF in polynomial regression returned:', itoa(info)))
6695 : :
6696 : : !Compute inverse of the LU factorized version of ATA
6697 : 12 : call DGETRI(ncoeffs,ATA,ncoeffs,tmp,tmptwo,ncoeffs,info)
6698 [ - + ]: 12 : ABI_CHECK(info == 0, sjoin('LAPACK DGETRI in polynomial regression returned:', itoa(info)))
6699 : :
6700 : : !Harvest polynomial coefficients
6701 [ - + + - : 2164 : coeffs = matmul(matmul(ATA,transpose(A)),yvals)
- + + - +
- + - - +
- + + + +
+ + + + +
+ + + - +
- + + + +
+ + + - ]
6702 : :
6703 : : !####################################################################
6704 : : !############## RMS error on the polynomial fit ###################
6705 : :
6706 : 12 : residual=0.0d0
6707 [ + + ]: 78 : do ipoint=1,npts
6708 : 66 : fitval=0.0d0
6709 [ + + ]: 264 : do icoeff=1,ncoeffs
6710 [ + + + + ]: 264 : if (icoeff==1.and.xvals(ipoint)==0.0) then
6711 : 12 : fitval=fitval+coeffs(icoeff)
6712 : : else
6713 : 186 : fitval=fitval+coeffs(icoeff)*xvals(ipoint)**(icoeff-1)
6714 : : end if
6715 : : end do
6716 : 78 : residual=residual+(fitval-yvals(ipoint))**2
6717 : : end do
6718 : 12 : RMSerr=sqrt(residual/(real(npts-1,8)))
6719 : :
6720 [ - + ]: 12 : ABI_FREE(A)
6721 [ - + ]: 12 : ABI_FREE(ATA)
6722 [ - + ]: 12 : ABI_FREE(tmp)
6723 [ - + ]: 12 : ABI_FREE(tmptwo)
6724 : :
6725 : 12 : end subroutine polynomial_regression
6726 : : !!***
6727 : :
6728 : : !!****f* ABINIT/blocked_loop
6729 : : !! NAME
6730 : : !! blocked_loop
6731 : : !!
6732 : : !! FUNCTION
6733 : : !! Helper function to implement blocked algorithms inside do loops i.e. algorithms
6734 : : !! operating on multiple items up to a maximum `batch_size`.
6735 : : !!
6736 : : !! Usage:
6737 : : !!
6738 : : !! batch_size = 4
6739 : : !! allocate(work(..., batch_size)
6740 : : !!
6741 : : !! do loop_index=1, loop_stop, batch_size
6742 : : !! ndat = blocked_loop(loop_index, loop_stop, batch_size)
6743 : : !! ! operate on ndat items in work
6744 : : !! end do
6745 : : !!
6746 : : !! SOURCE
6747 : :
6748 : 0 : integer pure function blocked_loop(loop_index, loop_stop, batch_size) result(ndat)
6749 : :
6750 : : !Arguments ----------------------------------------------
6751 : : integer,intent(in) :: loop_index, loop_stop, batch_size
6752 : : ! *********************************************************************
6753 : :
6754 [ # # ]: 0 : ndat = merge(batch_size, loop_stop - loop_index + 1, loop_index + batch_size - 1 <= loop_stop)
6755 : :
6756 : 0 : end function blocked_loop
6757 : : !!***
6758 : :
6759 : : !!****f* m_euler/geteuler
6760 : : !! NAME
6761 : : !! geteuler
6762 : : !!
6763 : : !! FUNCTION
6764 : : !! Compute the Euler angles (alpha, beta) corresponding to the spin quantization axis given in Cartesian coordinates.
6765 : : !!
6766 : : !! INPUTS
6767 : : !! spinaxis(3)=spin quantization axis
6768 : : !!
6769 : : !! OUTPUT
6770 : : !! alpha=Euler angle for rotation around z-axis
6771 : : !! beta =Euler angle for rotation around y-axis
6772 : : !!
6773 : : !! SOURCE
6774 : :
6775 : 2426960 : subroutine geteuler(spinaxis, alpha, beta)
6776 : :
6777 : : !Arguments -------------------------------
6778 : : !scalars
6779 : : real(dp),intent(out) :: alpha, beta
6780 : : !arrays
6781 : : real(dp),intent(in) :: spinaxis(3)
6782 : :
6783 : : !Local variables -------------------------
6784 : : !scalars
6785 : : real(dp) :: sx, sy, sz, norm, rxy
6786 : : !***********************************************************************
6787 : :
6788 : 2426960 : alpha = zero; beta = zero
6789 [ + + ]: 9707840 : norm = DOT_PRODUCT(spinaxis, spinaxis)
6790 : :
6791 [ + + ]: 2426960 : if (norm <= tol8*tol8) return
6792 : :
6793 : 1321836 : sx = spinaxis(1); sy = spinaxis(2); sz = spinaxis(3)
6794 : 1321836 : rxy = sqrt(sx*sx + sy*sy)
6795 [ + + ]: 1321836 : if (rxy > tol8) alpha = atan2(sy, sx)
6796 : 1321836 : beta = atan2(rxy, sz)
6797 : :
6798 : : end subroutine geteuler
6799 : : !!***
6800 : :
6801 : : !====================================================================
6802 : : ! bin_t: average x-value inside the bin
6803 : : !====================================================================
6804 : : !function bin_average(self, xvals) result(avg)
6805 : : ! class(bin_t), intent(in) :: self
6806 : : ! real(dp), intent(in) :: xvals(:)
6807 : : ! real(dp) :: avg
6808 : : ! integer :: i
6809 : : !
6810 : : ! if (self%npts == 0) then
6811 : : ! avg = 0.0_dp
6812 : : ! return
6813 : : ! end if
6814 : : !
6815 : : ! avg = 0.0_dp
6816 : : ! do i = 1, self%npts
6817 : : ! avg = avg + xvals(self%idx(i))
6818 : : ! end do
6819 : : ! avg = avg / real(self%npts, dp)
6820 : : !end function bin_average
6821 : :
6822 : : !====================================================================
6823 : : ! bins_t initialisation: only non-empty bins are stored
6824 : : !====================================================================
6825 : 0 : subroutine bins_init(self, nn, xvals, dx)
6826 : : class(bins_t), intent(out) :: self
6827 : : integer,intent(in) :: nn
6828 : : real(dp), target, intent(in) :: xvals(nn)
6829 : : real(dp), intent(in) :: dx
6830 : :
6831 : : integer :: i, k, b, idx_bin
6832 : : real(dp) :: xmin, xmax, length
6833 [ # # ]: 0 : integer, allocatable :: count_(:), map(:)
6834 : :
6835 : 0 : self%xvals => xvals
6836 : 0 : self%dx = dx
6837 : 0 : self%total_points = nn
6838 : :
6839 [ # # # # : 0 : xmin = minval(xvals)
# # # # ]
6840 [ # # # # : 0 : xmax = maxval(xvals)
# # # # ]
6841 : 0 : self%xmin = xmin
6842 : 0 : self%xmax = xmax
6843 : :
6844 : 0 : length = xmax - xmin
6845 : :
6846 : : ! Number of uniform bins
6847 [ # # ]: 0 : k = int(floor(length/dx)) + 1
6848 [ # # # # : 0 : ABI_MALLOC(count_, (k))
# # # # #
# # # ]
6849 [ # # ]: 0 : count_ = 0
6850 : :
6851 : : ! First pass: count
6852 [ # # ]: 0 : do i = 1, nn
6853 : 0 : b = 1 + int( (xvals(i) - xmin) / dx )
6854 : 0 : if (b < 1) b = 1
6855 : 0 : if (b > k) b = k
6856 : 0 : count_(b) = count_(b) + 1
6857 : : end do
6858 : :
6859 : : ! Map from full bin list to non-empty bins
6860 [ # # # # : 0 : ABI_MALLOC(map, (k))
# # # # ]
6861 [ # # ]: 0 : map = 0
6862 [ # # # # ]: 0 : self%nbins = count(count_ > 0)
6863 [ # # # # : 0 : ABI_MALLOC(self%bin, (self%nbins))
# # # # #
# # # # #
# # ]
6864 : :
6865 : : ! Fill map
6866 : 0 : idx_bin = 0
6867 [ # # ]: 0 : do b = 1, k
6868 [ # # ]: 0 : if (count_(b) > 0) then
6869 : 0 : idx_bin = idx_bin + 1
6870 : 0 : map(b) = idx_bin
6871 [ # # # # : 0 : ABI_MALLOC(self%bin(idx_bin)%idx, (count_(b)))
# # # # #
# # # ]
6872 : 0 : self%bin(idx_bin)%npts = count_(b)
6873 : 0 : self%bin(idx_bin)%xmin = xmin + (b-1)*dx
6874 : 0 : self%bin(idx_bin)%xmax = xmin + b *dx
6875 : : end if
6876 : : end do
6877 : :
6878 : : ! Temporary counters
6879 [ # # ]: 0 : count_ = 0
6880 : :
6881 : : ! Second pass: put indices into non-empty bins
6882 [ # # ]: 0 : do i = 1, nn
6883 : 0 : b = 1 + int( (xvals(i) - xmin)/dx )
6884 : 0 : if (b < 1) b = 1
6885 : 0 : if (b > k) b = k
6886 [ # # ]: 0 : if (map(b) > 0) then
6887 : 0 : idx_bin = map(b)
6888 : 0 : count_(b) = count_(b) + 1
6889 : 0 : self%bin(idx_bin)%idx(count_(b)) = i
6890 : : end if
6891 : : end do
6892 : :
6893 : : ! Simple loop interface
6894 : : !do i = 1, self%nbins
6895 : : ! write(*,*) "Bin", i, ": npts=", self%bin(i)%npts
6896 : : !end do
6897 : :
6898 [ # # # # ]: 0 : end subroutine bins_init
6899 : :
6900 : : !!****t* m_numeric_tools/bins_free
6901 : : !! NAME
6902 : : !! bins_free
6903 : : !!
6904 : : !! FUNCTION
6905 : : !!
6906 : : !! SOURCE
6907 : :
6908 : : subroutine bins_free(bins)
6909 : :
6910 : : class(bins_t),intent(inout) :: bins
6911 : : !!************************************************************************
6912 : : integer :: ii
6913 : : do ii = 1, bins%nbins
6914 : : ABI_SFREE(bins%bin(ii)%idx)
6915 : : end do
6916 : : ABI_SFREE(bins%bin)
6917 : : !
6918 : : end subroutine bins_free
6919 : : !!***
6920 : :
6921 : : !!****f* ABINIT/euclid_div
6922 : : !! NAME
6923 : : !! euclid_div
6924 : : !!
6925 : : !! FUNCTION
6926 : : !! Compute the Euclidian integer division aa / bb
6927 : : !! such that the remainder of the division is positive.
6928 : : !! For example,
6929 : : !! euclid_div(-3, 6) = -1.
6930 : : !!
6931 : : !! Equivalent to float arithmetic operation:
6932 : : !! qq = floor(real(aa) / real(bb))
6933 : : !!
6934 : : !! INPUTS
6935 : : !! aa, bb
6936 : : !!
6937 : : !! OUTPUT
6938 : : !! qq = a // b
6939 : : !!
6940 : : !! SOURCE
6941 : :
6942 : 47 : function euclid_div(aa, bb) result(qq)
6943 : : integer, intent(in) :: aa, bb
6944 : : integer :: qq
6945 : : integer :: rr
6946 : :
6947 : 47 : qq = aa / bb
6948 : 47 : rr = mod(aa,bb)
6949 : :
6950 [ + + ]: 47 : if (rr < 0) then
6951 [ + - ]: 33 : if (bb > 0) then
6952 : 33 : qq = qq - 1
6953 : 33 : rr = rr + bb
6954 : : else
6955 : 0 : qq = qq + 1
6956 : 0 : rr = rr - bb
6957 : : end if
6958 : : end if
6959 : :
6960 : 47 : end function euclid_div
6961 : : !!***
6962 : :
6963 [ + - # # : 12 : end module m_numeric_tools
# # # # #
# # # # #
# # # # ]
6964 : : !!***
|
