SPEED
Functions/Subroutines
R8LIB.f90 File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine gamma_values (n_data, x, fx)
 
subroutine gamma_log_values (n_data, x, fx)
 
subroutine get_unit (iunit)
 
integer(kind=4) function i4_log_10 (i)
 
integer(kind=4) function i4_modp (i, j)
 
integer(kind=4) function i4_uniform_ab (a, b, seed)
 
integer(kind=4) function i4_wrap (ival, ilo, ihi)
 
subroutine i4int_to_r8int (imin, imax, i, rmin, rmax, r)
 
subroutine i4vec_indicator0 (n, a)
 
subroutine i4vec_indicator1 (n, a)
 
subroutine i4vec_permute (n, p, a)
 
subroutine i4vec_print (n, a, title)
 
subroutine legendre_zeros (n, x)
 
subroutine perm_check0 (n, p)
 
subroutine perm_check1 (n, p)
 
subroutine perm_uniform (n, seed, p)
 
real(kind=8) function r8_abs (x)
 
real(kind=8) function r8_acos (c)
 
real(kind=8) function r8_acosh (x)
 
real(kind=8) function r8_add (x, y)
 
real(kind=8) function r8_agm (a, b)
 
real(kind=8) function r8_aint (x)
 
real(kind=8) function r8_asin (s)
 
real(kind=8) function r8_atan (y, x)
 
real(kind=8) function r8_big ()
 
real(kind=8) function r8_cas (x)
 
real(kind=8) function r8_ceiling (r)
 
real(kind=8) function r8_choose (n, k)
 
real(kind=8) function r8_chop (place, x)
 
real(kind=8) function r8_cosd (degrees)
 
real(kind=8) function r8_cotd (degrees)
 
real(kind=8) function r8_cscd (degrees)
 
real(kind=8) function r8_csc (theta)
 
complex(kind=8) function r8_csqrt (x)
 
real(kind=8) function r8_cube_root (x)
 
real(kind=8) function r8_degrees (radians)
 
real(kind=8) function r8_diff (x, y, n)
 
subroutine r8_digit (x, idigit, digit)
 
real(kind=8) function r8_divide_i4 (i, j)
 
real(kind=8) function r8_epsilon ()
 
real(kind=8) function r8_epsilon_compute ()
 
real(kind=8) function r8_exp (x)
 
real(kind=8) function r8_factorial (n)
 
real(kind=8) function r8_factorial2 (n)
 
real(kind=8) function r8_fall (x, n)
 
real(kind=8) function r8_floor (r)
 
real(kind=8) function r8_fraction (i, j)
 
real(kind=8) function r8_fractional (x)
 
real(kind=8) function r8_gamma (x)
 
real(kind=8) function r8_gamma_log (x)
 
real(kind=8) function r8_huge ()
 
real(kind=8) function r8_hypot (x, y)
 
logical(kind=4) function r8_in_01 (a)
 
logical(kind=4) function r8_insignificant (r, s)
 
logical(kind=4) function r8_is_int (r)
 
real(kind=8) function r8_log_2 (x)
 
real(kind=8) function r8_log_10 (x)
 
real(kind=8) function r8_log_b (x, b)
 
subroutine r8_mant (x, s, r, l)
 
real(kind=8) function r8_max (x, y)
 
real(kind=8) function r8_min (x, y)
 
real(kind=8) function r8_mod (x, y)
 
real(kind=8) function r8_modp (x, y)
 
real(kind=8) function r8_mop (i)
 
integer(kind=4) function r8_nint (x)
 
real(kind=8) function r8_normal_01 (seed)
 
real(kind=8) function r8_normal_ab (a, b, seed)
 
real(kind=8) function r8_pi ()
 
real(kind=8) function r8_pi_sqrt ()
 
real(kind=8) function r8_power (r, p)
 
subroutine r8_power_fast (r, p, rp, mults)
 
subroutine r8_print (r, title)
 
real(kind=8) function r8_pythag (a, b)
 
real(kind=8) function r8_radians (degrees)
 
real(kind=8) function r8_rise (x, n)
 
real(kind=8) function r8_round (x)
 
integer(kind=4) function r8_round_i4 (x)
 
subroutine r8_round2 (nplace, x, xround)
 
subroutine r8_roundb (base, nplace, x, xround)
 
subroutine r8_roundx (nplace, x, xround)
 
real(kind=8) function r8_secd (degrees)
 
real(kind=8) function r8_sech (x)
 
real(kind=8) function r8_sign (x)
 
real(kind=8) function r8_sign3 (x)
 
character function r8_sign_char (x)
 
logical(kind=4) function r8_sign_match (r1, r2)
 
logical(kind=4) function r8_sign_match_strict (r1, r2)
 
logical(kind=4) function r8_sign_opposite (r1, r2)
 
logical(kind=4) function r8_sign_opposite_strict (r1, r2)
 
real(kind=8) function r8_sind (degrees)
 
real(kind=8) function r8_sqrt_i4 (i)
 
subroutine r8_swap (x, y)
 
subroutine r8_swap3 (x, y, z)
 
real(kind=8) function r8_tand (degrees)
 
real(kind=8) function r8_tiny ()
 
subroutine r8_to_r8_discrete (r, rmin, rmax, nr, rd)
 
subroutine r8_to_dhms (r, d, h, m, s)
 
subroutine r8_to_i4 (xmin, xmax, x, ixmin, ixmax, ix)
 
real(kind=8) function r8_uniform_01 (seed)
 
real(kind=8) function r8_uniform_ab (a, b, seed)
 
subroutine r8_unswap3 (x, y, z)
 
real(kind=8) function r8_walsh_1d (x, digit)
 
real(kind=8) function r8_wrap (r, rlo, rhi)
 
subroutine r82_cheby (n, alo, ahi, a)
 
real(kind=8) function r82_dist_l2 (a1, a2)
 
logical(kind=4) function r82_eq (a1, a2)
 
logical(kind=4) function r82_ge (a1, a2)
 
logical(kind=4) function r82_gt (a1, a2)
 
logical(kind=4) function r82_le (a1, a2)
 
logical(kind=4) function r82_lt (a1, a2)
 
logical(kind=4) function r82_ne (a1, a2)
 
real(kind=8) function r82_norm (a)
 
subroutine r82_normalize (a)
 
subroutine r82_print (a, title)
 
subroutine r82_swap (x, y)
 
subroutine r82_uniform_ab (b, c, seed, a)
 
subroutine r82poly2_print (a, b, c, d, e, f)
 
subroutine r82poly2_type (a, b, c, d, e, f, type)
 
subroutine r82poly2_type_print (type)
 
subroutine r82vec_max (n, a, amax)
 
subroutine r82vec_min (n, a, amin)
 
subroutine r82vec_order_type (n, a, order)
 
subroutine r82vec_part_quick_a (n, a, l, r)
 
subroutine r82vec_permute (n, p, a)
 
subroutine r82vec_print (n, a, title)
 
subroutine r82vec_print_part (n, a, max_print, title)
 
subroutine r82vec_sort_heap_index_a (n, a, indx)
 
subroutine r82vec_sort_quick_a (n, a)
 
real(kind=8) function r83_norm (x, y, z)
 
subroutine r83_normalize (x, y, z)
 
subroutine r83_print (x, y, z, title)
 
subroutine r83_swap (x, y)
 
subroutine r83vec_max (n, a, amax)
 
subroutine r83vec_min (n, a, amin)
 
subroutine r83vec_normalize (n, x)
 
subroutine r83vec_print_part (n, a, max_print, title)
 
subroutine r84_normalize (v)
 
subroutine r8block_expand_linear (l, m, n, x, lfat, mfat, nfat, xfat)
 
subroutine r8block_print (l, m, n, a, title)
 
subroutine r8cmat_print (lda, m, n, a, title)
 
subroutine r8cmat_print_some (lda, m, n, a, ilo, jlo, ihi, jhi, title)
 
subroutine r8cmat_to_r8mat (lda, m, n, a1, a2)
 
subroutine r8col_compare (m, n, a, i, j, value)
 
subroutine r8col_duplicates (m, n, n_unique, seed, a)
 
subroutine r8col_find (m, n, a, x, col)
 
subroutine r8col_first_index (m, n, a, tol, first_index)
 
subroutine r8col_insert (n_max, m, n, a, x, col)
 
subroutine r8col_max (m, n, a, amax)
 
subroutine r8col_max_index (m, n, a, imax)
 
subroutine r8col_max_one (m, n, a)
 
subroutine r8col_mean (m, n, a, mean)
 
subroutine r8col_min (m, n, a, amin)
 
subroutine r8col_min_index (m, n, a, imin)
 
subroutine r8col_normalize_li (m, n, a)
 
subroutine r8col_part_quick_a (m, n, a, l, r)
 
subroutine r8col_permute (m, n, p, a)
 
subroutine r8col_reverse (m, n, a)
 
subroutine r8col_separation (m, n, a, d_min, d_max)
 
subroutine r8col_sort_heap_a (m, n, a)
 
subroutine r8col_sort_heap_index_a (m, n, a, indx)
 
subroutine r8col_sort_quick_a (m, n, a)
 
subroutine r8col_sorted_tol_undex (m, n, a, unique_num, tol, undx, xdnu)
 
subroutine r8col_sorted_tol_unique (m, n, a, tol, unique_num)
 
subroutine r8col_sorted_tol_unique_count (m, n, a, tol, unique_num)
 
subroutine r8col_sorted_undex (m, n, a, unique_num, undx, xdnu)
 
subroutine r8col_sorted_unique (m, n, a, unique_num)
 
subroutine r8col_sorted_unique_count (m, n, a, unique_num)
 
subroutine r8col_sortr_a (m, n, a, key)
 
subroutine r8col_sum (m, n, a, colsum)
 
subroutine r8col_swap (m, n, a, j1, j2)
 
subroutine r8col_to_r8vec (m, n, a, x)
 
subroutine r8col_tol_undex (m, n, a, unique_num, tol, undx, xdnu)
 
subroutine r8col_tol_unique_count (m, n, a, tol, unique_num)
 
subroutine r8col_tol_unique_index (m, n, a, tol, unique_index)
 
subroutine r8col_undex (m, n, a, unique_num, undx, xdnu)
 
subroutine r8col_uniform_abvec (m, n, a, b, seed, r)
 
subroutine r8col_unique_count (m, n, a, unique_num)
 
subroutine r8col_unique_index (m, n, a, unique_index)
 
subroutine r8col_variance (m, n, a, variance)
 
subroutine r8int_to_r8int (rmin, rmax, r, r2min, r2max, r2)
 
subroutine r8int_to_i4int (rmin, rmax, r, imin, imax, i)
 
subroutine r8mat_add (m, n, alpha, a, beta, b, c)
 
real(kind=8) function r8mat_amax (m, n, a)
 
subroutine r8mat_border_add (m, n, table, table2)
 
subroutine r8mat_border_cut (m, n, table, table2)
 
subroutine r8mat_cholesky_factor (n, a, c, flag)
 
subroutine r8mat_cholesky_factor_upper (n, a, c, flag)
 
subroutine r8mat_cholesky_inverse (n, a)
 
subroutine r8mat_cholesky_solve (n, l, b, x)
 
subroutine r8mat_cholesky_solve_upper (n, r, b, x)
 
subroutine r8mat_copy (m, n, a, b)
 
subroutine r8mat_covariance (m, n, x, c)
 
subroutine r8mat_det (n, a, det)
 
real(kind=8) function r8mat_det_2d (a)
 
real(kind=8) function r8mat_det_3d (a)
 
real(kind=8) function r8mat_det_4d (a)
 
real(kind=8) function r8mat_det_5d (a)
 
subroutine r8mat_diag_add_scalar (n, a, s)
 
subroutine r8mat_diag_add_vector (n, a, v)
 
subroutine r8mat_diag_get_vector (n, a, v)
 
subroutine r8mat_diag_set_scalar (n, a, s)
 
subroutine r8mat_diag_set_vector (n, a, v)
 
subroutine r8mat_diagonal (n, diag, a)
 
real(kind=8) function r8mat_diff_frobenius (m, n, a1, a2)
 
subroutine r8mat_expand_linear (m, n, x, mfat, nfat, xfat)
 
subroutine r8mat_expand_linear2 (m, n, a, m2, n2, a2)
 
subroutine r8mat_flip_cols (m, n, a, b)
 
subroutine r8mat_flip_rows (m, n, a, b)
 
subroutine r8mat_fs (n, a, b, info)
 
subroutine r8mat_fss (n, a, nb, b, info)
 
subroutine r8mat_givens_post (n, a, row, col, g)
 
subroutine r8mat_givens_pre (n, a, row, col, g)
 
subroutine r8mat_hess (fx, n, x, h)
 
subroutine r8mat_house_axh (n, a, v, ah)
 
subroutine r8mat_house_form (n, v, h)
 
subroutine r8mat_house_hxa (n, a, v, ha)
 
subroutine r8mat_house_post (n, a, row, col, h)
 
subroutine r8mat_house_pre (n, a, row, col, h)
 
subroutine r8mat_identity (n, a)
 
logical(kind=4) function r8mat_in_01 (m, n, a)
 
subroutine r8mat_indicator (m, n, table)
 
logical(kind=4) function r8mat_insignificant (m, n, r, s)
 
subroutine r8mat_inverse_2d (a, b, det)
 
subroutine r8mat_inverse_3d (a, b, det)
 
subroutine r8mat_inverse_4d (a, b, det)
 
subroutine r8mat_is_identity (n, a, error_frobenius)
 
subroutine r8mat_is_nonnegative (m, n, a, ival)
 
subroutine r8mat_is_symmetric (m, n, a, error_frobenius)
 
subroutine r8mat_jac (m, n, eps, fx, x, fprime)
 
subroutine r8mat_kronecker (m1, n1, a, m2, n2, b, c)
 
subroutine r8mat_l_inverse (n, a, b)
 
subroutine r8mat_l_print (m, n, a, title)
 
subroutine r8mat_l_solve (n, a, b, x)
 
subroutine r8mat_l1_inverse (n, a, b)
 
subroutine r8mat_lt_solve (n, a, b, x)
 
subroutine r8mat_lu (m, n, a, l, p, u)
 
real(kind=8) function r8mat_max (m, n, a)
 
subroutine r8mat_max_index (m, n, a, i, j)
 
real(kind=8) function r8mat_maxcol_minrow (m, n, a)
 
real(kind=8) function r8mat_maxrow_mincol (m, n, a)
 
real(kind=8) function r8mat_mean (m, n, a)
 
real(kind=8) function r8mat_min (m, n, a)
 
subroutine r8mat_min_index (m, n, a, i, j)
 
real(kind=8) function r8mat_mincol_maxrow (m, n, a)
 
real(kind=8) function r8mat_minrow_maxcol (m, n, a)
 
subroutine r8mat_minvm (n1, n2, a, b, c)
 
subroutine r8mat_mm (n1, n2, n3, a, b, c)
 
subroutine r8mat_mmt (n1, n2, n3, a, b, c)
 
subroutine r8mat_mtm (n1, n2, n3, a, b, c)
 
subroutine r8mat_mtv (m, n, a, x, y)
 
subroutine r8mat_mv (m, n, a, x, y)
 
subroutine r8mat_nint (m, n, a)
 
integer(kind=4) function r8mat_nonzeros (m, n, a)
 
real(kind=8) function r8mat_norm_eis (m, n, a)
 
real(kind=8) function r8mat_norm_fro (m, n, a)
 
real(kind=8) function r8mat_norm_fro_affine (m, n, a1, a2)
 
real(kind=8) function r8mat_norm_l1 (m, n, a)
 
real(kind=8) function r8mat_norm_l2 (m, n, a)
 
real(kind=8) function r8mat_norm_li (m, n, a)
 
subroutine r8mat_normal_01 (m, n, seed, r)
 
subroutine r8mat_nullspace (m, n, a, nullspace_size, nullspace)
 
subroutine r8mat_nullspace_size (m, n, a, nullspace_size)
 
subroutine r8mat_orth_uniform (n, seed, a)
 
subroutine r8mat_plot (m, n, a, title)
 
character function r8mat_plot_symbol (r)
 
subroutine r8mat_poly_char (n, a, p)
 
subroutine r8mat_power (n, a, npow, b)
 
subroutine r8mat_power_method (n, a, r, v)
 
subroutine r8mat_print (m, n, a, title)
 
subroutine r8mat_print_some (m, n, a, ilo, jlo, ihi, jhi, title)
 
subroutine r8mat_print2 (m, n, a)
 
subroutine r8mat_ref (m, n, a)
 
real(kind=8) function r8mat_rms (m, n, a)
 
subroutine r8mat_row_copy (m, n, i, v, a)
 
subroutine r8mat_row_set (i, r, m, n, a)
 
subroutine r8mat_rref (m, n, a)
 
subroutine r8mat_scale (m, n, s, a)
 
subroutine r8mat_solve (n, rhs_num, a, info)
 
subroutine r8mat_solve_2d (a, b, det, x)
 
subroutine r8mat_solve_3d (a, b, det, x)
 
subroutine r8mat_solve2 (n, a, b, x, ierror)
 
subroutine r8mat_sub (m, n, a, b, c)
 
real(kind=8) function r8mat_sum (m, n, a)
 
subroutine r8mat_symm_eigen (n, x, q, a)
 
subroutine r8mat_symm_jacobi (n, a)
 
subroutine r8mat_to_r8cmat (lda, m, n, a1, a2)
 
subroutine r8mat_to_r8plu (n, a, pivot, lu, info)
 
real(kind=8) function r8mat_trace (n, a)
 
subroutine r8mat_transpose (m, n, a, at)
 
subroutine r8mat_transpose_in_place (n, a)
 
subroutine r8mat_transpose_print (m, n, a, title)
 
subroutine r8mat_transpose_print_some (m, n, a, ilo, jlo, ihi, jhi, title)
 
subroutine r8mat_u_inverse (n, a, b)
 
subroutine r8mat_u_solve (n, a, b, x)
 
subroutine r8mat_u1_inverse (n, a, b)
 
subroutine r8mat_uniform_01 (m, n, seed, r)
 
subroutine r8mat_uniform_ab (m, n, a, b, seed, r)
 
subroutine r8mat_uniform_abvec (m, n, a, b, seed, r)
 
subroutine r8mat_ut_solve (n, a, b, x)
 
subroutine r8mat_vand2 (n, x, a)
 
real(kind=8) function r8mat_vtmv (m, n, x, a, y)
 
subroutine r8mat_zero (m, n, a)
 
subroutine r8plu_det (n, pivot, lu, det)
 
subroutine r8plu_inverse (n, pivot, lu, a_inverse)
 
subroutine r8plu_mul (n, pivot, lu, x, b)
 
subroutine r8plu_sol (n, pivot, lu, b, x)
 
subroutine r8plu_to_r8mat (n, pivot, lu, a)
 
subroutine r8poly_degree (na, a, degree)
 
subroutine r8poly_deriv (n, c, p, cp)
 
subroutine r8poly_lagrange_0 (npol, xpol, xval, wval)
 
subroutine r8poly_lagrange_1 (npol, xpol, xval, dwdx)
 
subroutine r8poly_lagrange_2 (npol, xpol, xval, dw2dx2)
 
subroutine r8poly_lagrange_coef (npol, ipol, xpol, pcof)
 
subroutine r8poly_lagrange_factor (npol, xpol, xval, wval, dwdx)
 
subroutine r8poly_lagrange_val (npol, ipol, xpol, xval, pval, dpdx)
 
subroutine r8poly_order (na, a, order)
 
subroutine r8poly_print (n, a, title)
 
subroutine r8poly_shift (scale, shift, n, poly_cof)
 
subroutine r8poly_value (m, c, n, x, p)
 
subroutine r8poly_value_2d (m, c, n, x, y, p)
 
subroutine r8poly2_ex (x1, y1, x2, y2, x3, y3, x, y, ierror)
 
subroutine r8poly2_ex2 (x1, y1, x2, y2, x3, y3, x, y, a, b, c, ierror)
 
subroutine r8poly2_root (a, b, c, r1, r2)
 
subroutine r8poly2_rroot (a, b, c, r1, r2)
 
subroutine r8poly2_val (x1, y1, x2, y2, x3, y3, x, y, yp, ypp)
 
subroutine r8poly2_val2 (dim_num, ndata, tdata, ydata, left, tval, yval)
 
subroutine r8poly3_root (a, b, c, d, r1, r2, r3)
 
subroutine r8poly4_root (a, b, c, d, e, r1, r2, r3, r4)
 
integer(kind=4) function r8r8_compare (x1, y1, x2, y2)
 
subroutine r8r8_print (a1, a2, title)
 
integer(kind=4) function r8r8r8_compare (x1, y1, z1, x2, y2, z2)
 
subroutine r8r8r8vec_index_insert_unique (n_max, n, x, y, z, indx, xval, yval, zval, ival, ierror)
 
subroutine r8r8r8vec_index_search (n, x, y, z, indx, xval, yval, zval, less, equal, more)
 
subroutine r8r8vec_index_insert_unique (n_max, n, x, y, indx, xval, yval, ival, ierror)
 
subroutine r8r8vec_index_search (n, x, y, indx, xval, yval, less, equal, more)
 
subroutine r8row_compare (m, n, a, i, j, value)
 
subroutine r8row_max (m, n, a, amax)
 
subroutine r8row_mean (m, n, a, mean)
 
subroutine r8row_min (m, n, a, amin)
 
subroutine r8row_part_quick_a (m, n, a, l, r)
 
subroutine r8row_reverse (m, n, a)
 
subroutine r8row_sort_heap_a (m, n, a)
 
subroutine r8row_sort_heap_index_a (m, n, a, indx)
 
subroutine r8row_sort_quick_a (m, n, a)
 
subroutine r8row_sorted_unique_count (m, n, a, unique_num)
 
subroutine r8row_sum (m, n, a, rowsum)
 
subroutine r8row_swap (m, n, a, i1, i2)
 
subroutine r8row_to_r8vec (m, n, a, x)
 
subroutine r8row_variance (m, n, a, variance)
 
subroutine r8slmat_print (m, n, a, title)
 
subroutine r8vec_01_to_ab (n, a, amax, amin)
 
subroutine r8vec_ab_to_01 (n, a)
 
subroutine r8vec_ab_to_cd (n, a, bmin, bmax, b)
 
logical(kind=4) function r8vec_all_nonpositive (n, a)
 
subroutine r8vec_amax (n, a, amax)
 
subroutine r8vec_amax_index (n, a, amax_index)
 
subroutine r8vec_amin (n, a, amin)
 
subroutine r8vec_amin_index (n, a, amin_index)
 
logical(kind=4) function r8vec_any_negative (n, a)
 
logical(kind=4) function r8vec_any_nonzero (n, a)
 
subroutine r8vec_any_normal (dim_num, v1, v2)
 
logical(kind=4) function r8vec_ascends (n, x)
 
logical(kind=4) function r8vec_ascends_strictly (n, x)
 
subroutine r8vec_bin (n, x, bin_num, bin_min, bin_max, bin, bin_limit)
 
subroutine r8vec_blend (n, t1, x1, t2, x2, x)
 
subroutine r8vec_bracket (n, x, xval, left, right)
 
subroutine r8vec_bracket2 (n, x, xval, start, left, right)
 
subroutine r8vec_bracket3 (n, t, tval, left)
 
subroutine r8vec_bracket4 (nt, t, ns, s, left)
 
integer(kind=4) function r8vec_bracket5 (nd, xd, xi)
 
subroutine r8vec_bracket6 (nd, xd, ni, xi, b)
 
subroutine r8vec_ceiling (n, r8vec, ceilingvec)
 
subroutine r8vec_chebyspace (n, a, b, x)
 
subroutine r8vec_cheby1space (n, a, b, x)
 
subroutine r8vec_cheby2space (n, a, b, x)
 
subroutine r8vec_circular_variance (n, x, circular_variance)
 
subroutine r8vec_compare (n, a1, a2, isgn)
 
subroutine r8vec_concatenate (n1, a, n2, b, c)
 
subroutine r8vec_convolution (m, x, n, y, z)
 
subroutine r8vec_convolution_circ (n, x, y, z)
 
subroutine r8vec_copy (n, a1, a2)
 
subroutine r8vec_correlation (n, x, y, correlation)
 
real(kind=8) function r8vec_covar (n, x, y)
 
real(kind=8) function r8vec_cross_product_2d (v1, v2)
 
real(kind=8) function r8vec_cross_product_affine_2d (v0, v1, v2)
 
subroutine r8vec_cross_product_3d (v1, v2, v3)
 
subroutine r8vec_cross_product_affine_3d (v0, v1, v2, v3)
 
subroutine r8vec_cum (n, a, a_cum)
 
subroutine r8vec_cum0 (n, a, a_cum)
 
subroutine r8vec_dif (n, h, cof)
 
real(kind=8) function r8vec_diff_dot_product (n, u1, v1, u2, v2)
 
real(kind=8) function r8vec_diff_norm (n, a, b)
 
real(kind=8) function r8vec_diff_norm_l1 (n, a, b)
 
real(kind=8) function r8vec_diff_norm_l2 (n, a, b)
 
real(kind=8) function r8vec_diff_norm_li (n, a, b)
 
real(kind=8) function r8vec_diff_norm_squared (n, a, b)
 
subroutine r8vec_direct_product (factor_index, factor_order, factor_value, factor_num, point_num, x)
 
subroutine r8vec_direct_product2 (factor_index, factor_order, factor_value, factor_num, point_num, w)
 
real(kind=8) function r8vec_distance (dim_num, v1, v2)
 
logical(kind=4) function r8vec_distinct (n, a)
 
real(kind=8) function r8vec_dot_product (n, v1, v2)
 
real(kind=8) function r8vec_dot_product_affine (n, v0, v1, v2)
 
real(kind=8) function r8vec_entropy (n, x)
 
logical(kind=4) function r8vec_eq (n, a1, a2)
 
subroutine r8vec_even (n, alo, ahi, a)
 
subroutine r8vec_even_select (n, xlo, xhi, ival, xval)
 
subroutine r8vec_even2 (maxval, nfill, nold, xold, nval, xval)
 
subroutine r8vec_even2_select (n, xlo, xhi, ival, xval)
 
subroutine r8vec_even3 (nold, nval, xold, xval)
 
subroutine r8vec_expand_linear (n, x, fat, xfat)
 
subroutine r8vec_expand_linear2 (n, x, before, fat, after, xfat)
 
subroutine r8vec_first_index (n, a, tol, first_index)
 
subroutine r8vec_floor (n, r8vec, floorvec)
 
subroutine r8vec_frac (n, a, k, frac)
 
subroutine r8vec_fraction (n, x, fraction)
 
logical(kind=4) function r8vec_gt (n, a1, a2)
 
subroutine r8vec_heap_a (n, a)
 
subroutine r8vec_heap_d (n, a)
 
subroutine r8vec_heap_d_extract (n, a, value)
 
subroutine r8vec_heap_d_insert (n, a, value)
 
subroutine r8vec_heap_d_max (n, a, value)
 
subroutine r8vec_histogram (n, a, a_lo, a_hi, histo_num, histo_gram)
 
subroutine r8vec_house_column (n, a, k, v)
 
real(kind=8) function r8vec_i4vec_dot_product (n, r8vec, i4vec)
 
logical(kind=4) function r8vec_in_01 (n, a)
 
logical(kind=4) function r8vec_in_ab (n, x, a, b)
 
subroutine r8vec_index_delete_all (n, x, indx, xval)
 
subroutine r8vec_index_delete_dupes (n, x, indx, n2, x2, indx2)
 
subroutine r8vec_index_delete_one (n, x, indx, xval, n2, x2, indx2)
 
subroutine r8vec_index_insert (n, x, indx, xval)
 
subroutine r8vec_index_insert_unique (n, x, indx, xval)
 
subroutine r8vec_index_order (n, x, indx)
 
subroutine r8vec_index_search (n, x, indx, xval, less, equal, more)
 
subroutine r8vec_index_sort_unique (n, x, indx, n2)
 
subroutine r8vec_index_sorted_range (n, r, indx, r_lo, r_hi, i_lo, i_hi)
 
subroutine r8vec_indexed_heap_d (n, a, indx)
 
subroutine r8vec_indexed_heap_d_extract (n, a, indx, indx_extract)
 
subroutine r8vec_indexed_heap_d_insert (n, a, indx, indx_insert)
 
subroutine r8vec_indexed_heap_d_max (n, a, indx, indx_max)
 
subroutine r8vec_indicator0 (n, a)
 
subroutine r8vec_indicator1 (n, a)
 
subroutine r8vec_insert (n, a, pos, value)
 
logical(kind=4) function r8vec_insignificant (n, r, s)
 
logical(kind=4) function r8vec_is_int (n, a)
 
logical(kind=4) function r8vec_is_nonnegative (n, a)
 
logical(kind=4) function r8vec_is_zero (n, a)
 
subroutine r8vec_legendre (n, x_first, x_last, x)
 
subroutine r8vec_linspace (n, a, b, x)
 
subroutine r8vec_linspace2 (n, a, b, x)
 
logical(kind=4) function r8vec_lt (n, a1, a2)
 
subroutine r8vec_mask_print (n, a, mask_num, mask, title)
 
real(kind=8) function r8vec_max (n, a)
 
subroutine r8vec_max_abs_index (n, a, max_index)
 
subroutine r8vec_max_index (n, a, max_index)
 
subroutine r8vec_mean (n, a, mean)
 
subroutine r8vec_mean_geometric (n, a, mean)
 
subroutine r8vec_median (n, a, median)
 
subroutine r8vec_mesh_2d (nx, ny, xvec, yvec, xmat, ymat)
 
subroutine r8vec_midspace (n, a, b, x)
 
real(kind=8) function r8vec_min (n, a)
 
subroutine r8vec_min_index (n, a, min_index)
 
real(kind=8) function r8vec_min_pos (n, a)
 
subroutine r8vec_mirror_next (n, a, done)
 
logical(kind=4) function r8vec_negative_strict (n, a)
 
subroutine r8vec_nint (n, a)
 
real(kind=8) function r8vec_norm (n, a)
 
real(kind=8) function r8vec_norm_affine (n, v0, v1)
 
integer(kind=4) function r8vec_norm_l0 (n, a)
 
real(kind=8) function r8vec_norm_l1 (n, a)
 
real(kind=8) function r8vec_norm_l2 (n, a)
 
real(kind=8) function r8vec_norm_li (n, a)
 
real(kind=8) function r8vec_norm_lp (n, a, p)
 
real(kind=8) function r8vec_norm_squared (n, a)
 
subroutine r8vec_normal_01 (n, seed, x)
 
subroutine r8vec_normalize (n, a)
 
subroutine r8vec_normalize_l1 (n, a)
 
real(kind=8) function r8vec_normsq (n, v)
 
real(kind=8) function r8vec_normsq_affine (n, v0, v1)
 
subroutine r8vec_order_type (n, a, order)
 
subroutine r8vec_part_quick_a (n, a, l, r)
 
subroutine r8vec_permute (n, p, a)
 
subroutine r8vec_permute_cyclic (n, k, a)
 
subroutine r8vec_permute_uniform (n, a, seed)
 
subroutine r8vec_polarize (n, a, p, a_normal, a_parallel)
 
logical(kind=4) function r8vec_positive_strict (n, a)
 
subroutine r8vec_print (n, a, title)
 
subroutine r8vec_print_16 (n, a, title)
 
subroutine r8vec_print_part (n, a, max_print, title)
 
subroutine r8vec_print_some (n, a, i_lo, i_hi, title)
 
subroutine r8vec_print2 (n, a)
 
real(kind=8) function r8vec_product (n, a)
 
subroutine r8vec_range (n, x, xmin, xmax, y, ymin, ymax)
 
subroutine r8vec_range_2 (n, a, amin, amax)
 
subroutine r8vec_reverse (n, a)
 
real(kind=8) function r8vec_rms (n, a)
 
subroutine r8vec_rotate (n, a, m)
 
real(kind=8) function r8vec_scalar_triple_product (v1, v2, v3)
 
subroutine r8vec_scale (s, n, x)
 
subroutine r8vec_search_binary_a (n, a, aval, indx)
 
subroutine r8vec_shift (shift, n, x)
 
subroutine r8vec_shift_circular (shift, n, x)
 
subroutine r8vec_sort_bubble_a (n, a)
 
subroutine r8vec_sort_bubble_d (n, a)
 
subroutine r8vec_sort_heap_a (n, a)
 
subroutine r8vec_sort_heap_d (n, a)
 
subroutine r8vec_sort_heap_index_a (n, a, indx)
 
subroutine r8vec_sort_heap_index_d (n, a, indx)
 
subroutine r8vec_sort_heap_mask_a (n, a, mask_num, mask, indx)
 
subroutine r8vec_sort_insert_a (n, a)
 
subroutine r8vec_sort_insert_index_a (n, a, indx)
 
subroutine r8vec_sort_insert_index_d (n, a, indx)
 
subroutine r8vec_sort_quick_a (n, a)
 
subroutine r8vec_sort_shell_a (n, a)
 
subroutine r8vec_sort2_a (n, x, y)
 
subroutine r8vec_sorted_merge_a (na, a, nb, b, nc, c)
 
integer(kind=4) function r8vec_sorted_nearest (n, a, value)
 
subroutine r8vec_sorted_range (n, r, r_lo, r_hi, i_lo, i_hi)
 
subroutine r8vec_sorted_split (n, a, split, i_lt, i_gt)
 
subroutine r8vec_sorted_undex (x_num, x_val, x_unique_num, tol, undx, xdnu)
 
subroutine r8vec_sorted_unique (n, a, tol, unique_num)
 
subroutine r8vec_sorted_unique_count (n, a, tol, unique_num)
 
subroutine r8vec_sorted_unique_hist (n, a, tol, maxuniq, unique_num, auniq, acount)
 
subroutine r8vec_split (n, a, split, isplit)
 
subroutine r8vec_std (n, a, std)
 
subroutine r8vec_step (x0, n, x, fx)
 
subroutine r8vec_stutter (n, a, m, am)
 
real(kind=8) function r8vec_sum (n, a)
 
subroutine r8vec_swap (n, a1, a2)
 
subroutine r8vec_transpose_print (n, a, title)
 
subroutine r8vec_undex (x_num, x_val, x_unique_num, tol, undx, xdnu)
 
subroutine r8vec_uniform_01 (n, seed, r)
 
subroutine r8vec_uniform_ab (n, a, b, seed, r)
 
subroutine r8vec_uniform_abvec (n, a, b, seed, r)
 
subroutine r8vec_uniform_unit (m, seed, w)
 
subroutine r8vec_unique_count (n, a, tol, unique_num)
 
subroutine r8vec_unique_index (n, a, tol, unique_index)
 
subroutine r8vec_variance (n, a, variance)
 
subroutine r8vec_vector_triple_product (v1, v2, v3, v)
 
subroutine r8vec_write (n, r, output_file)
 
subroutine r8vec_zero (n, a)
 
subroutine r8vec2_compare (n, a1, a2, i, j, isgn)
 
subroutine r8vec2_print (n, a1, a2, title)
 
subroutine r8vec2_print_some (n, x1, x2, max_print, title)
 
subroutine r8vec2_sort_a (n, a1, a2)
 
subroutine r8vec2_sort_d (n, a1, a2)
 
subroutine r8vec2_sort_heap_index_a (n, x, y, indx)
 
subroutine r8vec2_sorted_unique (n, a1, a2, unique_num)
 
subroutine r8vec2_sorted_unique_index (n, a1, a2, unique_num, indx)
 
subroutine r8vec2_sum_max_index (n, a, b, sum_max_index)
 
subroutine r8vec3_print (n, a1, a2, a3, title)
 
subroutine roots_to_r8poly (n, x, c)
 
subroutine sort_heap_external (n, indx, i, j, isgn)
 
subroutine timestamp ()
 

Function/Subroutine Documentation

◆ gamma_log_values()

subroutine gamma_log_values ( integer ( kind = 4 )  n_data,
real ( kind = 8 )  x,
real ( kind = 8 )  fx 
)

Definition at line 140 of file R8LIB.f90.

141
142!*****************************************************************************80
143!
144!! GAMMA_LOG_VALUES returns some values of the Log Gamma function.
145!
146! Discussion:
147!
148! In Mathematica, the function can be evaluated by:
149!
150! Log[Gamma[x]]
151!
152! Licensing:
153!
154! This code is distributed under the GNU LGPL license.
155!
156! Modified:
157!
158! 14 August 2004
159!
160! Author:
161!
162! John Burkardt
163!
164! Reference:
165!
166! Milton Abramowitz, Irene Stegun,
167! Handbook of Mathematical Functions,
168! National Bureau of Standards, 1964,
169! ISBN: 0-486-61272-4,
170! LC: QA47.A34.
171!
172! Stephen Wolfram,
173! The Mathematica Book,
174! Fourth Edition,
175! Cambridge University Press, 1999,
176! ISBN: 0-521-64314-7,
177! LC: QA76.95.W65.
178!
179! Parameters:
180!
181! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0
182! before the first call. On each call, the routine increments N_DATA by 1,
183! and returns the corresponding data; when there is no more data, the
184! output value of N_DATA will be 0 again.
185!
186! Output, real ( kind = 8 ) X, the argument of the function.
187!
188! Output, real ( kind = 8 ) FX, the value of the function.
189!
190 implicit none
191
192 integer ( kind = 4 ), parameter :: n_max = 20
193
194 real ( kind = 8 ) fx
195 real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
196 0.1524063822430784d+01, &
197 0.7966778177017837d+00, &
198 0.3982338580692348d+00, &
199 0.1520596783998375d+00, &
200 0.0000000000000000d+00, &
201 -0.4987244125983972d-01, &
202 -0.8537409000331584d-01, &
203 -0.1081748095078604d+00, &
204 -0.1196129141723712d+00, &
205 -0.1207822376352452d+00, &
206 -0.1125917656967557d+00, &
207 -0.9580769740706586d-01, &
208 -0.7108387291437216d-01, &
209 -0.3898427592308333d-01, &
210 0.00000000000000000d+00, &
211 0.69314718055994530d+00, &
212 0.17917594692280550d+01, &
213 0.12801827480081469d+02, &
214 0.39339884187199494d+02, &
215 0.71257038967168009d+02 /)
216 integer ( kind = 4 ) n_data
217 real ( kind = 8 ) x
218 real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
219 0.20d+00, &
220 0.40d+00, &
221 0.60d+00, &
222 0.80d+00, &
223 1.00d+00, &
224 1.10d+00, &
225 1.20d+00, &
226 1.30d+00, &
227 1.40d+00, &
228 1.50d+00, &
229 1.60d+00, &
230 1.70d+00, &
231 1.80d+00, &
232 1.90d+00, &
233 2.00d+00, &
234 3.00d+00, &
235 4.00d+00, &
236 10.00d+00, &
237 20.00d+00, &
238 30.00d+00 /)
239
240 if ( n_data < 0 ) then
241 n_data = 0
242 end if
243
244 n_data = n_data + 1
245
246 if ( n_max < n_data ) then
247 n_data = 0
248 x = 0.0d+00
249 fx = 0.0d+00
250 else
251 x = x_vec(n_data)
252 fx = fx_vec(n_data)
253 end if
254
255 return

◆ gamma_values()

subroutine gamma_values ( integer ( kind = 4 )  n_data,
real ( kind = 8 )  x,
real ( kind = 8 )  fx 
)

Definition at line 1 of file R8LIB.f90.

2
3!*****************************************************************************80
4!
5!! GAMMA_VALUES returns some values of the Gamma function.
6!
7! Discussion:
8!
9! The Gamma function is defined as:
10!
11! Gamma(Z) = integral ( 0 <= T < +oo) T^(Z-1) exp(-T) dT
12!
13! It satisfies the recursion:
14!
15! Gamma(X+1) = X * Gamma(X)
16!
17! Gamma is undefined for nonpositive integral X.
18! Gamma(0.5) = sqrt(PI)
19! For N a positive integer, Gamma(N+1) = N!, the standard factorial.
20!
21! In Mathematica, the function can be evaluated by:
22!
23! Gamma[x]
24!
25! Licensing:
26!
27! This code is distributed under the GNU LGPL license.
28!
29! Modified:
30!
31! 20 May 2007
32!
33! Author:
34!
35! John Burkardt
36!
37! Reference:
38!
39! Milton Abramowitz, Irene Stegun,
40! Handbook of Mathematical Functions,
41! National Bureau of Standards, 1964,
42! ISBN: 0-486-61272-4,
43! LC: QA47.A34.
44!
45! Stephen Wolfram,
46! The Mathematica Book,
47! Fourth Edition,
48! Cambridge University Press, 1999,
49! ISBN: 0-521-64314-7,
50! LC: QA76.95.W65.
51!
52! Parameters:
53!
54! Input/output, integer ( kind = 4 ) N_DATA. The user sets N_DATA to 0
55! before the first call. On each call, the routine increments N_DATA by 1,
56! and returns the corresponding data; when there is no more data, the
57! output value of N_DATA will be 0 again.
58!
59! Output, real ( kind = 8 ) X, the argument of the function.
60!
61! Output, real ( kind = 8 ) FX, the value of the function.
62!
63 implicit none
64
65 integer ( kind = 4 ), parameter :: n_max = 25
66
67 real ( kind = 8 ) fx
68 real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ &
69 -0.3544907701811032d+01, &
70 -0.1005871979644108d+03, &
71 0.9943258511915060d+02, &
72 0.9513507698668732d+01, &
73 0.4590843711998803d+01, &
74 0.2218159543757688d+01, &
75 0.1772453850905516d+01, &
76 0.1489192248812817d+01, &
77 0.1164229713725303d+01, &
78 0.1000000000000000d+01, &
79 0.9513507698668732d+00, &
80 0.9181687423997606d+00, &
81 0.8974706963062772d+00, &
82 0.8872638175030753d+00, &
83 0.8862269254527580d+00, &
84 0.8935153492876903d+00, &
85 0.9086387328532904d+00, &
86 0.9313837709802427d+00, &
87 0.9617658319073874d+00, &
88 0.1000000000000000d+01, &
89 0.2000000000000000d+01, &
90 0.6000000000000000d+01, &
91 0.3628800000000000d+06, &
92 0.1216451004088320d+18, &
93 0.8841761993739702d+31 /)
94 integer ( kind = 4 ) n_data
95 real ( kind = 8 ) x
96 real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ &
97 -0.50d+00, &
98 -0.01d+00, &
99 0.01d+00, &
100 0.10d+00, &
101 0.20d+00, &
102 0.40d+00, &
103 0.50d+00, &
104 0.60d+00, &
105 0.80d+00, &
106 1.00d+00, &
107 1.10d+00, &
108 1.20d+00, &
109 1.30d+00, &
110 1.40d+00, &
111 1.50d+00, &
112 1.60d+00, &
113 1.70d+00, &
114 1.80d+00, &
115 1.90d+00, &
116 2.00d+00, &
117 3.00d+00, &
118 4.00d+00, &
119 10.00d+00, &
120 20.00d+00, &
121 30.00d+00 /)
122
123 if ( n_data < 0 ) then
124 n_data = 0
125 end if
126
127 n_data = n_data + 1
128
129 if ( n_max < n_data ) then
130 n_data = 0
131 x = 0.0d+00
132 fx = 0.0d+00
133 else
134 x = x_vec(n_data)
135 fx = fx_vec(n_data)
136 end if
137
138 return

◆ get_unit()

subroutine get_unit ( integer ( kind = 4 )  iunit)

Definition at line 257 of file R8LIB.f90.

258
259!*****************************************************************************80
260!
261!! GET_UNIT returns a free FORTRAN unit number.
262!
263! Discussion:
264!
265! A "free" FORTRAN unit number is a value between 1 and 99 which
266! is not currently associated with an I/O device. A free FORTRAN unit
267! number is needed in order to open a file with the OPEN command.
268!
269! If IUNIT = 0, then no free FORTRAN unit could be found, although
270! all 99 units were checked (except for units 5, 6 and 9, which
271! are commonly reserved for console I/O).
272!
273! Otherwise, IUNIT is a value between 1 and 99, representing a
274! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6
275! are special, and will never return those values.
276!
277! Licensing:
278!
279! This code is distributed under the GNU LGPL license.
280!
281! Modified:
282!
283! 26 October 2008
284!
285! Author:
286!
287! John Burkardt
288!
289! Parameters:
290!
291! Output, integer ( kind = 4 ) IUNIT, the free unit number.
292!
293 implicit none
294
295 integer ( kind = 4 ) i
296 integer ( kind = 4 ) ios
297 integer ( kind = 4 ) iunit
298 logical ( kind = 4 ) lopen
299
300 iunit = 0
301
302 do i = 1, 99
303
304 if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then
305
306 inquire ( unit = i, opened = lopen, iostat = ios )
307
308 if ( ios == 0 ) then
309 if ( .not. lopen ) then
310 iunit = i
311 return
312 end if
313 end if
314
315 end if
316
317 end do
318
319 return

Referenced by r8vec_write().

Here is the caller graph for this function:

◆ i4_log_10()

integer ( kind = 4 ) function i4_log_10 ( integer ( kind = 4 )  i)

Definition at line 321 of file R8LIB.f90.

322
323!*****************************************************************************80
324!
325!! I4_LOG_10 returns the integer part of the logarithm base 10 of an I4.
326!
327! Discussion:
328!
329! I4_LOG_10 ( I ) + 1 is the number of decimal digits in I.
330!
331! An I4 is an integer ( kind = 4 ) value.
332!
333! Example:
334!
335! I I4_LOG_10
336! ----- --------
337! 0 0
338! 1 0
339! 2 0
340! 9 0
341! 10 1
342! 11 1
343! 99 1
344! 100 2
345! 101 2
346! 999 2
347! 1000 3
348! 1001 3
349! 9999 3
350! 10000 4
351!
352! Licensing:
353!
354! This code is distributed under the GNU LGPL license.
355!
356! Modified:
357!
358! 08 June 2003
359!
360! Author:
361!
362! John Burkardt
363!
364! Parameters:
365!
366! Input, integer ( kind = 4 ) I, the number whose logarithm base 10
367! is desired.
368!
369! Output, integer ( kind = 4 ) I4_LOG_10, the integer part of the
370! logarithm base 10 of the absolute value of X.
371!
372 implicit none
373
374 integer ( kind = 4 ) i
375 integer ( kind = 4 ) i_abs
376 integer ( kind = 4 ) i4_log_10
377 integer ( kind = 4 ) ten_pow
378
379 if ( i == 0 ) then
380
381 i4_log_10 = 0
382
383 else
384
385 i4_log_10 = 0
386 ten_pow = 10
387
388 i_abs = abs( i )
389
390 do while ( ten_pow <= i_abs )
391 i4_log_10 = i4_log_10 + 1
392 ten_pow = ten_pow * 10
393 end do
394
395 end if
396
397 return
i4_log_10
integer(kind=4) function i4_log_10(i)
Definition R8LIB.f90:322

References i4_log_10().

Referenced by i4_log_10().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ i4_modp()

integer ( kind = 4 ) function i4_modp ( integer ( kind = 4 )  i,
integer ( kind = 4 )  j 
)

Definition at line 399 of file R8LIB.f90.

400
401!*****************************************************************************80
402!
403!! I4_MODP returns the nonnegative remainder of I4 division.
404!
405! Discussion:
406!
407! If
408! NREM = I4_MODP ( I, J )
409! NMULT = ( I - NREM ) / J
410! then
411! I = J * NMULT + NREM
412! where NREM is always nonnegative.
413!
414! The MOD function computes a result with the same sign as the
415! quantity being divided. Thus, suppose you had an angle A,
416! and you wanted to ensure that it was between 0 and 360.
417! Then mod(A,360) would do, if A was positive, but if A
418! was negative, your result would be between -360 and 0.
419!
420! On the other hand, I4_MODP(A,360) is between 0 and 360, always.
421!
422! An I4 is an integer ( kind = 4 ) value.
423!
424! Example:
425!
426! I J MOD I4_MODP Factorization
427!
428! 107 50 7 7 107 = 2 * 50 + 7
429! 107 -50 7 7 107 = -2 * -50 + 7
430! -107 50 -7 43 -107 = -3 * 50 + 43
431! -107 -50 -7 43 -107 = 3 * -50 + 43
432!
433! Licensing:
434!
435! This code is distributed under the GNU LGPL license.
436!
437! Modified:
438!
439! 02 March 1999
440!
441! Author:
442!
443! John Burkardt
444!
445! Parameters:
446!
447! Input, integer ( kind = 4 ) I, the number to be divided.
448!
449! Input, integer ( kind = 4 ) J, the number that divides I.
450!
451! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is
452! divided by J.
453!
454 implicit none
455
456 integer ( kind = 4 ) i
457 integer ( kind = 4 ) i4_modp
458 integer ( kind = 4 ) j
459 integer ( kind = 4 ) value
460
461 if ( j == 0 ) then
462 write ( *, '(a)' ) ' '
463 write ( *, '(a)' ) 'I4_MODP - Fatal error!'
464 write ( *, '(a,i8)' ) ' Illegal divisor J = ', j
465 stop 1
466 end if
467
468 value = mod( i, j )
469
470 if ( value < 0 ) then
471 value = value + abs( j )
472 end if
473
474 i4_modp = value
475
476 return
i4_modp
integer(kind=4) function i4_modp(i, j)
Definition R8LIB.f90:400

References i4_modp().

Referenced by i4_modp(), and i4_wrap().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ i4_uniform_ab()

integer ( kind = 4 ) function i4_uniform_ab ( integer ( kind = 4 )  a,
integer ( kind = 4 )  b,
integer ( kind = 4 )  seed 
)

Definition at line 478 of file R8LIB.f90.

479
480!*****************************************************************************80
481!
482!! I4_UNIFORM_AB returns a scaled pseudorandom I4.
483!
484! Discussion:
485!
486! An I4 is an integer ( kind = 4 ) value.
487!
488! The pseudorandom number will be scaled to be uniformly distributed
489! between A and B.
490!
491! Licensing:
492!
493! This code is distributed under the GNU LGPL license.
494!
495! Modified:
496!
497! 12 November 2006
498!
499! Author:
500!
501! John Burkardt
502!
503! Reference:
504!
505! Paul Bratley, Bennett Fox, Linus Schrage,
506! A Guide to Simulation,
507! Springer Verlag, pages 201-202, 1983.
508!
509! Pierre L'Ecuyer,
510! Random Number Generation,
511! in Handbook of Simulation,
512! edited by Jerry Banks,
513! Wiley Interscience, page 95, 1998.
514!
515! Bennett Fox,
516! Algorithm 647:
517! Implementation and Relative Efficiency of Quasirandom
518! Sequence Generators,
519! ACM Transactions on Mathematical Software,
520! Volume 12, Number 4, pages 362-376, 1986.
521!
522! Peter Lewis, Allen Goodman, James Miller
523! A Pseudo-Random Number Generator for the System/360,
524! IBM Systems Journal,
525! Volume 8, pages 136-143, 1969.
526!
527! Parameters:
528!
529! Input, integer ( kind = 4 ) A, B, the limits of the interval.
530!
531! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
532! should NOT be 0. On output, SEED has been updated.
533!
534! Output, integer ( kind = 4 ) I4_UNIFORM_AB, a number between A and B.
535!
536 implicit none
537
538 integer ( kind = 4 ) a
539 integer ( kind = 4 ) b
540 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
541 integer ( kind = 4 ) i4_uniform_ab
542 integer ( kind = 4 ) k
543 real ( kind = 4 ) r
544 integer ( kind = 4 ) seed
545 integer ( kind = 4 ) value
546
547 if ( seed == 0 ) then
548 write ( *, '(a)' ) ' '
549 write ( *, '(a)' ) 'I4_UNIFORM_AB - Fatal error!'
550 write ( *, '(a)' ) ' Input value of SEED = 0.'
551 stop 1
552 end if
553
554 k = seed / 127773
555
556 seed = 16807 * ( seed - k * 127773 ) - k * 2836
557
558 if ( seed < 0 ) then
559 seed = seed + i4_huge
560 end if
561
562 r = real( seed, kind = 4 ) * 4.656612875e-10
563!
564! Scale R to lie between A-0.5 and B+0.5.
565!
566 r = ( 1.0e+00 - r ) * ( real( min( a, b ), kind = 4 ) - 0.5e+00 ) &
567 + r * ( real( max( a, b ), kind = 4 ) + 0.5e+00 )
568!
569! Use rounding to convert R to an integer between A and B.
570!
571 value = nint( r, kind = 4 )
572
573 value = max( value, min( a, b ) )
574 value = min( value, max( a, b ) )
575
576 i4_uniform_ab = value
577
578 return
i4_uniform_ab
integer(kind=4) function i4_uniform_ab(a, b, seed)
Definition R8LIB.f90:479

References i4_uniform_ab().

Referenced by i4_uniform_ab().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ i4_wrap()

integer ( kind = 4 ) function i4_wrap ( integer ( kind = 4 )  ival,
integer ( kind = 4 )  ilo,
integer ( kind = 4 )  ihi 
)

Definition at line 580 of file R8LIB.f90.

581
582!*****************************************************************************80
583!
584!! I4_WRAP forces an I4 to lie between given limits by wrapping.
585!
586! Discussion:
587!
588! An I4 is an integer ( kind = 4 ) value.
589!
590! There appears to be a bug in the GFORTRAN compiler which can lead to
591! erroneous results when the first argument of I4_WRAP is an expression.
592! In particular:
593!
594! do i = 1, 3
595! if ( test ) then
596! i4 = i4_wrap ( i + 1, 1, 3 )
597! end if
598! end do
599!
600! was, when I = 3, returning I4 = 3. So I had to replace this with
601!
602! do i = 1, 3
603! if ( test ) then
604! i4 = i + 1
605! i4 = i4_wrap ( i4, 1, 3 )
606! end if
607! end do
608!
609! Example:
610!
611! ILO = 4, IHI = 8
612!
613! I Value
614!
615! -2 8
616! -1 4
617! 0 5
618! 1 6
619! 2 7
620! 3 8
621! 4 4
622! 5 5
623! 6 6
624! 7 7
625! 8 8
626! 9 4
627! 10 5
628! 11 6
629! 12 7
630! 13 8
631! 14 4
632!
633! Licensing:
634!
635! This code is distributed under the GNU LGPL license.
636!
637! Modified:
638!
639! 07 September 2009
640!
641! Author:
642!
643! John Burkardt
644!
645! Parameters:
646!
647! Input, integer ( kind = 4 ) IVAL, a value.
648!
649! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds.
650!
651! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of the value.
652!
653 implicit none
654
655 integer ( kind = 4 ) i4_modp
656 integer ( kind = 4 ) i4_wrap
657 integer ( kind = 4 ) ihi
658 integer ( kind = 4 ) ilo
659 integer ( kind = 4 ) ival
660 integer ( kind = 4 ) jhi
661 integer ( kind = 4 ) jlo
662 integer ( kind = 4 ) value
663 integer ( kind = 4 ) wide
664
665 jlo = min( ilo, ihi )
666 jhi = max( ilo, ihi )
667
668 wide = jhi - jlo + 1
669
670 if ( wide == 1 ) then
671 value = jlo
672 else
673 value = jlo + i4_modp( ival - jlo, wide )
674 end if
675
676 i4_wrap = value
677
678 return
i4_wrap
integer(kind=4) function i4_wrap(ival, ilo, ihi)
Definition R8LIB.f90:581

References i4_modp(), and i4_wrap().

Referenced by i4_wrap().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ i4int_to_r8int()

subroutine i4int_to_r8int ( integer ( kind = 4 )  imin,
integer ( kind = 4 )  imax,
integer ( kind = 4 )  i,
real ( kind = 8 )  rmin,
real ( kind = 8 )  rmax,
real ( kind = 8 )  r 
)

Definition at line 680 of file R8LIB.f90.

681
682!*****************************************************************************80
683!
684!! I4INT_TO_R8INT maps an I4INT to an R8INT.
685!
686! Discussion:
687!
688! The formula used is:
689!
690! R := RMIN + ( RMAX - RMIN ) * ( I - IMIN ) / ( IMAX - IMIN )
691!
692! Licensing:
693!
694! This code is distributed under the GNU LGPL license.
695!
696! Modified:
697!
698! 01 January 2001
699!
700! Author:
701!
702! John Burkardt
703!
704! Parameters:
705!
706! Input, integer ( kind = 4 ) IMIN, IMAX, the range.
707!
708! Input, integer ( kind = 4 ) I, the integer to be converted.
709!
710! Input, real ( kind = 8 ) RMIN, RMAX, the range.
711!
712! Output, real ( kind = 8 ) R, the corresponding value in [RMIN,RMAX].
713!
714 implicit none
715
716 integer ( kind = 4 ) i
717 integer ( kind = 4 ) imax
718 integer ( kind = 4 ) imin
719 real ( kind = 8 ) r
720 real ( kind = 8 ) rmax
721 real ( kind = 8 ) rmin
722
723 if ( imax == imin ) then
724
725 r = 0.5d+00 * ( rmin + rmax )
726
727 else
728
729 r = ( real( imax - i, kind = 8 ) * rmin &
730 + real( i - imin, kind = 8 ) * rmax ) &
731 / real( imax - imin, kind = 8 )
732
733 end if
734
735 return

◆ i4vec_indicator0()

subroutine i4vec_indicator0 ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  a 
)

Definition at line 737 of file R8LIB.f90.

738
739!*****************************************************************************80
740!
741!! I4VEC_INDICATOR0 sets an I4VEC to the indicator vector (0,1,2,...)
742!
743! Discussion:
744!
745! An I4VEC is a vector of I4's.
746!
747! Licensing:
748!
749! This code is distributed under the GNU LGPL license.
750!
751! Modified:
752!
753! 27 September 2014
754!
755! Author:
756!
757! John Burkardt
758!
759! Parameters:
760!
761! Input, integer ( kind = 4 ) N, the number of elements of A.
762!
763! Output, integer ( kind = 4 ) A(N), the array.
764!
765 implicit none
766
767 integer ( kind = 4 ) n
768
769 integer ( kind = 4 ) a(n)
770 integer ( kind = 4 ) i
771
772 do i = 1, n
773 a(i) = i - 1
774 end do
775
776 return

◆ i4vec_indicator1()

subroutine i4vec_indicator1 ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  a 
)

Definition at line 778 of file R8LIB.f90.

779
780!*****************************************************************************80
781!
782!! I4VEC_INDICATOR1 sets an I4VEC to the indicator vector (1,2,3,...)
783!
784! Discussion:
785!
786! An I4VEC is a vector of I4's.
787!
788! Licensing:
789!
790! This code is distributed under the GNU LGPL license.
791!
792! Modified:
793!
794! 27 September 2014
795!
796! Author:
797!
798! John Burkardt
799!
800! Parameters:
801!
802! Input, integer ( kind = 4 ) N, the number of elements of A.
803!
804! Output, integer ( kind = 4 ) A(N), the array.
805!
806 implicit none
807
808 integer ( kind = 4 ) n
809
810 integer ( kind = 4 ) a(n)
811 integer ( kind = 4 ) i
812
813 do i = 1, n
814 a(i) = i
815 end do
816
817 return

Referenced by r8vec2_sort_heap_index_a(), r8vec_index_delete_dupes(), and r8vec_sort_heap_mask_a().

Here is the caller graph for this function:

◆ i4vec_permute()

subroutine i4vec_permute ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p,
integer ( kind = 4 ), dimension(n)  a 
)

Definition at line 819 of file R8LIB.f90.

820
821!*****************************************************************************80
822!
823!! I4VEC_PERMUTE permutes an I4VEC in place.
824!
825! Discussion:
826!
827! An I4VEC is a vector of I4's.
828!
829! This routine permutes an array of integer "objects", but the same
830! logic can be used to permute an array of objects of any arithmetic
831! type, or an array of objects of any complexity. The only temporary
832! storage required is enough to store a single object. The number
833! of data movements made is N + the number of cycles of order 2 or more,
834! which is never more than N + N/2.
835!
836! Example:
837!
838! Input:
839!
840! N = 5
841! P = ( 2, 4, 5, 1, 3 )
842! A = ( 1, 2, 3, 4, 5 )
843!
844! Output:
845!
846! A = ( 2, 4, 5, 1, 3 ).
847!
848! Licensing:
849!
850! This code is distributed under the GNU LGPL license.
851!
852! Modified:
853!
854! 20 July 2000
855!
856! Author:
857!
858! John Burkardt
859!
860! Parameters:
861!
862! Input, integer ( kind = 4 ) N, the number of objects.
863!
864! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means
865! that the I-th element of the output array should be the J-th
866! element of the input array.
867!
868! Input/output, integer ( kind = 4 ) A(N), the array to be permuted.
869!
870 implicit none
871
872 integer ( kind = 4 ) n
873
874 integer ( kind = 4 ) a(n)
875 integer ( kind = 4 ) a_temp
876 integer ( kind = 4 ) ierror
877 integer ( kind = 4 ) iget
878 integer ( kind = 4 ) iput
879 integer ( kind = 4 ) istart
880 integer ( kind = 4 ) p(n)
881
882 call perm_check1 ( n, p )
883!
884! Search for the next element of the permutation that has not been used.
885!
886 do istart = 1, n
887
888 if ( p(istart) < 0 ) then
889
890 cycle
891
892 else if ( p(istart) == istart ) then
893
894 p(istart) = - p(istart)
895 cycle
896
897 else
898
899 a_temp = a(istart)
900 iget = istart
901!
902! Copy the new value into the vacated entry.
903!
904 do
905
906 iput = iget
907 iget = p(iget)
908
909 p(iput) = - p(iput)
910
911 if ( iget < 1 .or. n < iget ) then
912 write ( *, '(a)' ) ' '
913 write ( *, '(a)' ) 'I4VEC_PERMUTE - Fatal error!'
914 write ( *, '(a)' ) ' A permutation index is out of range.'
915 write ( *, '(a,i8,a,i8)' ) ' P(', iput, ') = ', iget
916 stop 1
917 end if
918
919 if ( iget == istart ) then
920 a(iput) = a_temp
921 exit
922 end if
923
924 a(iput) = a(iget)
925
926 end do
927
928 end if
929
930 end do
931!
932! Restore the signs of the entries.
933!
934 p(1:n) = - p(1:n)
935
936 return
perm_check1
subroutine perm_check1(n, p)
Definition R8LIB.f90:1199

References perm_check1().

Here is the call graph for this function:

◆ i4vec_print()

subroutine i4vec_print ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  a,
character ( len = * )  title 
)

Definition at line 938 of file R8LIB.f90.

939
940!*****************************************************************************80
941!
942!! I4VEC_PRINT prints an I4VEC.
943!
944! Discussion:
945!
946! An I4VEC is a vector of I4's.
947!
948! Licensing:
949!
950! This code is distributed under the GNU LGPL license.
951!
952! Modified:
953!
954! 02 May 2010
955!
956! Author:
957!
958! John Burkardt
959!
960! Parameters:
961!
962! Input, integer ( kind = 4 ) N, the number of components of the vector.
963!
964! Input, integer ( kind = 4 ) A(N), the vector to be printed.
965!
966! Input, character ( len = * ) TITLE, a title.
967!
968 implicit none
969
970 integer ( kind = 4 ) n
971
972 integer ( kind = 4 ) a(n)
973 integer ( kind = 4 ) i
974 character ( len = * ) title
975
976 write ( *, '(a)' ) ' '
977 write ( *, '(a)' ) trim( title )
978 write ( *, '(a)' ) ' '
979 do i = 1, n
980 write ( *, '(2x,i8,a,2x,i12)' ) i, ':', a(i)
981 end do
982
983 return

◆ legendre_zeros()

subroutine legendre_zeros ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 985 of file R8LIB.f90.

986
987!*****************************************************************************80
988!
989!! LEGENDRE_ZEROS computes the zeros of the Legendre polynomial of degree N.
990!
991! Licensing:
992!
993! This code is distributed under the GNU LGPL license.
994!
995! Modified:
996!
997! 17 June 2011
998!
999! Author:
1000!
1001! Original FORTRAN77 version by Philip Davis, Philip Rabinowitz.
1002! FORTRAN90 version by John Burkardt.
1003!
1004! Reference:
1005!
1006! Philip Davis, Philip Rabinowitz,
1007! Methods of Numerical Integration,
1008! Second Edition,
1009! Dover, 2007,
1010! ISBN: 0486453391,
1011! LC: QA299.3.D28.
1012!
1013! Parameters:
1014!
1015! Input, integer ( kind = 4 ) N, the order.
1016! 0 < N.
1017!
1018! Output, real ( kind = 8 ) X(N), the locations of the zeros.
1019!
1020 implicit none
1021
1022 integer ( kind = 4 ) n
1023
1024 real ( kind = 8 ) d1
1025 real ( kind = 8 ) d2pn
1026 real ( kind = 8 ) d3pn
1027 real ( kind = 8 ) d4pn
1028 real ( kind = 8 ) dp
1029 real ( kind = 8 ) dpn
1030 real ( kind = 8 ) e1
1031 real ( kind = 8 ) fx
1032 real ( kind = 8 ) h
1033 integer ( kind = 4 ) i
1034 integer ( kind = 4 ) iback
1035 integer ( kind = 4 ) k
1036 integer ( kind = 4 ) m
1037 integer ( kind = 4 ) mp1mi
1038 integer ( kind = 4 ) ncopy
1039 integer ( kind = 4 ) nmove
1040 real ( kind = 8 ) p
1041 real ( kind = 8 ) pk
1042 real ( kind = 8 ) pkm1
1043 real ( kind = 8 ) pkp1
1044 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
1045 real ( kind = 8 ) t
1046 real ( kind = 8 ) u
1047 real ( kind = 8 ) v
1048 real ( kind = 8 ) x(n)
1049 real ( kind = 8 ) x0
1050 real ( kind = 8 ) xtemp
1051
1052 e1 = real( n * ( n + 1 ), kind = 8 )
1053
1054 m = ( n + 1 ) / 2
1055
1056 do i = 1, m
1057
1058 mp1mi = m + 1 - i
1059
1060 t = real( 4 * i - 1, kind = 8 ) * r8_pi &
1061 / real( 4 * n + 2, kind = 8 )
1062
1063 x0 = cos( t ) * ( 1.0d+00 - ( 1.0d+00 - 1.0d+00 &
1064 / real( n, kind = 8 ) ) &
1065 / real( 8 * n * n, kind = 8 ) )
1066
1067 pkm1 = 1.0d+00
1068 pk = x0
1069
1070 do k = 2, n
1071 pkp1 = 2.0d+00 * x0 * pk - pkm1 - ( x0 * pk - pkm1 ) &
1072 / real( k, kind = 8 )
1073 pkm1 = pk
1074 pk = pkp1
1075 end do
1076
1077 d1 = real( n, kind = 8 ) * ( pkm1 - x0 * pk )
1078
1079 dpn = d1 / ( 1.0d+00 - x0 ) / ( 1.0d+00 + x0 )
1080
1081 d2pn = ( 2.0d+00 * x0 * dpn - e1 * pk ) / ( 1.0d+00 - x0 ) &
1082 / ( 1.0d+00 + x0 )
1083
1084 d3pn = ( 4.0d+00 * x0 * d2pn + ( 2.0d+00 - e1 ) * dpn ) &
1085 / ( 1.0d+00 - x0 ) / ( 1.0d+00 + x0 )
1086
1087 d4pn = ( 6.0d+00 * x0 * d3pn + ( 6.0d+00 - e1 ) * d2pn ) &
1088 / ( 1.0d+00 - x0 ) / ( 1.0d+00 + x0 )
1089
1090 u = pk / dpn
1091 v = d2pn / dpn
1092!
1093! Initial approximation H:
1094!
1095 h = - u * ( 1.0d+00 + 0.5d+00 * u * ( v + u * ( v * v - d3pn / &
1096 ( 3.0d+00 * dpn ) ) ) )
1097!
1098! Refine H using one step of Newton's method:
1099!
1100 p = pk + h * ( dpn + 0.5d+00 * h * ( d2pn + h / 3.0d+00 &
1101 * ( d3pn + 0.25d+00 * h * d4pn ) ) )
1102
1103 dp = dpn + h * ( d2pn + 0.5d+00 * h * ( d3pn + h * d4pn / 3.0d+00 ) )
1104
1105 h = h - p / dp
1106
1107 xtemp = x0 + h
1108
1109 x(mp1mi) = xtemp
1110
1111 fx = d1 - h * e1 * ( pk + 0.5d+00 * h * ( dpn + h / 3.0d+00 &
1112 * ( d2pn + 0.25d+00 * h * ( d3pn + 0.2d+00 * h * d4pn ) ) ) )
1113
1114 end do
1115
1116 if ( mod( n, 2 ) == 1 ) then
1117 x(1) = 0.0d+00
1118 end if
1119!
1120! Shift the data up.
1121!
1122 nmove = ( n + 1 ) / 2
1123 ncopy = n - nmove
1124
1125 do i = 1, nmove
1126 iback = n + 1 - i
1127 x(iback) = x(iback-ncopy)
1128 end do
1129!
1130! Reflect values for the negative abscissas.
1131!
1132 do i = 1, n - nmove
1133 x(i) = - x(n+1-i)
1134 end do
1135
1136 return
r8_pi
real(kind=8) function r8_pi()
Definition R8LIB.f90:4439

References r8_pi().

Referenced by r8vec_legendre().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ perm_check0()

subroutine perm_check0 ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p 
)

Definition at line 1138 of file R8LIB.f90.

1139
1140!*****************************************************************************80
1141!
1142!! PERM_CHECK0 checks a 0-based permutation.
1143!
1144! Discussion:
1145!
1146! The routine verifies that each of the integers from 0 to
1147! to N-1 occurs among the N entries of the permutation.
1148!
1149! Licensing:
1150!
1151! This code is distributed under the GNU LGPL license.
1152!
1153! Modified:
1154!
1155! 24 October 2014
1156!
1157! Author:
1158!
1159! John Burkardt
1160!
1161! Parameters:
1162!
1163! Input, integer ( kind = 4 ) N, the number of entries.
1164!
1165! Input, integer ( kind = 4 ) P(N), the array to check.
1166!
1167 implicit none
1168
1169 integer ( kind = 4 ) n
1170
1171 integer ( kind = 4 ) ierror
1172 integer ( kind = 4 ) location
1173 integer ( kind = 4 ) p(n)
1174 integer ( kind = 4 ) value
1175
1176 do value = 0, n - 1
1177
1178 ierror = 1
1179
1180 do location = 1, n
1181 if ( p(location) == value ) then
1182 ierror = 0
1183 exit
1184 end if
1185 end do
1186
1187 if ( ierror /= 0 ) then
1188 write ( *, '(a)' ) ' '
1189 write ( *, '(a)' ) 'PERM_CHECK0 - Fatal error!'
1190 write ( *, '(a,i4)' ) ' Permutation is missing value ', value
1191 stop 1
1192 end if
1193
1194 end do
1195
1196 return

◆ perm_check1()

subroutine perm_check1 ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p 
)

Definition at line 1198 of file R8LIB.f90.

1199
1200!*****************************************************************************80
1201!
1202!! PERM_CHECK1 checks a 1-based permutation.
1203!
1204! Discussion:
1205!
1206! The routine verifies that each of the integers from 1 to
1207! to N occurs among the N entries of the permutation.
1208!
1209! Licensing:
1210!
1211! This code is distributed under the GNU LGPL license.
1212!
1213! Modified:
1214!
1215! 24 October 2014
1216!
1217! Author:
1218!
1219! John Burkardt
1220!
1221! Parameters:
1222!
1223! Input, integer ( kind = 4 ) N, the number of entries.
1224!
1225! Input, integer ( kind = 4 ) P(N), the array to check.
1226!
1227 implicit none
1228
1229 integer ( kind = 4 ) n
1230
1231 integer ( kind = 4 ) ierror
1232 integer ( kind = 4 ) location
1233 integer ( kind = 4 ) p(n)
1234 integer ( kind = 4 ) value
1235
1236 do value = 1, n
1237
1238 ierror = 1
1239
1240 do location = 1, n
1241 if ( p(location) == value ) then
1242 ierror = 0
1243 exit
1244 end if
1245 end do
1246
1247 if ( ierror /= 0 ) then
1248 write ( *, '(a)' ) ' '
1249 write ( *, '(a)' ) 'PERM_CHECK1 - Fatal error!'
1250 write ( *, '(a,i4)' ) ' Permutation is missing value ', value
1251 stop 1
1252 end if
1253
1254 end do
1255
1256 return

Referenced by i4vec_permute(), r82vec_permute(), r8col_permute(), and r8vec_permute().

Here is the caller graph for this function:

◆ perm_uniform()

subroutine perm_uniform ( integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
integer ( kind = 4 ), dimension(n)  p 
)

Definition at line 1258 of file R8LIB.f90.

1259
1260!*****************************************************************************80
1261!
1262!! PERM_UNIFORM selects a random permutation of N objects.
1263!
1264! Licensing:
1265!
1266! This code is distributed under the GNU LGPL license.
1267!
1268! Modified:
1269!
1270! 18 November 2008
1271!
1272! Author:
1273!
1274! John Burkardt
1275!
1276! Reference:
1277!
1278! Albert Nijenhuis, Herbert Wilf,
1279! Combinatorial Algorithms for Computers and Calculators,
1280! Academic Press, 1978,
1281! ISBN: 0-12-519260-6,
1282! LC: QA164.N54.
1283!
1284! Parameters:
1285!
1286! Input, integer ( kind = 4 ) N, the number of objects to be permuted.
1287!
1288! Input/output, integer ( kind = 4 ) SEED, a seed for the random
1289! number generator.
1290!
1291! Output, integer ( kind = 4 ) P(N), the permutation. P(I) is the "new"
1292! location of the object originally at I.
1293!
1294 implicit none
1295
1296 integer ( kind = 4 ) n
1297
1298 integer ( kind = 4 ) i
1299 integer ( kind = 4 ) i4_uniform_ab
1300 integer ( kind = 4 ) j
1301 integer ( kind = 4 ) k
1302 integer ( kind = 4 ) p(n)
1303 integer ( kind = 4 ) seed
1304
1305 do i = 1, n
1306 p(i) = i
1307 end do
1308
1309 do i = 1, n
1310 j = i4_uniform_ab( i, n, seed )
1311 k = p(i)
1312 p(i) = p(j)
1313 p(j) = k
1314 end do
1315
1316 return

Referenced by r8vec_permute_uniform().

Here is the caller graph for this function:

◆ r82_cheby()

subroutine r82_cheby ( integer ( kind = 4 )  n,
real ( kind = 8 )  alo,
real ( kind = 8 )  ahi,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 6626 of file R8LIB.f90.

6627
6628!*****************************************************************************80
6629!
6630!! R82_CHEBY sets up the Chebyshev abscissas in an R8 interval.
6631!
6632! Discussion:
6633!
6634! The routine sets up a vector of X values spaced between the values
6635! XLO and XHI in a similar way to the spacing of the Chebyshev
6636! points of the same order in the interval [-1,1].
6637!
6638! Licensing:
6639!
6640! This code is distributed under the GNU LGPL license.
6641!
6642! Modified:
6643!
6644! 07 December 2004
6645!
6646! Author:
6647!
6648! John Burkardt
6649!
6650! Parameters:
6651!
6652! Input, integer ( kind = 4 ) N, the number of points to compute.
6653!
6654! Input, real ( kind = 8 ) ALO, AHI, the range.
6655!
6656! Output, real ( kind = 8 ) A(N), the computed X values.
6657!
6658 implicit none
6659
6660 integer ( kind = 4 ) n
6661
6662 real ( kind = 8 ) a(n)
6663 real ( kind = 8 ) ahi
6664 real ( kind = 8 ) alo
6665 real ( kind = 8 ) arg
6666 integer ( kind = 4 ) i
6667 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
6668
6669 if ( n == 1 ) then
6670
6671 a(1) = 0.5d+00 * ( alo + ahi )
6672
6673 else if ( 1 < n ) then
6674
6675 do i = 1, n
6676
6677 arg = real( 2 * i - 1, kind = 8 ) * r8_pi &
6678 / real( 2 * n, kind = 8 )
6679
6680 a(i) = 0.5d+00 * ( ( 1.0d+00 + cos( arg ) ) * alo &
6681 + ( 1.0d+00 - cos( arg ) ) * ahi )
6682
6683 end do
6684
6685 end if
6686
6687 return

References r8_pi().

Here is the call graph for this function:

◆ r82_dist_l2()

real ( kind = 8 ) function r82_dist_l2 ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6689 of file R8LIB.f90.

6690
6691!*****************************************************************************80
6692!
6693!! R82_DIST_L2 returns the L2 distance between a pair of R82's.
6694!
6695! Discussion:
6696!
6697! An R82 is a vector of type R8, with two entries.
6698!
6699! The vector L2 norm is defined as:
6700!
6701! sqrt ( sum ( 1 <= I <= N ) A(I) * A(I) ).
6702!
6703! Licensing:
6704!
6705! This code is distributed under the GNU LGPL license.
6706!
6707! Modified:
6708!
6709! 08 December 2004
6710!
6711! Author:
6712!
6713! John Burkardt
6714!
6715! Parameters:
6716!
6717! Input, real ( kind = 8 ) A1(2), A2(2), the vectors.
6718!
6719! Output, real ( kind = 8 ) R82_DIST_L2, the L2 norm of the distance
6720! between A1 and A2.
6721!
6722 implicit none
6723
6724 integer ( kind = 4 ), parameter :: dim_num = 2
6725
6726 real ( kind = 8 ) a1(dim_num)
6727 real ( kind = 8 ) a2(dim_num)
6728 real ( kind = 8 ) r82_dist_l2
6729
6730 r82_dist_l2 = sqrt( sum( ( a1(1:dim_num) - a2(1:dim_num) )**2 ) )
6731
6732 return
r82_dist_l2
real(kind=8) function r82_dist_l2(a1, a2)
Definition R8LIB.f90:6690

References r82_dist_l2().

Referenced by r82_dist_l2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_eq()

logical ( kind = 4 ) function r82_eq ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6734 of file R8LIB.f90.

6735
6736!*****************************************************************************80
6737!
6738!! R82_EQ == ( A1 == A2 ) for two R82's.
6739!
6740! Discussion:
6741!
6742! An R82 is a vector of type R8, with two entries.
6743!
6744! The comparison is lexicographic.
6745!
6746! A1 == A2 <=> A1(1) == A2(1) and A1(2) == A2(2).
6747!
6748! Licensing:
6749!
6750! This code is distributed under the GNU LGPL license.
6751!
6752! Modified:
6753!
6754! 08 December 2004
6755!
6756! Author:
6757!
6758! John Burkardt
6759!
6760! Parameters:
6761!
6762! Input, real ( kind = 8 ) A1(2), A2(2), two R82 vectors to be compared.
6763!
6764! Output, logical ( kind = 4 ) R82_EQ, is TRUE if and only if A1 == A2.
6765!
6766 implicit none
6767
6768 integer ( kind = 4 ), parameter :: dim_num = 2
6769
6770 real ( kind = 8 ) a1(dim_num)
6771 real ( kind = 8 ) a2(dim_num)
6772 logical ( kind = 4 ) r82_eq
6773
6774 if ( all( a1(1:dim_num) == a2(1:dim_num) ) ) then
6775 r82_eq = .true.
6776 else
6777 r82_eq = .false.
6778 end if
6779
6780 return
r82_eq
logical(kind=4) function r82_eq(a1, a2)
Definition R8LIB.f90:6735

References r82_eq().

Referenced by r82_eq().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_ge()

logical ( kind = 4 ) function r82_ge ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6782 of file R8LIB.f90.

6783
6784!*****************************************************************************80
6785!
6786!! R82_GE == ( A1 >= A2 ) for two R82's.
6787!
6788! Discussion:
6789!
6790! An R82 is a vector of type R8, with two entries.
6791!
6792! The comparison is lexicographic.
6793!
6794! A1 >= A2 <=> A1(1) > A2(1) or ( A1(1) == A2(1) and A1(2) >= A2(2) ).
6795!
6796! Licensing:
6797!
6798! This code is distributed under the GNU LGPL license.
6799!
6800! Modified:
6801!
6802! 08 December 2004
6803!
6804! Author:
6805!
6806! John Burkardt
6807!
6808! Parameters:
6809!
6810! Input, real ( kind = 8 ) A1(2), A2(2), R82 vectors to be compared.
6811!
6812! Output, logical ( kind = 4 ) R82_GE, is TRUE if and only if A1 >= A2.
6813!
6814 implicit none
6815
6816 integer ( kind = 4 ), parameter :: dim_num = 2
6817
6818 real ( kind = 8 ) a1(dim_num)
6819 real ( kind = 8 ) a2(dim_num)
6820 integer ( kind = 4 ) i
6821 logical ( kind = 4 ) r82_ge
6822
6823 r82_ge = .true.
6824
6825 do i = 1, dim_num
6826
6827 if ( a2(i) < a1(i) ) then
6828 r82_ge = .true.
6829 exit
6830 else if ( a1(i) < a2(i) ) then
6831 r82_ge = .false.
6832 exit
6833 end if
6834
6835 end do
6836
6837 return
r82_ge
logical(kind=4) function r82_ge(a1, a2)
Definition R8LIB.f90:6783

References r82_ge().

Referenced by r82_ge().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_gt()

logical ( kind = 4 ) function r82_gt ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6839 of file R8LIB.f90.

6840
6841!*****************************************************************************80
6842!
6843!! R82_GT == ( A1 > A2 ) for two R82's.
6844!
6845! Discussion:
6846!
6847! An R82 is a vector of type R2, with two entries.
6848!
6849! The comparison is lexicographic.
6850!
6851! A1 > A2 <=> A1(1) > A2(1) or ( A1(1) == A2(1) and A1(2) > A2(2) ).
6852!
6853! Licensing:
6854!
6855! This code is distributed under the GNU LGPL license.
6856!
6857! Modified:
6858!
6859! 08 December 2004
6860!
6861! Author:
6862!
6863! John Burkardt
6864!
6865! Parameters:
6866!
6867! Input, real ( kind = 8 ) A1(2), A2(2), R82 vectors to be compared.
6868!
6869! Output, logical ( kind = 4 ) R82_GT, is TRUE if and only if A1 > A2.
6870!
6871 implicit none
6872
6873 integer ( kind = 4 ), parameter :: dim_num = 2
6874
6875 real ( kind = 8 ) a1(dim_num)
6876 real ( kind = 8 ) a2(dim_num)
6877 integer ( kind = 4 ) i
6878 logical ( kind = 4 ) r82_gt
6879
6880 r82_gt = .false.
6881
6882 do i = 1, dim_num
6883
6884 if ( a2(i) < a1(i) ) then
6885 r82_gt = .true.
6886 exit
6887 else if ( a1(i) < a2(i) ) then
6888 r82_gt = .false.
6889 exit
6890 end if
6891
6892 end do
6893
6894 return
r82_gt
logical(kind=4) function r82_gt(a1, a2)
Definition R8LIB.f90:6840

References r82_gt().

Referenced by r82_gt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_le()

logical ( kind = 4 ) function r82_le ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6896 of file R8LIB.f90.

6897
6898!*****************************************************************************80
6899!
6900!! R82_LE == ( A1 <= A2 ) for two R82's.
6901!
6902! Discussion:
6903!
6904! An R82 is a vector of type R8, with two entries.
6905!
6906! The comparison is lexicographic.
6907!
6908! A1 <= A2 <=> A1(1) < A2(1) or ( A1(1) == A2(1) and A1(2) <= A2(2) ).
6909!
6910! Licensing:
6911!
6912! This code is distributed under the GNU LGPL license.
6913!
6914! Modified:
6915!
6916! 08 December 2004
6917!
6918! Author:
6919!
6920! John Burkardt
6921!
6922! Parameters:
6923!
6924! Input, real ( kind = 8 ) A1(2), A2(2), R82 vectors to be compared.
6925!
6926! Output, logical ( kind = 4 ) R82_LE, is TRUE if and only if A1 <= A2.
6927!
6928 implicit none
6929
6930 integer ( kind = 4 ), parameter :: dim_num = 2
6931
6932 real ( kind = 8 ) a1(dim_num)
6933 real ( kind = 8 ) a2(dim_num)
6934 integer ( kind = 4 ) i
6935 logical ( kind = 4 ) r82_le
6936
6937 r82_le = .true.
6938
6939 do i = 1, dim_num
6940
6941 if ( a1(i) < a2(i) ) then
6942 r82_le = .true.
6943 exit
6944 else if ( a2(i) < a1(i) ) then
6945 r82_le = .false.
6946 exit
6947 end if
6948
6949 end do
6950
6951 return
r82_le
logical(kind=4) function r82_le(a1, a2)
Definition R8LIB.f90:6897

References r82_le().

Referenced by r82_le().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_lt()

logical ( kind = 4 ) function r82_lt ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 6953 of file R8LIB.f90.

6954
6955!*****************************************************************************80
6956!
6957!! R82_LT == ( A1 < A2 ) for two R82's.
6958!
6959! Discussion:
6960!
6961! An R82 is a vector of type R8, with two entries.
6962!
6963! The comparison is lexicographic.
6964!
6965! A1 < A2 <=> A1(1) < A2(1) or ( A1(1) == A2(1) and A1(2) < A2(2) ).
6966!
6967! Licensing:
6968!
6969! This code is distributed under the GNU LGPL license.
6970!
6971! Modified:
6972!
6973! 08 December 2004
6974!
6975! Author:
6976!
6977! John Burkardt
6978!
6979! Parameters:
6980!
6981! Input, real ( kind = 8 ) A1(2), A2(2), R82 vectors to be compared.
6982!
6983! Output, logical ( kind = 4 ) R82_LT, is TRUE if and only if A1 < A2.
6984!
6985 implicit none
6986
6987 integer ( kind = 4 ), parameter :: dim_num = 2
6988
6989 real ( kind = 8 ) a1(dim_num)
6990 real ( kind = 8 ) a2(dim_num)
6991 integer ( kind = 4 ) i
6992 logical ( kind = 4 ) r82_lt
6993
6994 r82_lt = .false.
6995
6996 do i = 1, dim_num
6997
6998 if ( a1(i) < a2(i) ) then
6999 r82_lt = .true.
7000 exit
7001 else if ( a2(i) < a1(i) ) then
7002 r82_lt = .false.
7003 exit
7004 end if
7005
7006 end do
7007
7008 return
r82_lt
logical(kind=4) function r82_lt(a1, a2)
Definition R8LIB.f90:6954

References r82_lt().

Referenced by r82_lt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_ne()

logical ( kind = 4 ) function r82_ne ( real ( kind = 8 ), dimension(dim_num)  a1,
real ( kind = 8 ), dimension(dim_num)  a2 
)

Definition at line 7010 of file R8LIB.f90.

7011
7012!*****************************************************************************80
7013!
7014!! R82_NE == ( A1 /= A2 ) for two R82's.
7015!
7016! Discussion:
7017!
7018! An R82 is a vector of type R8, with two entries.
7019!
7020! The comparison is lexicographic.
7021!
7022! A1 /= A2 <=> A1(1) /= A2(1) or A1(2) /= A2(2).
7023!
7024! Licensing:
7025!
7026! This code is distributed under the GNU LGPL license.
7027!
7028! Modified:
7029!
7030! 08 December 2004
7031!
7032! Author:
7033!
7034! John Burkardt
7035!
7036! Parameters:
7037!
7038! Input, real ( kind = 8 ) A1(2), A2(2), R82 vectors to be compared.
7039!
7040! Output, logical ( kind = 4 ) R82_NE, is TRUE if and only if A1 /= A2.
7041!
7042 implicit none
7043
7044 integer ( kind = 4 ), parameter :: dim_num = 2
7045
7046 real ( kind = 8 ) a1(dim_num)
7047 real ( kind = 8 ) a2(dim_num)
7048 logical ( kind = 4 ) r82_ne
7049
7050 if ( any( a1(1:dim_num) /= a2(1:dim_num) ) ) then
7051 r82_ne = .true.
7052 else
7053 r82_ne = .false.
7054 end if
7055
7056 return
r82_ne
logical(kind=4) function r82_ne(a1, a2)
Definition R8LIB.f90:7011

References r82_ne().

Referenced by r82_ne().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_norm()

real ( kind = 8 ) function r82_norm ( real ( kind = 8 ), dimension(2)  a)

Definition at line 7058 of file R8LIB.f90.

7059
7060!*****************************************************************************80
7061!
7062!! R82_NORM returns the Euclidean norm of an R82.
7063!
7064! Discussion:
7065!
7066! An R82 is a vector of type R8, with two entries.
7067!
7068! Licensing:
7069!
7070! This code is distributed under the GNU LGPL license.
7071!
7072! Modified:
7073!
7074! 11 October 2010
7075!
7076! Author:
7077!
7078! John Burkardt
7079!
7080! Parameters:
7081!
7082! Input, real ( kind = 8 ) A(2), the vector.
7083!
7084! Output, real ( kind = 8 ) R82_NORM, the norm.
7085!
7086 implicit none
7087
7088 real ( kind = 8 ) a(2)
7089 real ( kind = 8 ) r82_norm
7090
7091 r82_norm = sqrt( a(1) * a(1) + a(2) * a(2) )
7092
7093 return
r82_norm
real(kind=8) function r82_norm(a)
Definition R8LIB.f90:7059

References r82_norm().

Referenced by r82_norm().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82_normalize()

subroutine r82_normalize ( real ( kind = 8 ), dimension(2)  a)

Definition at line 7095 of file R8LIB.f90.

7096
7097!*****************************************************************************80
7098!
7099!! R82_NORMALIZE Euclidean normalizes an R82.
7100!
7101! Discussion:
7102!
7103! An R82 is a vector of type R8, with two entries.
7104!
7105! Licensing:
7106!
7107! This code is distributed under the GNU LGPL license.
7108!
7109! Modified:
7110!
7111! 27 October 2005
7112!
7113! Author:
7114!
7115! John Burkardt
7116!
7117! Parameters:
7118!
7119! Input/output, real ( kind = 8 ) A(2), the components of the vector.
7120!
7121 implicit none
7122
7123 real ( kind = 8 ) a(2)
7124 real ( kind = 8 ) norm
7125
7126 norm = sqrt( a(1) * a(1) + a(2) * a(2) )
7127
7128 if ( norm /= 0.0d+00 ) then
7129 a(1:2) = a(1:2) / norm
7130 end if
7131
7132 return

◆ r82_print()

subroutine r82_print ( real ( kind = 8 ), dimension(2)  a,
character ( len = * )  title 
)

Definition at line 7134 of file R8LIB.f90.

7135
7136!*****************************************************************************80
7137!
7138!! R82_PRINT prints an R82.
7139!
7140! Discussion:
7141!
7142! An R82 is a vector of type R8, with two entries.
7143!
7144! A format is used which suggests a coordinate pair:
7145!
7146! Example:
7147!
7148! Center : ( 1.23, 7.45 )
7149!
7150! Licensing:
7151!
7152! This code is distributed under the GNU LGPL license.
7153!
7154! Modified:
7155!
7156! 05 December 2004
7157!
7158! Author:
7159!
7160! John Burkardt
7161!
7162! Parameters:
7163!
7164! Input, real ( kind = 8 ) A(2), the coordinates of the vector.
7165!
7166! Input, character ( len = * ) TITLE, a title.
7167!
7168 implicit none
7169
7170 real ( kind = 8 ) a(2)
7171 character ( len = * ) title
7172
7173 if ( 0 < len_trim( title ) ) then
7174 write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1 )' ) &
7175 trim( title ), ' : (', a(1), ',', a(2), ')'
7176 else
7177 write ( *, '( 2x, a1, g14.6, a1, g14.6, a1 )' ) '(', a(1), ',', a(2), ')'
7178
7179 end if
7180
7181 return

◆ r82_swap()

subroutine r82_swap ( real ( kind = 8 ), dimension(dim_num)  x,
real ( kind = 8 ), dimension(dim_num)  y 
)

Definition at line 7183 of file R8LIB.f90.

7184
7185!*****************************************************************************80
7186!
7187!! R82_SWAP swaps two R82 values.
7188!
7189! Discussion:
7190!
7191! An R82 is a vector of type R8, with two entries.
7192!
7193! Licensing:
7194!
7195! This code is distributed under the GNU LGPL license.
7196!
7197! Modified:
7198!
7199! 08 December 2004
7200!
7201! Author:
7202!
7203! John Burkardt
7204!
7205! Parameters:
7206!
7207! Input/output, real ( kind = 8 ) X(2), Y(2). On output, the values of X and
7208! Y have been interchanged.
7209!
7210 implicit none
7211
7212 integer ( kind = 4 ), parameter :: dim_num = 2
7213
7214 real ( kind = 8 ) x(dim_num)
7215 real ( kind = 8 ) y(dim_num)
7216 real ( kind = 8 ) z(dim_num)
7217
7218 z(1:dim_num) = x(1:dim_num)
7219 x(1:dim_num) = y(1:dim_num)
7220 y(1:dim_num) = z(1:dim_num)
7221
7222 return

◆ r82_uniform_ab()

subroutine r82_uniform_ab ( real ( kind = 8 )  b,
real ( kind = 8 )  c,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(dim_num)  a 
)

Definition at line 7224 of file R8LIB.f90.

7225
7226!*****************************************************************************80
7227!
7228!! R82_UNIFORM_AB returns a random R82 value in a given range.
7229!
7230! Discussion:
7231!
7232! An R82 is a vector of type R8, with two entries.
7233!
7234! Licensing:
7235!
7236! This code is distributed under the GNU LGPL license.
7237!
7238! Modified:
7239!
7240! 08 December 2004
7241!
7242! Author:
7243!
7244! John Burkardt
7245!
7246! Parameters:
7247!
7248! Input, real ( kind = 8 ) B, C, the minimum and maximum values.
7249!
7250! Input/output, integer ( kind = 4 ) SEED, a seed for the random number
7251! generator.
7252!
7253! Output, real ( kind = 8 ) A(2), the randomly chosen value.
7254!
7255 implicit none
7256
7257 integer ( kind = 4 ), parameter :: dim_num = 2
7258
7259 real ( kind = 8 ) a(dim_num)
7260 real ( kind = 8 ) b
7261 real ( kind = 8 ) c
7262 real ( kind = 8 ) r8_uniform_ab
7263 integer ( kind = 4 ) i
7264 integer ( kind = 4 ) seed
7265
7266 do i = 1, dim_num
7267 a(i) = r8_uniform_ab( b, c, seed )
7268 end do
7269
7270 return
r8_uniform_ab
real(kind=8) function r8_uniform_ab(a, b, seed)
Definition R8LIB.f90:6352

References r8_uniform_ab().

Here is the call graph for this function:

◆ r82poly2_print()

subroutine r82poly2_print ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
real ( kind = 8 )  d,
real ( kind = 8 )  e,
real ( kind = 8 )  f 
)

Definition at line 7272 of file R8LIB.f90.

7273
7274!*****************************************************************************80
7275!
7276!! R82POLY2_PRINT prints a second order polynomial in two variables.
7277!
7278! Licensing:
7279!
7280! This code is distributed under the GNU LGPL license.
7281!
7282! Modified:
7283!
7284! 09 December 2004
7285!
7286! Author:
7287!
7288! John Burkardt
7289!
7290! Parameters:
7291!
7292! Input, real ( kind = 8 ) A, B, C, D, E, F, the coefficients.
7293!
7294 implicit none
7295
7296 real ( kind = 8 ) a
7297 real ( kind = 8 ) b
7298 real ( kind = 8 ) c
7299 real ( kind = 8 ) d
7300 real ( kind = 8 ) e
7301 real ( kind = 8 ) f
7302
7303 write ( *, &
7304 '( 2x, f8.4, '' * x^2 + '', f8.4, '' * y^2 + '', f8.4, '' * xy + '' )' ) &
7305 a, b, c
7306
7307 write ( *, &
7308 '( 2x, f8.4, '' * x + '', f8.4, '' * y + '', f8.4, '' = 0 '' )' ) d, e, f
7309
7310 return

◆ r82poly2_type()

subroutine r82poly2_type ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
real ( kind = 8 )  d,
real ( kind = 8 )  e,
real ( kind = 8 )  f,
integer ( kind = 4 )  type 
)

Definition at line 7312 of file R8LIB.f90.

7313
7314!*****************************************************************************80
7315!
7316!! R82POLY2_TYPE analyzes a second order polynomial in two variables.
7317!
7318! Discussion:
7319!
7320! The polynomial has the form
7321!
7322! A x^2 + B y^2 + C xy + Dx + Ey + F = 0
7323!
7324! The possible types of the solution set are:
7325!
7326! 1: a hyperbola;
7327! 9x^2 - 4y^2 -36x - 24y - 36 = 0
7328! 2: a parabola;
7329! 4x^2 + 1y^2 - 4xy + 3x - 4y + 1 = 0;
7330! 3: an ellipse;
7331! 9x^2 + 16y^2 +36x - 32y - 92 = 0;
7332! 4: an imaginary ellipse (no real solutions);
7333! x^2 + y^2 - 6x - 10y + 115 = 0;
7334! 5: a pair of intersecting lines;
7335! xy + 3x - y - 3 = 0
7336! 6: one point;
7337! x^2 + 2y^2 - 2x + 16y + 33 = 0;
7338! 7: a pair of distinct parallel lines;
7339! y^2 - 6y + 8 = 0
7340! 8: a pair of imaginary parallel lines (no real solutions);
7341! y^2 - 6y + 10 = 0
7342! 9: a pair of coincident lines.
7343! y^2 - 2y + 1 = 0
7344! 10: a single line;
7345! 2x - y + 1 = 0;
7346! 11; all space;
7347! 0 = 0;
7348! 12; no solutions;
7349! 1 = 0;
7350!
7351! Licensing:
7352!
7353! This code is distributed under the GNU LGPL license.
7354!
7355! Modified:
7356!
7357! 09 December 2004
7358!
7359! Author:
7360!
7361! John Burkardt
7362!
7363! Reference:
7364!
7365! Daniel Zwillinger, editor,
7366! CRC Standard Mathematical Tables and Formulae,
7367! CRC Press, 30th Edition, 1996, pages 282-284.
7368!
7369! Parameters:
7370!
7371! Input, real ( kind = 8 ) A, B, C, D, E, F, the coefficients.
7372!
7373! Output, integer ( kind = 4 ) TYPE, indicates the type of the solution set.
7374!
7375 implicit none
7376
7377 real ( kind = 8 ) a
7378 real ( kind = 8 ) b
7379 real ( kind = 8 ) c
7380 real ( kind = 8 ) d
7381 real ( kind = 8 ) delta
7382 real ( kind = 8 ) e
7383 real ( kind = 8 ) f
7384 real ( kind = 8 ) j
7385 real ( kind = 8 ) k
7386 integer ( kind = 4 ) type
7387!
7388! Handle the degenerate case.
7389!
7390 if ( a == 0.0d+00 .and. &
7391 b == 0.0d+00 .and. &
7392 c == 0.0d+00 ) then
7393 if ( d == 0.0d+00 .and. e == 0.0d+00 ) then
7394 if ( f == 0.0d+00 ) then
7395 type = 11
7396 else
7397 type = 12
7398 end if
7399 else
7400 type = 10
7401 end if
7402 return
7403 end if
7404
7405 delta = &
7406 8.0d+00 * a * b * f &
7407 + 2.0d+00 * c * e * d &
7408 - 2.0d+00 * a * e * e &
7409 - 2.0d+00 * b * d * d &
7410 - 2.0d+00 * f * c * c
7411
7412 j = 4.0d+00 * a * b - c * c
7413
7414 if ( delta /= 0.0d+00 ) then
7415 if ( j < 0.0d+00 ) then
7416 type = 1
7417 else if ( j == 0.0d+00 ) then
7418 type = 2
7419 else if ( 0.0d+00 < j ) then
7420 if ( sign( 1.0d+00, delta ) /= sign( 1.0d+00, ( a + b ) ) ) then
7421 type = 3
7422 else if ( sign( 1.0d+00, delta ) == sign( 1.0d+00, ( a + b ) ) ) then
7423 type = 4
7424 end if
7425 end if
7426 else if ( delta == 0.0d+00 ) then
7427 if ( j < 0.0d+00 ) then
7428 type = 5
7429 else if ( 0.0d+00 < j ) then
7430 type = 6
7431 else if ( j == 0.0d+00 ) then
7432
7433 k = 4.0d+00 * ( a + b ) * f - d * d - e * e
7434
7435 if ( k < 0.0d+00 ) then
7436 type = 7
7437 else if ( 0.0d+00 < k ) then
7438 type = 8
7439 else if ( k == 0.0d+00 ) then
7440 type = 9
7441 end if
7442
7443 end if
7444 end if
7445
7446 return

◆ r82poly2_type_print()

subroutine r82poly2_type_print ( integer ( kind = 4 )  type)

Definition at line 7448 of file R8LIB.f90.

7449
7450!*****************************************************************************80
7451!
7452!! R82POLY2_TYPE_PRINT prints the meaning of the output from R82POLY2_TYPE.
7453!
7454! Licensing:
7455!
7456! This code is distributed under the GNU LGPL license.
7457!
7458! Modified:
7459!
7460! 09 December 2004
7461!
7462! Author:
7463!
7464! John Burkardt
7465!
7466! Parameters:
7467!
7468! Input, integer ( kind = 4 ) TYPE, the type index returned by R82POLY2_TYPE.
7469!
7470 implicit none
7471
7472 integer ( kind = 4 ) type
7473
7474 if ( type == 1 ) then
7475 write ( *, '(a)' ) ' The set of solutions forms a hyperbola.'
7476 else if ( type == 2 ) then
7477 write ( *, '(a)' ) ' The set of solutions forms a parabola.'
7478 else if ( type == 3 ) then
7479 write ( *, '(a)' ) ' The set of solutions forms an ellipse.'
7480 else if ( type == 4 ) then
7481 write ( *, '(a)' ) ' The set of solutions forms an imaginary ellipse.'
7482 write ( *, '(a)' ) ' (There are no real solutions).'
7483 else if ( type == 5 ) then
7484 write ( *, '(a)' ) &
7485 ' The set of solutions forms a pair of intersecting lines.'
7486 else if ( type == 6 ) then
7487 write ( *, '(a)' ) ' The set of solutions is a single point.'
7488 else if ( type == 7 ) then
7489 write ( *, '(a)' ) &
7490 ' The set of solutions form a pair of distinct parallel lines.'
7491 else if ( type == 8 ) then
7492 write ( *, '(a)' ) &
7493 ' The set of solutions forms a pair of imaginary parallel lines.'
7494 write ( *, '(a)' ) ' (There are no real solutions).'
7495 else if ( type == 9 ) then
7496 write ( *, '(a)' ) &
7497 ' The set of solutions forms a pair of coincident lines.'
7498 else if ( type == 10 ) then
7499 write ( *, '(a)' ) ' The set of solutions forms a single line.'
7500 else if ( type == 11 ) then
7501 write ( *, '(a)' ) ' The set of solutions is all space.'
7502 else if ( type == 12 ) then
7503 write ( *, '(a)' ) ' The set of solutions is empty.'
7504 else
7505 write ( *, '(a)' ) ' This type index is unknown.'
7506 end if
7507
7508 return

◆ r82vec_max()

subroutine r82vec_max ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(2,n)  a,
real ( kind = 8 ), dimension(2)  amax 
)

Definition at line 7510 of file R8LIB.f90.

7511
7512!*****************************************************************************80
7513!
7514!! R82VEC_MAX returns the maximum value in an R82VEC.
7515!
7516! Discussion:
7517!
7518! An R82VEC is an array of pairs of R8's.
7519!
7520! Licensing:
7521!
7522! This code is distributed under the GNU LGPL license.
7523!
7524! Modified:
7525!
7526! 21 June 2006
7527!
7528! Author:
7529!
7530! John Burkardt
7531!
7532! Parameters:
7533!
7534! Input, integer ( kind = 4 ) N, the number of entries in the array.
7535!
7536! Input, real ( kind = 8 ) A(2,N), the array.
7537!
7538! Output, real ( kind = 8 ) AMAX(2); the largest entries in each row.
7539!
7540 implicit none
7541
7542 integer ( kind = 4 ) n
7543
7544 real ( kind = 8 ) a(2,n)
7545 real ( kind = 8 ) amax(2)
7546
7547 amax(1) = maxval( a(1,1:n) )
7548 amax(2) = maxval( a(2,1:n) )
7549
7550 return

◆ r82vec_min()

subroutine r82vec_min ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(2,n)  a,
real ( kind = 8 ), dimension(2)  amin 
)

Definition at line 7552 of file R8LIB.f90.

7553
7554!*****************************************************************************80
7555!
7556!! R82VEC_MIN returns the minimum value in an R82VEC.
7557!
7558! Discussion:
7559!
7560! An R82VEC is an array of pairs of R82's.
7561!
7562! Licensing:
7563!
7564! This code is distributed under the GNU LGPL license.
7565!
7566! Modified:
7567!
7568! 21 June 2006
7569!
7570! Author:
7571!
7572! John Burkardt
7573!
7574! Parameters:
7575!
7576! Input, integer ( kind = 4 ) N, the number of entries in the array.
7577!
7578! Input, real ( kind = 8 ) A(2,N), the array.
7579!
7580! Output, real ( kind = 8 ) AMIN(2); the smallest entries in each row.
7581!
7582 implicit none
7583
7584 integer ( kind = 4 ) n
7585
7586 real ( kind = 8 ) a(2,n)
7587 real ( kind = 8 ) amin(2)
7588
7589 amin(1) = minval( a(1,1:n) )
7590 amin(2) = minval( a(2,1:n) )
7591
7592 return

◆ r82vec_order_type()

subroutine r82vec_order_type ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  a,
integer ( kind = 4 )  order 
)

Definition at line 7594 of file R8LIB.f90.

7595
7596!*****************************************************************************80
7597!
7598!! R82VEC_ORDER_TYPE finds the order type of an R82VEC.
7599!
7600! Discussion:
7601!
7602! An R82VEC is an array of pairs of R8 values.
7603!
7604! The dictionary or lexicographic ordering is used.
7605!
7606! (X1,Y1) < (X2,Y2) <=> X1 < X2 or ( X1 = X2 and Y1 < Y2).
7607!
7608! Licensing:
7609!
7610! This code is distributed under the GNU LGPL license.
7611!
7612! Modified:
7613!
7614! 08 December 2004
7615!
7616! Author:
7617!
7618! John Burkardt
7619!
7620! Parameters:
7621!
7622! Input, integer ( kind = 4 ) N, the number of entries of the array.
7623!
7624! Input, real ( kind = 8 ) A(2,N), the array to be checked.
7625!
7626! Output, integer ( kind = 4 ) ORDER, order indicator:
7627! -1, no discernable order;
7628! 0, all entries are equal;
7629! 1, ascending order;
7630! 2, strictly ascending order;
7631! 3, descending order;
7632! 4, strictly descending order.
7633!
7634 implicit none
7635
7636 integer ( kind = 4 ) n
7637 integer ( kind = 4 ), parameter :: dim_num = 2
7638
7639 real ( kind = 8 ) a(dim_num,n)
7640 integer ( kind = 4 ) i
7641 integer ( kind = 4 ) order
7642!
7643! Search for the first value not equal to A(1,1).
7644!
7645 i = 1
7646
7647 do
7648
7649 i = i + 1
7650
7651 if ( n < i ) then
7652 order = 0
7653 return
7654 end if
7655
7656 if ( &
7657 a(1,1) < a(1,i) .or. &
7658 ( a(1,1) == a(1,i) .and. a(2,1) < a(2,i) ) &
7659 ) then
7660
7661 if ( i == 2 ) then
7662 order = 2
7663 else
7664 order = 1
7665 end if
7666
7667 exit
7668
7669 else if ( &
7670 a(1,i) < a(1,1) .or. &
7671 ( a(1,i) == a(1,1) .and. a(2,i) < a(2,1) ) &
7672 ) then
7673
7674 if ( i == 2 ) then
7675 order = 4
7676 else
7677 order = 3
7678 end if
7679
7680 exit
7681
7682 end if
7683
7684 end do
7685!
7686! Now we have a "direction". Examine subsequent entries.
7687!
7688 do
7689
7690 i = i + 1
7691 if ( n < i ) then
7692 exit
7693 end if
7694
7695 if ( order == 1 ) then
7696
7697 if ( &
7698 a(1,i) < a(1,i-1) .or. &
7699 ( a(1,i) == a(1,i-1) .and. a(2,i) < a(2,i-1) ) &
7700 ) then
7701 order = -1
7702 exit
7703 end if
7704
7705 else if ( order == 2 ) then
7706
7707 if ( &
7708 a(1,i) < a(1,i-1) .or. &
7709 ( a(1,i) == a(1,i-1) .and. a(2,i) < a(2,i-1) ) &
7710 ) then
7711 order = -1
7712 exit
7713 else if ( &
7714 a(1,i) == a(1,i-1) .and. a(2,i) == a(2,i-1) ) then
7715 order = 1
7716 end if
7717
7718 else if ( order == 3 ) then
7719
7720 if ( &
7721 a(1,i-1) < a(1,i) .or. &
7722 ( a(1,i-1) == a(1,i) .and. a(2,i-1) < a(2,i) ) &
7723 ) then
7724 order = -1
7725 exit
7726 end if
7727
7728 else if ( order == 4 ) then
7729
7730 if ( &
7731 a(1,i-1) < a(1,i) .or. &
7732 ( a(1,i-1) == a(1,i) .and. a(2,i-1) < a(2,i) ) &
7733 ) then
7734 order = -1
7735 exit
7736 else if ( a(1,i) == a(1,i-1) .and. a(2,i) == a(2,i-1) ) then
7737 order = 3
7738 end if
7739
7740 end if
7741
7742 end do
7743
7744 return

◆ r82vec_part_quick_a()

subroutine r82vec_part_quick_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  a,
integer ( kind = 4 )  l,
integer ( kind = 4 )  r 
)

Definition at line 7746 of file R8LIB.f90.

7747
7748!*****************************************************************************80
7749!
7750!! R82VEC_PART_QUICK_A reorders an R82VEC as part of a quick sort.
7751!
7752! Discussion:
7753!
7754! An R82VEC is an array of pairs of R82 values.
7755!
7756! The routine reorders the entries of A. Using A(1:2,1) as a
7757! key, all entries of A that are less than or equal to the key will
7758! precede the key, which precedes all entries that are greater than the key.
7759!
7760! Example:
7761!
7762! Input:
7763!
7764! N = 8
7765!
7766! A = ( (2,4), (8,8), (6,2), (0,2), (10,6), (10,0), (0,6), (4,8) )
7767!
7768! Output:
7769!
7770! L = 2, R = 4
7771!
7772! A = ( (0,2), (0,6), (2,4), (8,8), (6,2), (10,6), (10,0), (4,8) )
7773! ----------- ----------------------------------
7774! LEFT KEY RIGHT
7775!
7776! Licensing:
7777!
7778! This code is distributed under the GNU LGPL license.
7779!
7780! Modified:
7781!
7782! 08 December 2004
7783!
7784! Author:
7785!
7786! John Burkardt
7787!
7788! Parameters:
7789!
7790! Input, integer ( kind = 4 ) N, the number of entries of A.
7791!
7792! Input/output, real ( kind = 8 ) A(2,N). On input, the array to be checked.
7793! On output, A has been reordered as described above.
7794!
7795! Output, integer ( kind = 4 ) L, R, the indices of A that define the three
7796! segments. Let KEY = the input value of A(1:2,1). Then
7797! I <= L A(1:2,I) < KEY;
7798! L < I < R A(1:2,I) = KEY;
7799! R <= I KEY < A(1:2,I).
7800!
7801 implicit none
7802
7803 integer ( kind = 4 ) n
7804 integer ( kind = 4 ), parameter :: dim_num = 2
7805
7806 real ( kind = 8 ) a(dim_num,n)
7807 integer ( kind = 4 ) i
7808 real ( kind = 8 ) key(dim_num)
7809 integer ( kind = 4 ) l
7810 integer ( kind = 4 ) m
7811 integer ( kind = 4 ) r
7812 logical ( kind = 4 ) r8vec_eq
7813 logical ( kind = 4 ) r8vec_gt
7814 logical ( kind = 4 ) r8vec_lt
7815
7816 if ( n < 1 ) then
7817 write ( *, '(a)' ) ' '
7818 write ( *, '(a)' ) 'R82VEC_PART_QUICK_A - Fatal error!'
7819 write ( *, '(a)' ) ' N < 1.'
7820 write ( *, '(a,i8)' ) ' N = ', n
7821 stop 1
7822 else if ( n == 1 ) then
7823 l = 0
7824 r = 2
7825 return
7826 end if
7827
7828 key(1:dim_num) = a(1:dim_num,1)
7829 m = 1
7830!
7831! The elements of unknown size have indices between L+1 and R-1.
7832!
7833 l = 1
7834 r = n + 1
7835
7836 do i = 2, n
7837
7838 if ( r8vec_gt( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then
7839 r = r - 1
7840 call r8vec_swap ( dim_num, a(1:dim_num,r), a(1:dim_num,l+1) )
7841 else if ( r8vec_eq( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then
7842 m = m + 1
7843 call r8vec_swap ( dim_num, a(1:dim_num,m), a(1:dim_num,l+1) )
7844 l = l + 1
7845 else if ( r8vec_lt( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then
7846 l = l + 1
7847 end if
7848
7849 end do
7850!
7851! Now shift small elements to the left, and KEY elements to center.
7852!
7853 do i = 1, l - m
7854 a(1:dim_num,i) = a(1:dim_num,i+m)
7855 end do
7856
7857 l = l - m
7858
7859 do i = 1, dim_num
7860 a(i,l+1:l+m) = key(i)
7861 end do
7862
7863 return
r8vec_swap
subroutine r8vec_swap(n, a1, a2)
Definition R8LIB.f90:37930
r8vec_lt
logical(kind=4) function r8vec_lt(n, a1, a2)
Definition R8LIB.f90:32389
r8vec_eq
logical(kind=4) function r8vec_eq(n, a1, a2)
Definition R8LIB.f90:28999
r8vec_gt
logical(kind=4) function r8vec_gt(n, a1, a2)
Definition R8LIB.f90:29957

References r8vec_swap().

Referenced by r82vec_sort_quick_a().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r82vec_permute()

subroutine r82vec_permute ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p,
real ( kind = 8 ), dimension(2,n)  a 
)

Definition at line 7865 of file R8LIB.f90.

7866
7867!*****************************************************************************80
7868!
7869!! R82VEC_PERMUTE permutes an R82VEC in place.
7870!
7871! Discussion:
7872!
7873! An R82VEC is an array of pairs of R8 values.
7874!
7875! The same logic can be used to permute an array of objects of any
7876! arithmetic type, or an array of objects of any complexity. The only
7877! temporary storage required is enough to store a single object. The number
7878! of data movements made is N + the number of cycles of order 2 or more,
7879! which is never more than N + N/2.
7880!
7881! Example:
7882!
7883! Input:
7884!
7885! N = 5
7886! P = ( 2, 4, 5, 1, 3 )
7887! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
7888! (11.0, 22.0, 33.0, 44.0, 55.0 )
7889!
7890! Output:
7891!
7892! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 )
7893! ( 22.0, 44.0, 55.0, 11.0, 33.0 ).
7894!
7895! Licensing:
7896!
7897! This code is distributed under the GNU LGPL license.
7898!
7899! Modified:
7900!
7901! 13 March 2005
7902!
7903! Author:
7904!
7905! John Burkardt
7906!
7907! Parameters:
7908!
7909! Input, integer ( kind = 4 ) N, the number of objects.
7910!
7911! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means
7912! that the I-th element of the output array should be the J-th
7913! element of the input array.
7914!
7915! Input/output, real ( kind = 8 ) A(2,N), the array to be permuted.
7916!
7917 implicit none
7918
7919 integer ( kind = 4 ) n
7920 integer ( kind = 4 ), parameter :: dim_num = 2
7921
7922 real ( kind = 8 ) a(2,n)
7923 real ( kind = 8 ) a_temp(2)
7924 integer ( kind = 4 ) ierror
7925 integer ( kind = 4 ) iget
7926 integer ( kind = 4 ) iput
7927 integer ( kind = 4 ) istart
7928 integer ( kind = 4 ) p(n)
7929
7930 call perm_check1 ( n, p )
7931!
7932! Search for the next element of the permutation that has not been used.
7933!
7934 do istart = 1, n
7935
7936 if ( p(istart) < 0 ) then
7937
7938 else if ( p(istart) == istart ) then
7939
7940 p(istart) = - p(istart)
7941
7942 else
7943
7944 a_temp(1:2) = a(1:2,istart)
7945 iget = istart
7946!
7947! Copy the new value into the vacated entry.
7948!
7949 do
7950
7951 iput = iget
7952 iget = p(iget)
7953
7954 p(iput) = - p(iput)
7955
7956 if ( iget < 1 .or. n < iget ) then
7957 write ( *, '(a)' ) ' '
7958 write ( *, '(a)' ) 'R82VEC_PERMUTE - Fatal error!'
7959 write ( *, '(a)' ) ' A permutation index is out of range.'
7960 write ( *, '(a,i8,a,i8)' ) ' P(', iput, ') = ', iget
7961 stop 1
7962 end if
7963
7964 if ( iget == istart ) then
7965 a(1:2,iput) = a_temp(1:2)
7966 exit
7967 end if
7968
7969 a(1:2,iput) = a(1:2,iget)
7970
7971 end do
7972
7973 end if
7974
7975 end do
7976!
7977! Restore the signs of the entries.
7978!
7979 p(1:n) = - p(1:n)
7980
7981 return

References perm_check1().

Here is the call graph for this function:

◆ r82vec_print()

subroutine r82vec_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  a,
character ( len = * )  title 
)

Definition at line 7983 of file R8LIB.f90.

7984
7985!*****************************************************************************80
7986!
7987!! R82VEC_PRINT prints an R82VEC.
7988!
7989! Discussion:
7990!
7991! An R82VEC is an array of pairs of R82's.
7992!
7993! Licensing:
7994!
7995! This code is distributed under the GNU LGPL license.
7996!
7997! Modified:
7998!
7999! 08 December 2004
8000!
8001! Author:
8002!
8003! John Burkardt
8004!
8005! Parameters:
8006!
8007! Input, integer ( kind = 4 ) N, the number of components of the vector.
8008!
8009! Input, real ( kind = 8 ) A(2,N), the R82 vector to be printed.
8010!
8011! Input, character ( len = * ) TITLE, a title.
8012!
8013 implicit none
8014
8015 integer ( kind = 4 ) n
8016 integer ( kind = 4 ), parameter :: dim_num = 2
8017
8018 real ( kind = 8 ) a(dim_num,n)
8019 integer ( kind = 4 ) i
8020 character ( len = * ) title
8021
8022 write ( *, '(a)' ) ' '
8023 write ( *, '(a)' ) trim( title )
8024 write ( *, '(a)' ) ' '
8025 do i = 1, n
8026 write ( *, '(2x,i8,(5g14.6))' ) i, a(1:dim_num,i)
8027 end do
8028
8029 return

◆ r82vec_print_part()

subroutine r82vec_print_part ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(2,n)  a,
integer ( kind = 4 )  max_print,
character ( len = * )  title 
)

Definition at line 8031 of file R8LIB.f90.

8032
8033!*****************************************************************************80
8034!
8035!! R82VEC_PRINT_PART prints "part" of an R82VEC.
8036!
8037! Discussion:
8038!
8039! The user specifies MAX_PRINT, the maximum number of lines to print.
8040!
8041! If N, the size of the vector, is no more than MAX_PRINT, then
8042! the entire vector is printed, one entry per line.
8043!
8044! Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
8045! followed by a line of periods suggesting an omission,
8046! and the last entry.
8047!
8048! Licensing:
8049!
8050! This code is distributed under the GNU LGPL license.
8051!
8052! Modified:
8053!
8054! 09 November 2011
8055!
8056! Author:
8057!
8058! John Burkardt
8059!
8060! Parameters:
8061!
8062! Input, integer ( kind = 4 ) N, the number of entries of the vector.
8063!
8064! Input, real ( kind = 8 ) A(2,N), the vector to be printed.
8065!
8066! Input, integer ( kind = 4 ) MAX_PRINT, the maximum number of lines
8067! to print.
8068!
8069! Input, character ( len = * ) TITLE, a title.
8070!
8071 implicit none
8072
8073 integer ( kind = 4 ) n
8074
8075 real ( kind = 8 ) a(2,n)
8076 integer ( kind = 4 ) i
8077 integer ( kind = 4 ) max_print
8078 character ( len = * ) title
8079
8080 if ( max_print <= 0 ) then
8081 return
8082 end if
8083
8084 if ( n <= 0 ) then
8085 return
8086 end if
8087
8088 write ( *, '(a)' ) ' '
8089 write ( *, '(a)' ) trim( title )
8090 write ( *, '(a)' ) ' '
8091
8092 if ( n <= max_print ) then
8093
8094 do i = 1, n
8095 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) i, ':', a(1:2,i)
8096 end do
8097
8098 else if ( 3 <= max_print ) then
8099
8100 do i = 1, max_print - 2
8101 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) i, ':', a(1:2,i)
8102 end do
8103 write ( *, '(a)' ) ' ........ .............. ..............'
8104 i = n
8105 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) i, ':', a(1:2,i)
8106
8107 else
8108
8109 do i = 1, max_print - 1
8110 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) i, ':', a(1:2,i)
8111 end do
8112 i = max_print
8113 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,a)' ) i, ':', a(1:2,i), &
8114 '...more entries...'
8115
8116 end if
8117
8118 return

◆ r82vec_sort_heap_index_a()

subroutine r82vec_sort_heap_index_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 8120 of file R8LIB.f90.

8121
8122!*****************************************************************************80
8123!
8124!! R82VEC_SORT_HEAP_INDEX_A ascending index heaps an R82VEC.
8125!
8126! Discussion:
8127!
8128! An R82VEC is an array of R82's.
8129!
8130! The sorting is not actually carried out. Rather an index array is
8131! created which defines the sorting. This array may be used to sort
8132! or index the array, or to sort or index related arrays keyed on the
8133! original array.
8134!
8135! Once the index array is computed, the sorting can be carried out
8136! "implicitly:
8137!
8138! A(1:2,INDX(1:N)) is sorted,
8139!
8140! or explicitly, by the call
8141!
8142! call r82vec_permute ( n, indx, a )
8143!
8144! after which A(1:2,I), I = 1 to N is sorted.
8145!
8146! Licensing:
8147!
8148! This code is distributed under the GNU LGPL license.
8149!
8150! Modified:
8151!
8152! 08 December 2004
8153!
8154! Author:
8155!
8156! John Burkardt
8157!
8158! Parameters:
8159!
8160! Input, integer ( kind = 4 ) N, the number of entries in the array.
8161!
8162! Input, real ( kind = 8 ) A(2,N), an array to be index-sorted.
8163!
8164! Output, integer ( kind = 4 ) INDX(N), the sort index. The
8165! I-th element of the sorted array is A(1:2,INDX(I)).
8166!
8167 implicit none
8168
8169 integer ( kind = 4 ) n
8170 integer ( kind = 4 ), parameter :: dim_num = 2
8171
8172 real ( kind = 8 ) a(dim_num,n)
8173 real ( kind = 8 ) aval(dim_num)
8174 integer ( kind = 4 ) i
8175 integer ( kind = 4 ) indx(n)
8176 integer ( kind = 4 ) indxt
8177 integer ( kind = 4 ) ir
8178 integer ( kind = 4 ) j
8179 integer ( kind = 4 ) l
8180
8181 if ( n < 1 ) then
8182 return
8183 end if
8184
8185 do i = 1, n
8186 indx(i) = i
8187 end do
8188
8189 if ( n == 1 ) then
8190 return
8191 end if
8192
8193 l = n / 2 + 1
8194 ir = n
8195
8196 do
8197
8198 if ( 1 < l ) then
8199
8200 l = l - 1
8201 indxt = indx(l)
8202 aval(1:dim_num) = a(1:dim_num,indxt)
8203
8204 else
8205
8206 indxt = indx(ir)
8207 aval(1:dim_num) = a(1:dim_num,indxt)
8208 indx(ir) = indx(1)
8209 ir = ir - 1
8210
8211 if ( ir == 1 ) then
8212 indx(1) = indxt
8213 exit
8214 end if
8215
8216 end if
8217
8218 i = l
8219 j = l + l
8220
8221 do while ( j <= ir )
8222
8223 if ( j < ir ) then
8224 if ( a(1,indx(j)) < a(1,indx(j+1)) .or. &
8225 ( a(1,indx(j)) == a(1,indx(j+1)) .and. &
8226 a(2,indx(j)) < a(2,indx(j+1)) ) ) then
8227 j = j + 1
8228 end if
8229 end if
8230
8231 if ( aval(1) < a(1,indx(j)) .or. &
8232 ( aval(1) == a(1,indx(j)) .and. &
8233 aval(2) < a(2,indx(j)) ) ) then
8234 indx(i) = indx(j)
8235 i = j
8236 j = j + j
8237 else
8238 j = ir + 1
8239 end if
8240
8241 end do
8242
8243 indx(i) = indxt
8244
8245 end do
8246
8247 return

◆ r82vec_sort_quick_a()

subroutine r82vec_sort_quick_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  a 
)

Definition at line 8249 of file R8LIB.f90.

8250
8251!*****************************************************************************80
8252!
8253!! R82VEC_SORT_QUICK_A ascending sorts an R82VEC using quick sort.
8254!
8255! Discussion:
8256!
8257! An R82VEC is an array of R82's.
8258!
8259! Licensing:
8260!
8261! This code is distributed under the GNU LGPL license.
8262!
8263! Modified:
8264!
8265! 08 December 2004
8266!
8267! Author:
8268!
8269! John Burkardt
8270!
8271! Parameters:
8272!
8273! Input, integer ( kind = 4 ) N, the number of entries in the array.
8274!
8275! Input/output, real ( kind = 8 ) A(2,N).
8276! On input, the array to be sorted.
8277! On output, the array has been sorted.
8278!
8279 implicit none
8280
8281 integer ( kind = 4 ), parameter :: level_max = 30
8282 integer ( kind = 4 ) n
8283 integer ( kind = 4 ), parameter :: dim_num = 2
8284
8285 real ( kind = 8 ) a(dim_num,n)
8286 integer ( kind = 4 ) base
8287 integer ( kind = 4 ) l_segment
8288 integer ( kind = 4 ) level
8289 integer ( kind = 4 ) n_segment
8290 integer ( kind = 4 ) rsave(level_max)
8291 integer ( kind = 4 ) r_segment
8292
8293 if ( n < 1 ) then
8294 write ( *, '(a)' ) ' '
8295 write ( *, '(a)' ) 'R82VEC_SORT_QUICK_A - Fatal error!'
8296 write ( *, '(a)' ) ' N < 1.'
8297 write ( *, '(a,i8)' ) ' N = ', n
8298 stop 1
8299 else if ( n == 1 ) then
8300 return
8301 end if
8302
8303 level = 1
8304 rsave(level) = n + 1
8305 base = 1
8306 n_segment = n
8307
8308 do
8309!
8310! Partition the segment.
8311!
8312 call r82vec_part_quick_a ( n_segment, a(1,base), l_segment, r_segment )
8313!
8314! If the left segment has more than one element, we need to partition it.
8315!
8316 if ( 1 < l_segment ) then
8317
8318 if ( level_max < level ) then
8319 write ( *, '(a)' ) ' '
8320 write ( *, '(a)' ) 'R82VEC_SORT_QUICK_A - Fatal error!'
8321 write ( *, '(a,i8)' ) ' Exceeding recursion maximum of ', level_max
8322 stop 1
8323 end if
8324
8325 level = level + 1
8326 n_segment = l_segment
8327 rsave(level) = r_segment + base - 1
8328!
8329! The left segment and the middle segment are sorted.
8330! Must the right segment be partitioned?
8331!
8332 else if ( r_segment < n_segment ) then
8333
8334 n_segment = n_segment + 1 - r_segment
8335 base = base + r_segment - 1
8336!
8337! Otherwise, we back up a level if there is an earlier one.
8338!
8339 else
8340
8341 do
8342
8343 if ( level <= 1 ) then
8344 return
8345 end if
8346
8347 base = rsave(level)
8348 n_segment = rsave(level-1) - rsave(level)
8349 level = level - 1
8350
8351 if ( 0 < n_segment ) then
8352 exit
8353 end if
8354
8355 end do
8356
8357 end if
8358
8359 end do
8360
8361 return
r82vec_part_quick_a
subroutine r82vec_part_quick_a(n, a, l, r)
Definition R8LIB.f90:7747

References r82vec_part_quick_a().

Here is the call graph for this function:

◆ r83_norm()

real ( kind = 8 ) function r83_norm ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  z 
)

Definition at line 8363 of file R8LIB.f90.

8364
8365!*****************************************************************************80
8366!
8367!! R83_NORM returns the Euclidean norm of an R83.
8368!
8369! Discussion:
8370!
8371! An R83 is a vector of 3 R8's.
8372!
8373! Licensing:
8374!
8375! This code is distributed under the GNU LGPL license.
8376!
8377! Modified:
8378!
8379! 11 October 2010
8380!
8381! Author:
8382!
8383! John Burkardt
8384!
8385! Parameters:
8386!
8387! Input, real ( kind = 8 ) X, Y, Z, the vector.
8388!
8389! Output, real ( kind = 8 ) R83_NORM, the norm of the vector.
8390!
8391 implicit none
8392
8393 real ( kind = 8 ) r83_norm
8394 real ( kind = 8 ) x
8395 real ( kind = 8 ) y
8396 real ( kind = 8 ) z
8397
8398 r83_norm = sqrt( x * x + y * y + z * z )
8399
8400 return
r83_norm
real(kind=8) function r83_norm(x, y, z)
Definition R8LIB.f90:8364

References r83_norm().

Referenced by r83_norm().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r83_normalize()

subroutine r83_normalize ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  z 
)

Definition at line 8402 of file R8LIB.f90.

8403
8404!*****************************************************************************80
8405!
8406!! R83_NORMALIZE normalizes an R83.
8407!
8408! Discussion:
8409!
8410! An R83 is a vector of 3 R8's.
8411!
8412! Licensing:
8413!
8414! This code is distributed under the GNU LGPL license.
8415!
8416! Modified:
8417!
8418! 17 January 2000
8419!
8420! Author:
8421!
8422! John Burkardt
8423!
8424! Parameters:
8425!
8426! Input/output, real ( kind = 8 ) X, Y, Z, the components of the vector.
8427!
8428 implicit none
8429
8430 real ( kind = 8 ) norm
8431 real ( kind = 8 ) x
8432 real ( kind = 8 ) y
8433 real ( kind = 8 ) z
8434
8435 norm = sqrt( x * x + y * y + z * z )
8436
8437 if ( norm /= 0.0d+00 ) then
8438 x = x / norm
8439 y = y / norm
8440 z = z / norm
8441 end if
8442
8443 return

◆ r83_print()

subroutine r83_print ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  z,
character ( len = * )  title 
)

Definition at line 8445 of file R8LIB.f90.

8446
8447!*****************************************************************************80
8448!
8449!! R83_PRINT prints an R83.
8450!
8451! Discussion:
8452!
8453! An R83 is a vector of 3 R8's.
8454!
8455! A format is used which suggests a coordinate triple:
8456!
8457! Example:
8458!
8459! Center : ( 1.23, 7.45, -1.45 )
8460!
8461! Licensing:
8462!
8463! This code is distributed under the GNU LGPL license.
8464!
8465! Modified:
8466!
8467! 03 July 2001
8468!
8469! Author:
8470!
8471! John Burkardt
8472!
8473! Parameters:
8474!
8475! Input, real ( kind = 8 ) X, Y, Z, the coordinates of the vector.
8476!
8477! Input, character ( len = * ) TITLE, a title.
8478!
8479 implicit none
8480
8481 character ( len = * ) title
8482 real ( kind = 8 ) x
8483 real ( kind = 8 ) y
8484 real ( kind = 8 ) z
8485
8486 if ( 0 < len_trim( title ) ) then
8487 write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1, g14.6, a1 )' ) &
8488 trim( title ), ' : (', x, ',', y, ',', z, ')'
8489 else
8490 write ( *, '( 2x, a1, g14.6, a1, g14.6, a1, g14.6, a1 )' ) &
8491 '(', x, ',', y, ',', z, ')'
8492 end if
8493
8494 return

◆ r83_swap()

subroutine r83_swap ( real ( kind = 8 ), dimension(dim_num)  x,
real ( kind = 8 ), dimension(dim_num)  y 
)

Definition at line 8496 of file R8LIB.f90.

8497
8498!*****************************************************************************80
8499!
8500!! R83_SWAP swaps two R83's.
8501!
8502! Discussion:
8503!
8504! An R83 is a vector of 3 R8's.
8505!
8506! Licensing:
8507!
8508! This code is distributed under the GNU LGPL license.
8509!
8510! Modified:
8511!
8512! 07 December 2004
8513!
8514! Author:
8515!
8516! John Burkardt
8517!
8518! Parameters:
8519!
8520! Input/output, real ( kind = 8 ) X(3), Y(3). On output, the values
8521! of X and Y have been interchanged.
8522!
8523 implicit none
8524
8525 integer ( kind = 4 ), parameter :: dim_num = 3
8526
8527 real ( kind = 8 ) x(dim_num)
8528 real ( kind = 8 ) y(dim_num)
8529 real ( kind = 8 ) z(dim_num)
8530
8531 z(1:dim_num) = x(1:dim_num)
8532 x(1:dim_num) = y(1:dim_num)
8533 y(1:dim_num) = z(1:dim_num)
8534
8535 return

◆ r83vec_max()

subroutine r83vec_max ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(3,n)  a,
real ( kind = 8 ), dimension(3)  amax 
)

Definition at line 8537 of file R8LIB.f90.

8538
8539!*****************************************************************************80
8540!
8541!! R83VEC_MAX returns the maximum value in an R83VEC.
8542!
8543! Discussion:
8544!
8545! An R83VEC is an array of R83's.
8546!
8547! Licensing:
8548!
8549! This code is distributed under the GNU LGPL license.
8550!
8551! Modified:
8552!
8553! 10 November 2011
8554!
8555! Author:
8556!
8557! John Burkardt
8558!
8559! Parameters:
8560!
8561! Input, integer ( kind = 4 ) N, the number of entries in the array.
8562!
8563! Input, real ( kind = 8 ) A(3,N), the array.
8564!
8565! Output, real ( kind = 8 ) AMAX(3); the largest entries in each row.
8566!
8567 implicit none
8568
8569 integer ( kind = 4 ) n
8570
8571 real ( kind = 8 ) a(3,n)
8572 real ( kind = 8 ) amax(3)
8573 integer ( kind = 4 ) i
8574
8575 do i = 1, 3
8576 amax(i) = maxval( a(i,1:n) )
8577 end do
8578
8579 return

◆ r83vec_min()

subroutine r83vec_min ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(3,n)  a,
real ( kind = 8 ), dimension(3)  amin 
)

Definition at line 8581 of file R8LIB.f90.

8582
8583!*****************************************************************************80
8584!
8585!! R83VEC_MIN returns the minimum value in an R83VEC.
8586!
8587! Discussion:
8588!
8589! An R83VEC is an array of R83's.
8590!
8591! Licensing:
8592!
8593! This code is distributed under the GNU LGPL license.
8594!
8595! Modified:
8596!
8597! 10 November 2011
8598!
8599! Author:
8600!
8601! John Burkardt
8602!
8603! Parameters:
8604!
8605! Input, integer ( kind = 4 ) N, the number of entries in the array.
8606!
8607! Input, real ( kind = 8 ) A(3,N), the array.
8608!
8609! Output, real ( kind = 8 ) AMIN(3); the smallest entries in each row.
8610!
8611 implicit none
8612
8613 integer ( kind = 4 ) n
8614
8615 real ( kind = 8 ) a(3,n)
8616 real ( kind = 8 ) amin(3)
8617 integer ( kind = 4 ) i
8618
8619 do i = 1, 3
8620 amin(i) = minval( a(i,1:n) )
8621 end do
8622
8623 return

◆ r83vec_normalize()

subroutine r83vec_normalize ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(dim_num,n)  x 
)

Definition at line 8625 of file R8LIB.f90.

8626
8627!*****************************************************************************80
8628!
8629!! R83VEC_NORMALIZE normalizes each R83 in an R83VEC.
8630!
8631! Discussion:
8632!
8633! An R83VEC is a vector of R83's.
8634!
8635! An R83 is a vector of 3 R8's.
8636!
8637! Licensing:
8638!
8639! This code is distributed under the GNU LGPL license.
8640!
8641! Modified:
8642!
8643! 07 December 2004
8644!
8645! Author:
8646!
8647! John Burkardt
8648!
8649! Parameters:
8650!
8651! Input, integer ( kind = 4 ) N, the number of R83 vectors.
8652!
8653! Input/output, real ( kind = 8 ) X(3,N), the coordinates of N R83 vectors.
8654! On output, the nonzero vectors have been scaled to have unit L2 norm.
8655!
8656 implicit none
8657
8658 integer ( kind = 4 ) n
8659 integer ( kind = 4 ), parameter :: dim_num = 3
8660
8661 integer ( kind = 4 ) i
8662 real ( kind = 8 ) norm
8663 real ( kind = 8 ) x(dim_num,n)
8664
8665 do i = 1, n
8666
8667 norm = sqrt( sum( x(1:dim_num,i)**2 ) )
8668
8669 if ( norm /= 0.0d+00 ) then
8670 x(1:dim_num,i) = x(1:dim_num,i) / norm
8671 end if
8672
8673 end do
8674
8675 return

◆ r83vec_print_part()

subroutine r83vec_print_part ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(3,n)  a,
integer ( kind = 4 )  max_print,
character ( len = * )  title 
)

Definition at line 8677 of file R8LIB.f90.

8678
8679!*****************************************************************************80
8680!
8681!! R83VEC_PRINT_PART prints "part" of an R83VEC.
8682!
8683! Discussion:
8684!
8685! The user specifies MAX_PRINT, the maximum number of lines to print.
8686!
8687! If N, the size of the vector, is no more than MAX_PRINT, then
8688! the entire vector is printed, one entry per line.
8689!
8690! Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
8691! followed by a line of periods suggesting an omission,
8692! and the last entry.
8693!
8694! Licensing:
8695!
8696! This code is distributed under the GNU LGPL license.
8697!
8698! Modified:
8699!
8700! 09 November 2011
8701!
8702! Author:
8703!
8704! John Burkardt
8705!
8706! Parameters:
8707!
8708! Input, integer ( kind = 4 ) N, the number of entries of the vector.
8709!
8710! Input, real ( kind = 8 ) A(3,N), the vector to be printed.
8711!
8712! Input, integer ( kind = 4 ) MAX_PRINT, the maximum number of lines
8713! to print.
8714!
8715! Input, character ( len = * ) TITLE, a title.
8716!
8717 implicit none
8718
8719 integer ( kind = 4 ) n
8720
8721 real ( kind = 8 ) a(3,n)
8722 integer ( kind = 4 ) i
8723 integer ( kind = 4 ) max_print
8724 character ( len = * ) title
8725
8726 if ( max_print <= 0 ) then
8727 return
8728 end if
8729
8730 if ( n <= 0 ) then
8731 return
8732 end if
8733
8734 write ( *, '(a)' ) ' '
8735 write ( *, '(a)' ) trim( title )
8736 write ( *, '(a)' ) ' '
8737
8738 if ( n <= max_print ) then
8739
8740 do i = 1, n
8741 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) i, ':', a(1:3,i)
8742 end do
8743
8744 else if ( 3 <= max_print ) then
8745
8746 do i = 1, max_print - 2
8747 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) i, ':', a(1:3,i)
8748 end do
8749 write ( *, '(a)' ) &
8750 ' ........ .............. .............. ..............'
8751 i = n
8752 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) i, ':', a(1:3,i)
8753
8754 else
8755
8756 do i = 1, max_print - 1
8757 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) i, ':', a(1:3,i)
8758 end do
8759 i = max_print
8760 write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6,2x,a)' ) i, ':', a(1:3,i), &
8761 '...more entries...'
8762
8763 end if
8764
8765 return

◆ r84_normalize()

subroutine r84_normalize ( real ( kind = 8 ), dimension(dim_num)  v)

Definition at line 8767 of file R8LIB.f90.

8768
8769!*****************************************************************************80
8770!
8771!! R84_NORMALIZE normalizes an R84.
8772!
8773! Discussion:
8774!
8775! An R84 is a vector of four R8's.
8776!
8777! Licensing:
8778!
8779! This code is distributed under the GNU LGPL license.
8780!
8781! Modified:
8782!
8783! 12 December 2004
8784!
8785! Author:
8786!
8787! John Burkardt
8788!
8789! Parameters:
8790!
8791! Input/output, real ( kind = 8 ) V(4), the components of the vector.
8792!
8793 implicit none
8794
8795 integer ( kind = 4 ), parameter :: dim_num = 4
8796
8797 real ( kind = 8 ) norm
8798 real ( kind = 8 ) v(dim_num)
8799
8800 norm = sqrt( sum( v(1:dim_num)**2 ) )
8801
8802 if ( norm /= 0.0d+00 ) then
8803 v(1:dim_num) = v(1:dim_num) / norm
8804 end if
8805
8806 return

◆ r8_abs()

real ( kind = 8 ) function r8_abs ( real ( kind = 8 )  x)

Definition at line 1318 of file R8LIB.f90.

1319
1320!*****************************************************************************80
1321!
1322!! R8_ABS returns the absolute value of an R8.
1323!
1324! Discussion:
1325!
1326! An R8 is a real ( kind = 8 ) value.
1327!
1328! FORTRAN90 supplies the ABS function, which should be used instead
1329! of this function!
1330!
1331! Licensing:
1332!
1333! This code is distributed under the GNU LGPL license.
1334!
1335! Modified:
1336!
1337! 06 September 2005
1338!
1339! Author:
1340!
1341! John Burkardt
1342!
1343! Parameters:
1344!
1345! Input, real ( kind = 8 ) X, the number whose absolute value is desired.
1346!
1347! Output, real ( kind = 8 ) R8_ABS, the absolute value of X.
1348!
1349 implicit none
1350
1351 real ( kind = 8 ) r8_abs
1352 real ( kind = 8 ) x
1353
1354 if ( 0.0d+00 <= x ) then
1355 r8_abs = + x
1356 else
1357 r8_abs = - x
1358 end if
1359
1360 return
r8_abs
real(kind=8) function r8_abs(x)
Definition R8LIB.f90:1319

References r8_abs().

Referenced by r8_abs().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_acos()

real ( kind = 8 ) function r8_acos ( real ( kind = 8 )  c)

Definition at line 1362 of file R8LIB.f90.

1363
1364!*****************************************************************************80
1365!
1366!! R8_ACOS computes the arc cosine function, with argument truncation.
1367!
1368! Discussion:
1369!
1370! If you call your system ACOS routine with an input argument that is
1371! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant
1372! surprise (I did).
1373!
1374! This routine simply truncates arguments outside the range.
1375!
1376! Licensing:
1377!
1378! This code is distributed under the GNU LGPL license.
1379!
1380! Modified:
1381!
1382! 19 October 2012
1383!
1384! Author:
1385!
1386! John Burkardt
1387!
1388! Parameters:
1389!
1390! Input, real ( kind = 8 ) C, the argument.
1391!
1392! Output, real ( kind = 8 ) R8_ACOS, an angle whose cosine is C.
1393!
1394 implicit none
1395
1396 real ( kind = 8 ) c
1397 real ( kind = 8 ) c2
1398 real ( kind = 8 ) r8_acos
1399
1400 c2 = c
1401 c2 = max( c2, -1.0d+00 )
1402 c2 = min( c2, +1.0d+00 )
1403
1404 r8_acos = acos( c2 )
1405
1406 return
r8_acos
real(kind=8) function r8_acos(c)
Definition R8LIB.f90:1363

References r8_acos().

Referenced by r8_acos().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_acosh()

real ( kind = 8 ) function r8_acosh ( real ( kind = 8 )  x)

Definition at line 1408 of file R8LIB.f90.

1409
1410!*****************************************************************************80
1411!
1412!! R8_ACOSH evaluates the arc-hyperbolic cosine of an R8 argument.
1413!
1414! Licensing:
1415!
1416! This code is distributed under the GNU LGPL license.
1417!
1418! Modified:
1419!
1420! 10 September 2011
1421!
1422! Author:
1423!
1424! Original FORTRAN77 version by Wayne Fullerton.
1425! FORTRAN90 version by John Burkardt.
1426!
1427! Reference:
1428!
1429! Wayne Fullerton,
1430! Portable Special Function Routines,
1431! in Portability of Numerical Software,
1432! edited by Wayne Cowell,
1433! Lecture Notes in Computer Science, Volume 57,
1434! Springer 1977,
1435! ISBN: 978-3-540-08446-4,
1436! LC: QA297.W65.
1437!
1438! Parameters:
1439!
1440! Input, real ( kind = 8 ) X, the argument.
1441!
1442! Output, real ( kind = 8 ) R8_ACOSH, the arc-hyperbolic cosine of X.
1443!
1444 implicit none
1445
1446 real ( kind = 8 ), parameter :: dln2 = 0.69314718055994530941723212145818d+00
1447 real ( kind = 8 ) r8_acosh
1448 real ( kind = 8 ), parameter :: r8_tiny = 1.0d-30
1449 real ( kind = 8 ) value
1450 real ( kind = 8 ) x
1451 real ( kind = 8 ), save :: xmax = 0.0d+00
1452
1453 if ( xmax == 0.0d+00 ) then
1454 xmax = 1.0d+00 / sqrt( r8_tiny )
1455 end if
1456
1457 if ( x < 1.0d+00 ) then
1458 write ( *, '(a)' ) ' '
1459 write ( *, '(a)' ) 'R8_ACOSH - Fatal error!'
1460 write ( *, '(a)' ) ' X < 1.0'
1461 stop 1
1462 else if ( x < xmax ) then
1463 value = log( x + sqrt( x * x - 1.0d+00 ) )
1464 else
1465 value = dln2 + log( x )
1466 end if
1467
1468 r8_acosh = value
1469
1470 return
r8_tiny
real(kind=8) function r8_tiny()
Definition R8LIB.f90:5998
r8_acosh
real(kind=8) function r8_acosh(x)
Definition R8LIB.f90:1409

References r8_acosh(), and r8_tiny().

Referenced by r8_acosh().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_add()

real ( kind = 8 ) function r8_add ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 1472 of file R8LIB.f90.

1473
1474!*****************************************************************************80
1475!
1476!! R8_ADD returns the sum of two R8's.
1477!
1478! Discussion:
1479!
1480! An R8 is a real ( kind = 8 ) value.
1481!
1482! FORTRAN90 supplies the + operator, which should generally be used instead
1483! of this function!
1484!
1485! Licensing:
1486!
1487! This code is distributed under the GNU LGPL license.
1488!
1489! Modified:
1490!
1491! 11 August 2010
1492!
1493! Author:
1494!
1495! John Burkardt
1496!
1497! Parameters:
1498!
1499! Input, real ( kind = 8 ) X, Y, the numbers to be added.
1500!
1501! Output, real ( kind = 8 ) R8_ADD, the sum.
1502!
1503 implicit none
1504
1505 real ( kind = 8 ) r8_add
1506 real ( kind = 8 ) x
1507 real ( kind = 8 ) y
1508
1509 r8_add = x + y
1510
1511 return
r8_add
real(kind=8) function r8_add(x, y)
Definition R8LIB.f90:1473

References r8_add().

Referenced by r8_add(), and r8_epsilon_compute().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_agm()

real ( kind = 8 ) function r8_agm ( real ( kind = 8 )  a,
real ( kind = 8 )  b 
)

Definition at line 1513 of file R8LIB.f90.

1514
1515!*****************************************************************************80
1516!
1517!! R8_AGM computes the arithmetic-geometric mean of A and B.
1518!
1519! Discussion:
1520!
1521! The AGM is defined for nonnegative A and B.
1522!
1523! The AGM of numbers A and B is defined by by an iteration:
1524!
1525! A(0) = A
1526! B(0) = B
1527!
1528! A(N+1) = ( A(N) + B(N) ) / 2
1529! B(N+1) = sqrt ( A(N) * B(N) )
1530!
1531! The two sequences both converge to AGM(A,B). Convergence can be
1532! assumed when the two values are sufficiently close.
1533!
1534! In Mathematica, the AGM can be evaluated by
1535!
1536! ArithmeticGeometricMean [ a, b ]
1537!
1538! Licensing:
1539!
1540! This code is distributed under the GNU LGPL license.
1541!
1542! Modified:
1543!
1544! 09 February 2008
1545!
1546! Author:
1547!
1548! John Burkardt
1549!
1550! Reference:
1551!
1552! Stephen Wolfram,
1553! The Mathematica Book,
1554! Fourth Edition,
1555! Cambridge University Press, 1999,
1556! ISBN: 0-521-64314-7,
1557! LC: QA76.95.W65.
1558!
1559! Parameters:
1560!
1561! Input, real ( kind = 8 ) A, B, the arguments whose AGM is to be computed.
1562! 0 <= A, 0 <= B.
1563!
1564! Output, real ( kind = 8 ) R8_AGM, the arithmetic-geometric mean of A and B.
1565!
1566 implicit none
1567
1568 real ( kind = 8 ) a
1569 real ( kind = 8 ) a1
1570 real ( kind = 8 ) a2
1571 real ( kind = 8 ) b
1572 real ( kind = 8 ) b1
1573 real ( kind = 8 ) b2
1574 integer ( kind = 4 ) it
1575 integer ( kind = 4 ), parameter :: it_max = 1000
1576 real ( kind = 8 ) r8_agm
1577 real ( kind = 8 ) tol
1578
1579 if ( a < 0.0d+00 ) then
1580 write ( *, '(a)' ) ' '
1581 write ( *, '(a)' ) 'R8_AGM - Fatal error!'
1582 write ( *, '(a)' ) ' A < 0.'
1583 stop 1
1584 end if
1585
1586 if ( b < 0.0d+00 ) then
1587 write ( *, '(a)' ) ' '
1588 write ( *, '(a)' ) 'R8_AGM - Fatal error!'
1589 write ( *, '(a)' ) ' B < 0.'
1590 stop 1
1591 end if
1592
1593 if ( a == 0.0d+00 .or. b == 0.0d+00 ) then
1594 r8_agm = 0.0d+00
1595 return
1596 end if
1597
1598 if ( a == b ) then
1599 r8_agm = a
1600 return
1601 end if
1602
1603 it = 0
1604 tol = 100.0d+00 * epsilon( tol )
1605
1606 a1 = a
1607 b1 = b
1608
1609 do
1610
1611 it = it + 1
1612
1613 a2 = ( a1 + b1 ) / 2.0d+00
1614 b2 = sqrt( a1 * b1 )
1615
1616 if ( abs( a2 - b2 ) <= tol * ( a2 + b2 ) ) then
1617 exit
1618 end if
1619
1620 if ( it_max < it ) then
1621 write ( *, '(a)' ) ' '
1622 write ( *, '(a)' ) 'R8_AGM - Fatal error!'
1623 write ( *, '(a,i8)' ) ' Exceeded iteration limit ', it_max
1624 write ( *, '(a,g14.6)' ) ' Estimated value = ', a2
1625 stop 1
1626 end if
1627
1628 a1 = a2
1629 b1 = b2
1630
1631 end do
1632
1633 r8_agm = a2
1634
1635 return
r8_agm
real(kind=8) function r8_agm(a, b)
Definition R8LIB.f90:1514

References r8_agm().

Referenced by r8_agm().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_aint()

real ( kind = 8 ) function r8_aint ( real ( kind = 8 )  x)

Definition at line 1637 of file R8LIB.f90.

1638
1639!****************************************************************************80
1640!
1641!! R8_AINT truncates an R8 argument to an integer.
1642!
1643! Licensing:
1644!
1645! This code is distributed under the GNU LGPL license.
1646!
1647! Modified:
1648!
1649! 18 October 2011
1650!
1651! Author:
1652!
1653! John Burkardt.
1654!
1655! Parameters:
1656!
1657! Input, real ( kind = 8 ) X, the argument.
1658!
1659! Output, real ( kind = 8 ) R8_AINT, the truncated version of X.
1660!
1661 implicit none
1662
1663 real ( kind = 8 ) r8_aint
1664 real ( kind = 8 ) value
1665 real ( kind = 8 ) x
1666
1667 if ( x < 0.0d+00 ) then
1668 value = - int( abs( x ) )
1669 else
1670 value = int( abs( x ) )
1671 end if
1672
1673 r8_aint = value
1674
1675 return
r8_aint
real(kind=8) function r8_aint(x)
Definition R8LIB.f90:1638

References r8_aint().

Referenced by r8_aint().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_asin()

real ( kind = 8 ) function r8_asin ( real ( kind = 8 )  s)

Definition at line 1677 of file R8LIB.f90.

1678
1679!*****************************************************************************80
1680!
1681!! R8_ASIN computes the arc sine function, with argument truncation.
1682!
1683! Discussion:
1684!
1685! If you call your system ASIN routine with an input argument that is
1686! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant
1687! surprise (I did).
1688!
1689! This routine simply truncates arguments outside the range.
1690!
1691! Licensing:
1692!
1693! This code is distributed under the GNU LGPL license.
1694!
1695! Modified:
1696!
1697! 28 December 2004
1698!
1699! Author:
1700!
1701! John Burkardt
1702!
1703! Parameters:
1704!
1705! Input, real ( kind = 8 ) S, the argument.
1706!
1707! Output, real ( kind = 8 ) R8_ASIN, an angle whose sine is S.
1708!
1709 implicit none
1710
1711 real ( kind = 8 ) r8_asin
1712 real ( kind = 8 ) s
1713 real ( kind = 8 ) s2
1714
1715 s2 = s
1716 s2 = max( s2, -1.0d+00 )
1717 s2 = min( s2, +1.0d+00 )
1718
1719 r8_asin = asin( s2 )
1720
1721 return
r8_asin
real(kind=8) function r8_asin(s)
Definition R8LIB.f90:1678

References r8_asin().

Referenced by r8_asin().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_atan()

real ( kind = 8 ) function r8_atan ( real ( kind = 8 )  y,
real ( kind = 8 )  x 
)

Definition at line 1723 of file R8LIB.f90.

1724
1725!*****************************************************************************80
1726!
1727!! R8_ATAN computes the inverse tangent of the ratio Y / X.
1728!
1729! Discussion:
1730!
1731! R8_ATAN returns an angle whose tangent is ( Y / X ), a job which
1732! the built in functions ATAN and ATAN2 already do.
1733!
1734! However:
1735!
1736! * R8_ATAN always returns a positive angle, between 0 and 2 PI,
1737! while ATAN and ATAN2 return angles in the interval [-PI/2,+PI/2]
1738! and [-PI,+PI] respectively;
1739!
1740! * R8_ATAN accounts for the signs of X and Y, (as does ATAN2). The ATAN
1741! function by contrast always returns an angle in the first or fourth
1742! quadrants.
1743!
1744! Licensing:
1745!
1746! This code is distributed under the GNU LGPL license.
1747!
1748! Modified:
1749!
1750! 14 April 1999
1751!
1752! Author:
1753!
1754! John Burkardt
1755!
1756! Parameters:
1757!
1758! Input, real ( kind = 8 ) Y, X, two quantities which represent the
1759! tangent of an angle. If Y is not zero, then the tangent is (Y/X).
1760!
1761! Output, real ( kind = 8 ) R8_ATAN, an angle between 0 and 2 * PI, whose
1762! tangent is (Y/X), and which lies in the appropriate quadrant so that
1763! the signs of its cosine and sine match those of X and Y.
1764!
1765 implicit none
1766
1767 real ( kind = 8 ) abs_x
1768 real ( kind = 8 ) abs_y
1769 real ( kind = 8 ) r8_atan
1770 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
1771 real ( kind = 8 ) theta
1772 real ( kind = 8 ) theta_0
1773 real ( kind = 8 ) x
1774 real ( kind = 8 ) y
1775!
1776! Special cases:
1777!
1778 if ( x == 0.0d+00 ) then
1779
1780 if ( 0.0d+00 < y ) then
1781 theta = r8_pi / 2.0d+00
1782 else if ( y < 0.0d+00 ) then
1783 theta = 3.0d+00 * r8_pi / 2.0d+00
1784 else if ( y == 0.0d+00 ) then
1785 theta = 0.0d+00
1786 end if
1787
1788 else if ( y == 0.0d+00 ) then
1789
1790 if ( 0.0d+00 < x ) then
1791 theta = 0.0d+00
1792 else if ( x < 0.0d+00 ) then
1793 theta = r8_pi
1794 end if
1795!
1796! We assume that ATAN2 is correct when both arguments are positive.
1797!
1798 else
1799
1800 abs_y = abs( y )
1801 abs_x = abs( x )
1802
1803 theta_0 = atan2( abs_y, abs_x )
1804
1805 if ( 0.0d+00 < x .and. 0.0d+00 < y ) then
1806 theta = theta_0
1807 else if ( x < 0.0d+00 .and. 0.0d+00 < y ) then
1808 theta = r8_pi - theta_0
1809 else if ( x < 0.0d+00 .and. y < 0.0d+00 ) then
1810 theta = r8_pi + theta_0
1811 else if ( 0.0d+00 < x .and. y < 0.0d+00 ) then
1812 theta = 2.0d+00 * r8_pi - theta_0
1813 end if
1814
1815 end if
1816
1817 r8_atan = theta
1818
1819 return
r8_atan
real(kind=8) function r8_atan(y, x)
Definition R8LIB.f90:1724

References r8_atan(), and r8_pi().

Referenced by r8_atan().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_big()

real ( kind = 8 ) function r8_big

Definition at line 1821 of file R8LIB.f90.

1822
1823!*****************************************************************************80
1824!
1825!! R8_BIG returns a big R8.
1826!
1827! Discussion:
1828!
1829! The value returned by this function is NOT required to be the
1830! maximum representable R8.
1831! We simply want a "very large" but non-infinite number.
1832!
1833! Licensing:
1834!
1835! This code is distributed under the GNU LGPL license.
1836!
1837! Modified:
1838!
1839! 27 September 2014
1840!
1841! Author:
1842!
1843! John Burkardt
1844!
1845! Parameters:
1846!
1847! Output, real ( kind = 8 ) R8_BIG, a "big" value.
1848!
1849 implicit none
1850
1851 real ( kind = 8 ) r8_big
1852
1853 r8_big = 1.0d+30
1854
1855 return
r8_big
real(kind=8) function r8_big()
Definition R8LIB.f90:1822

References r8_big().

Referenced by r8_big(), and r8_exp().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_cas()

real ( kind = 8 ) function r8_cas ( real ( kind = 8 )  x)

Definition at line 1857 of file R8LIB.f90.

1858
1859!*****************************************************************************80
1860!
1861!! R8_CAS returns the "casine" of an R8.
1862!
1863! Discussion:
1864!
1865! The "casine", used in the discrete Hartley transform, is abbreviated
1866! CAS(X), and defined by:
1867!
1868! CAS(X) = cos ( X ) + sin( X )
1869! = sqrt ( 2 ) * sin ( X + pi/4 )
1870! = sqrt ( 2 ) * cos ( X - pi/4 )
1871!
1872! Licensing:
1873!
1874! This code is distributed under the GNU LGPL license.
1875!
1876! Modified:
1877!
1878! 06 January 2001
1879!
1880! Author:
1881!
1882! John Burkardt
1883!
1884! Reference:
1885!
1886! Ralph Hartley,
1887! A More Symmetrical Fourier Analysis Applied to Transmission Problems,
1888! Proceedings of the Institute of Radio Engineers,
1889! Volume 30, pages 144-150, 1942.
1890!
1891! Parameters:
1892!
1893! Input, real ( kind = 8 ) X, the number whose casine is desired.
1894!
1895! Output, real ( kind = 8 ) R8_CAS, the casine of X, which will be between
1896! plus or minus the square root of 2.
1897!
1898 implicit none
1899
1900 real ( kind = 8 ) r8_cas
1901 real ( kind = 8 ) x
1902
1903 r8_cas = cos( x ) + sin( x )
1904
1905 return
r8_cas
real(kind=8) function r8_cas(x)
Definition R8LIB.f90:1858

References r8_cas().

Referenced by r8_cas().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_ceiling()

real ( kind = 8 ) function r8_ceiling ( real ( kind = 8 )  r)

Definition at line 1907 of file R8LIB.f90.

1908
1909!*****************************************************************************80
1910!
1911!! R8_CEILING rounds an R8 "up" (towards +oo) to an integral R8.
1912!
1913! Example:
1914!
1915! R Value
1916!
1917! -1.1 -1.0
1918! -1.0 -1.0
1919! -0.9 0.0
1920! 0.0 0.0
1921! 5.0 5.0
1922! 5.1 6.0
1923! 5.9 6.0
1924! 6.0 6.0
1925!
1926! Licensing:
1927!
1928! This code is distributed under the GNU LGPL license.
1929!
1930! Modified:
1931!
1932! 10 November 2011
1933!
1934! Author:
1935!
1936! John Burkardt
1937!
1938! Parameters:
1939!
1940! Input, real ( kind = 8 ) R, the value to be rounded up.
1941!
1942! Output, real ( kind = 8 ) R8_CEILING, the rounded value.
1943!
1944 implicit none
1945
1946 real ( kind = 8 ) r
1947 real ( kind = 8 ) r8_ceiling
1948 integer ( kind = 4 ) value
1949
1950 value = real( int( r ), kind = 8 )
1951 if ( value < r ) then
1952 value = value + 1.0d+00
1953 end if
1954
1955 r8_ceiling = value
1956
1957 return
r8_ceiling
real(kind=8) function r8_ceiling(r)
Definition R8LIB.f90:1908

References r8_ceiling().

Referenced by r8_ceiling().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_choose()

real ( kind = 8 ) function r8_choose ( integer ( kind = 4 )  n,
integer ( kind = 4 )  k 
)

Definition at line 1959 of file R8LIB.f90.

1960
1961!*****************************************************************************80
1962!
1963!! R8_CHOOSE computes the binomial coefficient C(N,K) as an R8.
1964!
1965! Discussion:
1966!
1967! The value is calculated in such a way as to avoid overflow and
1968! roundoff. The calculation is done in R8 arithmetic.
1969!
1970! The formula used is:
1971!
1972! C(N,K) = N! / ( K! * (N-K)! )
1973!
1974! Licensing:
1975!
1976! This code is distributed under the GNU LGPL license.
1977!
1978! Modified:
1979!
1980! 24 March 2008
1981!
1982! Author:
1983!
1984! John Burkardt
1985!
1986! Reference:
1987!
1988! ML Wolfson, HV Wright,
1989! Algorithm 160:
1990! Combinatorial of M Things Taken N at a Time,
1991! Communications of the ACM,
1992! Volume 6, Number 4, April 1963, page 161.
1993!
1994! Parameters:
1995!
1996! Input, integer ( kind = 4 ) N, K, are the values of N and K.
1997!
1998! Output, real ( kind = 8 ) R8_CHOOSE, the number of combinations of N
1999! things taken K at a time.
2000!
2001 implicit none
2002
2003 integer ( kind = 4 ) i
2004 integer ( kind = 4 ) k
2005 integer ( kind = 4 ) mn
2006 integer ( kind = 4 ) mx
2007 integer ( kind = 4 ) n
2008 real ( kind = 8 ) r8_choose
2009 real ( kind = 8 ) value
2010
2011 mn = min( k, n - k )
2012
2013 if ( mn < 0 ) then
2014
2015 value = 0.0d+00
2016
2017 else if ( mn == 0 ) then
2018
2019 value = 1.0d+00
2020
2021 else
2022
2023 mx = max( k, n - k )
2024 value = real( mx + 1, kind = 8 )
2025
2026 do i = 2, mn
2027 value = ( value * real( mx + i, kind = 8 ) ) / real( i, kind = 8 )
2028 end do
2029
2030 end if
2031
2032 r8_choose = value
2033
2034 return
r8_choose
real(kind=8) function r8_choose(n, k)
Definition R8LIB.f90:1960

References r8_choose().

Referenced by r8_choose().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_chop()

real ( kind = 8 ) function r8_chop ( integer ( kind = 4 )  place,
real ( kind = 8 )  x 
)

Definition at line 2036 of file R8LIB.f90.

2037
2038!*****************************************************************************80
2039!
2040!! R8_CHOP chops an R8 to a given number of binary places.
2041!
2042! Example:
2043!
2044! 3.875 = 2 + 1 + 1/2 + 1/4 + 1/8.
2045!
2046! The following values would be returned for the 'chopped' value of
2047! 3.875:
2048!
2049! PLACE Value
2050!
2051! 1 2
2052! 2 3 = 2 + 1
2053! 3 3.5 = 2 + 1 + 1/2
2054! 4 3.75 = 2 + 1 + 1/2 + 1/4
2055! 5+ 3.875 = 2 + 1 + 1/2 + 1/4 + 1/8
2056!
2057! Licensing:
2058!
2059! This code is distributed under the GNU LGPL license.
2060!
2061! Modified:
2062!
2063! 20 April 2005
2064!
2065! Author:
2066!
2067! John Burkardt
2068!
2069! Parameters:
2070!
2071! Input, integer ( kind = 4 ) PLACE, the number of binary places to preserve.
2072! PLACE = 0 means return the integer part of X.
2073! PLACE = 1 means return the value of X, correct to 1/2.
2074! PLACE = 2 means return the value of X, correct to 1/4.
2075! PLACE = -1 means return the value of X, correct to 2.
2076!
2077! Input, real ( kind = 8 ) X, the number to be chopped.
2078!
2079! Output, real ( kind = 8 ) R8_CHOP, the chopped number.
2080!
2081 implicit none
2082
2083 real ( kind = 8 ) fac
2084 integer ( kind = 4 ) place
2085 real ( kind = 8 ) r8_chop
2086 real ( kind = 8 ) r8_log_2
2087 real ( kind = 8 ) r8_sign
2088 real ( kind = 8 ) s
2089 integer ( kind = 4 ) temp
2090 real ( kind = 8 ) x
2091
2092 s = r8_sign( x )
2093 temp = int( r8_log_2( abs( x ) ) )
2094 fac = 2.0d+00 ** ( temp - place + 1 )
2095 r8_chop = s * real( int( abs( x ) / fac ), kind = 8 ) * fac
2096
2097 return
r8_chop
real(kind=8) function r8_chop(place, x)
Definition R8LIB.f90:2037
r8_sign
real(kind=8) function r8_sign(x)
Definition R8LIB.f90:5509
r8_log_2
real(kind=8) function r8_log_2(x)
Definition R8LIB.f90:3802

References r8_chop(), r8_log_2(), and r8_sign().

Referenced by r8_chop().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_cosd()

real ( kind = 8 ) function r8_cosd ( real ( kind = 8 )  degrees)

Definition at line 2099 of file R8LIB.f90.

2100
2101!*****************************************************************************80
2102!
2103!! R8_COSD returns the cosine of an angle given in degrees.
2104!
2105! Licensing:
2106!
2107! This code is distributed under the GNU LGPL license.
2108!
2109! Modified:
2110!
2111! 27 July 2014
2112!
2113! Author:
2114!
2115! John Burkardt
2116!
2117! Parameters:
2118!
2119! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
2120!
2121! Output, real ( kind = 8 ) R8_COSD, the cosine of the angle.
2122!
2123 implicit none
2124
2125 real ( kind = 8 ) degrees
2126 real ( kind = 8 ) r8_cosd
2127 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
2128 real ( kind = 8 ) radians
2129
2130 radians = r8_pi * ( degrees / 180.0d+00 )
2131 r8_cosd = cos( radians )
2132
2133 return
r8_cosd
real(kind=8) function r8_cosd(degrees)
Definition R8LIB.f90:2100

References r8_cosd(), and r8_pi().

Referenced by r8_cosd().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_cotd()

real ( kind = 8 ) function r8_cotd ( real ( kind = 8 )  degrees)

Definition at line 2135 of file R8LIB.f90.

2136
2137!*****************************************************************************80
2138!
2139!! R8_COTD returns the cotangent of an angle given in degrees.
2140!
2141! Licensing:
2142!
2143! This code is distributed under the GNU LGPL license.
2144!
2145! Modified:
2146!
2147! 27 July 2014
2148!
2149! Author:
2150!
2151! John Burkardt
2152!
2153! Parameters:
2154!
2155! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
2156!
2157! Output, real ( kind = 8 ) R8_COTD, the cotangent of the angle.
2158!
2159 implicit none
2160
2161 real ( kind = 8 ) degrees
2162 real ( kind = 8 ) r8_cotd
2163 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
2164 real ( kind = 8 ) radians
2165
2166 radians = r8_pi * ( degrees / 180.0d+00 )
2167 r8_cotd = cos( radians ) / sin( radians )
2168
2169 return
r8_cotd
real(kind=8) function r8_cotd(degrees)
Definition R8LIB.f90:2136

References r8_cotd(), and r8_pi().

Referenced by r8_cotd().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_csc()

real ( kind = 8 ) function r8_csc ( real ( kind = 8 )  theta)

Definition at line 2207 of file R8LIB.f90.

2208
2209!*****************************************************************************80
2210!
2211!! R8_CSC returns the cosecant of X.
2212!
2213! Discussion:
2214!
2215! R8_CSC ( THETA ) = 1.0 / SIN ( THETA )
2216!
2217! The cosecant is not a built-in function in FORTRAN, and occasionally it
2218! is handier, or more concise, to be able to refer to it directly
2219! rather than through its definition in terms of the sine function.
2220!
2221! Licensing:
2222!
2223! This code is distributed under the GNU LGPL license.
2224!
2225! Modified:
2226!
2227! 05 March 2012
2228!
2229! Author:
2230!
2231! John Burkardt
2232!
2233! Parameters:
2234!
2235! Input, real ( kind = 8 ) THETA, the angle, in radians, whose
2236! cosecant is desired. It must be the case that SIN ( THETA ) is not zero.
2237!
2238! Output, real ( kind = 8 ) R8_CSC, the cosecant of THETA.
2239!
2240 implicit none
2241
2242 real ( kind = 8 ) r8_csc
2243 real ( kind = 8 ) theta
2244 real ( kind = 8 ) value
2245
2246 value = sin( theta )
2247
2248 if ( value == 0.0d+00 ) then
2249 write ( *, '(a)' ) ' '
2250 write ( *, '(a)' ) 'R8_CSC - Fatal error!'
2251 write ( *, '(a,g14.6)' ) ' Cosecant undefined for THETA = ', theta
2252 stop 1
2253 end if
2254
2255 r8_csc = 1.0d+00 / value
2256
2257 return
r8_csc
real(kind=8) function r8_csc(theta)
Definition R8LIB.f90:2208

References r8_csc().

Referenced by r8_csc().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_cscd()

real ( kind = 8 ) function r8_cscd ( real ( kind = 8 )  degrees)

Definition at line 2171 of file R8LIB.f90.

2172
2173!*****************************************************************************80
2174!
2175!! R8_CSCD returns the cosecant of an angle given in degrees.
2176!
2177! Licensing:
2178!
2179! This code is distributed under the GNU LGPL license.
2180!
2181! Modified:
2182!
2183! 27 July 2014
2184!
2185! Author:
2186!
2187! John Burkardt
2188!
2189! Parameters:
2190!
2191! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
2192!
2193! Output, real ( kind = 8 ) R8_CSCD, the cosecant of the angle.
2194!
2195 implicit none
2196
2197 real ( kind = 8 ) degrees
2198 real ( kind = 8 ) r8_cscd
2199 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
2200 real ( kind = 8 ) radians
2201
2202 radians = r8_pi * ( degrees / 180.0d+00 )
2203 r8_cscd = 1.0d+00 / sin( radians )
2204
2205 return
r8_cscd
real(kind=8) function r8_cscd(degrees)
Definition R8LIB.f90:2172

References r8_cscd(), and r8_pi().

Referenced by r8_cscd().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_csqrt()

complex ( kind = 8 ) function r8_csqrt ( real ( kind = 8 )  x)

Definition at line 2259 of file R8LIB.f90.

2260
2261!*****************************************************************************80
2262!
2263!! R8_CSQRT returns the complex square root of an R8.
2264!
2265! Licensing:
2266!
2267! This code is distributed under the GNU LGPL license.
2268!
2269! Modified:
2270!
2271! 23 October 2005
2272!
2273! Author:
2274!
2275! John Burkardt
2276!
2277! Parameters:
2278!
2279! Input, real ( kind = 8 ) X, the number whose square root is desired.
2280!
2281! Output, complex ( kind = 8 ) R8_CSQRT, the square root of X:
2282!
2283 implicit none
2284
2285 real ( kind = 8 ) argument
2286 real ( kind = 8 ) magnitude
2287 complex ( kind = 8 ) r8_csqrt
2288 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
2289 real ( kind = 8 ) x
2290
2291 if ( 0.0d+00 < x ) then
2292 magnitude = x
2293 argument = 0.0d+00
2294 else if ( 0.0d+00 == x ) then
2295 magnitude = 0.0d+00
2296 argument = 0.0d+00
2297 else if ( x < 0.0d+00 ) then
2298 magnitude = -x
2299 argument = r8_pi
2300 end if
2301
2302 magnitude = sqrt( magnitude )
2303 argument = argument / 2.0d+00
2304
2305 r8_csqrt = magnitude * cmplx( cos( argument ), sin( argument ), kind = 8 )
2306
2307 return
r8_csqrt
complex(kind=8) function r8_csqrt(x)
Definition R8LIB.f90:2260

References r8_csqrt(), and r8_pi().

Referenced by r8_csqrt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_cube_root()

real ( kind = 8 ) function r8_cube_root ( real ( kind = 8 )  x)

Definition at line 2309 of file R8LIB.f90.

2310
2311!*****************************************************************************80
2312!
2313!! R8_CUBE_ROOT returns the cube root of an R8.
2314!
2315! Discussion:
2316!
2317! This routine is designed to avoid the possible problems that can occur
2318! when formulas like 0.0^(1/3) or (-1.0)^(1/3) are to be evaluated.
2319!
2320! Licensing:
2321!
2322! This code is distributed under the GNU LGPL license.
2323!
2324! Modified:
2325!
2326! 01 March 1999
2327!
2328! Author:
2329!
2330! John Burkardt
2331!
2332! Parameters:
2333!
2334! Input, real ( kind = 8 ) X, the number whose cube root is desired.
2335!
2336! Output, real ( kind = 8 ) R8_CUBE_ROOT, the cube root of X.
2337!
2338 implicit none
2339
2340 real ( kind = 8 ) r8_cube_root
2341 real ( kind = 8 ) value
2342 real ( kind = 8 ) x
2343
2344 if ( 0.0d+00 < x ) then
2345 value = x ** ( 1.0d+00 / 3.0d+00 )
2346 else if ( x == 0.0d+00 ) then
2347 value = 0.0d+00
2348 else
2349 value = -( abs( x ) ) ** ( 1.0d+00 / 3.0d+00 )
2350 end if
2351
2352 r8_cube_root = value
2353
2354 return
r8_cube_root
real(kind=8) function r8_cube_root(x)
Definition R8LIB.f90:2310

References r8_cube_root().

Referenced by r8_cube_root().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_degrees()

real ( kind = 8 ) function r8_degrees ( real ( kind = 8 )  radians)

Definition at line 2356 of file R8LIB.f90.

2357
2358!*****************************************************************************80
2359!
2360!! R8_DEGREES converts an angle from radian to degree measure.
2361!
2362! Licensing:
2363!
2364! This code is distributed under the GNU LGPL license.
2365!
2366! Modified:
2367!
2368! 15 May 2013
2369!
2370! Author:
2371!
2372! John Burkardt
2373!
2374! Parameters:
2375!
2376! Input, real ( kind = 8 ) RADIANS, the angle measurement in radians.
2377!
2378! Output, real ( kind = 8 ) R8_DEGREES, the angle measurement in degrees.
2379!
2380 implicit none
2381
2382 real ( kind = 8 ) r8_degrees
2383 real ( kind = 8 ), parameter :: r8_pi = 3.1415926535897932384626434d+00
2384 real ( kind = 8 ) radians
2385
2386 r8_degrees = radians * 180.0d+00 / r8_pi
2387
2388 return
r8_degrees
real(kind=8) function r8_degrees(radians)
Definition R8LIB.f90:2357

References r8_degrees(), and r8_pi().

Referenced by r8_degrees().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_diff()

real ( kind = 8 ) function r8_diff ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
integer ( kind = 4 )  n 
)

Definition at line 2390 of file R8LIB.f90.

2391
2392!*****************************************************************************80
2393!
2394!! R8_DIFF computes the difference of two R8's to a specified accuracy.
2395!
2396! Discussion:
2397!
2398! The user controls how many binary digits of accuracy
2399! are to be used.
2400!
2401! N determines the accuracy of the value of the result. If N = 10,
2402! for example, only 11 binary places will be used in the arithmetic.
2403! In general, only N+1 binary places will be used.
2404!
2405! N may be zero. However, a negative value of N should
2406! not be used, since this will cause both X and Y to look like 0.
2407!
2408! Licensing:
2409!
2410! This code is distributed under the GNU LGPL license.
2411!
2412! Modified:
2413!
2414! 17 November 2004
2415!
2416! Author:
2417!
2418! John Burkardt
2419!
2420! Parameters:
2421!
2422! Input, real ( kind = 8 ) X, Y, the two values whose difference is desired.
2423!
2424! Input, integer ( kind = 4 ) N, the number of binary digits to use.
2425!
2426! Output, real ( kind = 8 ) R8_DIFF, the value of X-Y.
2427!
2428 implicit none
2429
2430 real ( kind = 8 ) cx
2431 real ( kind = 8 ) cy
2432 integer ( kind = 4 ) n
2433 real ( kind = 8 ) pow2
2434 real ( kind = 8 ) r8_diff
2435 real ( kind = 8 ) size
2436 real ( kind = 8 ) x
2437 real ( kind = 8 ) y
2438
2439 if ( x == y ) then
2440 r8_diff = 0.0d+00
2441 return
2442 end if
2443
2444 pow2 = 2.0d+00**n
2445!
2446! Compute the magnitude of X and Y, and take the larger of the
2447! two. At least one of the two values is not zero!
2448!
2449 size = max( abs( x ), abs( y ) )
2450!
2451! Make normalized copies of X and Y. One of the two values will
2452! actually be equal to 1.
2453!
2454 cx = x / size
2455 cy = y / size
2456!
2457! Here's where rounding comes in. We know that the larger of the
2458! the two values equals 1. We multiply both values by 2^N,
2459! where N+1 is the number of binary digits of accuracy we want
2460! to use, truncate the values, and divide back by 2^N.
2461!
2462 cx = real( int( cx * pow2 + sign( 0.5d+00, cx ) ), kind = 8 ) / pow2
2463 cy = real( int( cy * pow2 + sign( 0.5d+00, cy ) ), kind = 8 ) / pow2
2464!
2465! Take the difference now.
2466!
2467 r8_diff = cx - cy
2468!
2469! Undo the scaling.
2470!
2471 r8_diff = r8_diff * size
2472
2473 return
r8_diff
real(kind=8) function r8_diff(x, y, n)
Definition R8LIB.f90:2391

References r8_diff().

Referenced by r8_diff().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_digit()

subroutine r8_digit ( real ( kind = 8 )  x,
integer ( kind = 4 )  idigit,
integer ( kind = 4 )  digit 
)

Definition at line 2475 of file R8LIB.f90.

2476
2477!*****************************************************************************80
2478!
2479!! R8_DIGIT returns a particular decimal digit of an R8.
2480!
2481! Licensing:
2482!
2483! This code is distributed under the GNU LGPL license.
2484!
2485! Modified:
2486!
2487! 17 November 2004
2488!
2489! Author:
2490!
2491! John Burkardt
2492!
2493! Parameters:
2494!
2495! Input, real ( kind = 8 ) X, the number whose NDIG-th decimal digit
2496! is desired. If X is zero, all digits will be returned as 0.
2497!
2498! Input, integer ( kind = 4 ) IDIGIT, the position of the desired decimal
2499! digit. A value of 1 means the leading digit, a value of 2 the second digit
2500! and so on.
2501!
2502! Output, integer ( kind = 4 ) DIGIT, the value of the IDIGIT-th decimal
2503! digit of X.
2504!
2505 implicit none
2506
2507 integer ( kind = 4 ) digit
2508 integer ( kind = 4 ) i
2509 integer ( kind = 4 ) idigit
2510 integer ( kind = 4 ) ival
2511 real ( kind = 8 ) x
2512 real ( kind = 8 ) xcopy
2513
2514 if ( x == 0.0d+00 ) then
2515 digit = 0
2516 return
2517 end if
2518
2519 if ( idigit <= 0 ) then
2520 digit = 0
2521 return
2522 end if
2523!
2524! Set XCOPY = X, and then force XCOPY to lie between 1 and 10.
2525!
2526 xcopy = abs( x )
2527
2528 do while ( xcopy < 1.0d+00 )
2529 xcopy = xcopy * 10.0d+00
2530 end do
2531
2532 do while ( 10.0d+00 <= xcopy )
2533 xcopy = xcopy / 10.0d+00
2534 end do
2535
2536 do i = 1, idigit
2537 ival = int( xcopy )
2538 xcopy = ( xcopy - ival ) * 10.0d+00
2539 end do
2540
2541 digit = ival
2542
2543 return

◆ r8_divide_i4()

real ( kind = 8 ) function r8_divide_i4 ( integer ( kind = 4 )  i,
integer ( kind = 4 )  j 
)

Definition at line 2545 of file R8LIB.f90.

2546
2547!*****************************************************************************80
2548!
2549!! R8_DIVIDE_I4 returns an I4 fraction as an R8.
2550!
2551! Licensing:
2552!
2553! This code is distributed under the GNU LGPL license.
2554!
2555! Modified:
2556!
2557! 05 June 2012
2558!
2559! Author:
2560!
2561! John Burkardt
2562!
2563! Parameters:
2564!
2565! Input, integer ( kind = 4 ) I, J, the numerator and denominator.
2566!
2567! Output, real ( kind = 8 ) R8_DIVIDE_I4, the value of (I/J).
2568!
2569 implicit none
2570
2571 integer ( kind = 4 ) i
2572 integer ( kind = 4 ) j
2573 real ( kind = 8 ) r8_divide_i4
2574
2575 r8_divide_i4 = real( i, kind = 8 ) / real( j, kind = 8 )
2576
2577 return
r8_divide_i4
real(kind=8) function r8_divide_i4(i, j)
Definition R8LIB.f90:2546

References r8_divide_i4().

Referenced by r8_divide_i4().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_epsilon()

real ( kind = 8 ) function r8_epsilon

Definition at line 2579 of file R8LIB.f90.

2580
2581!*****************************************************************************80
2582!
2583!! R8_EPSILON returns the R8 roundoff unit.
2584!
2585! Discussion:
2586!
2587! The roundoff unit is a number R which is a power of 2 with the
2588! property that, to the precision of the computer's arithmetic,
2589! 1 < 1 + R
2590! but
2591! 1 = ( 1 + R / 2 )
2592!
2593! FORTRAN90 provides the superior library routine
2594!
2595! EPSILON ( X )
2596!
2597! Licensing:
2598!
2599! This code is distributed under the GNU LGPL license.
2600!
2601! Modified:
2602!
2603! 01 September 2012
2604!
2605! Author:
2606!
2607! John Burkardt
2608!
2609! Parameters:
2610!
2611! Output, real ( kind = 8 ) R8_EPSILON, the round-off unit.
2612!
2613 implicit none
2614
2615 real ( kind = 8 ) r8_epsilon
2616
2617 r8_epsilon = 2.220446049250313d-016
2618
2619 return
r8_epsilon
real(kind=8) function r8_epsilon()
Definition R8LIB.f90:2580

References r8_epsilon().

Referenced by r8_epsilon(), and r8_gamma().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_epsilon_compute()

real ( kind = 8 ) function r8_epsilon_compute

Definition at line 2621 of file R8LIB.f90.

2622
2623!*****************************************************************************80
2624!
2625!! R8_EPSILON_COMPUTE computes the R8 roundoff unit.
2626!
2627! Discussion:
2628!
2629! The roundoff unit is a number R which is a power of 2 with the
2630! property that, to the precision of the computer's arithmetic,
2631! 1 < 1 + R
2632! but
2633! 1 = ( 1 + R / 2 )
2634!
2635! FORTRAN90 provides the superior library routine
2636!
2637! EPSILON ( X )
2638!
2639! Licensing:
2640!
2641! This code is distributed under the GNU LGPL license.
2642!
2643! Modified:
2644!
2645! 31 August 2012
2646!
2647! Author:
2648!
2649! John Burkardt
2650!
2651! Parameters:
2652!
2653! Output, real ( kind = 8 ) R8_EPSILON_COMPUTE, the computed round-off unit.
2654!
2655 implicit none
2656
2657 real ( kind = 8 ) one
2658 real ( kind = 8 ) r8_add
2659 real ( kind = 8 ) r8_epsilon_compute
2660 real ( kind = 8 ) temp
2661 real ( kind = 8 ) test
2662 real ( kind = 8 ) value
2663
2664 one = real( 1, kind = 8 )
2665
2666 value = one
2667 temp = value / 2.0d+00
2668 test = r8_add( one, temp )
2669
2670 do while ( one < test )
2671 value = temp
2672 temp = value / 2.0d+00
2673 test = r8_add( one, temp )
2674 end do
2675
2676 r8_epsilon_compute = value
2677
2678 return
r8_epsilon_compute
real(kind=8) function r8_epsilon_compute()
Definition R8LIB.f90:2622

References r8_add(), and r8_epsilon_compute().

Referenced by r8_epsilon_compute().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_exp()

real ( kind = 8 ) function r8_exp ( real ( kind = 8 )  x)

Definition at line 2680 of file R8LIB.f90.

2681
2682!*****************************************************************************80
2683!
2684!! R8_EXP computes the exponential of an R8, avoiding overflow and underflow.
2685!
2686! Discussion:
2687!
2688! For arguments of very large magnitude, the evaluation of the
2689! exponential function can cause computational problems. Some languages
2690! and compilers may return an infinite value or a "Not-a-Number".
2691! An alternative, when dealing with a wide range of inputs, is simply
2692! to truncate the calculation for arguments whose magnitude is too large.
2693! Whether this is the right or convenient approach depends on the problem
2694! you are dealing with, and whether or not you really need accurate
2695! results for large magnitude inputs, or you just want your code to
2696! stop crashing.
2697!
2698! Licensing:
2699!
2700! This code is distributed under the GNU LGPL license.
2701!
2702! Modified:
2703!
2704! 19 September 2014
2705!
2706! Author:
2707!
2708! John Burkardt
2709!
2710! Parameters:
2711!
2712! Input, real ( kind = 8 ) X, the argument of the exponential function.
2713!
2714! Output, real ( kind = 8 ) R8_EXP, the value of exp ( X ).
2715!
2716 implicit none
2717
2718 real ( kind = 8 ) r8_exp
2719 real ( kind = 8 ), parameter :: r8_big = 1.0d+30
2720 real ( kind = 8 ), parameter :: r8_log_max = +69.0776d+00
2721 real ( kind = 8 ), parameter :: r8_log_min = -69.0776d+00
2722 real ( kind = 8 ) value
2723 real ( kind = 8 ) x
2724
2725 if ( x <= r8_log_min ) then
2726 value = 0.0d+00
2727 else if ( x < r8_log_max ) then
2728 value = exp( x )
2729 else
2730 value = r8_big
2731 end if
2732
2733 r8_exp = value
2734
2735 return
r8_exp
real(kind=8) function r8_exp(x)
Definition R8LIB.f90:2681

References r8_big(), and r8_exp().

Referenced by r8_exp().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_factorial()

real ( kind = 8 ) function r8_factorial ( integer ( kind = 4 )  n)

Definition at line 2737 of file R8LIB.f90.

2738
2739!*****************************************************************************80
2740!
2741!! R8_FACTORIAL computes the factorial of N.
2742!
2743! Discussion:
2744!
2745! factorial ( N ) = product ( 1 <= I <= N ) I
2746!
2747! Licensing:
2748!
2749! This code is distributed under the GNU LGPL license.
2750!
2751! Modified:
2752!
2753! 16 January 1999
2754!
2755! Author:
2756!
2757! John Burkardt
2758!
2759! Parameters:
2760!
2761! Input, integer ( kind = 4 ) N, the argument of the factorial function.
2762! If N is less than 1, the function value is returned as 1.
2763!
2764! Output, real ( kind = 8 ) R8_FACTORIAL, the factorial of N.
2765!
2766 implicit none
2767
2768 real ( kind = 8 ) r8_factorial
2769 integer ( kind = 4 ) i
2770 integer ( kind = 4 ) n
2771 real ( kind = 8 ) value
2772
2773 value = 1.0d+00
2774
2775 do i = 1, n
2776 value = value * real( i, kind = 8 )
2777 end do
2778
2779 r8_factorial = value
2780
2781 return
r8_factorial
real(kind=8) function r8_factorial(n)
Definition R8LIB.f90:2738

References r8_factorial().

Referenced by r8_factorial().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_factorial2()

real ( kind = 8 ) function r8_factorial2 ( integer ( kind = 4 )  n)

Definition at line 2783 of file R8LIB.f90.

2784
2785!*****************************************************************************80
2786!
2787!! R8_FACTORIAL2 computes the double factorial function.
2788!
2789! Discussion:
2790!
2791! FACTORIAL2( N ) = Product ( N * (N-2) * (N-4) * ... * 2 ) (N even)
2792! = Product ( N * (N-2) * (N-4) * ... * 1 ) (N odd)
2793!
2794! Example:
2795!
2796! N Value
2797!
2798! 0 1
2799! 1 1
2800! 2 2
2801! 3 3
2802! 4 8
2803! 5 15
2804! 6 48
2805! 7 105
2806! 8 384
2807! 9 945
2808! 10 3840
2809!
2810! Licensing:
2811!
2812! This code is distributed under the GNU LGPL license.
2813!
2814! Modified:
2815!
2816! 02 September 2007
2817!
2818! Author:
2819!
2820! John Burkardt
2821!
2822! Parameters:
2823!
2824! Input, integer ( kind = 4 ) N, the argument of the double factorial
2825! function. If N is less than 1, the value is returned as 1.0.
2826!
2827! Output, real ( kind = 8 ) R8_FACTORIAL2, the value.
2828!
2829 implicit none
2830
2831 integer ( kind = 4 ) n
2832 real ( kind = 8 ) r8_factorial2
2833 real ( kind = 8 ) r8_n
2834 real ( kind = 8 ) value
2835
2836 value = 1.0d+00
2837
2838 if ( 1 <= n ) then
2839
2840 r8_n = real( n, kind = 8 )
2841
2842 do while ( 1.0d+00 < r8_n )
2843 value = value * r8_n
2844 r8_n = r8_n - 2.0d+00
2845 end do
2846
2847 end if
2848
2849 r8_factorial2 = value
2850
2851 return
r8_factorial2
real(kind=8) function r8_factorial2(n)
Definition R8LIB.f90:2784

References r8_factorial2().

Referenced by r8_factorial2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_fall()

real ( kind = 8 ) function r8_fall ( real ( kind = 8 )  x,
integer ( kind = 4 )  n 
)

Definition at line 2853 of file R8LIB.f90.

2854
2855!*****************************************************************************80
2856!
2857!! R8_FALL computes the falling factorial function [X]_N.
2858!
2859! Discussion:
2860!
2861! Note that the number of "injections" or 1-to-1 mappings from
2862! a set of N elements to a set of M elements is [M]_N.
2863!
2864! The number of permutations of N objects out of M is [M]_N.
2865!
2866! Moreover, the Stirling numbers of the first kind can be used
2867! to convert a falling factorial into a polynomial, as follows:
2868!
2869! [X]_N = S^0_N + S^1_N * X + S^2_N * X^2 + ... + S^N_N X^N.
2870!
2871! The formula used is:
2872!
2873! [X]_N = X * ( X - 1 ) * ( X - 2 ) * ... * ( X - N + 1 ).
2874!
2875! Licensing:
2876!
2877! This code is distributed under the GNU LGPL license.
2878!
2879! Modified:
2880!
2881! 08 May 2003
2882!
2883! Author:
2884!
2885! John Burkardt
2886!
2887! Parameters:
2888!
2889! Input, real ( kind = 8 ) X, the argument of the falling factorial function.
2890!
2891! Input, integer ( kind = 4 ) N, the order of the falling factorial function.
2892! If N = 0, FALL = 1, if N = 1, FALL = X. Note that if N is
2893! negative, a "rising" factorial will be computed.
2894!
2895! Output, real ( kind = 8 ) R8_FALL, the value of the falling
2896! factorial function.
2897!
2898 implicit none
2899
2900 real ( kind = 8 ) arg
2901 integer ( kind = 4 ) i
2902 integer ( kind = 4 ) n
2903 real ( kind = 8 ) r8_fall
2904 real ( kind = 8 ) value
2905 real ( kind = 8 ) x
2906
2907 value = 1.0d+00
2908
2909 arg = x
2910
2911 if ( 0 < n ) then
2912
2913 do i = 1, n
2914 value = value * arg
2915 arg = arg - 1.0d+00
2916 end do
2917
2918 else if ( n < 0 ) then
2919
2920 do i = -1, n, -1
2921 value = value * arg
2922 arg = arg + 1.0d+00
2923 end do
2924
2925 end if
2926
2927 r8_fall = value
2928
2929 return
r8_fall
real(kind=8) function r8_fall(x, n)
Definition R8LIB.f90:2854

References r8_fall().

Referenced by r8_fall().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_floor()

real ( kind = 8 ) function r8_floor ( real ( kind = 8 )  r)

Definition at line 2931 of file R8LIB.f90.

2932
2933!*****************************************************************************80
2934!
2935!! R8_FLOOR rounds an R8 "down" (towards -oo) to the nearest integral R8.
2936!
2937! Example:
2938!
2939! R Value
2940!
2941! -1.1 -2.0
2942! -1.0 -1.0
2943! -0.9 -1.0
2944! 0.0 0.0
2945! 5.0 5.0
2946! 5.1 5.0
2947! 5.9 5.0
2948! 6.0 6.0
2949!
2950! Licensing:
2951!
2952! This code is distributed under the GNU LGPL license.
2953!
2954! Modified:
2955!
2956! 10 November 2011
2957!
2958! Author:
2959!
2960! John Burkardt
2961!
2962! Parameters:
2963!
2964! Input, real ( kind = 8 ) R, the value to be rounded down.
2965!
2966! Output, real ( kind = 8 ) R8_FLOOR, the rounded value.
2967!
2968 implicit none
2969
2970 real ( kind = 8 ) r
2971 real ( kind = 8 ) r8_floor
2972 real ( kind = 8 ) value
2973
2974 value = real( int( r ), kind = 8 )
2975 if ( r < value ) then
2976 value = value - 1.0d+00
2977 end if
2978
2979 r8_floor = value
2980
2981 return
r8_floor
real(kind=8) function r8_floor(r)
Definition R8LIB.f90:2932

References r8_floor().

Referenced by r8_floor().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_fraction()

real ( kind = 8 ) function r8_fraction ( integer ( kind = 4 )  i,
integer ( kind = 4 )  j 
)

Definition at line 2983 of file R8LIB.f90.

2984
2985!*****************************************************************************80
2986!
2987!! R8_FRACTION uses real arithmetic on an integer ratio.
2988!
2989! Discussion:
2990!
2991! Given integer variables I and J, both FORTRAN and C will evaluate
2992! an expression such as "I/J" using what is called "integer division",
2993! with the result being an integer. It is often convenient to express
2994! the parts of a fraction as integers but expect the result to be computed
2995! using real arithmetic. This function carries out that operation.
2996!
2997! Example:
2998!
2999! I J I/J R8_FRACTION
3000!
3001! 1 2 0 0.5
3002! 7 4 1 1.75
3003! 8 4 2 2.00
3004! 9 4 2 2.25
3005!
3006! Licensing:
3007!
3008! This code is distributed under the GNU LGPL license.
3009!
3010! Modified:
3011!
3012! 05 October 2010
3013!
3014! Author:
3015!
3016! John Burkardt
3017!
3018! Parameters:
3019!
3020! Input, integer ( kind = 4 ) I, J, the arguments.
3021!
3022! Output, real ( kind = 8 ) R8_FRACTION, the value of the ratio.
3023!
3024 implicit none
3025
3026 integer ( kind = 4 ) i
3027 integer ( kind = 4 ) j
3028 real ( kind = 8 ) r8_fraction
3029
3030 r8_fraction = real( i, kind = 8 ) / real( j, kind = 8 )
3031
3032 return
r8_fraction
real(kind=8) function r8_fraction(i, j)
Definition R8LIB.f90:2984

References r8_fraction().

Referenced by r8_fraction().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_fractional()

real ( kind = 8 ) function r8_fractional ( real ( kind = 8 )  x)

Definition at line 3034 of file R8LIB.f90.

3035
3036!*****************************************************************************80
3037!
3038!! R8_FRACTIONAL returns the fractional part of an R8.
3039!
3040! Discussion:
3041!
3042! If we regard a real number as
3043!
3044! R = SIGN * ( WHOLE + FRACTION )
3045!
3046! where
3047!
3048! SIGN is +1 or -1,
3049! WHOLE is a nonnegative integer
3050! FRACTION is a nonnegative real number strictly less than 1,
3051!
3052! then this routine returns the value of FRACTION.
3053!
3054! Example:
3055!
3056! R FRACTION
3057!
3058! 0.00 0.00
3059! 1.01 0.01
3060! 2.02 0.02
3061! 19.73 0.73
3062! -4.34 0.34
3063!
3064! Licensing:
3065!
3066! This code is distributed under the GNU LGPL license.
3067!
3068! Modified:
3069!
3070! 16 January 2007
3071!
3072! Author:
3073!
3074! John Burkardt
3075!
3076! Parameters:
3077!
3078! Input, real ( kind = 8 ) X, the argument.
3079!
3080! Output, real ( kind = 8 ) R8_FRACTIONAL, the fractional part of X.
3081!
3082 implicit none
3083
3084 real ( kind = 8 ) r8_fractional
3085 real ( kind = 8 ) x
3086
3087 r8_fractional = abs( x ) - real( int( abs( x ) ), kind = 8 )
3088
3089 return
r8_fractional
real(kind=8) function r8_fractional(x)
Definition R8LIB.f90:3035

References r8_fractional().

Referenced by r8_fractional().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_gamma()

real ( kind = 8 ) function r8_gamma ( real ( kind = 8 )  x)

Definition at line 3091 of file R8LIB.f90.

3092
3093!*****************************************************************************80
3094!
3095!! R8_GAMMA evaluates Gamma(X) for a real argument.
3096!
3097! Discussion:
3098!
3099! This routine calculates the gamma function for a real argument X.
3100!
3101! Computation is based on an algorithm outlined in reference 1.
3102! The program uses rational functions that approximate the gamma
3103! function to at least 20 significant decimal digits. Coefficients
3104! for the approximation over the interval (1,2) are unpublished.
3105! Those for the approximation for 12 <= X are from reference 2.
3106!
3107! Licensing:
3108!
3109! This code is distributed under the GNU LGPL license.
3110!
3111! Modified:
3112!
3113! 15 April 2013
3114!
3115! Author:
3116!
3117! Original FORTRAN77 version by William Cody, Laura Stoltz.
3118! FORTRAN90 version by John Burkardt.
3119!
3120! Reference:
3121!
3122! William Cody,
3123! An Overview of Software Development for Special Functions,
3124! in Numerical Analysis Dundee, 1975,
3125! edited by GA Watson,
3126! Lecture Notes in Mathematics 506,
3127! Springer, 1976.
3128!
3129! John Hart, Ward Cheney, Charles Lawson, Hans Maehly,
3130! Charles Mesztenyi, John Rice, Henry Thatcher,
3131! Christoph Witzgall,
3132! Computer Approximations,
3133! Wiley, 1968,
3134! LC: QA297.C64.
3135!
3136! Parameters:
3137!
3138! Input, real ( kind = 8 ) X, the argument of the function.
3139!
3140! Output, real ( kind = 8 ) R8_GAMMA, the value of the function.
3141!
3142 implicit none
3143
3144 real ( kind = 8 ), dimension ( 7 ) :: c = (/ &
3145 -1.910444077728d-03, &
3146 8.4171387781295d-04, &
3147 -5.952379913043012d-04, &
3148 7.93650793500350248d-04, &
3149 -2.777777777777681622553d-03, &
3150 8.333333333333333331554247d-02, &
3151 5.7083835261d-03 /)
3152 real ( kind = 8 ) fact
3153 integer ( kind = 4 ) i
3154 integer ( kind = 4 ) n
3155 real ( kind = 8 ), dimension ( 8 ) :: p = (/ &
3156 -1.71618513886549492533811d+00, &
3157 2.47656508055759199108314d+01, &
3158 -3.79804256470945635097577d+02, &
3159 6.29331155312818442661052d+02, &
3160 8.66966202790413211295064d+02, &
3161 -3.14512729688483675254357d+04, &
3162 -3.61444134186911729807069d+04, &
3163 6.64561438202405440627855d+04 /)
3164 logical ( kind = 4 ) parity
3165 real ( kind = 8 ), dimension ( 8 ) :: q = (/ &
3166 -3.08402300119738975254353d+01, &
3167 3.15350626979604161529144d+02, &
3168 -1.01515636749021914166146d+03, &
3169 -3.10777167157231109440444d+03, &
3170 2.25381184209801510330112d+04, &
3171 4.75584627752788110767815d+03, &
3172 -1.34659959864969306392456d+05, &
3173 -1.15132259675553483497211d+05 /)
3174 real ( kind = 8 ) r8_epsilon
3175 real ( kind = 8 ) r8_gamma
3176 real ( kind = 8 ), parameter :: r8_pi = 3.1415926535897932384626434d+00
3177 real ( kind = 8 ) res
3178 real ( kind = 8 ), parameter :: sqrtpi = 0.9189385332046727417803297d+00
3179 real ( kind = 8 ) sum
3180 real ( kind = 8 ) x
3181 real ( kind = 8 ), parameter :: xbig = 171.624d+00
3182 real ( kind = 8 ) xden
3183 real ( kind = 8 ), parameter :: xinf = 1.79d+308
3184 real ( kind = 8 ), parameter :: xminin = 2.23d-308
3185 real ( kind = 8 ) xnum
3186 real ( kind = 8 ) y
3187 real ( kind = 8 ) y1
3188 real ( kind = 8 ) ysq
3189 real ( kind = 8 ) z
3190
3191 parity = .false.
3192 fact = 1.0d+00
3193 n = 0
3194 y = x
3195!
3196! Argument is negative.
3197!
3198 if ( y <= 0.0d+00 ) then
3199
3200 y = - x
3201 y1 = aint( y )
3202 res = y - y1
3203
3204 if ( res /= 0.0d+00 ) then
3205
3206 if ( y1 /= aint( y1 * 0.5d+00 ) * 2.0d+00 ) then
3207 parity = .true.
3208 end if
3209
3210 fact = - r8_pi / sin( r8_pi * res )
3211 y = y + 1.0d+00
3212
3213 else
3214
3215 res = xinf
3216 r8_gamma = res
3217 return
3218
3219 end if
3220
3221 end if
3222!
3223! Argument is positive.
3224!
3225 if ( y < r8_epsilon( ) ) then
3226!
3227! Argument < EPS.
3228!
3229 if ( xminin <= y ) then
3230 res = 1.0d+00 / y
3231 else
3232 res = xinf
3233 r8_gamma = res
3234 return
3235 end if
3236
3237 else if ( y < 12.0d+00 ) then
3238
3239 y1 = y
3240!
3241! 0.0 < argument < 1.0.
3242!
3243 if ( y < 1.0d+00 ) then
3244
3245 z = y
3246 y = y + 1.0d+00
3247!
3248! 1.0 < argument < 12.0.
3249! Reduce argument if necessary.
3250!
3251 else
3252
3253 n = int( y ) - 1
3254 y = y - real( n, kind = 8 )
3255 z = y - 1.0d+00
3256
3257 end if
3258!
3259! Evaluate approximation for 1.0 < argument < 2.0.
3260!
3261 xnum = 0.0d+00
3262 xden = 1.0d+00
3263 do i = 1, 8
3264 xnum = ( xnum + p(i) ) * z
3265 xden = xden * z + q(i)
3266 end do
3267
3268 res = xnum / xden + 1.0d+00
3269!
3270! Adjust result for case 0.0 < argument < 1.0.
3271!
3272 if ( y1 < y ) then
3273
3274 res = res / y1
3275!
3276! Adjust result for case 2.0 < argument < 12.0.
3277!
3278 else if ( y < y1 ) then
3279
3280 do i = 1, n
3281 res = res * y
3282 y = y + 1.0d+00
3283 end do
3284
3285 end if
3286
3287 else
3288!
3289! Evaluate for 12.0 <= argument.
3290!
3291 if ( y <= xbig ) then
3292
3293 ysq = y * y
3294 sum = c(7)
3295 do i = 1, 6
3296 sum = sum / ysq + c(i)
3297 end do
3298 sum = sum / y - y + sqrtpi
3299 sum = sum + ( y - 0.5d+00 ) * log( y )
3300 res = exp( sum )
3301
3302 else
3303
3304 res = xinf
3305 r8_gamma = res
3306 return
3307
3308 end if
3309
3310 end if
3311!
3312! Final adjustments and return.
3313!
3314 if ( parity ) then
3315 res = - res
3316 end if
3317
3318 if ( fact /= 1.0d+00 ) then
3319 res = fact / res
3320 end if
3321
3322 r8_gamma = res
3323
3324 return
r8_gamma
real(kind=8) function r8_gamma(x)
Definition R8LIB.f90:3092

References r8_epsilon(), r8_gamma(), and r8_pi().

Referenced by r8_gamma().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_gamma_log()

real ( kind = 8 ) function r8_gamma_log ( real ( kind = 8 )  x)

Definition at line 3326 of file R8LIB.f90.

3327
3328!*****************************************************************************80
3329!
3330!! R8_GAMMA_LOG evaluates the logarithm of the gamma function.
3331!
3332! Discussion:
3333!
3334! This routine calculates the LOG(GAMMA) function for a positive real
3335! argument X. Computation is based on an algorithm outlined in
3336! references 1 and 2. The program uses rational functions that
3337! theoretically approximate LOG(GAMMA) to at least 18 significant
3338! decimal digits. The approximation for X > 12 is from reference
3339! 3, while approximations for X < 12.0 are similar to those in
3340! reference 1, but are unpublished.
3341!
3342! Licensing:
3343!
3344! This code is distributed under the GNU LGPL license.
3345!
3346! Modified:
3347!
3348! 15 April 2013
3349!
3350! Author:
3351!
3352! Original FORTRAN77 version by William Cody, Laura Stoltz.
3353! FORTRAN90 version by John Burkardt.
3354!
3355! Reference:
3356!
3357! William Cody, Kenneth Hillstrom,
3358! Chebyshev Approximations for the Natural Logarithm of the
3359! Gamma Function,
3360! Mathematics of Computation,
3361! Volume 21, Number 98, April 1967, pages 198-203.
3362!
3363! Kenneth Hillstrom,
3364! ANL/AMD Program ANLC366S, DGAMMA/DLGAMA,
3365! May 1969.
3366!
3367! John Hart, Ward Cheney, Charles Lawson, Hans Maehly,
3368! Charles Mesztenyi, John Rice, Henry Thatcher,
3369! Christoph Witzgall,
3370! Computer Approximations,
3371! Wiley, 1968,
3372! LC: QA297.C64.
3373!
3374! Parameters:
3375!
3376! Input, real ( kind = 8 ) X, the argument of the function.
3377!
3378! Output, real ( kind = 8 ) R8_GAMMA_LOG, the value of the function.
3379!
3380 implicit none
3381
3382 real ( kind = 8 ), dimension ( 7 ) :: c = (/ &
3383 -1.910444077728d-03, &
3384 8.4171387781295d-04, &
3385 -5.952379913043012d-04, &
3386 7.93650793500350248d-04, &
3387 -2.777777777777681622553d-03, &
3388 8.333333333333333331554247d-02, &
3389 5.7083835261d-03 /)
3390 real ( kind = 8 ) corr
3391 real ( kind = 8 ) :: d1 = -5.772156649015328605195174d-01
3392 real ( kind = 8 ) :: d2 = 4.227843350984671393993777d-01
3393 real ( kind = 8 ) :: d4 = 1.791759469228055000094023d+00
3394 real ( kind = 8 ), parameter :: frtbig = 2.25d+76
3395 integer ( kind = 4 ) i
3396 real ( kind = 8 ), dimension ( 8 ) :: p1 = (/ &
3397 4.945235359296727046734888d+00, &
3398 2.018112620856775083915565d+02, &
3399 2.290838373831346393026739d+03, &
3400 1.131967205903380828685045d+04, &
3401 2.855724635671635335736389d+04, &
3402 3.848496228443793359990269d+04, &
3403 2.637748787624195437963534d+04, &
3404 7.225813979700288197698961d+03 /)
3405 real ( kind = 8 ), dimension ( 8 ) :: p2 = (/ &
3406 4.974607845568932035012064d+00, &
3407 5.424138599891070494101986d+02, &
3408 1.550693864978364947665077d+04, &
3409 1.847932904445632425417223d+05, &
3410 1.088204769468828767498470d+06, &
3411 3.338152967987029735917223d+06, &
3412 5.106661678927352456275255d+06, &
3413 3.074109054850539556250927d+06 /)
3414 real ( kind = 8 ), dimension ( 8 ) :: p4 = (/ &
3415 1.474502166059939948905062d+04, &
3416 2.426813369486704502836312d+06, &
3417 1.214755574045093227939592d+08, &
3418 2.663432449630976949898078d+09, &
3419 2.940378956634553899906876d+10, &
3420 1.702665737765398868392998d+11, &
3421 4.926125793377430887588120d+11, &
3422 5.606251856223951465078242d+11 /)
3423 real ( kind = 8 ), dimension ( 8 ) :: q1 = (/ &
3424 6.748212550303777196073036d+01, &
3425 1.113332393857199323513008d+03, &
3426 7.738757056935398733233834d+03, &
3427 2.763987074403340708898585d+04, &
3428 5.499310206226157329794414d+04, &
3429 6.161122180066002127833352d+04, &
3430 3.635127591501940507276287d+04, &
3431 8.785536302431013170870835d+03 /)
3432 real ( kind = 8 ), dimension ( 8 ) :: q2 = (/ &
3433 1.830328399370592604055942d+02, &
3434 7.765049321445005871323047d+03, &
3435 1.331903827966074194402448d+05, &
3436 1.136705821321969608938755d+06, &
3437 5.267964117437946917577538d+06, &
3438 1.346701454311101692290052d+07, &
3439 1.782736530353274213975932d+07, &
3440 9.533095591844353613395747d+06 /)
3441 real ( kind = 8 ), dimension ( 8 ) :: q4 = (/ &
3442 2.690530175870899333379843d+03, &
3443 6.393885654300092398984238d+05, &
3444 4.135599930241388052042842d+07, &
3445 1.120872109616147941376570d+09, &
3446 1.488613728678813811542398d+10, &
3447 1.016803586272438228077304d+11, &
3448 3.417476345507377132798597d+11, &
3449 4.463158187419713286462081d+11 /)
3450 real ( kind = 8 ) r8_gamma_log
3451 real ( kind = 8 ) res
3452 real ( kind = 8 ), parameter :: sqrtpi = 0.9189385332046727417803297d+00
3453 real ( kind = 8 ) x
3454 real ( kind = 8 ), parameter :: xbig = 2.55d+305
3455 real ( kind = 8 ) xden
3456 real ( kind = 8 ), parameter :: xinf = 1.79d+308
3457 real ( kind = 8 ) xm1
3458 real ( kind = 8 ) xm2
3459 real ( kind = 8 ) xm4
3460 real ( kind = 8 ) xnum
3461 real ( kind = 8 ) y
3462 real ( kind = 8 ) ysq
3463
3464 y = x
3465
3466 if ( 0.0d+00 < y .and. y <= xbig ) then
3467
3468 if ( y <= epsilon( y ) ) then
3469
3470 res = - log( y )
3471!
3472! EPS < X <= 1.5.
3473!
3474 else if ( y <= 1.5d+00 ) then
3475
3476 if ( y < 0.6796875d+00 ) then
3477 corr = -log( y )
3478 xm1 = y
3479 else
3480 corr = 0.0d+00
3481 xm1 = ( y - 0.5d+00 ) - 0.5d+00
3482 end if
3483
3484 if ( y <= 0.5d+00 .or. 0.6796875d+00 <= y ) then
3485
3486 xden = 1.0d+00
3487 xnum = 0.0d+00
3488 do i = 1, 8
3489 xnum = xnum * xm1 + p1(i)
3490 xden = xden * xm1 + q1(i)
3491 end do
3492
3493 res = corr + ( xm1 * ( d1 + xm1 * ( xnum / xden ) ) )
3494
3495 else
3496
3497 xm2 = ( y - 0.5d+00 ) - 0.5d+00
3498 xden = 1.0d+00
3499 xnum = 0.0d+00
3500 do i = 1, 8
3501 xnum = xnum * xm2 + p2(i)
3502 xden = xden * xm2 + q2(i)
3503 end do
3504
3505 res = corr + xm2 * ( d2 + xm2 * ( xnum / xden ) )
3506
3507 end if
3508!
3509! 1.5 < X <= 4.0.
3510!
3511 else if ( y <= 4.0d+00 ) then
3512
3513 xm2 = y - 2.0d+00
3514 xden = 1.0d+00
3515 xnum = 0.0d+00
3516 do i = 1, 8
3517 xnum = xnum * xm2 + p2(i)
3518 xden = xden * xm2 + q2(i)
3519 end do
3520
3521 res = xm2 * ( d2 + xm2 * ( xnum / xden ) )
3522!
3523! 4.0 < X <= 12.0.
3524!
3525 else if ( y <= 12.0d+00 ) then
3526
3527 xm4 = y - 4.0d+00
3528 xden = -1.0d+00
3529 xnum = 0.0d+00
3530 do i = 1, 8
3531 xnum = xnum * xm4 + p4(i)
3532 xden = xden * xm4 + q4(i)
3533 end do
3534
3535 res = d4 + xm4 * ( xnum / xden )
3536!
3537! Evaluate for 12 <= argument.
3538!
3539 else
3540
3541 res = 0.0d+00
3542
3543 if ( y <= frtbig ) then
3544
3545 res = c(7)
3546 ysq = y * y
3547
3548 do i = 1, 6
3549 res = res / ysq + c(i)
3550 end do
3551
3552 end if
3553
3554 res = res / y
3555 corr = log( y )
3556 res = res + sqrtpi - 0.5d+00 * corr
3557 res = res + y * ( corr - 1.0d+00 )
3558
3559 end if
3560!
3561! Return for bad arguments.
3562!
3563 else
3564
3565 res = xinf
3566
3567 end if
3568!
3569! Final adjustments and return.
3570!
3571 r8_gamma_log = res
3572
3573 return
r8_gamma_log
real(kind=8) function r8_gamma_log(x)
Definition R8LIB.f90:3327

References r8_gamma_log().

Referenced by r8_gamma_log().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_huge()

real ( kind = 8 ) function r8_huge

Definition at line 3575 of file R8LIB.f90.

3576
3577!*****************************************************************************80
3578!
3579!! R8_HUGE returns a very large R8.
3580!
3581! Discussion:
3582!
3583! The value returned by this function is intended to be the largest
3584! representable real value.
3585!
3586! FORTRAN90 provides a built-in routine HUGE ( X ) that
3587! can return the maximum representable number of the same datatype
3588! as X, if that is what is really desired.
3589!
3590! Licensing:
3591!
3592! This code is distributed under the GNU LGPL license.
3593!
3594! Modified:
3595!
3596! 27 September 2014
3597!
3598! Author:
3599!
3600! John Burkardt
3601!
3602! Parameters:
3603!
3604! Output, real ( kind = 8 ) R8_HUGE, a "huge" value.
3605!
3606 implicit none
3607
3608 real ( kind = 8 ) r8_huge
3609
3610 r8_huge = 1.79769313486231571d+308
3611
3612 return
r8_huge
real(kind=8) function r8_huge()
Definition R8LIB.f90:3576

References r8_huge().

Referenced by r8_huge().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_hypot()

real ( kind = 8 ) function r8_hypot ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 3614 of file R8LIB.f90.

3615
3616!*****************************************************************************80
3617!
3618!! R8_HYPOT returns the value of sqrt ( X^2 + Y^2 ).
3619!
3620! Licensing:
3621!
3622! This code is distributed under the GNU LGPL license.
3623!
3624! Modified:
3625!
3626! 22 March 2012
3627!
3628! Author:
3629!
3630! John Burkardt
3631!
3632! Parameters:
3633!
3634! Input, real ( kind = 8 ) X, Y, the arguments.
3635!
3636! Output, real ( kind = 8 ) R8_HYPOT, the value of sqrt ( X^2 + Y^2 ).
3637!
3638 implicit none
3639
3640 real ( kind = 8 ) a
3641 real ( kind = 8 ) b
3642 real ( kind = 8 ) c
3643 real ( kind = 8 ) r8_hypot
3644 real ( kind = 8 ) x
3645 real ( kind = 8 ) y
3646
3647 if ( abs( x ) < abs( y ) ) then
3648 a = abs( y )
3649 b = abs( x )
3650 else
3651 a = abs( x )
3652 b = abs( y )
3653 end if
3654!
3655! A contains the larger value.
3656!
3657 if ( a == 0.0d+00 ) then
3658 c = 0.0d+00
3659 else
3660 c = a * sqrt( 1.0d+00 + ( b / a )**2 )
3661 end if
3662
3663 r8_hypot = c
3664
3665 return
r8_hypot
real(kind=8) function r8_hypot(x, y)
Definition R8LIB.f90:3615

References r8_hypot().

Referenced by r8_hypot().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_in_01()

logical ( kind = 4 ) function r8_in_01 ( real ( kind = 8 )  a)

Definition at line 3667 of file R8LIB.f90.

3668
3669!*****************************************************************************80
3670!
3671!! R8_IN_01 is TRUE if an R8 is in the range [0,1].
3672!
3673! Licensing:
3674!
3675! This code is distributed under the GNU LGPL license.
3676!
3677! Modified:
3678!
3679! 06 October 2004
3680!
3681! Author:
3682!
3683! John Burkardt
3684!
3685! Parameters:
3686!
3687! Input, real ( kind = 8 ) A, the value.
3688!
3689! Output, logical ( kind = 4 ) R8_IN_01, is TRUE if 0 <= A <= 1.
3690!
3691 implicit none
3692
3693 real ( kind = 8 ) a
3694 logical ( kind = 4 ) r8_in_01
3695 logical ( kind = 4 ) value
3696
3697 if ( a < 0.0d+00 .or. 1.0d+00 < a ) then
3698 value = .false.
3699 else
3700 value = .true.
3701 end if
3702
3703 r8_in_01 = value
3704
3705 return
r8_in_01
logical(kind=4) function r8_in_01(a)
Definition R8LIB.f90:3668

References r8_in_01().

Referenced by r8_in_01().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_insignificant()

logical ( kind = 4 ) function r8_insignificant ( real ( kind = 8 )  r,
real ( kind = 8 )  s 
)

Definition at line 3707 of file R8LIB.f90.

3708
3709!*****************************************************************************80
3710!
3711!! R8_INSIGNIFICANT determines if an R8 is insignificant.
3712!
3713! Licensing:
3714!
3715! This code is distributed under the GNU LGPL license.
3716!
3717! Modified:
3718!
3719! 26 November 2011
3720!
3721! Author:
3722!
3723! John Burkardt
3724!
3725! Parameters:
3726!
3727! Input, real ( kind = 8 ) R, the number to be compared against.
3728!
3729! Input, real ( kind = 8 ) S, the number to be compared.
3730!
3731! Output, logical ( kind = 4 ) R8_INSIGNIFICANT, is TRUE if S is
3732! insignificant compared to R.
3733!
3734 implicit none
3735
3736 real ( kind = 8 ) r
3737 logical ( kind = 4 ) r8_insignificant
3738 real ( kind = 8 ) s
3739 real ( kind = 8 ) t
3740 real ( kind = 8 ) tol
3741 logical ( kind = 4 ) value
3742
3743 value = .true.
3744
3745 t = r + s
3746 tol = epsilon( r ) * abs( r )
3747
3748 if ( tol < abs( r - t ) ) then
3749 value = .false.
3750 end if
3751
3752 r8_insignificant = value
3753
3754 return
r8_insignificant
logical(kind=4) function r8_insignificant(r, s)
Definition R8LIB.f90:3708

References r8_insignificant().

Referenced by r8_insignificant().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_is_int()

logical ( kind = 4 ) function r8_is_int ( real ( kind = 8 )  r)

Definition at line 3756 of file R8LIB.f90.

3757
3758!*****************************************************************************80
3759!
3760!! R8_IS_INT determines if an R8 represents an integer value.
3761!
3762! Licensing:
3763!
3764! This code is distributed under the GNU LGPL license.
3765!
3766! Modified:
3767!
3768! 07 September 2004
3769!
3770! Author:
3771!
3772! John Burkardt
3773!
3774! Parameters:
3775!
3776! Input, real ( kind = 8 ) R, the number to be checked.
3777!
3778! Output, logical ( kind = 4 ) R8_IS_INT, is TRUE if R is an integer value.
3779!
3780 implicit none
3781
3782 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
3783 real ( kind = 8 ) r
3784 logical ( kind = 4 ) r8_is_int
3785 logical ( kind = 4 ) value
3786
3787 if ( real( i4_huge, kind = 8 ) < r ) then
3788 value = .false.
3789 else if ( r < - real( i4_huge, kind = 8 ) ) then
3790 value = .false.
3791 else if ( r == real( int( r ), kind = 8 ) ) then
3792 value = .true.
3793 else
3794 value = .false.
3795 end if
3796
3797 r8_is_int = value
3798
3799 return
r8_is_int
logical(kind=4) function r8_is_int(r)
Definition R8LIB.f90:3757

References r8_is_int().

Referenced by r8_is_int().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_log_10()

real ( kind = 8 ) function r8_log_10 ( real ( kind = 8 )  x)

Definition at line 3844 of file R8LIB.f90.

3845
3846!*****************************************************************************80
3847!
3848!! R8_LOG_10 returns the logarithm base 10 of an R8.
3849!
3850! Discussion:
3851!
3852! value = Log10 ( |X| )
3853!
3854! Licensing:
3855!
3856! This code is distributed under the GNU LGPL license.
3857!
3858! Modified:
3859!
3860! 27 August 2002
3861!
3862! Author:
3863!
3864! John Burkardt
3865!
3866! Parameters:
3867!
3868! Input, real ( kind = 8 ) X, the number whose base 2 logarithm is desired.
3869! X should not be 0.
3870!
3871! Output, real ( kind = 8 ) R8_LOG_10, the logarithm base 10 of the absolute
3872! value of X. It should be true that |X| = 10**R8_LOG_10.
3873!
3874 implicit none
3875
3876 real ( kind = 8 ) r8_log_10
3877 real ( kind = 8 ) x
3878
3879 if ( x == 0.0d+00 ) then
3880 r8_log_10 = - huge( x )
3881 else
3882 r8_log_10 = log10( abs( x ) )
3883 end if
3884
3885 return
r8_log_10
real(kind=8) function r8_log_10(x)
Definition R8LIB.f90:3845

References r8_log_10().

Referenced by r8_log_10(), r8mat_print2(), and r8vec_print2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_log_2()

real ( kind = 8 ) function r8_log_2 ( real ( kind = 8 )  x)

Definition at line 3801 of file R8LIB.f90.

3802
3803!*****************************************************************************80
3804!
3805!! R8_LOG_2 returns the logarithm base 2 of an R8.
3806!
3807! Discussion:
3808!
3809! value = Log ( |X| ) / Log ( 2.0 )
3810!
3811! Licensing:
3812!
3813! This code is distributed under the GNU LGPL license.
3814!
3815! Modified:
3816!
3817! 27 August 2002
3818!
3819! Author:
3820!
3821! John Burkardt
3822!
3823! Parameters:
3824!
3825! Input, real ( kind = 8 ) X, the number whose base 2 logarithm is desired.
3826! X should not be 0.
3827!
3828! Output, real ( kind = 8 ) R8_LOG_2, the logarithm base 2 of the absolute
3829! value of X. It should be true that |X| = 2^R8_LOG_2.
3830!
3831 implicit none
3832
3833 real ( kind = 8 ) r8_log_2
3834 real ( kind = 8 ) x
3835
3836 if ( x == 0.0d+00 ) then
3837 r8_log_2 = - huge( x )
3838 else
3839 r8_log_2 = log( abs( x ) ) / log( 2.0d+00 )
3840 end if
3841
3842 return

References r8_log_2().

Referenced by r8_chop(), r8_log_2(), and r8vec_entropy().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_log_b()

real ( kind = 8 ) function r8_log_b ( real ( kind = 8 )  x,
real ( kind = 8 )  b 
)

Definition at line 3887 of file R8LIB.f90.

3888
3889!*****************************************************************************80
3890!
3891!! R8_LOG_B returns the logarithm base B of an R8.
3892!
3893! Discussion:
3894!
3895! value = log ( |X| ) / log ( |B| )
3896!
3897! Licensing:
3898!
3899! This code is distributed under the GNU LGPL license.
3900!
3901! Modified:
3902!
3903! 27 August 2002
3904!
3905! Author:
3906!
3907! John Burkardt
3908!
3909! Parameters:
3910!
3911! Input, real ( kind = 8 ) X, the number whose base B logarithm is desired.
3912! X should not be 0.
3913!
3914! Input, real ( kind = 8 ) B, the base, which should not be 0, 1 or -1.
3915!
3916! Output, real ( kind = 8 ) R8_LOG_B, the logarithm base B of the absolute
3917! value of X. It should be true that |X| = |B|**R8_LOG_B.
3918!
3919 implicit none
3920
3921 real ( kind = 8 ) b
3922 real ( kind = 8 ) r8_log_b
3923 real ( kind = 8 ) x
3924
3925 if ( b == 0.0d+00 .or. b == 1.0d+00 .or. b == - 1.0d+00 ) then
3926 r8_log_b = - huge( x )
3927 else if ( abs( x ) == 0.0d+00 ) then
3928 r8_log_b = - huge( x )
3929 else
3930 r8_log_b = log( abs( x ) ) / log( abs( b ) )
3931 end if
3932
3933 return
r8_log_b
real(kind=8) function r8_log_b(x, b)
Definition R8LIB.f90:3888

References r8_log_b().

Referenced by r8_log_b().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_mant()

subroutine r8_mant ( real ( kind = 8 )  x,
integer ( kind = 4 )  s,
real ( kind = 8 )  r,
integer ( kind = 4 )  l 
)

Definition at line 3935 of file R8LIB.f90.

3936
3937!*****************************************************************************80
3938!
3939!! R8_MANT computes the "mantissa" or "fraction part" of an R8.
3940!
3941! Discussion:
3942!
3943! X = S * R * 2^L
3944!
3945! S is +1 or -1,
3946! R is an real value between 1.0 and 2.0,
3947! L is an integer.
3948!
3949! Licensing:
3950!
3951! This code is distributed under the GNU LGPL license.
3952!
3953! Modified:
3954!
3955! 30 June 2000
3956!
3957! Author:
3958!
3959! John Burkardt
3960!
3961! Parameters:
3962!
3963! Input, real ( kind = 8 ) X, the number to be decomposed.
3964!
3965! Output, integer ( kind = 4 ) S, the "sign" of the number.
3966! S will be -1 if X is less than 0, and +1 if X is greater
3967! than or equal to zero.
3968!
3969! Output, real ( kind = 8 ) R, the mantissa of X. R will be greater
3970! than or equal to 1, and strictly less than 2. The one
3971! exception occurs if X is zero, in which case R will also
3972! be zero.
3973!
3974! Output, integer ( kind = 4 ) L, the integer part of the logarithm
3975! (base 2) of X.
3976!
3977 implicit none
3978
3979 integer ( kind = 4 ) l
3980 real ( kind = 8 ) r
3981 integer ( kind = 4 ) s
3982 real ( kind = 8 ) x
3983!
3984! Determine the sign.
3985!
3986 if ( x < 0.0d+00 ) then
3987 s = -1
3988 else
3989 s = + 1
3990 end if
3991!
3992! Set R to the absolute value of X, and L to zero.
3993! Then force R to lie between 1 and 2.
3994!
3995 if ( x < 0.0d+00 ) then
3996 r = - x
3997 else
3998 r = + x
3999 end if
4000
4001 l = 0
4002!
4003! Time to bail out if X is zero.
4004!
4005 if ( x == 0.0d+00 ) then
4006 return
4007 end if
4008
4009 do while ( 2.0d+00 <= r )
4010 r = r / 2.0d+00
4011 l = l + 1
4012 end do
4013
4014 do while ( r < 1.0d+00 )
4015 r = r * 2.0d+00
4016 l = l - 1
4017 end do
4018
4019 return

◆ r8_max()

real ( kind = 8 ) function r8_max ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 4021 of file R8LIB.f90.

4022
4023!*****************************************************************************80
4024!
4025!! R8_MAX returns the maximum of two R8's.
4026!
4027! Licensing:
4028!
4029! This code is distributed under the GNU LGPL license.
4030!
4031! Modified:
4032!
4033! 05 May 2014
4034!
4035! Author:
4036!
4037! John Burkardt
4038!
4039! Parameters:
4040!
4041! Input, real ( kind = 8 ) X, Y, the numbers to compare.
4042!
4043! Output, real ( kind = 8 ) R8_MAX, the maximum of X and Y.
4044!
4045 implicit none
4046
4047 real ( kind = 8 ) r8_max
4048 real ( kind = 8 ) x
4049 real ( kind = 8 ) y
4050
4051 if ( x < y ) then
4052 r8_max = y
4053 else
4054 r8_max = x
4055 end if
4056
4057 return
r8_max
real(kind=8) function r8_max(x, y)
Definition R8LIB.f90:4022

References r8_max().

Referenced by r8_max().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_min()

real ( kind = 8 ) function r8_min ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 4059 of file R8LIB.f90.

4060
4061!*****************************************************************************80
4062!
4063!! R8_MIN returns the minimum of two R8's.
4064!
4065! Licensing:
4066!
4067! This code is distributed under the GNU LGPL license.
4068!
4069! Modified:
4070!
4071! 05 May 2014
4072!
4073! Author:
4074!
4075! John Burkardt
4076!
4077! Parameters:
4078!
4079! Input, real ( kind = 8 ) X, Y, the numbers to compare.
4080!
4081! Output, real ( kind = 8 ) R8_MIN, the minimum of X and Y.
4082!
4083 implicit none
4084
4085 real ( kind = 8 ) r8_min
4086 real ( kind = 8 ) x
4087 real ( kind = 8 ) y
4088
4089 if ( x < y ) then
4090 r8_min = x
4091 else
4092 r8_min = y
4093 end if
4094
4095 return
r8_min
real(kind=8) function r8_min(x, y)
Definition R8LIB.f90:4060

References r8_min().

Referenced by r8_min().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_mod()

real ( kind = 8 ) function r8_mod ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 4097 of file R8LIB.f90.

4098
4099!*****************************************************************************80
4100!
4101!! R8_MOD returns the remainder of R8 division.
4102!
4103! Discussion:
4104!
4105! If
4106! REM = R8_MOD ( X, Y )
4107! RMULT = ( X - REM ) / Y
4108! then
4109! X = Y * RMULT + REM
4110! where REM has the same sign as X, and abs ( REM ) < Y.
4111!
4112! Example:
4113!
4114! X Y R8_MOD R8_MOD Factorization
4115!
4116! 107 50 7 107 = 2 * 50 + 7
4117! 107 -50 7 107 = -2 * -50 + 7
4118! -107 50 -7 -107 = -2 * 50 - 7
4119! -107 -50 -7 -107 = 2 * -50 - 7
4120!
4121! Licensing:
4122!
4123! This code is distributed under the GNU LGPL license.
4124!
4125! Modified:
4126!
4127! 14 June 2007
4128!
4129! Author:
4130!
4131! John Burkardt
4132!
4133! Parameters:
4134!
4135! Input, real ( kind = 8 ) X, the number to be divided.
4136!
4137! Input, real ( kind = 8 ) Y, the number that divides X.
4138!
4139! Output, real ( kind = 8 ) R8_MOD, the remainder when X is divided by Y.
4140!
4141 implicit none
4142
4143 real ( kind = 8 ) r8_mod
4144 real ( kind = 8 ) x
4145 real ( kind = 8 ) y
4146
4147 if ( y == 0.0d+00 ) then
4148 write ( *, '(a)' ) ' '
4149 write ( *, '(a)' ) 'R8_MOD - Fatal error!'
4150 write ( *, '(a,g14.6)' ) ' R8_MOD ( X, Y ) called with Y = ', y
4151 stop 1
4152 end if
4153
4154 r8_mod = x - real( int( x / y ), kind = 8 ) * y
4155
4156 if ( x < 0.0d+00 .and. 0.0d+00 < r8_mod ) then
4157 r8_mod = r8_mod - abs( y )
4158 else if ( 0.0d+00 < x .and. r8_mod < 0.0d+00 ) then
4159 r8_mod = r8_mod + abs( y )
4160 end if
4161
4162 return
r8_mod
real(kind=8) function r8_mod(x, y)
Definition R8LIB.f90:4098

References r8_mod().

Referenced by r8_mod().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_modp()

real ( kind = 8 ) function r8_modp ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 4164 of file R8LIB.f90.

4165
4166!*****************************************************************************80
4167!
4168!! R8_MODP returns the nonnegative remainder of R8 division.
4169!
4170! Discussion:
4171!
4172! If
4173! REM = R8_MODP ( X, Y )
4174! RMULT = ( X - REM ) / Y
4175! then
4176! X = Y * RMULT + REM
4177! where REM is always nonnegative.
4178!
4179! The MOD function computes a result with the same sign as the
4180! quantity being divided. Thus, suppose you had an angle A,
4181! and you wanted to ensure that it was between 0 and 360.
4182! Then mod(A,360.0) would do, if A was positive, but if A
4183! was negative, your result would be between -360 and 0.
4184!
4185! On the other hand, R8_MODP(A,360.0) is between 0 and 360, always.
4186!
4187! Example:
4188!
4189! X Y MOD R8_MODP R8_MODP Factorization
4190!
4191! 107 50 7 7 107 = 2 * 50 + 7
4192! 107 -50 7 7 107 = -2 * -50 + 7
4193! -107 50 -7 43 -107 = -3 * 50 + 43
4194! -107 -50 -7 43 -107 = 3 * -50 + 43
4195!
4196! Licensing:
4197!
4198! This code is distributed under the GNU LGPL license.
4199!
4200! Modified:
4201!
4202! 19 October 2004
4203!
4204! Author:
4205!
4206! John Burkardt
4207!
4208! Parameters:
4209!
4210! Input, real ( kind = 8 ) X, the number to be divided.
4211!
4212! Input, real ( kind = 8 ) Y, the number that divides X.
4213!
4214! Output, real ( kind = 8 ) R8_MODP, the nonnegative remainder
4215! when X is divided by Y.
4216!
4217 implicit none
4218
4219 real ( kind = 8 ) r8_modp
4220 real ( kind = 8 ) x
4221 real ( kind = 8 ) y
4222
4223 if ( y == 0.0d+00 ) then
4224 write ( *, '(a)' ) ' '
4225 write ( *, '(a)' ) 'R8_MODP - Fatal error!'
4226 write ( *, '(a,g14.6)' ) ' R8_MODP ( X, Y ) called with Y = ', y
4227 stop 1
4228 end if
4229
4230 r8_modp = mod( x, y )
4231
4232 if ( r8_modp < 0.0d+00 ) then
4233 r8_modp = r8_modp + abs( y )
4234 end if
4235
4236 return
r8_modp
real(kind=8) function r8_modp(x, y)
Definition R8LIB.f90:4165

References r8_modp().

Referenced by r8_modp().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_mop()

real ( kind = 8 ) function r8_mop ( integer ( kind = 4 )  i)

Definition at line 4238 of file R8LIB.f90.

4239
4240!*****************************************************************************80
4241!
4242!! R8_MOP returns the I-th power of -1 as an R8.
4243!
4244! Discussion:
4245!
4246! An R8 is a real ( kind = 8 ) value.
4247!
4248! Licensing:
4249!
4250! This code is distributed under the GNU LGPL license.
4251!
4252! Modified:
4253!
4254! 07 November 2007
4255!
4256! Author:
4257!
4258! John Burkardt
4259!
4260! Parameters:
4261!
4262! Input, integer ( kind = 4 ) I, the power of -1.
4263!
4264! Output, real ( kind = 8 ) R8_MOP, the I-th power of -1.
4265!
4266 implicit none
4267
4268 integer ( kind = 4 ) i
4269 real ( kind = 8 ) r8_mop
4270 real ( kind = 8 ) value
4271
4272 if ( mod( i, 2 ) == 0 ) then
4273 value = + 1.0d+00
4274 else
4275 value = - 1.0d+00
4276 end if
4277
4278 r8_mop = value
4279
4280 return
r8_mop
real(kind=8) function r8_mop(i)
Definition R8LIB.f90:4239

References r8_mop().

Referenced by r8_mop().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_nint()

integer ( kind = 4 ) function r8_nint ( real ( kind = 8 )  x)

Definition at line 4282 of file R8LIB.f90.

4283
4284!*****************************************************************************80
4285!
4286!! R8_NINT returns the nearest integer to an R8.
4287!
4288! Example:
4289!
4290! X R8_NINT
4291!
4292! 1.3 1
4293! 1.4 1
4294! 1.5 1 or 2
4295! 1.6 2
4296! 0.0 0
4297! -0.7 -1
4298! -1.1 -1
4299! -1.6 -2
4300!
4301! Licensing:
4302!
4303! This code is distributed under the GNU LGPL license.
4304!
4305! Modified:
4306!
4307! 08 September 2005
4308!
4309! Author:
4310!
4311! John Burkardt
4312!
4313! Parameters:
4314!
4315! Input, real ( kind = 8 ) X, the value.
4316!
4317! Output, integer ( kind = 4 ) R8_NINT, the nearest integer to X.
4318!
4319 implicit none
4320
4321 integer ( kind = 4 ) r8_nint
4322 integer ( kind = 4 ) s
4323 real ( kind = 8 ) x
4324
4325 if ( x < 0.0d+00 ) then
4326 s = - 1
4327 else
4328 s = + 1
4329 end if
4330
4331 r8_nint = s * int( abs( x ) + 0.5d+00 )
4332
4333 return
r8_nint
integer(kind=4) function r8_nint(x)
Definition R8LIB.f90:4283

References r8_nint().

Referenced by r8_nint().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_normal_01()

real ( kind = 8 ) function r8_normal_01 ( integer ( kind = 4 )  seed)

Definition at line 4335 of file R8LIB.f90.

4336
4337!*****************************************************************************80
4338!
4339!! R8_NORMAL_01 returns a unit pseudonormal R8.
4340!
4341! Discussion:
4342!
4343! The standard normal probability distribution function (PDF) has
4344! mean 0 and standard deviation 1.
4345!
4346! Licensing:
4347!
4348! This code is distributed under the GNU LGPL license.
4349!
4350! Modified:
4351!
4352! 06 August 2013
4353!
4354! Author:
4355!
4356! John Burkardt
4357!
4358! Parameters:
4359!
4360! Input/output, integer ( kind = 4 ) SEED, a seed for the random number
4361! generator.
4362!
4363! Output, real ( kind = 8 ) R8_NORMAL_01, a sample of the standard
4364! normal PDF.
4365!
4366 implicit none
4367
4368 real ( kind = 8 ) r1
4369 real ( kind = 8 ) r2
4370 real ( kind = 8 ) r8_normal_01
4371 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
4372 real ( kind = 8 ) r8_uniform_01
4373 integer ( kind = 4 ) seed
4374 real ( kind = 8 ) x
4375
4376 r1 = r8_uniform_01( seed )
4377 r2 = r8_uniform_01( seed )
4378 x = sqrt( - 2.0d+00 * log( r1 ) ) * cos( 2.0d+00 * r8_pi * r2 )
4379
4380 r8_normal_01 = x
4381
4382 return
r8_normal_01
real(kind=8) function r8_normal_01(seed)
Definition R8LIB.f90:4336
r8_uniform_01
real(kind=8) function r8_uniform_01(seed)
Definition R8LIB.f90:6253

References r8_normal_01(), r8_pi(), and r8_uniform_01().

Referenced by r8_normal_01(), and r8mat_orth_uniform().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_normal_ab()

real ( kind = 8 ) function r8_normal_ab ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
integer ( kind = 4 )  seed 
)

Definition at line 4384 of file R8LIB.f90.

4385
4386!*****************************************************************************80
4387!
4388!! R8_NORMAL_AB returns a scaled pseudonormal R8.
4389!
4390! Discussion:
4391!
4392! The normal probability distribution function (PDF) is sampled,
4393! with mean A and standard deviation B.
4394!
4395! Licensing:
4396!
4397! This code is distributed under the GNU LGPL license.
4398!
4399! Modified:
4400!
4401! 06 August 2013
4402!
4403! Author:
4404!
4405! John Burkardt
4406!
4407! Parameters:
4408!
4409! Input, real ( kind = 8 ) A, the mean of the PDF.
4410!
4411! Input, real ( kind = 8 ) B, the standard deviation of the PDF.
4412!
4413! Input/output, integer ( kind = 4 ) SEED, a seed for the random number
4414! generator.
4415!
4416! Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
4417!
4418 implicit none
4419
4420 real ( kind = 8 ) a
4421 real ( kind = 8 ) b
4422 real ( kind = 8 ) r1
4423 real ( kind = 8 ) r2
4424 real ( kind = 8 ) r8_normal_ab
4425 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
4426 real ( kind = 8 ) r8_uniform_01
4427 integer ( kind = 4 ) seed
4428 real ( kind = 8 ) x
4429
4430 r1 = r8_uniform_01( seed )
4431 r2 = r8_uniform_01( seed )
4432 x = sqrt( - 2.0d+00 * log( r1 ) ) * cos( 2.0d+00 * r8_pi * r2 )
4433
4434 r8_normal_ab = a + b * x
4435
4436 return
r8_normal_ab
real(kind=8) function r8_normal_ab(a, b, seed)
Definition R8LIB.f90:4385

References r8_normal_ab(), r8_pi(), and r8_uniform_01().

Referenced by r8_normal_ab().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_pi()

real ( kind = 8 ) function r8_pi

Definition at line 4438 of file R8LIB.f90.

4439
4440!*****************************************************************************80
4441!
4442!! R8_PI returns the value of pi as an R8.
4443!
4444! Licensing:
4445!
4446! This code is distributed under the GNU LGPL license.
4447!
4448! Modified:
4449!
4450! 19 December 2001
4451!
4452! Author:
4453!
4454! John Burkardt
4455!
4456! Parameters:
4457!
4458! Output, real ( kind = 8 ) R8_PI, the value of pi.
4459!
4460 implicit none
4461
4462 real ( kind = 8 ) r8_pi
4463
4464 r8_pi = 3.141592653589793d+00
4465
4466 return

References r8_pi().

Referenced by legendre_zeros(), r82_cheby(), r8_atan(), r8_cosd(), r8_cotd(), r8_cscd(), r8_csqrt(), r8_degrees(), r8_gamma(), r8_normal_01(), r8_normal_ab(), r8_pi(), r8_radians(), r8_secd(), r8_sind(), r8_tand(), r8poly3_root(), r8vec_cheby1space(), r8vec_cheby2space(), r8vec_chebyspace(), and r8vec_normal_01().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_pi_sqrt()

real ( kind = 8 ) function r8_pi_sqrt

Definition at line 4468 of file R8LIB.f90.

4469
4470!*****************************************************************************80
4471!
4472!! R8_PI_SQRT returns the square root of pi as an R8.
4473!
4474! Licensing:
4475!
4476! This code is distributed under the GNU LGPL license.
4477!
4478! Modified:
4479!
4480! 11 September 2012
4481!
4482! Author:
4483!
4484! John Burkardt
4485!
4486! Parameters:
4487!
4488! Output, real ( kind = 8 ) R8_PI_SQRT, the square root of pi.
4489!
4490 implicit none
4491
4492 real ( kind = 8 ) r8_pi_sqrt
4493
4494 r8_pi_sqrt = 1.7724538509055160273d+00
4495
4496 return
r8_pi_sqrt
real(kind=8) function r8_pi_sqrt()
Definition R8LIB.f90:4469

References r8_pi_sqrt().

Referenced by r8_pi_sqrt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_power()

real ( kind = 8 ) function r8_power ( real ( kind = 8 )  r,
integer ( kind = 4 )  p 
)

Definition at line 4498 of file R8LIB.f90.

4499
4500!*****************************************************************************80
4501!
4502!! R8_POWER computes the P-th power of an R8.
4503!
4504! Licensing:
4505!
4506! This code is distributed under the GNU LGPL license.
4507!
4508! Modified:
4509!
4510! 04 October 2005
4511!
4512! Author:
4513!
4514! John Burkardt
4515!
4516! Parameters:
4517!
4518! Input, real ( kind = 8 ) R, the base.
4519!
4520! Input, integer ( kind = 4 ) P, the power, which may be negative.
4521!
4522! Output, real ( kind = 8 ) R8_POWER, the value of the P-th power of R.
4523!
4524 implicit none
4525
4526 integer ( kind = 4 ) p
4527 real ( kind = 8 ) r
4528 real ( kind = 8 ) r8_power
4529 real ( kind = 8 ) value
4530!
4531! Special case. R^0 = 1.
4532!
4533 if ( p == 0 ) then
4534
4535 value = 1.0d+00
4536!
4537! Special case. Positive powers of 0 are 0.
4538! For negative powers of 0, we go ahead and compute R^P,
4539! relying on the software to complain.
4540!
4541 else if ( r == 0.0d+00 ) then
4542
4543 if ( 0 < p ) then
4544 value = 0.0d+00
4545 else
4546 value = r ** p
4547 end if
4548
4549 else if ( 1 <= p ) then
4550 value = r ** p
4551 else
4552 value = 1.0d+00 / r ** (-p)
4553 end if
4554
4555 r8_power = value
4556
4557 return
r8_power
real(kind=8) function r8_power(r, p)
Definition R8LIB.f90:4499

References r8_power().

Referenced by r8_power().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_power_fast()

subroutine r8_power_fast ( real ( kind = 8 )  r,
integer ( kind = 4 )  p,
real ( kind = 8 )  rp,
integer ( kind = 4 )  mults 
)

Definition at line 4559 of file R8LIB.f90.

4560
4561!*****************************************************************************80
4562!
4563!! R8_POWER_FAST computes an integer power of an R8.
4564!
4565! Discussion:
4566!
4567! Obviously, R^P can be computed using P-1 multiplications.
4568!
4569! However, R^P can also be computed using at most 2*LOG2(P) multiplications.
4570! To do the calculation this way, let N = LOG2(P).
4571! Compute A, A^2, A^4, ..., A^N by N-1 successive squarings.
4572! Start the value of R^P at A, and each time that there is a 1 in
4573! the binary expansion of P, multiply by the current result of the squarings.
4574!
4575! This algorithm is not optimal. For small exponents, and for special
4576! cases, the result can be computed even more quickly.
4577!
4578! Licensing:
4579!
4580! This code is distributed under the GNU LGPL license.
4581!
4582! Modified:
4583!
4584! 30 March 2000
4585!
4586! Author:
4587!
4588! John Burkardt
4589!
4590! Parameters:
4591!
4592! Input, real ( kind = 8 ) R, the base.
4593!
4594! Input, integer ( kind = 4 ) P, the power, which may be negative.
4595!
4596! Output, real ( kind = 8 ) RP, the value of R^P.
4597!
4598! Output, integer ( kind = 4 ) MULTS, the number of multiplications
4599! and divisions.
4600!
4601 implicit none
4602
4603 integer ( kind = 4 ) mults
4604 integer ( kind = 4 ) p
4605 integer ( kind = 4 ) p_mag
4606 integer ( kind = 4 ) p_sign
4607 real ( kind = 8 ) r
4608 real ( kind = 8 ) r2
4609 real ( kind = 8 ) rp
4610
4611 mults = 0
4612!
4613! Special bases.
4614!
4615 if ( r == 1.0d+00 ) then
4616 rp = 1.0d+00
4617 return
4618 end if
4619
4620 if ( r == -1.0d+00 ) then
4621
4622 if ( mod( p, 2 ) == 1 ) then
4623 rp = -1.0d+00
4624 else
4625 rp = 1.0d+00
4626 end if
4627
4628 return
4629
4630 end if
4631
4632 if ( r == 0.0d+00 ) then
4633
4634 if ( p <= 0 ) then
4635 write ( *, '(a)' ) ' '
4636 write ( *, '(a)' ) 'R8_POWER_FAST - Fatal error!'
4637 write ( *, '(a)' ) ' Base R is zero, and exponent is negative.'
4638 write ( *, '(a,i8)' ) ' Exponent P = ', p
4639 stop 1
4640 end if
4641
4642 rp = 0.0d+00
4643 return
4644
4645 end if
4646!
4647! Special powers.
4648!
4649 if ( p == -1 ) then
4650 rp = 1.0d+00 / r
4651 mults = mults + 1
4652 return
4653 else if ( p == 0 ) then
4654 rp = 1.0d+00
4655 return
4656 else if ( p == 1 ) then
4657 rp = r
4658 return
4659 end if
4660!
4661! Some work to do.
4662!
4663 p_mag = abs( p )
4664 p_sign = sign( 1, p )
4665
4666 rp = 1.0d+00
4667 r2 = r
4668
4669 do while ( 0 < p_mag )
4670
4671 if ( mod( p_mag, 2 ) == 1 ) then
4672 rp = rp * r2
4673 mults = mults + 1
4674 end if
4675
4676 p_mag = p_mag / 2
4677 r2 = r2 * r2
4678 mults = mults + 1
4679
4680 end do
4681
4682 if ( p_sign == -1 ) then
4683 rp = 1.0d+00 / rp
4684 mults = mults + 1
4685 end if
4686
4687 return

◆ r8_print()

subroutine r8_print ( real ( kind = 8 )  r,
character ( len = * )  title 
)

Definition at line 4689 of file R8LIB.f90.

4690
4691!*****************************************************************************80
4692!
4693!! R8_PRINT prints an R8.
4694!
4695! Licensing:
4696!
4697! This code is distributed under the GNU LGPL license.
4698!
4699! Modified:
4700!
4701! 14 August 2014
4702!
4703! Author:
4704!
4705! John Burkardt
4706!
4707! Parameters:
4708!
4709! Input, real ( kind = 8 ) R, the value.
4710!
4711! Input, character ( len = * ) TITLE, a title.
4712!
4713 implicit none
4714
4715 real ( kind = 8 ) r
4716 character ( len = * ) title
4717
4718 write ( *, '(a,2x,g14.6)' ) trim( title ), r
4719
4720 return

◆ r8_pythag()

real ( kind = 8 ) function r8_pythag ( real ( kind = 8 )  a,
real ( kind = 8 )  b 
)

Definition at line 4722 of file R8LIB.f90.

4723
4724!*****************************************************************************80
4725!
4726!! R8_PYTHAG computes sqrt ( A * A + B * B ), avoiding overflow and underflow.
4727!
4728! Licensing:
4729!
4730! This code is distributed under the GNU LGPL license.
4731!
4732! Modified:
4733!
4734! 17 April 2004
4735!
4736! Author:
4737!
4738! John Burkardt
4739!
4740! Parameters:
4741!
4742! Input, real ( kind = 8 ) A, B, the values for which sqrt ( A * A + B * B )
4743! is desired.
4744!
4745! Output, real ( kind = 8 ) R8_PYTHAG, the value of sqrt ( A * A + B * B ).
4746!
4747 implicit none
4748
4749 real ( kind = 8 ) a
4750 real ( kind = 8 ) a_abs
4751 real ( kind = 8 ) b
4752 real ( kind = 8 ) b_abs
4753 real ( kind = 8 ) r8_pythag
4754
4755 a_abs = abs( a )
4756 b_abs = abs( b )
4757
4758 if ( b_abs < a_abs ) then
4759 r8_pythag = a_abs * sqrt( 1.0d+00 + ( b_abs / a_abs ) * ( b_abs / a_abs ) )
4760 else if ( b_abs == 0.0d+00 ) then
4761 r8_pythag = 0.0d+00
4762 else if ( a_abs <= b_abs ) then
4763 r8_pythag = b_abs * sqrt( 1.0d+00 + ( a_abs / b_abs ) * ( a_abs / b_abs ) )
4764 end if
4765
4766 return
r8_pythag
real(kind=8) function r8_pythag(a, b)
Definition R8LIB.f90:4723

References r8_pythag().

Referenced by r8_pythag().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_radians()

real ( kind = 8 ) function r8_radians ( real ( kind = 8 )  degrees)

Definition at line 4768 of file R8LIB.f90.

4769
4770!*****************************************************************************80
4771!
4772!! R8_RADIANS converts an angle from degree to radian measure.
4773!
4774! Licensing:
4775!
4776! This code is distributed under the GNU LGPL license.
4777!
4778! Modified:
4779!
4780! 15 May 2013
4781!
4782! Author:
4783!
4784! John Burkardt
4785!
4786! Parameters:
4787!
4788! Input, real ( kind = 8 ) DEGREES, the angle measurement in degrees.
4789!
4790! Output, real ( kind = 8 ) R8_RADIANS, the angle measurement in radians.
4791!
4792 implicit none
4793
4794 real ( kind = 8 ) degrees
4795 real ( kind = 8 ), parameter :: r8_pi = 3.1415926535897932384626434d+00
4796 real ( kind = 8 ) r8_radians
4797
4798 r8_radians = degrees * r8_pi / 180.0d+00
4799
4800 return
r8_radians
real(kind=8) function r8_radians(degrees)
Definition R8LIB.f90:4769

References r8_pi(), and r8_radians().

Referenced by r8_radians().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_rise()

real ( kind = 8 ) function r8_rise ( real ( kind = 8 )  x,
integer ( kind = 4 )  n 
)

Definition at line 4802 of file R8LIB.f90.

4803
4804!*****************************************************************************80
4805!
4806!! R8_RISE computes the rising factorial function [X]^N.
4807!
4808! Discussion:
4809!
4810! [X]^N = X * ( X + 1 ) * ( X + 2 ) * ... * ( X + N - 1 ).
4811!
4812! Note that the number of ways of arranging N objects in M ordered
4813! boxes is [M]^N. (Here, the ordering of the objects in each box matters).
4814! Thus, 2 objects in 2 boxes have the following 6 possible arrangements:
4815!
4816! -|12, 1|2, 12|-, -|21, 2|1, 21|-.
4817!
4818! Moreover, the number of non-decreasing maps from a set of
4819! N to a set of M ordered elements is [M]^N / N!. Thus the set of
4820! nondecreasing maps from (1,2,3) to (a,b,c,d) is the 20 elements:
4821!
4822! aaa, abb, acc, add, aab, abc, acd, aac, abd, aad
4823! bbb, bcc, bdd, bbc, bcd, bbd, ccc, cdd, ccd, ddd.
4824!
4825! Licensing:
4826!
4827! This code is distributed under the GNU LGPL license.
4828!
4829! Modified:
4830!
4831! 08 May 2003
4832!
4833! Author:
4834!
4835! John Burkardt
4836!
4837! Parameters:
4838!
4839! Input, real ( kind = 8 ) X, the argument of the rising factorial function.
4840!
4841! Input, integer ( kind = 4 ) N, the order of the rising factorial function.
4842! If N = 0, RISE = 1, if N = 1, RISE = X. Note that if N is
4843! negative, a "falling" factorial will be computed.
4844!
4845! Output, real ( kind = 8 ) R8_RISE, the value of the rising factorial
4846! function.
4847!
4848 implicit none
4849
4850 real ( kind = 8 ) arg
4851 integer ( kind = 4 ) i
4852 integer ( kind = 4 ) n
4853 real ( kind = 8 ) r8_rise
4854 real ( kind = 8 ) value
4855 real ( kind = 8 ) x
4856
4857 value = 1.0d+00
4858
4859 arg = x
4860
4861 if ( 0 < n ) then
4862
4863 do i = 1, n
4864 value = value * arg
4865 arg = arg + 1.0d+00
4866 end do
4867
4868 else if ( n < 0 ) then
4869
4870 do i = -1, n, -1
4871 value = value * arg
4872 arg = arg - 1.0d+00
4873 end do
4874
4875 end if
4876
4877 r8_rise = value
4878
4879 return
r8_rise
real(kind=8) function r8_rise(x, n)
Definition R8LIB.f90:4803

References r8_rise().

Referenced by r8_rise().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_round()

real ( kind = 8 ) function r8_round ( real ( kind = 8 )  x)

Definition at line 4881 of file R8LIB.f90.

4882
4883!*****************************************************************************80
4884!
4885!! R8_ROUND sets an R8 to the nearest integral value.
4886!
4887! Example:
4888!
4889! X R8_ROUND
4890!
4891! 1.3 1.0
4892! 1.4 1.0
4893! 1.5 1.0 or 2.0
4894! 1.6 2.0
4895! 0.0 0.0
4896! -0.7 -1.0
4897! -1.1 -1.0
4898! -1.6 -2.0
4899!
4900! Licensing:
4901!
4902! This code is distributed under the GNU LGPL license.
4903!
4904! Modified:
4905!
4906! 15 October 2012
4907!
4908! Author:
4909!
4910! John Burkardt
4911!
4912! Parameters:
4913!
4914! Input, real ( kind = 8 ) X, the value.
4915!
4916! Output, real ( kind = 8 ) R8_ROUND, the rounded value.
4917!
4918 implicit none
4919
4920 real ( kind = 8 ) r8_round
4921 real ( kind = 8 ) value
4922 real ( kind = 8 ) x
4923
4924 if ( x < 0.0d+00 ) then
4925 value = - real( int( - x + 0.5d+00 ), kind = 8 )
4926 else
4927 value = real( int( + x + 0.5d+00 ), kind = 8 )
4928 end if
4929
4930 r8_round = value
4931
4932 return
r8_round
real(kind=8) function r8_round(x)
Definition R8LIB.f90:4882

References r8_round().

Referenced by r8_round().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_round2()

subroutine r8_round2 ( integer ( kind = 4 )  nplace,
real ( kind = 8 )  x,
real ( kind = 8 )  xround 
)

Definition at line 4993 of file R8LIB.f90.

4994
4995!*****************************************************************************80
4996!
4997!! R8_ROUND2 rounds an R8 in base 2.
4998!
4999! Discussion:
5000!
5001! Assume that the input quantity X has the form
5002!
5003! X = S * J * 2^L
5004!
5005! where S is plus or minus 1, L is an integer, and J is a binary
5006! mantissa which is either exactly zero, or greater than or equal
5007! to 0.5 and strictly less than 1.0.
5008!
5009! Then on return, XROUND will satisfy
5010!
5011! XROUND = S * K * 2^L
5012!
5013! where S and L are unchanged, and K is a binary mantissa which
5014! agrees with J in the first NPLACE binary digits and is zero
5015! thereafter.
5016!
5017! If NPLACE is 0, XROUND will always be zero.
5018!
5019! If NPLACE is 1, the mantissa of XROUND will be 0 or 0.5.
5020!
5021! If NPLACE is 2, the mantissa of XROUND will be 0, 0.25, 0.50,
5022! or 0.75.
5023!
5024! Licensing:
5025!
5026! This code is distributed under the GNU LGPL license.
5027!
5028! Modified:
5029!
5030! 01 March 1999
5031!
5032! Author:
5033!
5034! John Burkardt
5035!
5036! Parameters:
5037!
5038! Input, integer ( kind = 4 ) NPLACE, the number of binary digits to
5039! preserve. NPLACE should be 0 or positive.
5040!
5041! Input, real ( kind = 8 ) X, the number to be decomposed.
5042!
5043! Output, real ( kind = 8 ) XROUND, the rounded value of X.
5044!
5045 implicit none
5046
5047 integer ( kind = 4 ) iplace
5048 integer ( kind = 4 ) l
5049 integer ( kind = 4 ) nplace
5050 integer ( kind = 4 ) s
5051 real ( kind = 8 ) x
5052 real ( kind = 8 ) xmant
5053 real ( kind = 8 ) xround
5054 real ( kind = 8 ) xtemp
5055
5056 xround = 0.0d+00
5057!
5058! 1: Handle the special case of 0.
5059!
5060 if ( x == 0.0d+00 ) then
5061 return
5062 end if
5063
5064 if ( nplace <= 0 ) then
5065 return
5066 end if
5067!
5068! 2: Determine the sign S.
5069!
5070 if ( 0.0d+00 < x ) then
5071 s = 1
5072 xtemp = x
5073 else
5074 s = -1
5075 xtemp = -x
5076 end if
5077!
5078! 3: Force XTEMP to lie between 1 and 2, and compute the
5079! logarithm L.
5080!
5081 l = 0
5082
5083 do while ( 2.0d+00 <= xtemp )
5084 xtemp = xtemp / 2.0d+00
5085 l = l + 1
5086 end do
5087
5088 do while ( xtemp < 1.0d+00 )
5089 xtemp = xtemp * 2.0d+00
5090 l = l - 1
5091 end do
5092!
5093! 4: Strip out the digits of the mantissa as XMANT, and decrease L.
5094!
5095 xmant = 0.0d+00
5096 iplace = 0
5097
5098 do
5099
5100 xmant = 2.0d+00 * xmant
5101
5102 if ( 1.0d+00 <= xtemp ) then
5103 xmant = xmant + 1.0d+00
5104 xtemp = xtemp - 1.0d+00
5105 end if
5106
5107 iplace = iplace + 1
5108
5109 if ( xtemp == 0.0d+00 .or. nplace <= iplace ) then
5110 xround = s * xmant * 2.0d+00**l
5111 exit
5112 end if
5113
5114 l = l - 1
5115 xtemp = xtemp * 2.0d+00
5116
5117 end do
5118
5119 return

◆ r8_round_i4()

integer ( kind = 4 ) function r8_round_i4 ( real ( kind = 8 )  x)

Definition at line 4934 of file R8LIB.f90.

4935
4936!*****************************************************************************80
4937!
4938!! R8_ROUND_I4 sets an R8 to the nearest integral value, returning an I4
4939!
4940! Example:
4941!
4942! X R8_ROUND_I4
4943!
4944! 1.3 1
4945! 1.4 1
4946! 1.5 1 or 2
4947! 1.6 2
4948! 0.0 0
4949! -0.7 -1
4950! -1.1 -1
4951! -1.6 -2
4952!
4953! Discussion:
4954!
4955! In FORTRAN90, we rely on the fact that, for positive X, int ( X )
4956! is the "floor" function, returning the largest integer less than
4957! or equal to X.
4958!
4959! Licensing:
4960!
4961! This code is distributed under the GNU LGPL license.
4962!
4963! Modified:
4964!
4965! 25 March 2013
4966!
4967! Author:
4968!
4969! John Burkardt
4970!
4971! Parameters:
4972!
4973! Input, real ( kind = 8 ) X, the value.
4974!
4975! Output, integer ( kind = 4 ) R8_ROUND_I4, the rounded value.
4976!
4977 implicit none
4978
4979 integer ( kind = 4 ) r8_round_i4
4980 integer ( kind = 4 ) value
4981 real ( kind = 8 ) x
4982
4983 if ( x < 0.0d+00 ) then
4984 value = - int( - x + 0.5d+00 )
4985 else
4986 value = int( + x + 0.5d+00 )
4987 end if
4988
4989 r8_round_i4 = value
4990
4991 return
r8_round_i4
integer(kind=4) function r8_round_i4(x)
Definition R8LIB.f90:4935

References r8_round_i4().

Referenced by r8_round_i4().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_roundb()

subroutine r8_roundb ( integer ( kind = 4 )  base,
integer ( kind = 4 )  nplace,
real ( kind = 8 )  x,
real ( kind = 8 )  xround 
)

Definition at line 5121 of file R8LIB.f90.

5122
5123!*****************************************************************************80
5124!
5125!! R8_ROUNDB rounds an R8 in a given base.
5126!
5127! Discussion:
5128!
5129! The code does not seem to do a good job of rounding when
5130! the base is negative.
5131!
5132! Assume that the input quantity X has the form
5133!
5134! X = S * J * BASE^L
5135!
5136! where S is plus or minus 1, L is an integer, and J is a
5137! mantissa base BASE which is either exactly zero, or greater
5138! than or equal to (1/BASE) and less than 1.0.
5139!
5140! Then on return, XROUND will satisfy
5141!
5142! XROUND = S * K * BASE^L
5143!
5144! where S and L are unchanged, and K is a mantissa base BASE
5145! which agrees with J in the first NPLACE digits and is zero
5146! thereafter.
5147!
5148! Note that because of rounding, for most bases, most numbers
5149! with a fractional quantities cannot be stored exactly in the
5150! computer, and hence will have trailing "bogus" digits.
5151!
5152! If NPLACE is 0, XROUND will always be zero.
5153!
5154! If NPLACE is 1, the mantissa of XROUND will be 0,
5155! 1/BASE, 2/BASE, ..., (BASE-1)/BASE.
5156!
5157! If NPLACE is 2, the mantissa of XROUND will be 0,
5158! BASE/BASE^2, (BASE+1)/BASE^2, ...,
5159! BASE^2-2/BASE^2, BASE^2-1/BASE^2.
5160!
5161! Licensing:
5162!
5163! This code is distributed under the GNU LGPL license.
5164!
5165! Modified:
5166!
5167! 01 March 1999
5168!
5169! Author:
5170!
5171! John Burkardt
5172!
5173! Parameters:
5174!
5175! Input, integer ( kind = 4 ) BASE, the base of the arithmetic.
5176! BASE must not be zero. Theoretically, BASE may be negative.
5177!
5178! Input, integer ( kind = 4 ) NPLACE, the number of digits base BASE to
5179! preserve. NPLACE should be 0 or positive.
5180!
5181! Input, real ( kind = 8 ) X, the number to be decomposed.
5182!
5183! Output, real ( kind = 8 ) XROUND, the rounded value of X.
5184!
5185 implicit none
5186
5187 integer ( kind = 4 ) base
5188 integer ( kind = 4 ) iplace
5189 integer ( kind = 4 ) is
5190 integer ( kind = 4 ) js
5191 integer ( kind = 4 ) l
5192 integer ( kind = 4 ) nplace
5193 real ( kind = 8 ) x
5194 real ( kind = 8 ) xmant
5195 real ( kind = 8 ) xround
5196 real ( kind = 8 ) xtemp
5197
5198 xround = 0.0d+00
5199!
5200! 0: Error checks.
5201!
5202 if ( base == 0 ) then
5203 write ( *, '(a)' ) ' '
5204 write ( *, '(a)' ) 'R8_ROUNDB - Fatal error!'
5205 write ( *, '(a)' ) ' The base BASE cannot be zero.'
5206 stop 1
5207 end if
5208!
5209! 1: Handle the special case of 0.
5210!
5211 if ( x == 0.0d+00 ) then
5212 return
5213 end if
5214
5215 if ( nplace <= 0 ) then
5216 return
5217 end if
5218!
5219! 2: Determine the sign IS.
5220!
5221 if ( 0.0d+00 < x ) then
5222 is = 1
5223 xtemp = x
5224 else
5225 is = -1
5226 xtemp = -x
5227 end if
5228!
5229! 3: Force XTEMP to lie between 1 and ABS(BASE), and compute the
5230! logarithm L.
5231!
5232 l = 0
5233
5234 do while ( abs( base ) <= abs( xtemp ) )
5235
5236 xtemp = xtemp / real( base, kind = 8 )
5237
5238 if ( xtemp < 0.0d+00 ) then
5239 is = -is
5240 xtemp = -xtemp
5241 end if
5242
5243 l = l + 1
5244
5245 end do
5246
5247 do while ( abs( xtemp ) < 1.0d+00 )
5248
5249 xtemp = xtemp * base
5250
5251 if ( xtemp < 0.0d+00 ) then
5252 is = -is
5253 xtemp = -xtemp
5254 end if
5255
5256 l = l - 1
5257
5258 end do
5259!
5260! 4: Now strip out the digits of the mantissa as XMANT, and
5261! decrease L.
5262!
5263 xmant = 0.0d+00
5264 iplace = 0
5265 js = is
5266
5267 do
5268
5269 xmant = base * xmant
5270
5271 if ( xmant < 0.0d+00 ) then
5272 js = -js
5273 xmant = -xmant
5274 end if
5275
5276 if ( 1.0d+00 <= xtemp ) then
5277 xmant = xmant + int( xtemp )
5278 xtemp = xtemp - int( xtemp )
5279 end if
5280
5281 iplace = iplace + 1
5282
5283 if ( xtemp == 0.0d+00 .or. nplace <= iplace ) then
5284 xround = js * xmant * ( real( base, kind = 8 ) )**l
5285 exit
5286 end if
5287
5288 l = l - 1
5289 xtemp = xtemp * base
5290
5291 if ( xtemp < 0.0d+00 ) then
5292 is = -is
5293 xtemp = -xtemp
5294 end if
5295
5296 end do
5297
5298 return

◆ r8_roundx()

subroutine r8_roundx ( integer ( kind = 4 )  nplace,
real ( kind = 8 )  x,
real ( kind = 8 )  xround 
)

Definition at line 5300 of file R8LIB.f90.

5301
5302!*****************************************************************************80
5303!
5304!! R8_ROUNDX rounds an R8 in base 10.
5305!
5306! Discussion:
5307!
5308! Assume that the input quantity X has the form
5309!
5310! X = S * J * 10^L
5311!
5312! where S is plus or minus 1, L is an integer, and J is a decimal
5313! mantissa which is either exactly zero, or greater than or equal
5314! to 0.1 and less than 1.0.
5315!
5316! Then on return, XROUND will satisfy
5317!
5318! XROUND = S * K * 10^L
5319!
5320! where S and L are unchanged, and K is a decimal mantissa which
5321! agrees with J in the first NPLACE decimal digits and is zero
5322! thereafter.
5323!
5324! Note that because of rounding, most decimal fraction quantities
5325! cannot be stored exactly in the computer, and hence will have
5326! trailing "bogus" digits.
5327!
5328! If NPLACE is 0, XROUND will always be zero.
5329!
5330! If NPLACE is 1, the mantissa of XROUND will be 0, 0.1,
5331! 0.2, ..., or 0.9.
5332!
5333! If NPLACE is 2, the mantissa of XROUND will be 0, 0.01, 0.02,
5334! 0.03, ..., 0.98, 0.99.
5335!
5336! Licensing:
5337!
5338! This code is distributed under the GNU LGPL license.
5339!
5340! Modified:
5341!
5342! 01 March 1999
5343!
5344! Author:
5345!
5346! John Burkardt
5347!
5348! Parameters:
5349!
5350! Input, integer ( kind = 4 ) NPLACE, the number of decimal digits to
5351! preserve. NPLACE should be 0 or positive.
5352!
5353! Input, real ( kind = 8 ) X, the number to be decomposed.
5354!
5355! Output, real ( kind = 8 ) XROUND, the rounded value of X.
5356!
5357 implicit none
5358
5359 integer ( kind = 4 ) iplace
5360 integer ( kind = 4 ) is
5361 integer ( kind = 4 ) l
5362 integer ( kind = 4 ) nplace
5363 real ( kind = 8 ) x
5364 real ( kind = 8 ) xmant
5365 real ( kind = 8 ) xround
5366 real ( kind = 8 ) xtemp
5367
5368 xround = 0.0d+00
5369!
5370! 1: Handle the special case of 0.
5371!
5372 if ( x == 0.0d+00 ) then
5373 return
5374 end if
5375
5376 if ( nplace <= 0 ) then
5377 return
5378 end if
5379!
5380! 2: Determine the sign IS.
5381!
5382 if ( 0.0d+00 < x ) then
5383 is = 1
5384 xtemp = x
5385 else
5386 is = -1
5387 xtemp = -x
5388 end if
5389!
5390! 3: Force XTEMP to lie between 1 and 10, and compute the
5391! logarithm L.
5392!
5393 l = 0
5394
5395 do while ( 10.0d+00 <= x )
5396 xtemp = xtemp / 10.0d+00
5397 l = l + 1
5398 end do
5399
5400 do while ( xtemp < 1.0d+00 )
5401 xtemp = xtemp * 10.0d+00
5402 l = l - 1
5403 end do
5404!
5405! 4: Now strip out the digits of the mantissa as XMANT, and
5406! decrease L.
5407!
5408 xmant = 0.0d+00
5409 iplace = 0
5410
5411 do
5412
5413 xmant = 10.0d+00 * xmant
5414
5415 if ( 1.0d+00 <= xtemp ) then
5416 xmant = xmant + int( xtemp )
5417 xtemp = xtemp - int( xtemp )
5418 end if
5419
5420 iplace = iplace + 1
5421
5422 if ( xtemp == 0.0d+00 .or. nplace <= iplace ) then
5423 xround = is * xmant * ( 10.0d+00**l )
5424 exit
5425 end if
5426
5427 l = l - 1
5428 xtemp = xtemp * 10.0d+00
5429
5430 end do
5431
5432 return

◆ r8_secd()

real ( kind = 8 ) function r8_secd ( real ( kind = 8 )  degrees)

Definition at line 5434 of file R8LIB.f90.

5435
5436!*****************************************************************************80
5437!
5438!! R8_SECD returns the secant of an angle given in degrees.
5439!
5440! Licensing:
5441!
5442! This code is distributed under the GNU LGPL license.
5443!
5444! Modified:
5445!
5446! 27 July 2014
5447!
5448! Author:
5449!
5450! John Burkardt
5451!
5452! Parameters:
5453!
5454! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
5455!
5456! Output, real ( kind = 8 ) R8_SECD, the secant of the angle.
5457!
5458 implicit none
5459
5460 real ( kind = 8 ) degrees
5461 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
5462 real ( kind = 8 ) r8_secd
5463 real ( kind = 8 ) radians
5464
5465 radians = r8_pi * ( degrees / 180.0d+00 )
5466 r8_secd = 1.0d+00 / cos( radians )
5467
5468 return
r8_secd
real(kind=8) function r8_secd(degrees)
Definition R8LIB.f90:5435

References r8_pi(), and r8_secd().

Referenced by r8_secd().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sech()

real ( kind = 8 ) function r8_sech ( real ( kind = 8 )  x)

Definition at line 5470 of file R8LIB.f90.

5471
5472!*****************************************************************************80
5473!
5474!! R8_SECH evaluates the hyperbolic secant, while avoiding COSH overflow.
5475!
5476! Licensing:
5477!
5478! This code is distributed under the GNU LGPL license.
5479!
5480! Modified:
5481!
5482! 29 August 2000
5483!
5484! Author:
5485!
5486! John Burkardt
5487!
5488! Parameters:
5489!
5490! Input, real ( kind = 8 ) X, the argument of the function.
5491!
5492! Output, real ( kind = 8 ) R8_SECH, the value of the function.
5493!
5494 implicit none
5495
5496 real ( kind = 8 ), parameter :: log_huge = 80.0d+00
5497 real ( kind = 8 ) r8_sech
5498 real ( kind = 8 ) x
5499
5500 if ( log_huge < abs( x ) ) then
5501 r8_sech = 0.0d+00
5502 else
5503 r8_sech = 1.0d+00 / cosh( x )
5504 end if
5505
5506 return
r8_sech
real(kind=8) function r8_sech(x)
Definition R8LIB.f90:5471

References r8_sech().

Referenced by r8_sech().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign()

real ( kind = 8 ) function r8_sign ( real ( kind = 8 )  x)

Definition at line 5508 of file R8LIB.f90.

5509
5510!*****************************************************************************80
5511!
5512!! R8_SIGN returns the sign of an R8.
5513!
5514! Discussion:
5515!
5516! value = -1 if X < 0;
5517! value = +1 if X => 0.
5518!
5519! Note that the standard FORTRAN90 "sign" function is more complicated.
5520! In particular,
5521!
5522! Z = sign ( X, Y )
5523!
5524! means that
5525!
5526! Z = |X| if 0 <= Y;
5527! - |X| if Y < 0;
5528!
5529! Licensing:
5530!
5531! This code is distributed under the GNU LGPL license.
5532!
5533! Modified:
5534!
5535! 27 March 2004
5536!
5537! Author:
5538!
5539! John Burkardt
5540!
5541! Parameters:
5542!
5543! Input, real ( kind = 8 ) X, the number whose sign is desired.
5544!
5545! Output, real ( kind = 8 ) R8_SIGN, the sign of X:
5546!
5547 implicit none
5548
5549 real ( kind = 8 ) r8_sign
5550 real ( kind = 8 ) value
5551 real ( kind = 8 ) x
5552
5553 if ( x < 0.0d+00 ) then
5554 value = -1.0d+00
5555 else
5556 value = +1.0d+00
5557 end if
5558
5559 r8_sign = value
5560
5561 return

References r8_sign().

Referenced by r8_chop(), and r8_sign().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign3()

real ( kind = 8 ) function r8_sign3 ( real ( kind = 8 )  x)

Definition at line 5563 of file R8LIB.f90.

5564
5565!*****************************************************************************80
5566!
5567!! R8_SIGN3 returns the three-way sign of an R8.
5568!
5569! Licensing:
5570!
5571! This code is distributed under the GNU LGPL license.
5572!
5573! Modified:
5574!
5575! 28 September 2014
5576!
5577! Author:
5578!
5579! John Burkardt
5580!
5581! Parameters:
5582!
5583! Input, real ( kind = 8 ) X, the number whose sign is desired.
5584!
5585! Output, real ( kind = 8 ) R8_SIGN3, the sign of X:
5586!
5587 implicit none
5588
5589 real ( kind = 8 ) r8_sign3
5590 real ( kind = 8 ) value
5591 real ( kind = 8 ) x
5592
5593 if ( x < 0.0d+00 ) then
5594 value = -1.0d+00
5595 else if ( x == 0.0d+00 ) then
5596 value = 0.0d+00
5597 else
5598 value = +1.0d+00
5599 end if
5600
5601 r8_sign3 = value
5602
5603 return
r8_sign3
real(kind=8) function r8_sign3(x)
Definition R8LIB.f90:5564

References r8_sign3().

Referenced by r8_sign3().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign_char()

character function r8_sign_char ( real ( kind = 8 )  x)

Definition at line 5605 of file R8LIB.f90.

5606
5607!*****************************************************************************80
5608!
5609!! R8_SIGN_CHAR returns a character indicating the sign of an R8.
5610!
5611! Licensing:
5612!
5613! This code is distributed under the GNU LGPL license.
5614!
5615! Modified:
5616!
5617! 28 April 2012
5618!
5619! Author:
5620!
5621! John Burkardt
5622!
5623! Parameters:
5624!
5625! Input, real ( kind = 8 ) X, the number whose sign is desired.
5626!
5627! Output, character R8_SIGN_CHAR, the sign of X, '-', '0' or '+'.
5628!
5629 implicit none
5630
5631 character r8_sign_char
5632 character value
5633 real ( kind = 8 ) x
5634
5635 if ( x < 0.0d+00 ) then
5636 value = '-'
5637 else if ( x == 0.0d+00 ) then
5638 value = '0'
5639 else
5640 value = '+'
5641 end if
5642
5643 r8_sign_char = value
5644
5645 return
r8_sign_char
character function r8_sign_char(x)
Definition R8LIB.f90:5606

References r8_sign_char().

Referenced by r8_sign_char().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign_match()

logical ( kind = 4 ) function r8_sign_match ( real ( kind = 8 )  r1,
real ( kind = 8 )  r2 
)

Definition at line 5647 of file R8LIB.f90.

5648
5649!*****************************************************************************80
5650!
5651!! R8_SIGN_MATCH is TRUE if two R8's are of the same sign.
5652!
5653! Discussion:
5654!
5655! This test could be coded numerically as
5656!
5657! if ( 0 <= r1 * r2 ) then ...
5658!
5659! Licensing:
5660!
5661! This code is distributed under the GNU LGPL license.
5662!
5663! Modified:
5664!
5665! 26 April 2012
5666!
5667! Author:
5668!
5669! John Burkardt
5670!
5671! Parameters:
5672!
5673! Input, real ( kind = 8 ) R1, R2, the values to check.
5674!
5675! Output, logical ( kind = 4 ) R8_SIGN_MATCH, is TRUE if
5676! ( R1 <= 0 and R2 <= 0 ) or ( 0 <= R1 and 0 <= R2 ).
5677!
5678 implicit none
5679
5680 real ( kind = 8 ) r1
5681 real ( kind = 8 ) r2
5682 logical ( kind = 4 ) r8_sign_match
5683
5684 r8_sign_match = ( r1 <= 0.0d+00 .and. r2 <= 0.0d+00 ) .or. &
5685 ( 0.0d+00 <= r1 .and. 0.0d+00 <= r2 )
5686
5687 return
r8_sign_match
logical(kind=4) function r8_sign_match(r1, r2)
Definition R8LIB.f90:5648

References r8_sign_match().

Referenced by r8_sign_match().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign_match_strict()

logical ( kind = 4 ) function r8_sign_match_strict ( real ( kind = 8 )  r1,
real ( kind = 8 )  r2 
)

Definition at line 5689 of file R8LIB.f90.

5690
5691!*****************************************************************************80
5692!
5693!! R8_SIGN_MATCH_STRICT is TRUE if two R8's are of the same strict sign.
5694!
5695! Licensing:
5696!
5697! This code is distributed under the GNU LGPL license.
5698!
5699! Modified:
5700!
5701! 28 April 2012
5702!
5703! Author:
5704!
5705! John Burkardt
5706!
5707! Parameters:
5708!
5709! Input, real ( kind = 8 ) R1, R2, the values to check.
5710!
5711! Output, logical ( kind = 4 ) R8_SIGN_MATCH_STRICT, is TRUE if the
5712! signs match.
5713!
5714 implicit none
5715
5716 real ( kind = 8 ) r1
5717 real ( kind = 8 ) r2
5718 logical ( kind = 4 ) r8_sign_match_strict
5719
5720 r8_sign_match_strict = &
5721 ( r1 < 0.0d+00 .and. r2 < 0.0d+00 ) .or. &
5722 ( r1 == 0.0d+00 .and. r2 == 0.0d+00 ) .or. &
5723 ( 0.0d+00 < r1 .and. 0.0d+00 < r2 )
5724
5725 return
r8_sign_match_strict
logical(kind=4) function r8_sign_match_strict(r1, r2)
Definition R8LIB.f90:5690

References r8_sign_match_strict().

Referenced by r8_sign_match_strict().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign_opposite()

logical ( kind = 4 ) function r8_sign_opposite ( real ( kind = 8 )  r1,
real ( kind = 8 )  r2 
)

Definition at line 5727 of file R8LIB.f90.

5728
5729!*****************************************************************************80
5730!
5731!! R8_SIGN_OPPOSITE is TRUE if two R8's are not of the same sign.
5732!
5733! Discussion:
5734!
5735! This test could be coded numerically as
5736!
5737! if ( r1 * r2 <= 0.0 ) then ...
5738!
5739! Licensing:
5740!
5741! This code is distributed under the GNU LGPL license.
5742!
5743! Modified:
5744!
5745! 23 June 2010
5746!
5747! Author:
5748!
5749! John Burkardt
5750!
5751! Parameters:
5752!
5753! Input, real ( kind = 8 ) R1, R2, the values to check.
5754!
5755! Output, logical ( kind = 4 ) R8_SIGN_OPPOSITE, is TRUE if
5756! ( R1 <= 0 and 0 <= R2 ) or ( R2 <= 0 and 0 <= R1 ).
5757!
5758 implicit none
5759
5760 real ( kind = 8 ) r1
5761 real ( kind = 8 ) r2
5762 logical ( kind = 4 ) r8_sign_opposite
5763
5764 r8_sign_opposite = ( r1 <= 0.0d+00 .and. 0.0d+00 <= r2 ) .or. &
5765 ( r2 <= 0.0d+00 .and. 0.0d+00 <= r1 )
5766
5767 return
r8_sign_opposite
logical(kind=4) function r8_sign_opposite(r1, r2)
Definition R8LIB.f90:5728

References r8_sign_opposite().

Referenced by r8_sign_opposite().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sign_opposite_strict()

logical ( kind = 4 ) function r8_sign_opposite_strict ( real ( kind = 8 )  r1,
real ( kind = 8 )  r2 
)

Definition at line 5769 of file R8LIB.f90.

5770
5771!*****************************************************************************80
5772!
5773!! R8_SIGN_OPPOSITE_STRICT is TRUE if two R8's are strictly of opposite sign.
5774!
5775! Discussion:
5776!
5777! This test could be coded numerically as
5778!
5779! if ( r1 * r2 < 0.0 ) then ...
5780!
5781! Licensing:
5782!
5783! This code is distributed under the GNU LGPL license.
5784!
5785! Modified:
5786!
5787! 23 June 2010
5788!
5789! Author:
5790!
5791! John Burkardt
5792!
5793! Parameters:
5794!
5795! Input, real ( kind = 8 ) R1, R2, the values to check.
5796!
5797! Output, logical ( kind = 4 ) R8_SIGN_OPPOSITE_STRICT, is TRUE if
5798! ( R1 < 0 and 0 < R2 ) or ( R2 < 0 and 0 < R1 ).
5799!
5800 implicit none
5801
5802 real ( kind = 8 ) r1
5803 real ( kind = 8 ) r2
5804 logical ( kind = 4 ) r8_sign_opposite_strict
5805
5806 r8_sign_opposite_strict = ( r1 < 0.0d+00 .and. 0.0d+00 < r2 ) .or. &
5807 ( r2 < 0.0d+00 .and. 0.0d+00 < r1 )
5808
5809 return
r8_sign_opposite_strict
logical(kind=4) function r8_sign_opposite_strict(r1, r2)
Definition R8LIB.f90:5770

References r8_sign_opposite_strict().

Referenced by r8_sign_opposite_strict().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sind()

real ( kind = 8 ) function r8_sind ( real ( kind = 8 )  degrees)

Definition at line 5811 of file R8LIB.f90.

5812
5813!*****************************************************************************80
5814!
5815!! R8_SIND returns the sine of an angle given in degrees.
5816!
5817! Licensing:
5818!
5819! This code is distributed under the GNU LGPL license.
5820!
5821! Modified:
5822!
5823! 27 July 2014
5824!
5825! Author:
5826!
5827! John Burkardt
5828!
5829! Parameters:
5830!
5831! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
5832!
5833! Output, real ( kind = 8 ) R8_SIND, the sine of the angle.
5834!
5835 implicit none
5836
5837 real ( kind = 8 ) degrees
5838 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
5839 real ( kind = 8 ) r8_sind
5840 real ( kind = 8 ) radians
5841
5842 radians = r8_pi * ( degrees / 180.0d+00 )
5843 r8_sind = sin( radians )
5844
5845 return
r8_sind
real(kind=8) function r8_sind(degrees)
Definition R8LIB.f90:5812

References r8_pi(), and r8_sind().

Referenced by r8_sind().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_sqrt_i4()

real ( kind = 8 ) function r8_sqrt_i4 ( integer ( kind = 4 )  i)

Definition at line 5847 of file R8LIB.f90.

5848
5849!*****************************************************************************80
5850!
5851!! R8_SQRT_I4 returns the square root of an I4 as an R8.
5852!
5853! Licensing:
5854!
5855! This code is distributed under the GNU LGPL license.
5856!
5857! Modified:
5858!
5859! 04 June 2012
5860!
5861! Author:
5862!
5863! John Burkardt
5864!
5865! Parameters:
5866!
5867! Input, integer ( kind = 4 ) I, the number whose square root is desired.
5868!
5869! Output, real ( kind = 8 ) R8_SQRT_I4, the value of sqrt(I).
5870!
5871 implicit none
5872
5873 integer ( kind = 4 ) i
5874 real ( kind = 8 ) r8_sqrt_i4
5875
5876 r8_sqrt_i4 = sqrt( real( i, kind = 8 ) )
5877
5878 return
r8_sqrt_i4
real(kind=8) function r8_sqrt_i4(i)
Definition R8LIB.f90:5848

References r8_sqrt_i4().

Referenced by r8_sqrt_i4().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_swap()

subroutine r8_swap ( real ( kind = 8 )  x,
real ( kind = 8 )  y 
)

Definition at line 5880 of file R8LIB.f90.

5881
5882!*****************************************************************************80
5883!
5884!! R8_SWAP swaps two R8's.
5885!
5886! Licensing:
5887!
5888! This code is distributed under the GNU LGPL license.
5889!
5890! Modified:
5891!
5892! 22 December 2000
5893!
5894! Author:
5895!
5896! John Burkardt
5897!
5898! Parameters:
5899!
5900! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and
5901! Y have been interchanged.
5902!
5903 implicit none
5904
5905 real ( kind = 8 ) x
5906 real ( kind = 8 ) y
5907 real ( kind = 8 ) z
5908
5909 z = x
5910 x = y
5911 y = z
5912
5913 return

Referenced by r8poly2_val(), r8vec2_sort_a(), r8vec2_sort_d(), r8vec_sort2_a(), r8vec_sort_heap_d(), and r8vec_split().

Here is the caller graph for this function:

◆ r8_swap3()

subroutine r8_swap3 ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  z 
)

Definition at line 5915 of file R8LIB.f90.

5916
5917!*****************************************************************************80
5918!
5919!! R8_SWAP3 swaps three R8's.
5920!
5921! Example:
5922!
5923! Input:
5924!
5925! X = 1, Y = 2, Z = 3
5926!
5927! Output:
5928!
5929! X = 2, Y = 3, Z = 1
5930!
5931! Licensing:
5932!
5933! This code is distributed under the GNU LGPL license.
5934!
5935! Modified:
5936!
5937! 08 June 2000
5938!
5939! Author:
5940!
5941! John Burkardt
5942!
5943! Parameters:
5944!
5945! Input/output, real ( kind = 8 ) X, Y, Z, three values to be swapped.
5946!
5947 implicit none
5948
5949 real ( kind = 8 ) w
5950 real ( kind = 8 ) x
5951 real ( kind = 8 ) y
5952 real ( kind = 8 ) z
5953
5954 w = x
5955 x = y
5956 y = z
5957 z = w
5958
5959 return

◆ r8_tand()

real ( kind = 8 ) function r8_tand ( real ( kind = 8 )  degrees)

Definition at line 5961 of file R8LIB.f90.

5962
5963!*****************************************************************************80
5964!
5965!! R8_TAND returns the tangent of an angle given in degrees.
5966!
5967! Licensing:
5968!
5969! This code is distributed under the GNU LGPL license.
5970!
5971! Modified:
5972!
5973! 27 July 2014
5974!
5975! Author:
5976!
5977! John Burkardt
5978!
5979! Parameters:
5980!
5981! Input, real ( kind = 8 ) DEGREES, the angle in degrees.
5982!
5983! Output, real ( kind = 8 ) R8_TAND, the tangent of the angle.
5984!
5985 implicit none
5986
5987 real ( kind = 8 ) degrees
5988 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
5989 real ( kind = 8 ) r8_tand
5990 real ( kind = 8 ) radians
5991
5992 radians = r8_pi * ( degrees / 180.0d+00 )
5993 r8_tand = tan( radians )
5994
5995 return
r8_tand
real(kind=8) function r8_tand(degrees)
Definition R8LIB.f90:5962

References r8_pi(), and r8_tand().

Referenced by r8_tand().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_tiny()

real ( kind = 8 ) function r8_tiny

Definition at line 5997 of file R8LIB.f90.

5998
5999!*****************************************************************************80
6000!
6001!! R8_TINY returns a very small but positive R8.
6002!
6003! Discussion:
6004!
6005! FORTRAN90 provides a built-in routine TINY ( X ) that
6006! is more suitable for this purpose, returning the smallest positive
6007! but normalized real number.
6008!
6009! This routine does NOT try to provide an accurate value for TINY.
6010! Instead, it simply returns a "reasonable" value, that is, a rather
6011! small, but representable, real number.
6012!
6013! Licensing:
6014!
6015! This code is distributed under the GNU LGPL license.
6016!
6017! Modified:
6018!
6019! 08 March 2007
6020!
6021! Author:
6022!
6023! John Burkardt
6024!
6025! Parameters:
6026!
6027! Output, real ( kind = 8 ) R8_TINY, a "tiny" value.
6028!
6029 implicit none
6030
6031 real ( kind = 8 ) r8_tiny
6032
6033 r8_tiny = 1.0d-30
6034
6035 return

References r8_tiny().

Referenced by r8_acosh(), and r8_tiny().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_to_dhms()

subroutine r8_to_dhms ( real ( kind = 8 )  r,
integer ( kind = 4 )  d,
integer ( kind = 4 )  h,
integer ( kind = 4 )  m,
integer ( kind = 4 )  s 
)

Definition at line 6120 of file R8LIB.f90.

6121
6122!*****************************************************************************80
6123!
6124!! R8_TO_DHMS converts decimal days into days, hours, minutes, seconds.
6125!
6126! Licensing:
6127!
6128! This code is distributed under the GNU LGPL license.
6129!
6130! Modified:
6131!
6132! 08 April 2000
6133!
6134! Author:
6135!
6136! John Burkardt
6137!
6138! Parameters:
6139!
6140! Input, real ( kind = 8 ) R, a decimal number representing a time
6141! period measured in days.
6142!
6143! Output, integer ( kind = 4 ) D, H, M, S, the equivalent number of days,
6144! hours, minutes and seconds.
6145!
6146 implicit none
6147
6148 integer ( kind = 4 ) d
6149 integer ( kind = 4 ) h
6150 integer ( kind = 4 ) m
6151 real ( kind = 8 ) r
6152 real ( kind = 8 ) r_copy
6153 integer ( kind = 4 ) s
6154
6155 r_copy = abs( r )
6156
6157 d = int( r_copy )
6158
6159 r_copy = r_copy - d
6160 r_copy = 24.0d+00 * r_copy
6161 h = int( r_copy )
6162
6163 r_copy = r_copy - h
6164 r_copy = 60.0d+00 * r_copy
6165 m = int( r_copy )
6166
6167 r_copy = r_copy - m
6168 r_copy = 60.0d+00 * r_copy
6169 s = int( r_copy )
6170
6171 if ( r < 0.0d+00 ) then
6172 d = -d
6173 h = -h
6174 m = -m
6175 s = -s
6176 end if
6177
6178 return

◆ r8_to_i4()

subroutine r8_to_i4 ( real ( kind = 8 )  xmin,
real ( kind = 8 )  xmax,
real ( kind = 8 )  x,
integer ( kind = 4 )  ixmin,
integer ( kind = 4 )  ixmax,
integer ( kind = 4 )  ix 
)

Definition at line 6180 of file R8LIB.f90.

6181
6182!*****************************************************************************80
6183!
6184!! R8_TO_I4 maps X in [XMIN, XMAX] to integer IX in [IXMIN, IXMAX].
6185!
6186! Formula:
6187!
6188! IX := IXMIN + ( IXMAX - IXMIN ) * ( X - XMIN ) / ( XMAX - XMIN )
6189! IX := min ( IX, max ( IXMIN, IXMAX ) )
6190! IX := max ( IX, min ( IXMIN, IXMAX ) )
6191!
6192! Licensing:
6193!
6194! This code is distributed under the GNU LGPL license.
6195!
6196! Modified:
6197!
6198! 19 April 2014
6199!
6200! Author:
6201!
6202! John Burkardt
6203!
6204! Parameters:
6205!
6206! Input, real ( kind = 8 ) XMIN, XMAX, the range. XMAX and
6207! XMIN must not be equal. It is not necessary that XMIN be less than XMAX.
6208!
6209! Input, real ( kind = 8 ) X, the number to be converted.
6210!
6211! Input, integer ( kind = 4 ) IXMIN, IXMAX, the allowed range of the output
6212! variable. IXMAX corresponds to XMAX, and IXMIN to XMIN.
6213! It is not necessary that IXMIN be less than IXMAX.
6214!
6215! Output, integer ( kind = 4 ) IX, the value in the range [IXMIN,IXMAX] that
6216! corresponds to X.
6217!
6218 implicit none
6219
6220 integer ( kind = 4 ) ix
6221 integer ( kind = 4 ) ixmax
6222 integer ( kind = 4 ) ixmin
6223 real ( kind = 8 ) temp
6224 real ( kind = 8 ) x
6225 real ( kind = 8 ) xmax
6226 real ( kind = 8 ) xmin
6227
6228 if ( xmax == xmin ) then
6229 write ( *, '(a)' ) ' '
6230 write ( *, '(a)' ) 'R8_TO_I4 - Fatal error!'
6231 write ( *, '(a)' ) ' XMAX = XMIN, making a zero divisor.'
6232 write ( *, '(a,g14.6)' ) ' XMAX = ', xmax
6233 write ( *, '(a,g14.6)' ) ' XMIN = ', xmin
6234 stop 1
6235 end if
6236
6237 temp = &
6238 ( ( xmax - x ) * real( ixmin, kind = 8 ) &
6239 + ( x - xmin ) * real( ixmax, kind = 8 ) ) &
6240 / ( xmax - xmin )
6241
6242 if ( 0.0d+00 <= temp ) then
6243 temp = temp + 0.5d+00
6244 else
6245 temp = temp - 0.5d+00
6246 end if
6247
6248 ix = int( temp )
6249
6250 return

◆ r8_to_r8_discrete()

subroutine r8_to_r8_discrete ( real ( kind = 8 )  r,
real ( kind = 8 )  rmin,
real ( kind = 8 )  rmax,
integer ( kind = 4 )  nr,
real ( kind = 8 )  rd 
)

Definition at line 6037 of file R8LIB.f90.

6038
6039!*****************************************************************************80
6040!
6041!! R8_TO_R8_DISCRETE maps R to RD in [RMIN, RMAX] with NR possible values.
6042!
6043! Formula:
6044!
6045! if ( R < RMIN ) then
6046! RD = RMIN
6047! else if ( RMAX < R ) then
6048! RD = RMAX
6049! else
6050! T = nint ( ( NR - 1 ) * ( R - RMIN ) / ( RMAX - RMIN ) )
6051! RD = RMIN + T * ( RMAX - RMIN ) / real ( NR - 1 )
6052!
6053! In the special case where NR = 1, when
6054!
6055! XD = 0.5 * ( RMAX + RMIN )
6056!
6057! Licensing:
6058!
6059! This code is distributed under the GNU LGPL license.
6060!
6061! Modified:
6062!
6063! 21 April 2005
6064!
6065! Author:
6066!
6067! John Burkardt
6068!
6069! Parameters:
6070!
6071! Input, real ( kind = 8 ) R, the number to be converted.
6072!
6073! Input, real ( kind = 8 ) RMAX, RMIN, the maximum and minimum
6074! values for RD.
6075!
6076! Input, integer ( kind = 4 ) NR, the number of allowed values for XD.
6077! NR should be at least 1.
6078!
6079! Output, real ( kind = 8 ) RD, the corresponding discrete value.
6080!
6081 implicit none
6082
6083 integer ( kind = 4 ) f
6084 integer ( kind = 4 ) nr
6085 real ( kind = 8 ) r
6086 real ( kind = 8 ) rd
6087 real ( kind = 8 ) rmax
6088 real ( kind = 8 ) rmin
6089!
6090! Check for errors.
6091!
6092 if ( nr < 1 ) then
6093 write ( *, '(a)' ) ' '
6094 write ( *, '(a)' ) 'R8_TO_R8_DISCRETE - Fatal error!'
6095 write ( *, '(a,i8)' ) ' NR = ', nr
6096 write ( *, '(a)' ) ' but NR must be at least 1.'
6097 stop 1
6098 end if
6099
6100 if ( nr == 1 ) then
6101 rd = 0.5d+00 * ( rmin + rmax )
6102 return
6103 end if
6104
6105 if ( rmax == rmin ) then
6106 rd = rmax
6107 return
6108 end if
6109
6110 f = nint( real( nr, kind = 8 ) * ( rmax - r ) / ( rmax - rmin ) )
6111 f = max( f, 0 )
6112 f = min( f, nr )
6113
6114 rd = ( real( f, kind = 8 ) * rmin &
6115 + real( nr - f, kind = 8 ) * rmax ) &
6116 / real( nr, kind = 8 )
6117
6118 return

◆ r8_uniform_01()

real ( kind = 8 ) function r8_uniform_01 ( integer ( kind = 4 )  seed)

Definition at line 6252 of file R8LIB.f90.

6253
6254!*****************************************************************************80
6255!
6256!! R8_UNIFORM_01 returns a unit pseudorandom R8.
6257!
6258! Discussion:
6259!
6260! An R8 is a real ( kind = 8 ) value.
6261!
6262! For now, the input quantity SEED is an integer variable.
6263!
6264! This routine implements the recursion
6265!
6266! seed = 16807 * seed mod ( 2^31 - 1 )
6267! r8_uniform_01 = seed / ( 2^31 - 1 )
6268!
6269! The integer arithmetic never requires more than 32 bits,
6270! including a sign bit.
6271!
6272! If the initial seed is 12345, then the first three computations are
6273!
6274! Input Output R8_UNIFORM_01
6275! SEED SEED
6276!
6277! 12345 207482415 0.096616
6278! 207482415 1790989824 0.833995
6279! 1790989824 2035175616 0.947702
6280!
6281! Licensing:
6282!
6283! This code is distributed under the GNU LGPL license.
6284!
6285! Modified:
6286!
6287! 05 July 2006
6288!
6289! Author:
6290!
6291! John Burkardt
6292!
6293! Reference:
6294!
6295! Paul Bratley, Bennett Fox, Linus Schrage,
6296! A Guide to Simulation,
6297! Springer Verlag, pages 201-202, 1983.
6298!
6299! Pierre L'Ecuyer,
6300! Random Number Generation,
6301! in Handbook of Simulation,
6302! edited by Jerry Banks,
6303! Wiley Interscience, page 95, 1998.
6304!
6305! Bennett Fox,
6306! Algorithm 647:
6307! Implementation and Relative Efficiency of Quasirandom
6308! Sequence Generators,
6309! ACM Transactions on Mathematical Software,
6310! Volume 12, Number 4, pages 362-376, 1986.
6311!
6312! Peter Lewis, Allen Goodman, James Miller
6313! A Pseudo-Random Number Generator for the System/360,
6314! IBM Systems Journal,
6315! Volume 8, pages 136-143, 1969.
6316!
6317! Parameters:
6318!
6319! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should
6320! NOT be 0. On output, SEED has been updated.
6321!
6322! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
6323! strictly between 0 and 1.
6324!
6325 implicit none
6326
6327 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
6328 integer ( kind = 4 ) k
6329 real ( kind = 8 ) r8_uniform_01
6330 integer ( kind = 4 ) seed
6331
6332 if ( seed == 0 ) then
6333 write ( *, '(a)' ) ' '
6334 write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!'
6335 write ( *, '(a)' ) ' Input value of SEED = 0.'
6336 stop 1
6337 end if
6338
6339 k = seed / 127773
6340
6341 seed = 16807 * ( seed - k * 127773 ) - k * 2836
6342
6343 if ( seed < 0 ) then
6344 seed = seed + i4_huge
6345 end if
6346
6347 r8_uniform_01 = real( seed, kind = 8 ) * 4.656612875d-10
6348
6349 return

References r8_uniform_01().

Referenced by r8_normal_01(), r8_normal_ab(), r8_uniform_01(), and r8vec_normal_01().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_uniform_ab()

real ( kind = 8 ) function r8_uniform_ab ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
integer ( kind = 4 )  seed 
)

Definition at line 6351 of file R8LIB.f90.

6352
6353!*****************************************************************************80
6354!
6355!! R8_UNIFORM_AB returns a scaled pseudorandom R8.
6356!
6357! Discussion:
6358!
6359! An R8 is a real ( kind = 8 ) value.
6360!
6361! For now, the input quantity SEED is an integer variable.
6362!
6363! The pseudorandom number should be uniformly distributed
6364! between A and B.
6365!
6366! Licensing:
6367!
6368! This code is distributed under the GNU LGPL license.
6369!
6370! Modified:
6371!
6372! 05 July 2006
6373!
6374! Author:
6375!
6376! John Burkardt
6377!
6378! Parameters:
6379!
6380! Input, real ( kind = 8 ) A, B, the limits of the interval.
6381!
6382! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should
6383! NOT be 0. On output, SEED has been updated.
6384!
6385! Output, real ( kind = 8 ) R8_UNIFORM_AB, a number strictly between A and B.
6386!
6387 implicit none
6388
6389 real ( kind = 8 ) a
6390 real ( kind = 8 ) b
6391 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
6392 integer ( kind = 4 ) k
6393 real ( kind = 8 ) r8_uniform_ab
6394 integer ( kind = 4 ) seed
6395
6396 if ( seed == 0 ) then
6397 write ( *, '(a)' ) ' '
6398 write ( *, '(a)' ) 'R8_UNIFORM_AB - Fatal error!'
6399 write ( *, '(a)' ) ' Input value of SEED = 0.'
6400 stop 1
6401 end if
6402
6403 k = seed / 127773
6404
6405 seed = 16807 * ( seed - k * 127773 ) - k * 2836
6406
6407 if ( seed < 0 ) then
6408 seed = seed + i4_huge
6409 end if
6410
6411 r8_uniform_ab = a + ( b - a ) * real( seed, kind = 8 ) * 4.656612875d-10
6412
6413 return

References r8_uniform_ab().

Referenced by r82_uniform_ab(), and r8_uniform_ab().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_unswap3()

subroutine r8_unswap3 ( real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  z 
)

Definition at line 6415 of file R8LIB.f90.

6416
6417!*****************************************************************************80
6418!
6419!! R8_UNSWAP3 unswaps three R8's.
6420!
6421! Example:
6422!
6423! Input:
6424!
6425! X = 2, Y = 3, Z = 1
6426!
6427! Output:
6428!
6429! X = 1, Y = 2, Z = 3
6430!
6431! Licensing:
6432!
6433! This code is distributed under the GNU LGPL license.
6434!
6435! Modified:
6436!
6437! 16 July 2000
6438!
6439! Author:
6440!
6441! John Burkardt
6442!
6443! Parameters:
6444!
6445! Input/output, real ( kind = 8 ) X, Y, Z, three values to be swapped.
6446!
6447 implicit none
6448
6449 real ( kind = 8 ) w
6450 real ( kind = 8 ) x
6451 real ( kind = 8 ) y
6452 real ( kind = 8 ) z
6453
6454 w = z
6455 z = y
6456 y = x
6457 x = w
6458
6459 return

◆ r8_walsh_1d()

real ( kind = 8 ) function r8_walsh_1d ( real ( kind = 8 )  x,
integer ( kind = 4 )  digit 
)

Definition at line 6461 of file R8LIB.f90.

6462
6463!*****************************************************************************80
6464!
6465!! R8_WALSH_1D evaluates the Walsh function.
6466!
6467! Discussion:
6468!
6469! Consider the binary representation of X, and number the digits
6470! in descending order, from leading to lowest, with the units digit
6471! being numbered 0.
6472!
6473! The Walsh function W(J)(X) is equal to the J-th binary digit of X.
6474!
6475! Licensing:
6476!
6477! This code is distributed under the GNU LGPL license.
6478!
6479! Modified:
6480!
6481! 17 May 2003
6482!
6483! Author:
6484!
6485! John Burkardt
6486!
6487! Parameters:
6488!
6489! Input, real ( kind = 8 ) X, the argument of the Walsh function.
6490!
6491! Input, integer ( kind = 4 ) DIGIT, the index of the Walsh function.
6492!
6493! Output, real ( kind = 8 ) R8_WALSH_1D, the value of the Walsh function.
6494!
6495 implicit none
6496
6497 integer ( kind = 4 ) digit
6498 integer ( kind = 4 ) n
6499 real ( kind = 8 ) r8_walsh_1d
6500 real ( kind = 8 ) x
6501 real ( kind = 8 ) x_copy
6502!
6503! Hide the effect of the sign of X.
6504!
6505 x_copy = abs( x )
6506!
6507! If DIGIT is positive, divide by 2 DIGIT times.
6508! If DIGIT is negative, multiply by 2 (-DIGIT) times.
6509!
6510 x_copy = x_copy / 2.0d+00**digit
6511!
6512! Make it an integer.
6513! Because it's positive, and we're using INT, we don't change the
6514! units digit.
6515!
6516 n = int( x_copy )
6517!
6518! Is the units digit odd or even?
6519!
6520 if ( mod( n, 2 ) == 0 ) then
6521 r8_walsh_1d = 0.0d+00
6522 else
6523 r8_walsh_1d = 1.0d+00
6524 end if
6525
6526 return
r8_walsh_1d
real(kind=8) function r8_walsh_1d(x, digit)
Definition R8LIB.f90:6462

References r8_walsh_1d().

Referenced by r8_walsh_1d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8_wrap()

real ( kind = 8 ) function r8_wrap ( real ( kind = 8 )  r,
real ( kind = 8 )  rlo,
real ( kind = 8 )  rhi 
)

Definition at line 6528 of file R8LIB.f90.

6529
6530!*****************************************************************************80
6531!
6532!! R8_WRAP forces an R8 to lie between given limits by wrapping.
6533!
6534! Discussion:
6535!
6536! An R8 is a real ( kind = 8 ) value.
6537!
6538! Example:
6539!
6540! RLO = 4.0, RHI = 8.0
6541!
6542! R Value
6543!
6544! -2 8
6545! -1 4
6546! 0 5
6547! 1 6
6548! 2 7
6549! 3 8
6550! 4 4
6551! 5 5
6552! 6 6
6553! 7 7
6554! 8 8
6555! 9 4
6556! 10 5
6557! 11 6
6558! 12 7
6559! 13 8
6560! 14 4
6561!
6562! Licensing:
6563!
6564! This code is distributed under the GNU LGPL license.
6565!
6566! Modified:
6567!
6568! 04 July 2011
6569!
6570! Author:
6571!
6572! John Burkardt
6573!
6574! Parameters:
6575!
6576! Input, real ( kind = 8 ) R, a value.
6577!
6578! Input, real ( kind = 8 ) RLO, RHI, the desired bounds.
6579!
6580! Output, real ( kind = 8 ) R8_WRAP, a "wrapped" version of the value.
6581!
6582 implicit none
6583
6584 integer ( kind = 4 ) n
6585 real ( kind = 8 ) r
6586 real ( kind = 8 ) r8_wrap
6587 real ( kind = 8 ) rhi
6588 real ( kind = 8 ) rhi2
6589 real ( kind = 8 ) rlo
6590 real ( kind = 8 ) rlo2
6591 real ( kind = 8 ) rwide
6592 real ( kind = 8 ) value
6593!
6594! Guarantee RLO2 < RHI2.
6595!
6596 rlo2 = min( rlo, rhi )
6597 rhi2 = max( rlo, rhi )
6598!
6599! Find the width.
6600!
6601 rwide = rhi2 - rlo2
6602!
6603! Add enough copies of (RHI2-RLO2) to R so that the
6604! result ends up in the interval RLO2 - RHI2.
6605!
6606 if ( rwide == 0.0d+00 ) then
6607 value = rlo
6608 else if ( r < rlo2 ) then
6609 n = int( ( rlo2 - r ) / rwide ) + 1
6610 value = r + n * rwide
6611 if ( value == rhi ) then
6612 value = rlo
6613 end if
6614 else
6615 n = int( ( r - rlo2 ) / rwide )
6616 value = r - n * rwide
6617 if ( value == rlo ) then
6618 value = rhi
6619 end if
6620 end if
6621
6622 r8_wrap = value
6623
6624 return
r8_wrap
real(kind=8) function r8_wrap(r, rlo, rhi)
Definition R8LIB.f90:6529

References r8_wrap().

Referenced by r8_wrap().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8block_expand_linear()

subroutine r8block_expand_linear ( integer ( kind = 4 )  l,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(l,m,n)  x,
integer ( kind = 4 )  lfat,
integer ( kind = 4 )  mfat,
integer ( kind = 4 )  nfat,
real ( kind = 8 ), dimension((l-1)*(lfat+1)+1,(m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)  xfat 
)

Definition at line 8808 of file R8LIB.f90.

8809
8810!*****************************************************************************80
8811!
8812!! R8BLOCK_EXPAND_LINEAR linearly interpolates new data into an R8BLOCK.
8813!
8814! Discussion:
8815!
8816! An R8BLOCK is a 3D array of R8 values.
8817!
8818! In this routine, the expansion is specified by giving the number
8819! of intermediate values to generate between each pair of original
8820! data rows and columns.
8821!
8822! The interpolation is not actually linear. It uses the functions
8823!
8824! 1, x, y, z, xy, xz, yz, xyz.
8825!
8826! Licensing:
8827!
8828! This code is distributed under the GNU LGPL license.
8829!
8830! Modified:
8831!
8832! 17 October 2001
8833!
8834! Author:
8835!
8836! John Burkardt
8837!
8838! Parameters:
8839!
8840! Input, integer ( kind = 4 ) L, M, N, the dimensions of the input data.
8841!
8842! Input, real ( kind = 8 ) X(L,M,N), the original data.
8843!
8844! Input, integer ( kind = 4 ) LFAT, MFAT, NFAT, the number of data values
8845! to interpolate original data values in the first, second and third
8846! dimensions.
8847!
8848! Output, real ( kind = 8 ) XFAT(L2,M2,N2), the fattened data, where
8849! L2 = (L-1)*(LFAT+1)+1,
8850! M2 = (M-1)*(MFAT+1)+1,
8851! N2 = (N-1)*(NFAT+1)+1.
8852!
8853 implicit none
8854
8855 integer ( kind = 4 ) l
8856 integer ( kind = 4 ) lfat
8857 integer ( kind = 4 ) m
8858 integer ( kind = 4 ) mfat
8859 integer ( kind = 4 ) n
8860 integer ( kind = 4 ) nfat
8861
8862 integer ( kind = 4 ) i
8863 integer ( kind = 4 ) ihi
8864 integer ( kind = 4 ) ii
8865 integer ( kind = 4 ) iii
8866 integer ( kind = 4 ) ip1
8867 integer ( kind = 4 ) j
8868 integer ( kind = 4 ) jhi
8869 integer ( kind = 4 ) jj
8870 integer ( kind = 4 ) jjj
8871 integer ( kind = 4 ) jp1
8872 integer ( kind = 4 ) k
8873 integer ( kind = 4 ) khi
8874 integer ( kind = 4 ) kk
8875 integer ( kind = 4 ) kkk
8876 integer ( kind = 4 ) kp1
8877 real ( kind = 8 ) r
8878 real ( kind = 8 ) s
8879 real ( kind = 8 ) t
8880 real ( kind = 8 ) x(l,m,n)
8881 real ( kind = 8 ) x000
8882 real ( kind = 8 ) x001
8883 real ( kind = 8 ) x010
8884 real ( kind = 8 ) x011
8885 real ( kind = 8 ) x100
8886 real ( kind = 8 ) x101
8887 real ( kind = 8 ) x110
8888 real ( kind = 8 ) x111
8889 real ( kind = 8 ) xfat((l-1)*(lfat+1)+1,(m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)
8890
8891 do i = 1, l
8892
8893 if ( i < l ) then
8894 ihi = lfat
8895 else
8896 ihi = 0
8897 end if
8898
8899 do j = 1, m
8900
8901 if ( j < m ) then
8902 jhi = mfat
8903 else
8904 jhi = 0
8905 end if
8906
8907 do k = 1, n
8908
8909 if ( k < n ) then
8910 khi = nfat
8911 else
8912 khi = 0
8913 end if
8914
8915 if ( i < l ) then
8916 ip1 = i + 1
8917 else
8918 ip1 = i
8919 end if
8920
8921 if ( j < m ) then
8922 jp1 = j + 1
8923 else
8924 jp1 = j
8925 end if
8926
8927 if ( k < n ) then
8928 kp1 = k + 1
8929 else
8930 kp1 = k
8931 end if
8932
8933 x000 = x(i,j,k)
8934 x001 = x(i,j,kp1)
8935 x100 = x(ip1,j,k)
8936 x101 = x(ip1,j,kp1)
8937 x010 = x(i,jp1,k)
8938 x011 = x(i,jp1,kp1)
8939 x110 = x(ip1,jp1,k)
8940 x111 = x(ip1,jp1,kp1)
8941
8942 do ii = 0, ihi
8943
8944 r = real( ii, kind = 8 ) &
8945 / real( ihi + 1, kind = 8 )
8946
8947 do jj = 0, jhi
8948
8949 s = real( jj, kind = 8 ) &
8950 / real( jhi + 1, kind = 8 )
8951
8952 do kk = 0, khi
8953
8954 t = real( kk, kind = 8 ) &
8955 / real( khi + 1, kind = 8 )
8956
8957 iii = 1 + ( i - 1 ) * ( lfat + 1 ) + ii
8958 jjj = 1 + ( j - 1 ) * ( mfat + 1 ) + jj
8959 kkk = 1 + ( k - 1 ) * ( nfat + 1 ) + kk
8960
8961 xfat(iii,jjj,kkk) = &
8962 x000 * ( 1.0d+00 - r ) * ( 1.0d+00 - s ) * ( 1.0d+00 - t ) &
8963 + x001 * ( 1.0d+00 - r ) * ( 1.0d+00 - s ) * ( t ) &
8964 + x010 * ( 1.0d+00 - r ) * ( s ) * ( 1.0d+00 - t ) &
8965 + x011 * ( 1.0d+00 - r ) * ( s ) * ( t ) &
8966 + x100 * ( r ) * ( 1.0d+00 - s ) * ( 1.0d+00 - t ) &
8967 + x101 * ( r ) * ( 1.0d+00 - s ) * ( t ) &
8968 + x110 * ( r ) * ( s ) * ( 1.0d+00 - t ) &
8969 + x111 * ( r ) * ( s ) * ( t )
8970
8971 end do
8972
8973 end do
8974
8975 end do
8976
8977 end do
8978
8979 end do
8980
8981 end do
8982
8983 return

◆ r8block_print()

subroutine r8block_print ( integer ( kind = 4 )  l,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(l,m,n)  a,
character ( len = * )  title 
)

Definition at line 8985 of file R8LIB.f90.

8986
8987!*****************************************************************************80
8988!
8989!! R8BLOCK_PRINT prints an R8BLOCK.
8990!
8991! Discussion:
8992!
8993! An R8BLOCK is a 3D array of R8 values.
8994!
8995! Licensing:
8996!
8997! This code is distributed under the GNU LGPL license.
8998!
8999! Modified:
9000!
9001! 11 October 2001
9002!
9003! Author:
9004!
9005! John Burkardt
9006!
9007! Parameters:
9008!
9009! Input, integer ( kind = 4 ) L, M, N, the dimensions of the block.
9010!
9011! Input, real ( kind = 8 ) A(L,M,N), the matrix to be printed.
9012!
9013! Input, character ( len = * ) TITLE, a title.
9014!
9015 implicit none
9016
9017 integer ( kind = 4 ) l
9018 integer ( kind = 4 ) m
9019 integer ( kind = 4 ) n
9020
9021 real ( kind = 8 ) a(l,m,n)
9022 integer ( kind = 4 ) i
9023 integer ( kind = 4 ) j
9024 integer ( kind = 4 ) jhi
9025 integer ( kind = 4 ) jlo
9026 integer ( kind = 4 ) k
9027 character ( len = * ) title
9028
9029 write ( *, '(a)' ) ' '
9030 write ( *, '(a)' ) trim( title )
9031
9032 do k = 1, n
9033
9034 write ( *, '(a)' ) ' '
9035 write ( *, '(a,i8)' ) ' K = ', k
9036
9037 do jlo = 1, m, 5
9038 jhi = min( jlo + 4, m )
9039 write ( *, '(a)' ) ' '
9040 write ( *, '(10x,5(i8,6x))' ) (j, j = jlo, jhi )
9041 write ( *, '(a)' ) ' '
9042 do i = 1, l
9043 write ( *, '(2x,i8,5g14.6)' ) i, a(i,jlo:jhi,k)
9044 end do
9045 end do
9046
9047 end do
9048
9049 return

◆ r8cmat_print()

subroutine r8cmat_print ( integer ( kind = 4 )  lda,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(lda,n)  a,
character ( len = * )  title 
)

Definition at line 9051 of file R8LIB.f90.

9052
9053!*****************************************************************************80
9054!
9055!! R8CMAT_PRINT prints an R8CMAT.
9056!
9057! Discussion:
9058!
9059! An R8CMAT is an MxN array of R8's, stored with a leading dimension
9060! of LD, and hence accessed either as a double indexed array:
9061! (I,J) -> (I,J)
9062! or as a vector:
9063! (I,J) -> (I+J*LD).
9064!
9065! Licensing:
9066!
9067! This code is distributed under the GNU LGPL license.
9068!
9069! Modified:
9070!
9071! 19 March 2014
9072!
9073! Author:
9074!
9075! John Burkardt
9076!
9077! Parameters:
9078!
9079! Input, integer ( kind = 4 ) LDA, the leading dimension of A.
9080!
9081! Input, integer ( kind = 4 ) M, the number of rows in A.
9082!
9083! Input, integer ( kind = 4 ) N, the number of columns in A.
9084!
9085! Input, real ( kind = 8 ) A(LDA,N), the M by N matrix.
9086!
9087! Input, character ( len = * ) TITLE, a title.
9088!
9089 implicit none
9090
9091 integer ( kind = 4 ) lda
9092 integer ( kind = 4 ) m
9093 integer ( kind = 4 ) n
9094
9095 real ( kind = 8 ) a(lda,n)
9096 character ( len = * ) title
9097
9098 call r8cmat_print_some ( lda, m, n, a, 1, 1, m, n, title )
9099
9100 return
r8cmat_print_some
subroutine r8cmat_print_some(lda, m, n, a, ilo, jlo, ihi, jhi, title)
Definition R8LIB.f90:9103

References r8cmat_print_some().

Here is the call graph for this function:

◆ r8cmat_print_some()

subroutine r8cmat_print_some ( integer ( kind = 4 )  lda,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(lda,n)  a,
integer ( kind = 4 )  ilo,
integer ( kind = 4 )  jlo,
integer ( kind = 4 )  ihi,
integer ( kind = 4 )  jhi,
character ( len = * )  title 
)

Definition at line 9102 of file R8LIB.f90.

9103
9104!*****************************************************************************80
9105!
9106!! R8CMAT_PRINT_SOME prints some of an R8CMAT.
9107!
9108! Discussion:
9109!
9110! An R8CMAT is an MxN array of R8's, stored with a leading dimension
9111! of LD, and hence accessed either as a double indexed array:
9112! (I,J) -> (I,J)
9113! or as a vector:
9114! (I,J) -> (I+J*LD).
9115!
9116! Licensing:
9117!
9118! This code is distributed under the GNU LGPL license.
9119!
9120! Modified:
9121!
9122! 18 March 2014
9123!
9124! Author:
9125!
9126! John Burkardt
9127!
9128! Parameters:
9129!
9130! Input, integer ( kind = 4 ) LDA, the leading dimension of A.
9131!
9132! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9133!
9134! Input, real ( kind = 8 ) A(LDA,N), the M by N matrix.
9135!
9136! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
9137!
9138! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
9139!
9140! Input, character ( len = * ) TITLE, a title.
9141!
9142 implicit none
9143
9144 integer ( kind = 4 ), parameter :: incx = 5
9145 integer ( kind = 4 ) lda
9146 integer ( kind = 4 ) m
9147 integer ( kind = 4 ) n
9148
9149 real ( kind = 8 ) a(lda,n)
9150 character ( len = 14 ) ctemp(incx)
9151 integer ( kind = 4 ) i
9152 integer ( kind = 4 ) i2hi
9153 integer ( kind = 4 ) i2lo
9154 integer ( kind = 4 ) ihi
9155 integer ( kind = 4 ) ilo
9156 integer ( kind = 4 ) inc
9157 integer ( kind = 4 ) j
9158 integer ( kind = 4 ) j2
9159 integer ( kind = 4 ) j2hi
9160 integer ( kind = 4 ) j2lo
9161 integer ( kind = 4 ) jhi
9162 integer ( kind = 4 ) jlo
9163 character ( len = * ) title
9164
9165 write ( *, '(a)' ) ' '
9166 write ( *, '(a)' ) trim( title )
9167
9168 if ( m <= 0 .or. n <= 0 ) then
9169 write ( *, '(a)' ) ' '
9170 write ( *, '(a)' ) ' (None)'
9171 return
9172 end if
9173
9174 do j2lo = max( jlo, 1 ), min( jhi, n ), incx
9175
9176 j2hi = j2lo + incx - 1
9177 j2hi = min( j2hi, n )
9178 j2hi = min( j2hi, jhi )
9179
9180 inc = j2hi + 1 - j2lo
9181
9182 write ( *, '(a)' ) ' '
9183
9184 do j = j2lo, j2hi
9185 j2 = j + 1 - j2lo
9186 write ( ctemp(j2), '(i8,6x)' ) j
9187 end do
9188
9189 write ( *, '('' Col '',5a14)' ) ctemp(1:inc)
9190 write ( *, '(a)' ) ' Row'
9191 write ( *, '(a)' ) ' '
9192
9193 i2lo = max( ilo, 1 )
9194 i2hi = min( ihi, m )
9195
9196 do i = i2lo, i2hi
9197
9198 do j2 = 1, inc
9199
9200 j = j2lo - 1 + j2
9201
9202 if ( a(i,j) == real( int( a(i,j) ), kind = 8 ) ) then
9203 write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
9204 else
9205 write ( ctemp(j2), '(g14.6)' ) a(i,j)
9206 end if
9207
9208 end do
9209
9210 write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )
9211
9212 end do
9213
9214 end do
9215
9216 return

Referenced by r8cmat_print().

Here is the caller graph for this function:

◆ r8cmat_to_r8mat()

subroutine r8cmat_to_r8mat ( integer ( kind = 4 )  lda,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(lda,n)  a1,
real ( kind = 8 ), dimension(m,n)  a2 
)

Definition at line 9218 of file R8LIB.f90.

9219
9220!*****************************************************************************80
9221!
9222!! R8CMAT_TO_R8MAT transfers data from an R8CMAT to an R8MAT.
9223!
9224! Discussion:
9225!
9226! An R8CMAT is an MxN array of R8's, stored with a leading dimension LD,
9227! accessible as a vector:
9228! (I,J) -> (I+J*LD).
9229! or as a doubly-dimensioned array, if declared A(LD,N):
9230! (I,J) -> A(I,J)
9231!
9232! An R8MAT is an MxN array of R8's,
9233! accessible as a vector:
9234! (I,J) -> (I+J*M).
9235! or as a doubly-dimensioned array, if declared A(M,N):
9236! (I,J) -> A(I,J)
9237!
9238! Licensing:
9239!
9240! This code is distributed under the GNU LGPL license.
9241!
9242! Modified:
9243!
9244! 19 March 2014
9245!
9246! Author:
9247!
9248! John Burkardt
9249!
9250! Parameters:
9251!
9252! Input, integer ( kind = 4 ) LDA, the leading dimension of A1.
9253!
9254! Input, integer ( kind = 4 ) M, the number of rows of data.
9255! M <= LDA.
9256!
9257! Input, integer ( kind = 4 ) N, the number of columns of data.
9258!
9259! Input, real ( kind = 8 ) A1(LDA,N), the matrix to be copied.
9260!
9261! Output, real ( kind = 8 ) A2(M,N), a copy of the
9262! information in the MxN submatrix of A1.
9263!
9264 implicit none
9265
9266 integer ( kind = 4 ) lda
9267 integer ( kind = 4 ) m
9268 integer ( kind = 4 ) n
9269
9270 real ( kind = 8 ) a1(lda,n)
9271 real ( kind = 8 ) a2(m,n)
9272
9273 a2(1:m,1:n) = a1(1:m,1:n)
9274
9275 return

◆ r8col_compare()

subroutine r8col_compare ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j,
integer ( kind = 4 )  value 
)

Definition at line 9277 of file R8LIB.f90.

9278
9279!*****************************************************************************80
9280!
9281!! R8COL_COMPARE compares columns in an R8COL.
9282!
9283! Discussion:
9284!
9285! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9286! each of length M.
9287!
9288! Example:
9289!
9290! Input:
9291!
9292! M = 3, N = 4, I = 2, J = 4
9293!
9294! A = (
9295! 1. 2. 3. 4.
9296! 5. 6. 7. 8.
9297! 9. 10. 11. 12. )
9298!
9299! Output:
9300!
9301! VALUE = -1
9302!
9303! Licensing:
9304!
9305! This code is distributed under the GNU LGPL license.
9306!
9307! Modified:
9308!
9309! 05 December 2004
9310!
9311! Author:
9312!
9313! John Burkardt
9314!
9315! Parameters:
9316!
9317! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9318!
9319! Input, real ( kind = 8 ) A(M,N), the M by N array.
9320!
9321! Input, integer ( kind = 4 ) I, J, the columns to be compared.
9322! I and J must be between 1 and N.
9323!
9324! Output, integer ( kind = 4 ) VALUE, the results of the comparison:
9325! -1, column I < column J,
9326! 0, column I = column J,
9327! +1, column J < column I.
9328!
9329 implicit none
9330
9331 integer ( kind = 4 ) m
9332 integer ( kind = 4 ) n
9333
9334 real ( kind = 8 ) a(m,n)
9335 integer ( kind = 4 ) i
9336 integer ( kind = 4 ) j
9337 integer ( kind = 4 ) k
9338 integer ( kind = 4 ) value
9339!
9340! Check.
9341!
9342 if ( i < 1 .or. n < i ) then
9343 write ( *, '(a)' ) ' '
9344 write ( *, '(a)' ) 'R8COL_COMPARE - Fatal error!'
9345 write ( *, '(a)' ) ' Column index I is out of bounds.'
9346 write ( *, '(a,i8)' ) ' I = ', i
9347 stop 1
9348 end if
9349
9350 if ( j < 1 .or. n < j ) then
9351 write ( *, '(a)' ) ' '
9352 write ( *, '(a)' ) 'R8COL_COMPARE - Fatal error!'
9353 write ( *, '(a)' ) ' Column index J is out of bounds.'
9354 write ( *, '(a,i8)' ) ' J = ', j
9355 stop 1
9356 end if
9357
9358 value = 0
9359
9360 if ( i == j ) then
9361 return
9362 end if
9363
9364 k = 1
9365
9366 do while ( k <= m )
9367
9368 if ( a(k,i) < a(k,j) ) then
9369 value = -1
9370 return
9371 else if ( a(k,j) < a(k,i) ) then
9372 value = +1
9373 return
9374 end if
9375
9376 k = k + 1
9377
9378 end do
9379
9380 return

Referenced by r8col_insert().

Here is the caller graph for this function:

◆ r8col_duplicates()

subroutine r8col_duplicates ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
integer ( kind = 4 )  n_unique,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 9382 of file R8LIB.f90.

9383
9384!*****************************************************************************80
9385!
9386!! R8COL_DUPLICATES generates an R8COL with some duplicate columns.
9387!
9388! Discussion:
9389!
9390! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9391! each of length M.
9392!
9393! This routine generates a random R8COL with a specified number of
9394! duplicate columns.
9395!
9396! Licensing:
9397!
9398! This code is distributed under the GNU LGPL license.
9399!
9400! Modified:
9401!
9402! 21 July 2010
9403!
9404! Author:
9405!
9406! John Burkardt
9407!
9408! Parameters:
9409!
9410! Input, integer ( kind = 4 ) M, the number of rows in each column of A.
9411!
9412! Input, integer ( kind = 4 ) N, the number of columns in A.
9413!
9414! Input, integer ( kind = 4 ) N_UNIQUE, the number of unique columns in A.
9415! 1 <= N_UNIQUE <= N.
9416!
9417! Input/output, integer ( kind = 4 ) SEED, a seed for the random
9418! number generator.
9419!
9420! Output, real ( kind = 8 ) A(M,N), the array.
9421!
9422 implicit none
9423
9424 integer ( kind = 4 ) m
9425 integer ( kind = 4 ) n
9426
9427 real ( kind = 8 ) a(m,n)
9428 integer ( kind = 4 ) i4_uniform_ab
9429 integer ( kind = 4 ) j1
9430 integer ( kind = 4 ) j2
9431 integer ( kind = 4 ) n_unique
9432 integer ( kind = 4 ) seed
9433 real ( kind = 8 ) temp(m)
9434
9435 if ( n_unique < 1 .or. n < n_unique ) then
9436 write ( *, '(a)' ) ' '
9437 write ( *, '(a)' ) 'R8COL_DUPLICATES - Fatal error!'
9438 write ( *, '(a)' ) ' 1 <= N_UNIQUE <= N is required.'
9439 stop 1
9440 end if
9441
9442 call r8mat_uniform_01 ( m, n_unique, seed, a )
9443!
9444! Randomly copy unique columns.
9445!
9446 do j1 = n_unique + 1, n
9447 j2 = i4_uniform_ab( 1, n_unique, seed )
9448 a(1:m,j1) = a(1:m,j2)
9449 end do
9450!
9451! Permute the columns.
9452!
9453 do j1 = 1, n
9454 j2 = i4_uniform_ab( j1, n, seed )
9455 temp(1:m) = a(1:m,j1)
9456 a(1:m,j1) = a(1:m,j2)
9457 a(1:m,j2) = temp(1:m)
9458 end do
9459
9460 return
r8mat_uniform_01
subroutine r8mat_uniform_01(m, n, seed, r)
Definition R8LIB.f90:20634

References r8mat_uniform_01().

Here is the call graph for this function:

◆ r8col_find()

subroutine r8col_find ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  x,
integer ( kind = 4 )  col 
)

Definition at line 9462 of file R8LIB.f90.

9463
9464!*****************************************************************************80
9465!
9466!! R8COL_FIND seeks a column value in an R8COL.
9467!
9468! Discussion:
9469!
9470! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9471! each of length M.
9472!
9473! Example:
9474!
9475! Input:
9476!
9477! M = 3,
9478! N = 4,
9479!
9480! A = (
9481! 1. 2. 3. 4.
9482! 5. 6. 7. 8.
9483! 9. 10. 11. 12. )
9484!
9485! x = ( 3.,
9486! 7.,
9487! 11. )
9488!
9489! Output:
9490!
9491! COL = 3
9492!
9493! Licensing:
9494!
9495! This code is distributed under the GNU LGPL license.
9496!
9497! Modified:
9498!
9499! 05 December 2004
9500!
9501! Author:
9502!
9503! John Burkardt
9504!
9505! Parameters:
9506!
9507! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9508!
9509! Input, real ( kind = 8 ) A(M,N), a table of numbers, regarded as
9510! N columns of vectors of length M.
9511!
9512! Input, real ( kind = 8 ) X(M), a vector to be matched with a column of A.
9513!
9514! Output, integer ( kind = 4 ) COL, the index of the first column of A
9515! which exactly matches every entry of X, or -1 if no match
9516! could be found.
9517!
9518 implicit none
9519
9520 integer ( kind = 4 ) m
9521 integer ( kind = 4 ) n
9522
9523 real ( kind = 8 ) a(m,n)
9524 integer ( kind = 4 ) col
9525 integer ( kind = 4 ) i
9526 integer ( kind = 4 ) j
9527 real ( kind = 8 ) x(m)
9528
9529 col = -1
9530
9531 do j = 1, n
9532
9533 col = j
9534
9535 do i = 1, m
9536 if ( x(i) /= a(i,j) ) then
9537 col = -1
9538 exit
9539 end if
9540 end do
9541
9542 if ( col /= -1 ) then
9543 return
9544 end if
9545
9546 end do
9547
9548 return

◆ r8col_first_index()

subroutine r8col_first_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(n)  first_index 
)

Definition at line 9550 of file R8LIB.f90.

9551
9552!*****************************************************************************80
9553!
9554!! R8COL_FIRST_INDEX indexes the first occurrence of values in an R8COL.
9555!
9556! Discussion:
9557!
9558! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9559! each of length M.
9560!
9561! For element A(1:M,J) of the matrix, FIRST_INDEX(J) is the index in A of
9562! the first column whose entries are equal to A(1:M,J).
9563!
9564! Licensing:
9565!
9566! This code is distributed under the GNU LGPL license.
9567!
9568! Modified:
9569!
9570! 24 November 2008
9571!
9572! Author:
9573!
9574! John Burkardt
9575!
9576! Parameters:
9577!
9578! Input, integer ( kind = 4 ) M, N, the number of rows and columns of A.
9579! The length of an "element" of A, and the number of "elements".
9580!
9581! Input, real ( kind = 8 ) A(M,N), the array.
9582!
9583! Input, real ( kind = 8 ) TOL, a tolerance for equality.
9584!
9585! Output, integer ( kind = 4 ) FIRST_INDEX(N), the first occurrence index.
9586!
9587 implicit none
9588
9589 integer ( kind = 4 ) m
9590 integer ( kind = 4 ) n
9591
9592 real ( kind = 8 ) a(m,n)
9593 integer ( kind = 4 ) first_index(n)
9594 integer ( kind = 4 ) j1
9595 integer ( kind = 4 ) j2
9596 real ( kind = 8 ) tol
9597
9598 first_index(1:n) = -1
9599
9600 do j1 = 1, n
9601
9602 if ( first_index(j1) == -1 ) then
9603
9604 first_index(j1) = j1
9605
9606 do j2 = j1 + 1, n
9607 if ( maxval( abs( a(1:m,j1) - a(1:m,j2) ) ) <= tol ) then
9608 first_index(j2) = j1
9609 end if
9610 end do
9611
9612 end if
9613
9614 end do
9615
9616 return

◆ r8col_insert()

subroutine r8col_insert ( integer ( kind = 4 )  n_max,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n_max)  a,
real ( kind = 8 ), dimension(m)  x,
integer ( kind = 4 )  col 
)

Definition at line 9618 of file R8LIB.f90.

9619
9620!*****************************************************************************80
9621!
9622!! R8COL_INSERT inserts a column into an R8COL.
9623!
9624! Discussion:
9625!
9626! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9627! each of length M.
9628!
9629! Example:
9630!
9631! Input:
9632!
9633! N_MAX = 10,
9634! M = 3,
9635! N = 4,
9636!
9637! A = (
9638! 1. 2. 3. 4.
9639! 5. 6. 7. 8.
9640! 9. 10. 11. 12. )
9641!
9642! X = ( 3., 4., 18. )
9643!
9644! Output:
9645!
9646! N = 5,
9647!
9648! A = (
9649! 1. 2. 3. 3. 4.
9650! 5. 6. 4. 7. 8.
9651! 9. 10. 18. 11. 12. )
9652!
9653! COL = 3
9654!
9655! Licensing:
9656!
9657! This code is distributed under the GNU LGPL license.
9658!
9659! Modified:
9660!
9661! 05 December 2004
9662!
9663! Author:
9664!
9665! John Burkardt
9666!
9667! Parameters:
9668!
9669! Input, integer ( kind = 4 ) N_MAX, the maximum number of columns in A.
9670!
9671! Input, integer ( kind = 4 ) M, the number of rows.
9672!
9673! Input/output, integer ( kind = 4 ) N, the number of columns.
9674! If the new column is inserted into the table, then the output
9675! value of N will be increased by 1.
9676!
9677! Input/output, real ( kind = 8 ) A(M,N_MAX), a table of numbers, regarded
9678! as an array of columns. The columns must have been sorted
9679! lexicographically.
9680!
9681! Input, real ( kind = 8 ) X(M), a vector of data which will be inserted
9682! into the table if it does not already occur.
9683!
9684! Output, integer ( kind = 4 ) COL.
9685! I, X was inserted into column I.
9686! -I, column I was already equal to X.
9687! 0, N = N_MAX.
9688!
9689 implicit none
9690
9691 integer ( kind = 4 ) m
9692 integer ( kind = 4 ) n_max
9693
9694 real ( kind = 8 ) a(m,n_max)
9695 integer ( kind = 4 ) col
9696 integer ( kind = 4 ) high
9697 integer ( kind = 4 ) isgn
9698 integer ( kind = 4 ) j
9699 integer ( kind = 4 ) low
9700 integer ( kind = 4 ) mid
9701 integer ( kind = 4 ) n
9702 real ( kind = 8 ) x(m)
9703!
9704! Refuse to work if N_MAX <= N.
9705!
9706 if ( n_max <= n ) then
9707 col = 0
9708 return
9709 end if
9710!
9711! Stick X temporarily in column N+1, just so it's easy to use R8COL_COMPARE.
9712!
9713 a(1:m,n+1) = x(1:m)
9714!
9715! Do a binary search.
9716!
9717 low = 1
9718 high = n
9719
9720 do
9721
9722 if ( high < low ) then
9723 col = low
9724 exit
9725 end if
9726
9727 mid = ( low + high ) / 2
9728
9729 call r8col_compare ( m, n + 1, a, mid, n + 1, isgn )
9730
9731 if ( isgn == 0 ) then
9732 col = -mid
9733 return
9734 else if ( isgn == -1 ) then
9735 low = mid + 1
9736 else if ( isgn == +1 ) then
9737 high = mid - 1
9738 end if
9739
9740 end do
9741!
9742! Shift part of the table up to make room.
9743!
9744 do j = n, col, -1
9745 a(1:m,j+1) = a(1:m,j)
9746 end do
9747!
9748! Insert the new column.
9749!
9750 a(1:m,col) = x(1:m)
9751
9752 n = n + 1
9753
9754 return
r8col_compare
subroutine r8col_compare(m, n, a, i, j, value)
Definition R8LIB.f90:9278

References r8col_compare().

Here is the call graph for this function:

◆ r8col_max()

subroutine r8col_max ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  amax 
)

Definition at line 9756 of file R8LIB.f90.

9757
9758!*****************************************************************************80
9759!
9760!! R8COL_MAX returns the maximums in an R8COL.
9761!
9762! Discussion:
9763!
9764! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9765! each of length M.
9766!
9767! Licensing:
9768!
9769! This code is distributed under the GNU LGPL license.
9770!
9771! Modified:
9772!
9773! 15 September 2005
9774!
9775! Author:
9776!
9777! John Burkardt
9778!
9779! Parameters:
9780!
9781! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9782!
9783! Input, real ( kind = 8 ) A(M,N), the array to be examined.
9784!
9785! Output, real ( kind = 8 ) AMAX(N), the maximums of the columns.
9786!
9787 implicit none
9788
9789 integer ( kind = 4 ) m
9790 integer ( kind = 4 ) n
9791
9792 real ( kind = 8 ) a(m,n)
9793 real ( kind = 8 ) amax(n)
9794 integer ( kind = 4 ) j
9795
9796 do j = 1, n
9797
9798 amax(j) = maxval( a(1:m,j) )
9799
9800 end do
9801
9802 return

◆ r8col_max_index()

subroutine r8col_max_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 ), dimension(n)  imax 
)

Definition at line 9804 of file R8LIB.f90.

9805
9806!*****************************************************************************80
9807!
9808!! R8COL_MAX_INDEX returns the indices of column maximums in an R8COL.
9809!
9810! Discussion:
9811!
9812! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9813! each of length M.
9814!
9815! Licensing:
9816!
9817! This code is distributed under the GNU LGPL license.
9818!
9819! Modified:
9820!
9821! 15 September 2005
9822!
9823! Author:
9824!
9825! John Burkardt
9826!
9827! Parameters:
9828!
9829! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9830!
9831! Input, real ( kind = 8 ) A(M,N), the array to be examined.
9832!
9833! Output, integer ( kind = 4 ) IMAX(N); IMAX(I) is the row of A in which
9834! the maximum for column I occurs.
9835!
9836 implicit none
9837
9838 integer ( kind = 4 ) m
9839 integer ( kind = 4 ) n
9840
9841 real ( kind = 8 ) a(m,n)
9842 real ( kind = 8 ) amax
9843 integer ( kind = 4 ) i
9844 integer ( kind = 4 ) imax(n)
9845 integer ( kind = 4 ) j
9846
9847 do j = 1, n
9848
9849 imax(j) = 1
9850 amax = a(1,j)
9851 do i = 2, m
9852 if ( amax < a(i,j) ) then
9853 imax(j) = i
9854 amax = a(i,j)
9855 end if
9856 end do
9857
9858 end do
9859
9860 return

◆ r8col_max_one()

subroutine r8col_max_one ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 9862 of file R8LIB.f90.

9863
9864!*****************************************************************************80
9865!
9866!! R8COL_MAX_ONE rescales an R8COL so each column maximum is 1.
9867!
9868! Discussion:
9869!
9870! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9871! each of length M.
9872!
9873! Licensing:
9874!
9875! This code is distributed under the GNU LGPL license.
9876!
9877! Modified:
9878!
9879! 08 May 2010
9880!
9881! Author:
9882!
9883! John Burkardt
9884!
9885! Parameters:
9886!
9887! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9888!
9889! Input/output, real ( kind = 8 ) A(M,N), the array to be rescaled.
9890!
9891 implicit none
9892
9893 integer ( kind = 4 ) m
9894 integer ( kind = 4 ) n
9895
9896 real ( kind = 8 ) a(m,n)
9897 integer ( kind = 4 ) i
9898 integer ( kind = 4 ) i_big
9899 integer ( kind = 4 ) j
9900
9901 do j = 1, n
9902
9903 i_big = 1
9904 do i = 2, m
9905 if ( abs( a(i_big,j) ) < abs( a(i,j) ) ) then
9906 i_big = i
9907 end if
9908 end do
9909
9910 if ( a(i_big,j) /= 0.0d+00 ) then
9911 a(1:m,j) = a(1:m,j) / a(i_big,j)
9912 end if
9913
9914 end do
9915
9916 return

◆ r8col_mean()

subroutine r8col_mean ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  mean 
)

Definition at line 9918 of file R8LIB.f90.

9919
9920!*****************************************************************************80
9921!
9922!! R8COL_MEAN returns the column means of an R8COL.
9923!
9924! Discussion:
9925!
9926! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9927! each of length M.
9928!
9929! Example:
9930!
9931! A =
9932! 1 2 3
9933! 2 6 7
9934!
9935! MEAN =
9936! 1.5 4.0 5.0
9937!
9938! Licensing:
9939!
9940! This code is distributed under the GNU LGPL license.
9941!
9942! Modified:
9943!
9944! 05 December 2004
9945!
9946! Author:
9947!
9948! John Burkardt
9949!
9950! Parameters:
9951!
9952! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
9953!
9954! Input, real ( kind = 8 ) A(M,N), the array to be examined.
9955!
9956! Output, real ( kind = 8 ) MEAN(N), the means, or averages, of the columns.
9957!
9958 implicit none
9959
9960 integer ( kind = 4 ) m
9961 integer ( kind = 4 ) n
9962
9963 real ( kind = 8 ) a(m,n)
9964 integer ( kind = 4 ) j
9965 real ( kind = 8 ) mean(n)
9966
9967 do j = 1, n
9968 mean(j) = sum( a(1:m,j) )
9969 end do
9970
9971 mean(1:n) = mean(1:n) / real( m, kind = 8 )
9972
9973 return

◆ r8col_min()

subroutine r8col_min ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  amin 
)

Definition at line 9975 of file R8LIB.f90.

9976
9977!*****************************************************************************80
9978!
9979!! R8COL_MIN returns the column minimums of an R8COL.
9980!
9981! Discussion:
9982!
9983! An R8COL is an M by N array of R8's, regarded as an array of N columns,
9984! each of length M.
9985!
9986! Licensing:
9987!
9988! This code is distributed under the GNU LGPL license.
9989!
9990! Modified:
9991!
9992! 05 December 2004
9993!
9994! Author:
9995!
9996! John Burkardt
9997!
9998! Parameters:
9999!
10000! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
10001!
10002! Input, real ( kind = 8 ) A(M,N), the array to be examined.
10003!
10004! Output, real ( kind = 8 ) AMIN(N), the minimums of the columns.
10005!
10006 implicit none
10007
10008 integer ( kind = 4 ) m
10009 integer ( kind = 4 ) n
10010
10011 real ( kind = 8 ) a(m,n)
10012 real ( kind = 8 ) amin(n)
10013 integer ( kind = 4 ) j
10014
10015 do j = 1, n
10016
10017 amin(j) = minval( a(1:m,j) )
10018
10019 end do
10020
10021 return

◆ r8col_min_index()

subroutine r8col_min_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 ), dimension(n)  imin 
)

Definition at line 10023 of file R8LIB.f90.

10024
10025!*****************************************************************************80
10026!
10027!! R8COL_MIN_INDEX returns the indices of column minimums in an R8COL.
10028!
10029! Discussion:
10030!
10031! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10032! each of length M.
10033!
10034! Licensing:
10035!
10036! This code is distributed under the GNU LGPL license.
10037!
10038! Modified:
10039!
10040! 15 September 2005
10041!
10042! Author:
10043!
10044! John Burkardt
10045!
10046! Parameters:
10047!
10048! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
10049!
10050! Input, real ( kind = 8 ) A(M,N), the array to be examined.
10051!
10052! Output, integer ( kind = 4 ) IMIN(N); IMIN(I) is the row of A in which
10053! the minimum for column I occurs.
10054!
10055 implicit none
10056
10057 integer ( kind = 4 ) m
10058 integer ( kind = 4 ) n
10059
10060 real ( kind = 8 ) a(m,n)
10061 real ( kind = 8 ) amin
10062 integer ( kind = 4 ) i
10063 integer ( kind = 4 ) imin(n)
10064 integer ( kind = 4 ) j
10065
10066 do j = 1, n
10067
10068 imin(j) = 1
10069 amin = a(1,j)
10070 do i = 2, m
10071 if ( a(i,j) < amin ) then
10072 imin(j) = i
10073 amin = a(i,j)
10074 end if
10075 end do
10076
10077 end do
10078
10079 return

◆ r8col_normalize_li()

subroutine r8col_normalize_li ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 10081 of file R8LIB.f90.

10082
10083!*****************************************************************************80
10084!
10085!! R8COL_NORMALIZE_LI normalizes an R8COL with the column infinity norm.
10086!
10087! Discussion:
10088!
10089! Each column is scaled so that the entry of maximum norm has the value 1.
10090!
10091! Licensing:
10092!
10093! This code is distributed under the GNU LGPL license.
10094!
10095! Modified:
10096!
10097! 08 February 2012
10098!
10099! Author:
10100!
10101! John Burkardt
10102!
10103! Parameters:
10104!
10105! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
10106!
10107! Input/output, real ( kind = 8 ) A(M,N), the array to be normalized.
10108!
10109 implicit none
10110
10111 integer ( kind = 4 ) m
10112 integer ( kind = 4 ) n
10113
10114 real ( kind = 8 ) a(m,n)
10115 real ( kind = 8 ) c
10116 integer ( kind = 4 ) i
10117 integer ( kind = 4 ) j
10118
10119 do j = 1, n
10120
10121 c = a(1,j)
10122
10123 do i = 2, m
10124 if ( abs( c ) < abs( a(i,j) ) ) then
10125 c = a(i,j)
10126 end if
10127 end do
10128
10129 if ( c /= 0.0d+00 ) then
10130 a(1:m,j) = a(1:m,j) / c
10131 end if
10132
10133 end do
10134
10135 return

◆ r8col_part_quick_a()

subroutine r8col_part_quick_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  l,
integer ( kind = 4 )  r 
)

Definition at line 10137 of file R8LIB.f90.

10138
10139!*****************************************************************************80
10140!
10141!! R8COL_PART_QUICK_A reorders the columns of an R8COL.
10142!
10143! Discussion:
10144!
10145! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10146! each of length M.
10147!
10148! The routine reorders the columns of A. Using A(1:M,1) as a
10149! key, all entries of A that are less than or equal to the key will
10150! precede the key, which precedes all entries that are greater than the key.
10151!
10152! Example:
10153!
10154! Input:
10155!
10156! M = 2, N = 8
10157! A = ( 2 8 6 0 10 10 0 5
10158! 4 8 2 2 6 0 6 8 )
10159!
10160! Output:
10161!
10162! L = 2, R = 4
10163!
10164! A = ( 0 0 2 8 6 10 10 5
10165! 2 6 4 8 2 6 0 8 )
10166! ---- -------------
10167! LEFT KEY RIGHT
10168!
10169! Licensing:
10170!
10171! This code is distributed under the GNU LGPL license.
10172!
10173! Modified:
10174!
10175! 05 December 2004
10176!
10177! Author:
10178!
10179! John Burkardt
10180!
10181! Parameters:
10182!
10183! Input, integer ( kind = 4 ) M, the row dimension of A, and the length of
10184! a column.
10185!
10186! Input, integer ( kind = 4 ) N, the column dimension of A.
10187!
10188! Input/output, real ( kind = 8 ) A(M,N). On input, the array to be checked.
10189! On output, A has been reordered as described above.
10190!
10191! Output, integer ( kind = 4 ) L, R, the indices of A that define the three
10192! segments. Let KEY = the input value of A(1:M,1). Then
10193! I <= L A(1:M,I) < KEY;
10194! L < I < R A(1:M,I) = KEY;
10195! R <= I KEY < A(1:M,I).
10196!
10197 implicit none
10198
10199 integer ( kind = 4 ) m
10200 integer ( kind = 4 ) n
10201
10202 real ( kind = 8 ) a(m,n)
10203 integer ( kind = 4 ) j
10204 integer ( kind = 4 ) k
10205 real ( kind = 8 ) key(m)
10206 integer ( kind = 4 ) l
10207 integer ( kind = 4 ) r
10208 logical ( kind = 4 ) r8vec_eq
10209 logical ( kind = 4 ) r8vec_gt
10210 logical ( kind = 4 ) r8vec_lt
10211
10212 if ( n < 1 ) then
10213 write ( *, '(a)' ) ' '
10214 write ( *, '(a)' ) 'R8COL_PART_QUICK_A - Fatal error!'
10215 write ( *, '(a)' ) ' N < 1.'
10216 return
10217 end if
10218
10219 if ( n == 1 ) then
10220 l = 0
10221 r = 2
10222 return
10223 end if
10224
10225 key(1:m) = a(1:m,1)
10226 k = 1
10227!
10228! The elements of unknown size have indices between L+1 and R-1.
10229!
10230 l = 1
10231 r = n + 1
10232
10233 do j = 2, n
10234
10235 if ( r8vec_gt( m, a(1:m,l+1), key(1:m) ) ) then
10236 r = r - 1
10237 call r8vec_swap ( m, a(1:m,r), a(1:m,l+1) )
10238 else if ( r8vec_eq( m, a(1:m,l+1), key(1:m) ) ) then
10239 k = k + 1
10240 call r8vec_swap ( m, a(1:m,k), a(1:m,l+1) )
10241 l = l + 1
10242 else if ( r8vec_lt( m, a(1:m,l+1), key(1:m) ) ) then
10243 l = l + 1
10244 end if
10245
10246 end do
10247!
10248! Shift small elements to the left.
10249!
10250 do j = 1, l - k
10251 a(1:m,j) = a(1:m,j+k)
10252 end do
10253!
10254! Shift KEY elements to center.
10255!
10256 do j = l - k + 1, l
10257 a(1:m,j) = key(1:m)
10258 end do
10259!
10260! Update L.
10261!
10262 l = l - k
10263
10264 return

References r8vec_swap().

Referenced by r8col_sort_quick_a().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8col_permute()

subroutine r8col_permute ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 10266 of file R8LIB.f90.

10267
10268!*****************************************************************************80
10269!
10270!! R8COL_PERMUTE permutes an R8COL in place.
10271!
10272! Discussion:
10273!
10274! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10275! each of length M.
10276!
10277! The same logic can be used to permute an array of objects of any
10278! arithmetic type, or an array of objects of any complexity. The only
10279! temporary storage required is enough to store a single object. The number
10280! of data movements made is N + the number of cycles of order 2 or more,
10281! which is never more than N + N/2.
10282!
10283! Example:
10284!
10285! Input:
10286!
10287! M = 2
10288! N = 5
10289! P = ( 2, 4, 5, 1, 3 )
10290! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
10291! (11.0, 22.0, 33.0, 44.0, 55.0 )
10292!
10293! Output:
10294!
10295! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 )
10296! ( 22.0, 44.0, 55.0, 11.0, 33.0 ).
10297!
10298! Licensing:
10299!
10300! This code is distributed under the GNU LGPL license.
10301!
10302! Modified:
10303!
10304! 09 December 2006
10305!
10306! Author:
10307!
10308! John Burkardt
10309!
10310! Parameters:
10311!
10312! Input, integer ( kind = 4 ) M, the dimension of objects.
10313!
10314! Input, integer ( kind = 4 ) N, the number of objects.
10315!
10316! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means
10317! that the I-th element of the output array should be the J-th
10318! element of the input array.
10319!
10320! Input/output, real ( kind = 8 ) A(M,N), the array to be permuted.
10321!
10322 implicit none
10323
10324 integer ( kind = 4 ) m
10325 integer ( kind = 4 ) n
10326
10327 real ( kind = 8 ) a(m,n)
10328 real ( kind = 8 ) a_temp(m)
10329 integer ( kind = 4 ) ierror
10330 integer ( kind = 4 ) iget
10331 integer ( kind = 4 ) iput
10332 integer ( kind = 4 ) istart
10333 integer ( kind = 4 ) p(n)
10334
10335 call perm_check1 ( n, p )
10336!
10337! Search for the next element of the permutation that has not been used.
10338!
10339 do istart = 1, n
10340
10341 if ( p(istart) < 0 ) then
10342
10343 cycle
10344
10345 else if ( p(istart) == istart ) then
10346
10347 p(istart) = - p(istart)
10348 cycle
10349
10350 else
10351
10352 a_temp(1:m) = a(1:m,istart)
10353 iget = istart
10354!
10355! Copy the new value into the vacated entry.
10356!
10357 do
10358
10359 iput = iget
10360 iget = p(iget)
10361
10362 p(iput) = - p(iput)
10363
10364 if ( iget < 1 .or. n < iget ) then
10365 write ( *, '(a)' ) ' '
10366 write ( *, '(a)' ) 'R8COL_PERMUTE - Fatal error!'
10367 write ( *, '(a)' ) ' A permutation index is out of range.'
10368 write ( *, '(a,i8,a,i8)' ) ' P(', iput, ') = ', iget
10369 stop 1
10370 end if
10371
10372 if ( iget == istart ) then
10373 a(1:m,iput) = a_temp(1:m)
10374 exit
10375 end if
10376
10377 a(1:m,iput) = a(1:m,iget)
10378
10379 end do
10380
10381 end if
10382
10383 end do
10384!
10385! Restore the signs of the entries.
10386!
10387 p(1:n) = - p(1:n)
10388
10389 return

References perm_check1().

Here is the call graph for this function:

◆ r8col_reverse()

subroutine r8col_reverse ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 10391 of file R8LIB.f90.

10392
10393!*****************************************************************************80
10394!
10395!! R8COL_REVERSE reverses the order of columns in an R8COL.
10396!
10397! Discussion:
10398!
10399! To reverse the columns is to start with something like
10400!
10401! 11 12 13 14 15
10402! 21 22 23 24 25
10403! 31 32 33 34 35
10404! 41 42 43 44 45
10405! 51 52 53 54 55
10406!
10407! and return
10408!
10409! 15 14 13 12 11
10410! 25 24 23 22 21
10411! 35 34 33 32 31
10412! 45 44 43 42 41
10413! 55 54 53 52 51
10414!
10415! Licensing:
10416!
10417! This code is distributed under the GNU LGPL license.
10418!
10419! Modified:
10420!
10421! 06 May 2013
10422!
10423! Author:
10424!
10425! John Burkardt
10426!
10427! Parameters:
10428!
10429! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
10430!
10431! Input/output, real ( kind = 8 ) A(M,N), the matrix.
10432!
10433 implicit none
10434
10435 integer ( kind = 4 ) m
10436 integer ( kind = 4 ) n
10437
10438 real ( kind = 8 ) a(m,n)
10439 integer ( kind = 4 ) j
10440 integer ( kind = 4 ) jhi
10441 real ( kind = 8 ) t(m)
10442
10443 jhi = n / 2
10444
10445 do j = 1, jhi
10446 t(1:m) = a(1:m,j)
10447 a(1:m,j) = a(1:m,n+1-j)
10448 a(1:m,n+1-j) = t(1:m)
10449 end do
10450
10451 return

◆ r8col_separation()

subroutine r8col_separation ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  d_min,
real ( kind = 8 )  d_max 
)

Definition at line 10453 of file R8LIB.f90.

10454
10455!*****************************************************************************80
10456!
10457!! R8COL_SEPARATION returns the "separation" of an R8COL.
10458!
10459! Discussion:
10460!
10461! D_MIN is the minimum distance between two columns,
10462! D_MAX is the maximum distance between two columns.
10463!
10464! The distances are measured using the Loo norm.
10465!
10466! Licensing:
10467!
10468! This code is distributed under the GNU LGPL license.
10469!
10470! Modified:
10471!
10472! 24 February 2014
10473!
10474! Author:
10475!
10476! John Burkardt
10477!
10478! Parameters:
10479!
10480! Input, integer ( kind = 4 ) M, N, the number of rows and columns
10481! in the array. If N < 2, it does not make sense to call this routine.
10482!
10483! Input, real ( kind = 8 ) A(M,N), the array whose variances are desired.
10484!
10485! Output, real ( kind = 8 ) D_MIN, D_MAX, the minimum and maximum distances.
10486!
10487 implicit none
10488
10489 integer ( kind = 4 ) m
10490 integer ( kind = 4 ) n
10491
10492 real ( kind = 8 ) a(m,n)
10493 real ( kind = 8 ) d
10494 real ( kind = 8 ) d_max
10495 real ( kind = 8 ) d_min
10496 integer ( kind = 4 ) j1
10497 integer ( kind = 4 ) j2
10498
10499 d_min = huge( d_min )
10500 d_max = 0.0d+00
10501
10502 do j1 = 1, n
10503 do j2 = j1 + 1, n
10504 d = maxval( abs( a(1:m,j1) - a(1:m,j2) ) )
10505 d_min = min( d_min, d )
10506 d_max = max( d_max, d )
10507 end do
10508 end do
10509
10510 return

◆ r8col_sort_heap_a()

subroutine r8col_sort_heap_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 10512 of file R8LIB.f90.

10513
10514!*****************************************************************************80
10515!
10516!! R8COL_SORT_HEAP_A ascending heapsorts an R8COL.
10517!
10518! Discussion:
10519!
10520! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10521! each of length M.
10522!
10523! In lexicographic order, the statement "X < Y", applied to two real
10524! vectors X and Y of length M, means that there is some index I, with
10525! 1 <= I <= M, with the property that
10526!
10527! X(J) = Y(J) for J < I,
10528! and
10529! X(I) < Y(I).
10530!
10531! In other words, the first time they differ, X is smaller.
10532!
10533! Licensing:
10534!
10535! This code is distributed under the GNU LGPL license.
10536!
10537! Modified:
10538!
10539! 05 December 2004
10540!
10541! Author:
10542!
10543! John Burkardt
10544!
10545! Parameters:
10546!
10547! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
10548!
10549! Input/output, real ( kind = 8 ) A(M,N).
10550! On input, the array of N columns of M-vectors.
10551! On output, the columns of A have been sorted in lexicographic order.
10552!
10553 implicit none
10554
10555 integer ( kind = 4 ) m
10556 integer ( kind = 4 ) n
10557
10558 real ( kind = 8 ) a(m,n)
10559 integer ( kind = 4 ) i
10560 integer ( kind = 4 ) indx
10561 integer ( kind = 4 ) isgn
10562 integer ( kind = 4 ) j1
10563 integer ( kind = 4 ) j2
10564 real ( kind = 8 ) t(m)
10565
10566 if ( m <= 0 ) then
10567 return
10568 end if
10569
10570 if ( n <= 1 ) then
10571 return
10572 end if
10573!
10574! Initialize.
10575!
10576 indx = 0
10577 isgn = 0
10578 j1 = 0
10579 j2 = 0
10580!
10581! Call the external heap sorter.
10582!
10583 do
10584
10585 call sort_heap_external ( n, indx, j1, j2, isgn )
10586!
10587! Interchange columns J1 and J2.
10588!
10589 if ( 0 < indx ) then
10590
10591 t(1:m) = a(1:m,j1)
10592 a(1:m,j1) = a(1:m,j2)
10593 a(1:m,j2) = t(1:m)
10594!
10595! Compare columns J1 and J2.
10596!
10597 else if ( indx < 0 ) then
10598
10599 isgn = 0
10600
10601 do i = 1, m
10602
10603 if ( a(i,j1) < a(i,j2) ) then
10604 isgn = -1
10605 exit
10606 else if ( a(i,j2) < a(i,j1) ) then
10607 isgn = +1
10608 exit
10609 end if
10610
10611 end do
10612!
10613! The columns are sorted.
10614!
10615 else if ( indx == 0 ) then
10616
10617 exit
10618
10619 end if
10620
10621 end do
10622
10623 return
sort_heap_external
subroutine sort_heap_external(n, indx, i, j, isgn)
Definition R8LIB.f90:39686

References sort_heap_external().

Here is the call graph for this function:

◆ r8col_sort_heap_index_a()

subroutine r8col_sort_heap_index_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 10625 of file R8LIB.f90.

10626
10627!*****************************************************************************80
10628!
10629!! R8COL_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8COL.
10630!
10631! Discussion:
10632!
10633! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10634! each of length M.
10635!
10636! The sorting is not actually carried out. Rather an index array is
10637! created which defines the sorting. This array may be used to sort
10638! or index the array, or to sort or index related arrays keyed on the
10639! original array.
10640!
10641! A(*,J1) < A(*,J2) if the first nonzero entry of A(*,J1)-A(*,J2)
10642! is negative.
10643!
10644! Once the index array is computed, the sorting can be carried out
10645! "implicitly:
10646!
10647! A(*,INDX(*)) is sorted,
10648!
10649! Licensing:
10650!
10651! This code is distributed under the GNU LGPL license.
10652!
10653! Modified:
10654!
10655! 27 October 2008
10656!
10657! Author:
10658!
10659! John Burkardt
10660!
10661! Parameters:
10662!
10663! Input, integer ( kind = 4 ) M, the number of rows in each column of A.
10664!
10665! Input, integer ( kind = 4 ) N, the number of columns in A.
10666!
10667! Input, real ( kind = 8 ) A(M,N), the array.
10668!
10669! Output, integer ( kind = 4 ) INDX(N), the sort index. The I-th element
10670! of the sorted array is column INDX(I).
10671!
10672 implicit none
10673
10674 integer ( kind = 4 ) m
10675 integer ( kind = 4 ) n
10676
10677 real ( kind = 8 ) a(m,n)
10678 real ( kind = 8 ) column(m)
10679 integer ( kind = 4 ) i
10680 integer ( kind = 4 ) indx(n)
10681 integer ( kind = 4 ) indxt
10682 integer ( kind = 4 ) ir
10683 integer ( kind = 4 ) isgn
10684 integer ( kind = 4 ) j
10685 integer ( kind = 4 ) l
10686
10687 if ( n < 1 ) then
10688 return
10689 end if
10690
10691 do i = 1, n
10692 indx(i) = i
10693 end do
10694
10695 if ( n == 1 ) then
10696 return
10697 end if
10698
10699 l = ( n / 2 ) + 1
10700 ir = n
10701
10702 do
10703
10704 if ( 1 < l ) then
10705
10706 l = l - 1
10707 indxt = indx(l)
10708 column(1:m) = a(1:m,indxt)
10709
10710 else
10711
10712 indxt = indx(ir)
10713 column(1:m) = a(1:m,indxt)
10714 indx(ir) = indx(1)
10715 ir = ir - 1
10716
10717 if ( ir == 1 ) then
10718 indx(1) = indxt
10719 exit
10720 end if
10721
10722 end if
10723
10724 i = l
10725 j = l + l
10726
10727 do while ( j <= ir )
10728
10729 if ( j < ir ) then
10730
10731 call r8vec_compare ( m, a(1:m,indx(j)), a(1:m,indx(j+1)), isgn )
10732
10733 if ( isgn < 0 ) then
10734 j = j + 1
10735 end if
10736
10737 end if
10738
10739 call r8vec_compare ( m, column, a(1:m,indx(j)), isgn )
10740
10741 if ( isgn < 0 ) then
10742 indx(i) = indx(j)
10743 i = j
10744 j = j + j
10745 else
10746 j = ir + 1
10747 end if
10748
10749 end do
10750
10751 indx(i) = indxt
10752
10753 end do
10754
10755 return
r8vec_compare
subroutine r8vec_compare(n, a1, a2, isgn)
Definition R8LIB.f90:27252

References r8vec_compare().

Referenced by r8col_tol_undex(), r8col_tol_unique_count(), and r8col_undex().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8col_sort_quick_a()

subroutine r8col_sort_quick_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 10757 of file R8LIB.f90.

10758
10759!*****************************************************************************80
10760!
10761!! R8COL_SORT_QUICK_A ascending quick sorts an R8COL.
10762!
10763! Discussion:
10764!
10765! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10766! each of length M.
10767!
10768! Licensing:
10769!
10770! This code is distributed under the GNU LGPL license.
10771!
10772! Modified:
10773!
10774! 21 May 2012
10775!
10776! Author:
10777!
10778! John Burkardt
10779!
10780! Parameters:
10781!
10782! Input, integer ( kind = 4 ) M, the row order of A, and the length of
10783! a column.
10784!
10785! Input, integer ( kind = 4 ) N, the number of columns of A.
10786!
10787! Input/output, real ( kind = 8 ) A(M,N).
10788! On input, the array to be sorted.
10789! On output, the array has been sorted.
10790!
10791 implicit none
10792
10793 integer ( kind = 4 ), parameter :: level_max = 30
10794 integer ( kind = 4 ) m
10795 integer ( kind = 4 ) n
10796
10797 real ( kind = 8 ) a(m,n)
10798 integer ( kind = 4 ) base
10799 integer ( kind = 4 ) l_segment
10800 integer ( kind = 4 ) level
10801 integer ( kind = 4 ) n_segment
10802 integer ( kind = 4 ) rsave(level_max)
10803 integer ( kind = 4 ) r_segment
10804
10805 if ( m <= 0 ) then
10806 return
10807 end if
10808
10809 if ( n < 1 ) then
10810 write ( *, '(a)' ) ' '
10811 write ( *, '(a)' ) 'R8COL_SORT_QUICK_A - Fatal error!'
10812 write ( *, '(a)' ) ' N < 1.'
10813 write ( *, '(a,i8)' ) ' N = ', n
10814 stop 1
10815 end if
10816
10817 if ( n == 1 ) then
10818 return
10819 end if
10820
10821 level = 1
10822 rsave(level) = n + 1
10823 base = 1
10824 n_segment = n
10825
10826 do
10827!
10828! Partition the segment.
10829!
10830 call r8col_part_quick_a ( m, n_segment, a(1:m,base:base+n_segment-1), &
10831 l_segment, r_segment )
10832!
10833! If the left segment has more than one element, we need to partition it.
10834!
10835 if ( 1 < l_segment ) then
10836
10837 if ( level_max < level ) then
10838 write ( *, '(a)' ) ' '
10839 write ( *, '(a)' ) 'R8COL_SORT_QUICK_A - Fatal error!'
10840 write ( *, '(a,i8)' ) ' Exceeding recursion maximum of ', level_max
10841 stop 1
10842 end if
10843
10844 level = level + 1
10845 n_segment = l_segment
10846 rsave(level) = r_segment + base - 1
10847!
10848! The left segment and the middle segment are sorted.
10849! Must the right segment be partitioned?
10850!
10851 else if ( r_segment < n_segment ) then
10852
10853 n_segment = n_segment + 1 - r_segment
10854 base = base + r_segment - 1
10855!
10856! Otherwise, we back up a level if there is an earlier one.
10857!
10858 else
10859
10860 do
10861
10862 if ( level <= 1 ) then
10863 return
10864 end if
10865
10866 base = rsave(level)
10867 n_segment = rsave(level-1) - rsave(level)
10868 level = level - 1
10869
10870 if ( 0 < n_segment ) then
10871 exit
10872 end if
10873
10874 end do
10875
10876 end if
10877
10878 end do
10879
10880 return
r8col_part_quick_a
subroutine r8col_part_quick_a(m, n, a, l, r)
Definition R8LIB.f90:10138

References r8col_part_quick_a().

Here is the call graph for this function:

◆ r8col_sorted_tol_undex()

subroutine r8col_sorted_tol_undex ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(unique_num)  undx,
integer ( kind = 4 ), dimension(n)  xdnu 
)

Definition at line 10882 of file R8LIB.f90.

10883
10884!*****************************************************************************80
10885!
10886!! R8COL_SORTED_TOL_UNDEX indexes tolerably unique entries in a sorted R8COL.
10887!
10888! Discussion:
10889!
10890! An R8COL is an M by N array of R8's, regarded as an array of N columns,
10891! each of length M.
10892!
10893! The goal of this routine is to determine a vector UNDX,
10894! which points, to the tolerably unique elements of A, in sorted order,
10895! and a vector XDNU, which identifies, for each entry of A, the index of
10896! the unique sorted element of A.
10897!
10898! This is all done with index vectors, so that the elements of
10899! A are never moved.
10900!
10901! Assuming A is already sorted, we examine the entries of A in order,
10902! noting the unique entries, creating the entries of XDNU and
10903! UNDX as we go.
10904!
10905! Once this process has been completed, the vector A could be
10906! replaced by a compressed vector XU, containing the unique entries
10907! of A in sorted order, using the formula
10908!
10909! XU(*) = A(UNDX(*)).
10910!
10911! We could then, if we wished, reconstruct the entire vector A, or
10912! any element of it, by index, as follows:
10913!
10914! A(I) = XU(XDNU(I)).
10915!
10916! We could then replace A by the combination of XU and XDNU.
10917!
10918! Later, when we need the I-th entry of A, we can locate it as
10919! the XDNU(I)-th entry of XU.
10920!
10921! Here is an example of a vector A, the unique sort and
10922! inverse unique sort vectors and the compressed unique sorted vector.
10923!
10924! I A XU Undx Xdnu
10925! ----+------+------+-----+-----+
10926! 1 | 11.0 | 11.0 1 1
10927! 2 | 11.0 | 22.0 5 1
10928! 3 | 11.0 | 33.0 8 1
10929! 4 | 11.0 | 55.0 9 1
10930! 5 | 22.0 | 2
10931! 6 | 22.0 | 2
10932! 7 | 22.0 | 2
10933! 8 | 33.0 | 3
10934! 9 | 55.0 | 4
10935!
10936! Licensing:
10937!
10938! This code is distributed under the GNU LGPL license.
10939!
10940! Modified:
10941!
10942! 17 July 2010
10943!
10944! Author:
10945!
10946! John Burkardt
10947!
10948! Parameters:
10949!
10950! Input, integer ( kind = 4 ) M, the dimension of the data values.
10951!
10952! Input, integer ( kind = 4 ) N, the number of data values.
10953!
10954! Input, real ( kind = 8 ) A(M,N), the data values.
10955!
10956! Input, integer ( kind = 4 ) UNIQUE_NUM, the number of unique values
10957! in A. This value is only required for languages in which the size of
10958! UNDX must be known in advance.
10959!
10960! Input, real ( kind = 8 ) TOL, a tolerance for equality.
10961!
10962! Output, integer ( kind = 4 ) UNDX(UNIQUE_NUM), the UNDX vector.
10963!
10964! Output, integer ( kind = 4 ) XDNU(N), the XDNU vector.
10965!
10966 implicit none
10967
10968 integer ( kind = 4 ) m
10969 integer ( kind = 4 ) n
10970 integer ( kind = 4 ) unique_num
10971
10972 real ( kind = 8 ) a(m,n)
10973 real ( kind = 8 ) diff
10974 integer ( kind = 4 ) i
10975 integer ( kind = 4 ) i2
10976 integer ( kind = 4 ) j
10977 integer ( kind = 4 ) k
10978 real ( kind = 8 ) tol
10979 integer ( kind = 4 ) undx(unique_num)
10980 logical ( kind = 4 ) unique
10981 integer ( kind = 4 ) xdnu(n)
10982!
10983! Consider entry I = 1.
10984! It is unique, so set the number of unique items to K.
10985! Set the K-th unique item to I.
10986! Set the representative of item I to the K-th unique item.
10987!
10988 i = 1
10989 k = 1
10990 undx(k) = i
10991 xdnu(i) = k
10992!
10993! Consider entry I.
10994!
10995! If it is unique, increase the unique count K, set the
10996! K-th unique item to I, and set the representative of I to K.
10997!
10998! If it is not unique, set the representative of item I to a
10999! previously determined unique item that is close to it.
11000!
11001 do i = 2, n
11002
11003 unique = .true.
11004
11005 do j = 1, k
11006 i2 = undx(j)
11007 diff = maxval( abs( a(1:m,i) - a(1:m,i2) ) )
11008 if ( diff <= tol ) then
11009 unique = .false.
11010 xdnu(i) = j
11011 exit
11012 end if
11013 end do
11014
11015 if ( unique ) then
11016 k = k + 1
11017 undx(k) = i
11018 xdnu(i) = k
11019 end if
11020
11021 end do
11022
11023 return

◆ r8col_sorted_tol_unique()

subroutine r8col_sorted_tol_unique ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 11025 of file R8LIB.f90.

11026
11027!*****************************************************************************80
11028!
11029!! R8COL_SORTED_TOL_UNIQUE keeps tolerably unique elements in a sorted R8COL.
11030!
11031! Discussion:
11032!
11033! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11034! each of length M.
11035!
11036! The columns of the array may be ascending or descending sorted.
11037!
11038! Licensing:
11039!
11040! This code is distributed under the GNU LGPL license.
11041!
11042! Modified:
11043!
11044! 16 July 2010
11045!
11046! Author:
11047!
11048! John Burkardt
11049!
11050! Parameters:
11051!
11052! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11053!
11054! Input/output, real ( kind = 8 ) A(M,N).
11055! On input, the sorted array of N columns of M-vectors.
11056! On output, a sorted array of columns of M-vectors.
11057!
11058! Input, real ( kind = 8 ) TOL, a tolerance for equality.
11059!
11060! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
11061!
11062 implicit none
11063
11064 integer ( kind = 4 ) m
11065 integer ( kind = 4 ) n
11066
11067 real ( kind = 8 ) a(m,n)
11068 real ( kind = 8 ) diff
11069 integer ( kind = 4 ) i
11070 integer ( kind = 4 ) j
11071 real ( kind = 8 ) tol
11072 logical ( kind = 4 ) unique
11073 integer ( kind = 4 ) unique_num
11074
11075 if ( n <= 0 ) then
11076 unique_num = 0
11077 return
11078 end if
11079
11080 unique_num = 1
11081
11082 do i = 2, n
11083
11084 unique = .true.
11085
11086 do j = 1, unique_num
11087 diff = maxval( abs( a(1:m,j) - a(1:m,i) ) )
11088 if ( diff <= tol ) then
11089 unique = .false.
11090 exit
11091 end if
11092 end do
11093
11094 if ( unique ) then
11095 unique_num = unique_num + 1
11096 a(1:m,unique_num) = a(1:m,i)
11097 end if
11098
11099 end do
11100
11101 return

◆ r8col_sorted_tol_unique_count()

subroutine r8col_sorted_tol_unique_count ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 11103 of file R8LIB.f90.

11104
11105!*****************************************************************************80
11106!
11107!! R8COL_SORTED_TOL_UNIQUE_COUNT: tolerably unique elements in a sorted R8COL.
11108!
11109! Discussion:
11110!
11111! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11112! each of length M.
11113!
11114! The columns of the array may be ascending or descending sorted.
11115!
11116! If the tolerance is large enough, then the concept of uniqueness
11117! can become ambiguous. If we have a tolerance of 1.5, then in the
11118! list ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) is it fair to say we have only
11119! one unique entry? That would be because 1 may be regarded as unique,
11120! and then 2 is too close to 1 to be unique, and 3 is too close to 2 to
11121! be unique and so on.
11122!
11123! This seems wrongheaded. So I prefer the idea that an item is not
11124! unique under a tolerance only if it is close to something that IS unique.
11125! Thus, the unique items are guaranteed to cover the space if we include
11126! a disk of radius TOL around each one.
11127!
11128! Licensing:
11129!
11130! This code is distributed under the GNU LGPL license.
11131!
11132! Modified:
11133!
11134! 19 July 2010
11135!
11136! Author:
11137!
11138! John Burkardt
11139!
11140! Parameters:
11141!
11142! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11143!
11144! Input, real ( kind = 8 ) A(M,N), a sorted array, containing
11145! N columns of data.
11146!
11147! Input, real ( kind = 8 ) TOL, a tolerance for equality.
11148!
11149! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
11150!
11151 implicit none
11152
11153 integer ( kind = 4 ) m
11154 integer ( kind = 4 ) n
11155
11156 real ( kind = 8 ) a(m,n)
11157 real ( kind = 8 ) diff
11158 integer ( kind = 4 ) i
11159 integer ( kind = 4 ) i2
11160 integer ( kind = 4 ) j
11161 integer ( kind = 4 ) k
11162 real ( kind = 8 ) tol
11163 integer ( kind = 4 ) undx(n)
11164 logical ( kind = 4 ) unique
11165 integer ( kind = 4 ) unique_num
11166!
11167! Consider entry I = 1.
11168! It is unique, so set the number of unique items to K.
11169! Set the K-th unique item to I.
11170!
11171 i = 1
11172 k = 1
11173 undx(k) = i
11174!
11175! Consider entry I.
11176!
11177! If it is unique, increase the unique count K and set the
11178! K-th unique item to I.
11179!
11180 do i = 2, n
11181
11182 unique = .true.
11183
11184 do j = 1, k
11185 i2 = undx(j)
11186 diff = maxval( abs( a(1:m,i) - a(1:m,i2) ) )
11187 if ( diff <= tol ) then
11188 unique = .false.
11189 exit
11190 end if
11191 end do
11192
11193 if ( unique ) then
11194 k = k + 1
11195 undx(k) = i
11196 end if
11197
11198 end do
11199
11200 unique_num = k
11201
11202 return

◆ r8col_sorted_undex()

subroutine r8col_sorted_undex ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num,
integer ( kind = 4 ), dimension(unique_num)  undx,
integer ( kind = 4 ), dimension(n)  xdnu 
)

Definition at line 11204 of file R8LIB.f90.

11205
11206!*****************************************************************************80
11207!
11208!! R8COL_SORTED_UNDEX returns unique sorted indexes for a sorted R8COL.
11209!
11210! Discussion:
11211!
11212! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11213! each of length M.
11214!
11215! The goal of this routine is to determine a vector UNDX,
11216! which points, to the unique elements of A, in sorted order,
11217! and a vector XDNU, which identifies, for each entry of A, the index of
11218! the unique sorted element of A.
11219!
11220! This is all done with index vectors, so that the elements of
11221! A are never moved.
11222!
11223! Assuming A is already sorted, we examine the entries of A in order,
11224! noting the unique entries, creating the entries of XDNU and
11225! UNDX as we go.
11226!
11227! Once this process has been completed, the vector A could be
11228! replaced by a compressed vector XU, containing the unique entries
11229! of A in sorted order, using the formula
11230!
11231! XU(*) = A(UNDX(*)).
11232!
11233! We could then, if we wished, reconstruct the entire vector A, or
11234! any element of it, by index, as follows:
11235!
11236! A(I) = XU(XDNU(I)).
11237!
11238! We could then replace A by the combination of XU and XDNU.
11239!
11240! Later, when we need the I-th entry of A, we can locate it as
11241! the XDNU(I)-th entry of XU.
11242!
11243! Here is an example of a vector A, the sort and inverse sort
11244! index vectors, and the unique sort and inverse unique sort vectors
11245! and the compressed unique sorted vector.
11246!
11247! I A XU Undx Xdnu
11248! ----+------+------+-----+-----+
11249! 1 | 11.0 | 11.0 1 1
11250! 2 | 11.0 | 22.0 5 1
11251! 3 | 11.0 | 33.0 8 1
11252! 4 | 11.0 | 55.0 9 1
11253! 5 | 22.0 | 2
11254! 6 | 22.0 | 2
11255! 7 | 22.0 | 2
11256! 8 | 33.0 | 3
11257! 9 | 55.0 | 4
11258!
11259! Licensing:
11260!
11261! This code is distributed under the GNU LGPL license.
11262!
11263! Modified:
11264!
11265! 17 July 2010
11266!
11267! Author:
11268!
11269! John Burkardt
11270!
11271! Parameters:
11272!
11273! Input, integer ( kind = 4 ) M, the dimension of the data values.
11274!
11275! Input, integer ( kind = 4 ) N, the number of data values.
11276!
11277! Input, real ( kind = 8 ) AL(M,N), the data values.
11278!
11279! Input, integer ( kind = 4 ) UNIQUE_NUM, the number of unique values
11280! in A. This value is only required for languages in which the size of
11281! UNDX must be known in advance.
11282!
11283! Output, integer ( kind = 4 ) UNDX(UNIQUE_NUM), the UNDX vector.
11284!
11285! Output, integer ( kind = 4 ) XDNU(N), the XDNU vector.
11286!
11287 implicit none
11288
11289 integer ( kind = 4 ) m
11290 integer ( kind = 4 ) n
11291 integer ( kind = 4 ) unique_num
11292
11293 real ( kind = 8 ) a(m,n)
11294 integer ( kind = 4 ) i
11295 integer ( kind = 4 ) j
11296 integer ( kind = 4 ) undx(unique_num)
11297 integer ( kind = 4 ) xdnu(n)
11298!
11299! Walk through the sorted array.
11300!
11301 i = 1
11302 j = 1
11303 undx(j) = i
11304 xdnu(i) = j
11305
11306 do i = 2, n
11307
11308 if ( any( a(1:m,i) /= a(1:m,j) ) ) then
11309 j = j + 1
11310 undx(j) = i
11311 end if
11312
11313 xdnu(i) = j
11314
11315 end do
11316
11317 return

◆ r8col_sorted_unique()

subroutine r8col_sorted_unique ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num 
)

Definition at line 11319 of file R8LIB.f90.

11320
11321!*****************************************************************************80
11322!
11323!! R8COL_SORTED_UNIQUE keeps unique elements in a sorted R8COL.
11324!
11325! Discussion:
11326!
11327! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11328! each of length M.
11329!
11330! The columns of the array may be ascending or descending sorted.
11331!
11332! Licensing:
11333!
11334! This code is distributed under the GNU LGPL license.
11335!
11336! Modified:
11337!
11338! 16 July 2010
11339!
11340! Author:
11341!
11342! John Burkardt
11343!
11344! Parameters:
11345!
11346! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11347!
11348! Input/output, real ( kind = 8 ) A(M,N).
11349! On input, the sorted array of N columns of M-vectors.
11350! On output, a sorted array of columns of M-vectors.
11351!
11352! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
11353!
11354 implicit none
11355
11356 integer ( kind = 4 ) m
11357 integer ( kind = 4 ) n
11358
11359 real ( kind = 8 ) a(m,n)
11360 integer ( kind = 4 ) j1
11361 integer ( kind = 4 ) j2
11362 integer ( kind = 4 ) unique_num
11363
11364 if ( n <= 0 ) then
11365 unique_num = 0
11366 return
11367 end if
11368
11369 j1 = 1
11370
11371 do j2 = 2, n
11372
11373 if ( any( a(1:m,j1) /= a(1:m,j2) ) ) then
11374 j1 = j1 + 1
11375 a(1:m,j1) = a(1:m,j2)
11376 end if
11377
11378 end do
11379
11380 unique_num = j1
11381
11382 return

◆ r8col_sorted_unique_count()

subroutine r8col_sorted_unique_count ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num 
)

Definition at line 11384 of file R8LIB.f90.

11385
11386!*****************************************************************************80
11387!
11388!! R8COL_SORTED_UNIQUE_COUNT counts unique elements in a sorted R8COL.
11389!
11390! Discussion:
11391!
11392! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11393! each of length M.
11394!
11395! The columns of the array may be ascending or descending sorted.
11396!
11397! Licensing:
11398!
11399! This code is distributed under the GNU LGPL license.
11400!
11401! Modified:
11402!
11403! 16 July 2010
11404!
11405! Author:
11406!
11407! John Burkardt
11408!
11409! Parameters:
11410!
11411! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11412!
11413! Input, real ( kind = 8 ) A(M,N), a sorted array, containing
11414! N columns of data.
11415!
11416! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
11417!
11418 implicit none
11419
11420 integer ( kind = 4 ) m
11421 integer ( kind = 4 ) n
11422
11423 real ( kind = 8 ) a(m,n)
11424 integer ( kind = 4 ) j1
11425 integer ( kind = 4 ) j2
11426 integer ( kind = 4 ) unique_num
11427
11428 unique_num = 0
11429
11430 if ( n <= 0 ) then
11431 return
11432 end if
11433
11434 unique_num = 1
11435 j1 = 1
11436
11437 do j2 = 2, n
11438
11439 if ( any( a(1:m,j1) /= a(1:m,j2) ) ) then
11440 unique_num = unique_num + 1
11441 j1 = j2
11442 end if
11443
11444 end do
11445
11446 return

◆ r8col_sortr_a()

subroutine r8col_sortr_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  key 
)

Definition at line 11448 of file R8LIB.f90.

11449
11450!*****************************************************************************80
11451!
11452!! R8COL_SORTR_A ascending sorts one column of an R8COL, adjusting all columns.
11453!
11454! Discussion:
11455!
11456! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11457! each of length M.
11458!
11459! Licensing:
11460!
11461! This code is distributed under the GNU LGPL license.
11462!
11463! Modified:
11464!
11465! 05 December 2004
11466!
11467! Author:
11468!
11469! John Burkardt
11470!
11471! Parameters:
11472!
11473! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11474!
11475! Input/output, real ( kind = 8 ) A(M,N).
11476! On input, an unsorted M by N array.
11477! On output, rows of the array have been shifted in such
11478! a way that column KEY of the array is in nondecreasing order.
11479!
11480! Input, integer ( kind = 4 ) KEY, the column in which the "key" value
11481! is stored. On output, column KEY of the array will be
11482! in nondecreasing order.
11483!
11484 implicit none
11485
11486 integer ( kind = 4 ) m
11487 integer ( kind = 4 ) n
11488
11489 real ( kind = 8 ) a(m,n)
11490 integer ( kind = 4 ) i
11491 integer ( kind = 4 ) indx
11492 integer ( kind = 4 ) isgn
11493 integer ( kind = 4 ) j
11494 integer ( kind = 4 ) key
11495
11496 if ( m <= 0 ) then
11497 return
11498 end if
11499
11500 if ( key < 1 .or. n < key ) then
11501 write ( *, '(a)' ) ' '
11502 write ( *, '(a)' ) 'R8COL_SORTR_A - Fatal error!'
11503 write ( *, '(a)' ) ' The value of KEY is not a legal column index.'
11504 write ( *, '(a,i8)' ) ' KEY = ', key
11505 write ( *, '(a,i8)' ) ' N = ', n
11506 stop 1
11507 end if
11508!
11509! Initialize.
11510!
11511 i = 0
11512 indx = 0
11513 isgn = 0
11514 j = 0
11515!
11516! Call the external heap sorter.
11517!
11518 do
11519
11520 call sort_heap_external ( m, indx, i, j, isgn )
11521!
11522! Interchange the I and J objects.
11523!
11524 if ( 0 < indx ) then
11525
11526 call r8row_swap ( m, n, a, i, j )
11527!
11528! Compare the I and J objects.
11529!
11530 else if ( indx < 0 ) then
11531
11532 if ( a(i,key) < a(j,key) ) then
11533 isgn = -1
11534 else
11535 isgn = +1
11536 end if
11537
11538 else if ( indx == 0 ) then
11539
11540 exit
11541
11542 end if
11543
11544 end do
11545
11546 return
r8row_swap
subroutine r8row_swap(m, n, a, i1, i2)
Definition R8LIB.f90:24941

References r8row_swap(), and sort_heap_external().

Here is the call graph for this function:

◆ r8col_sum()

subroutine r8col_sum ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  colsum 
)

Definition at line 11548 of file R8LIB.f90.

11549
11550!*****************************************************************************80
11551!
11552!! R8COL_SUM sums the columns of an R8COL.
11553!
11554! Discussion:
11555!
11556! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11557! each of length M.
11558!
11559! Licensing:
11560!
11561! This code is distributed under the GNU LGPL license.
11562!
11563! Modified:
11564!
11565! 05 December 2004
11566!
11567! Author:
11568!
11569! John Burkardt
11570!
11571! Parameters:
11572!
11573! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11574!
11575! Input, real ( kind = 8 ) A(M,N), the array to be examined.
11576!
11577! Output, real ( kind = 8 ) COLSUM(N), the sums of the columns.
11578!
11579 implicit none
11580
11581 integer ( kind = 4 ) m
11582 integer ( kind = 4 ) n
11583
11584 real ( kind = 8 ) a(m,n)
11585 real ( kind = 8 ) colsum(n)
11586 integer ( kind = 4 ) j
11587
11588 do j = 1, n
11589 colsum(j) = sum( a(1:m,j) )
11590 end do
11591
11592 return

◆ r8col_swap()

subroutine r8col_swap ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  j1,
integer ( kind = 4 )  j2 
)

Definition at line 11594 of file R8LIB.f90.

11595
11596!*****************************************************************************80
11597!
11598!! R8COL_SWAP swaps columns I and J of an R8COL.
11599!
11600! Discussion:
11601!
11602! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11603! each of length M.
11604!
11605! Example:
11606!
11607! Input:
11608!
11609! M = 3, N = 4, J1 = 2, J2 = 4
11610!
11611! A = (
11612! 1. 2. 3. 4.
11613! 5. 6. 7. 8.
11614! 9. 10. 11. 12. )
11615!
11616! Output:
11617!
11618! A = (
11619! 1. 4. 3. 2.
11620! 5. 8. 7. 6.
11621! 9. 12. 11. 10. )
11622!
11623! Licensing:
11624!
11625! This code is distributed under the GNU LGPL license.
11626!
11627! Modified:
11628!
11629! 05 December 2004
11630!
11631! Author:
11632!
11633! John Burkardt
11634!
11635! Parameters:
11636!
11637! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11638!
11639! Input/output, real ( kind = 8 ) A(M,N), the M by N array.
11640!
11641! Input, integer ( kind = 4 ) J1, J2, the columns to be swapped.
11642!
11643 implicit none
11644
11645 integer ( kind = 4 ) m
11646 integer ( kind = 4 ) n
11647
11648 real ( kind = 8 ) a(m,n)
11649 real ( kind = 8 ) col(m)
11650 integer ( kind = 4 ) j1
11651 integer ( kind = 4 ) j2
11652
11653 if ( j1 < 1 .or. n < j1 .or. j2 < 1 .or. n < j2 ) then
11654 write ( *, '(a)' ) ' '
11655 write ( *, '(a)' ) 'R8COL_SWAP - Fatal error!'
11656 write ( *, '(a)' ) ' J1 or J2 is out of bounds.'
11657 write ( *, '(a,i8)' ) ' J1 = ', j1
11658 write ( *, '(a,i8)' ) ' J2 = ', j2
11659 write ( *, '(a,i8)' ) ' NCOL = ', n
11660 stop 1
11661 end if
11662
11663 if ( j1 == j2 ) then
11664 return
11665 end if
11666
11667 col(1:m) = a(1:m,j1)
11668 a(1:m,j1) = a(1:m,j2)
11669 a(1:m,j2) = col(1:m)
11670
11671 return

◆ r8col_to_r8vec()

subroutine r8col_to_r8vec ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m*n)  x 
)

Definition at line 11673 of file R8LIB.f90.

11674
11675!*****************************************************************************80
11676!
11677!! R8COL_TO_R8VEC converts an R8COL to an R8VEC.
11678!
11679! Discussion:
11680!
11681! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11682! each of length M.
11683!
11684! An R8VEC is a vector of R8's.
11685!
11686! Example:
11687!
11688! M = 3, N = 4
11689!
11690! A =
11691! 11 12 13 14
11692! 21 22 23 24
11693! 31 32 33 34
11694!
11695! X = ( 11, 21, 31, 12, 22, 32, 13, 23, 33, 14, 24, 34 )
11696!
11697! Licensing:
11698!
11699! This code is distributed under the GNU LGPL license.
11700!
11701! Modified:
11702!
11703! 05 December 2004
11704!
11705! Author:
11706!
11707! John Burkardt
11708!
11709! Parameters:
11710!
11711! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
11712!
11713! Input, real ( kind = 8 ) A(M,N), the array.
11714!
11715! Output, real ( kind = 8 ) X(M*N), a vector containing the N columns of A.
11716!
11717 implicit none
11718
11719 integer ( kind = 4 ) m
11720 integer ( kind = 4 ) n
11721
11722 real ( kind = 8 ) a(m,n)
11723 integer ( kind = 4 ) j
11724 integer ( kind = 4 ) k
11725 real ( kind = 8 ) x(m*n)
11726
11727 k = 1
11728 do j = 1, n
11729 x(k:k+m-1) = a(1:m,j)
11730 k = k + m
11731 end do
11732
11733 return

◆ r8col_tol_undex()

subroutine r8col_tol_undex ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(unique_num)  undx,
integer ( kind = 4 ), dimension(n)  xdnu 
)

Definition at line 11735 of file R8LIB.f90.

11736
11737!*****************************************************************************80
11738!
11739!! R8COL_TOL_UNDEX indexes tolerably unique entries of an R8COL.
11740!
11741! Discussion:
11742!
11743! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11744! each of length M.
11745!
11746! The goal of this routine is to determine a vector UNDX,
11747! which points, to the unique elements of A, in sorted order,
11748! and a vector XDNU, which identifies, for each entry of A, the index of
11749! the unique sorted element of A.
11750!
11751! This is all done with index vectors, so that the elements of
11752! A are never moved.
11753!
11754! The first step of the algorithm requires the indexed sorting
11755! of A, which creates arrays INDX and XDNI. (If all the entries
11756! of A are unique, then these arrays are the same as UNDX and XDNU.)
11757!
11758! We then use INDX to examine the entries of A in sorted order,
11759! noting the unique entries, creating the entries of XDNU and
11760! UNDX as we go.
11761!
11762! Once this process has been completed, the object X could be
11763! replaced by a compressed object XU, containing the unique entries
11764! of X in sorted order, using the formula
11765!
11766! XU(*) = A(UNDX(*)).
11767!
11768! We could then, if we wished, reconstruct the entire vector A, or
11769! any element of it, by index, as follows:
11770!
11771! A(I) = XU(XDNU(I)).
11772!
11773! We could then replace A by the combination of XU and XDNU.
11774!
11775! Later, when we need the I-th entry of A, we can locate it as
11776! the XDNU(I)-th entry of XU.
11777!
11778! Here is an example of a vector A, the sort and inverse sort
11779! index vectors, and the unique sort and inverse unique sort vectors
11780! and the compressed unique sorted vector.
11781!
11782! I A Indx Xdni XU Undx Xdnu
11783! ----+-----+-----+-----+--------+-----+-----+
11784! 1 | 11. 1 1 | 11. 1 1
11785! 2 | 22. 3 5 | 22. 2 2
11786! 3 | 11. 6 2 | 33. 4 1
11787! 4 | 33. 9 8 | 55. 5 3
11788! 5 | 55. 2 9 | 4
11789! 6 | 11. 7 3 | 1
11790! 7 | 22. 8 6 | 2
11791! 8 | 22. 4 7 | 2
11792! 9 | 11. 5 4 | 1
11793!
11794! INDX(2) = 3 means that sorted item(2) is A(3).
11795! XDNI(2) = 5 means that A(2) is sorted item(5).
11796!
11797! UNDX(3) = 4 means that unique sorted item(3) is at A(4).
11798! XDNU(8) = 2 means that A(8) is at unique sorted item(2).
11799!
11800! XU(XDNU(I))) = A(I).
11801! XU(I) = A(UNDX(I)).
11802!
11803! Licensing:
11804!
11805! This code is distributed under the GNU LGPL license.
11806!
11807! Modified:
11808!
11809! 17 July 2010
11810!
11811! Author:
11812!
11813! John Burkardt
11814!
11815! Parameters:
11816!
11817! Input, integer ( kind = 4 ) M, the dimension of the data values.
11818!
11819! Input, integer ( kind = 4 ) N, the number of data values.
11820!
11821! Input, real ( kind = 8 ) A(M,N), the data values.
11822!
11823! Input, integer ( kind = 4 ) UNIQUE_NUM, the number of unique values
11824! in A. This value is only required for languages in which the size of
11825! UNDX must be known in advance.
11826!
11827! Input, real ( kind = 8 ) TOL, a tolerance for equality.
11828!
11829! Output, integer ( kind = 4 ) UNDX(UNIQUE_NUM), the UNDX vector.
11830!
11831! Output, integer ( kind = 4 ) XDNU(N), the XDNU vector.
11832!
11833 implicit none
11834
11835 integer ( kind = 4 ) m
11836 integer ( kind = 4 ) n
11837 integer ( kind = 4 ) unique_num
11838
11839 real ( kind = 8 ) a(m,n)
11840 real ( kind = 8 ) diff
11841 integer ( kind = 4 ) i
11842 integer ( kind = 4 ) indx(n)
11843 integer ( kind = 4 ) j
11844 integer ( kind = 4 ) k
11845 real ( kind = 8 ) tol
11846 integer ( kind = 4 ) undx(unique_num)
11847 logical ( kind = 4 ) unique
11848 integer ( kind = 4 ) xdnu(n)
11849!
11850! Implicitly sort the array.
11851!
11852 call r8col_sort_heap_index_a ( m, n, a, indx )
11853!
11854! Consider entry I = 1.
11855! It is unique, so set the number of unique items to K.
11856! Set the K-th unique item to I.
11857! Set the representative of item I to the K-th unique item.
11858!
11859 i = 1
11860 k = 1
11861 undx(k) = indx(i)
11862 xdnu(indx(i)) = k
11863!
11864! Consider entry I.
11865!
11866! If it is unique, increase the unique count K, set the
11867! K-th unique item to I, and set the representative of I to K.
11868!
11869! If it is not unique, set the representative of item I to a
11870! previously determined unique item that is close to it.
11871!
11872 do i = 2, n
11873
11874 unique = .true.
11875
11876 do j = 1, k
11877 diff = maxval( abs( a(1:m,indx(i)) - a(1:m,undx(j)) ) )
11878 if ( diff <= tol ) then
11879 unique = .false.
11880 xdnu(indx(i)) = j
11881 exit
11882 end if
11883 end do
11884
11885 if ( unique ) then
11886 k = k + 1
11887 undx(k) = indx(i)
11888 xdnu(indx(i)) = k
11889 end if
11890
11891 end do
11892
11893 return
r8col_sort_heap_index_a
subroutine r8col_sort_heap_index_a(m, n, a, indx)
Definition R8LIB.f90:10626

References r8col_sort_heap_index_a().

Here is the call graph for this function:

◆ r8col_tol_unique_count()

subroutine r8col_tol_unique_count ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 11895 of file R8LIB.f90.

11896
11897!*****************************************************************************80
11898!
11899!! R8COL_TOL_UNIQUE_COUNT counts tolerably unique entries in an R8COL.
11900!
11901! Discussion:
11902!
11903! An R8COL is an M by N array of R8's, regarded as an array of N columns,
11904! each of length M.
11905!
11906! If the tolerance is large enough, then the concept of uniqueness
11907! can become ambiguous. If we have a tolerance of 1.5, then in the
11908! list ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) is it fair to say we have only
11909! one unique entry? That would be because 1 may be regarded as unique,
11910! and then 2 is too close to 1 to be unique, and 3 is too close to 2 to
11911! be unique and so on.
11912!
11913! This seems wrongheaded. So I prefer the idea that an item is not
11914! unique under a tolerance only if it is close to something that IS unique.
11915! Thus, the unique items are guaranteed to cover the space if we include
11916! a disk of radius TOL around each one.
11917!
11918! Licensing:
11919!
11920! This code is distributed under the GNU LGPL license.
11921!
11922! Modified:
11923!
11924! 19 July 2010
11925!
11926! Author:
11927!
11928! John Burkardt
11929!
11930! Parameters:
11931!
11932! Input, integer ( kind = 4 ) M, the number of rows.
11933!
11934! Input, integer ( kind = 4 ) N, the number of columns.
11935!
11936! Input, real ( kind = 8 ) A(M,N), the array of N columns of data.
11937!
11938! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
11939!
11940! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
11941!
11942 implicit none
11943
11944 integer ( kind = 4 ) m
11945 integer ( kind = 4 ) n
11946
11947 real ( kind = 8 ) a(m,n)
11948 real ( kind = 8 ) diff
11949 integer ( kind = 4 ) i
11950 integer ( kind = 4 ) indx(n)
11951 integer ( kind = 4 ) j
11952 integer ( kind = 4 ) k
11953 real ( kind = 8 ) tol
11954 integer ( kind = 4 ) undx(n)
11955 logical ( kind = 4 ) unique
11956 integer ( kind = 4 ) unique_num
11957!
11958! Implicitly sort the array.
11959!
11960 call r8col_sort_heap_index_a ( m, n, a, indx )
11961!
11962! Consider entry I = 1.
11963! It is unique, so set the number of unique items to K.
11964! Set the K-th unique item to I.
11965! Set the representative of item I to the K-th unique item.
11966!
11967 i = 1
11968 k = 1
11969 undx(k) = indx(i)
11970!
11971! Consider entry I.
11972!
11973! If it is unique, increase the unique count K, set the
11974! K-th unique item to I, and set the representative of I to K.
11975!
11976! If it is not unique, set the representative of item I to a
11977! previously determined unique item that is close to it.
11978!
11979 do i = 2, n
11980
11981 unique = .true.
11982
11983 do j = 1, k
11984 diff = maxval( abs( a(1:m,indx(i)) - a(1:m,undx(j)) ) )
11985 if ( diff <= tol ) then
11986 unique = .false.
11987 exit
11988 end if
11989 end do
11990
11991 if ( unique ) then
11992 k = k + 1
11993 undx(k) = indx(i)
11994 end if
11995
11996 end do
11997
11998 unique_num = k
11999
12000 return

References r8col_sort_heap_index_a().

Here is the call graph for this function:

◆ r8col_tol_unique_index()

subroutine r8col_tol_unique_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(n)  unique_index 
)

Definition at line 12002 of file R8LIB.f90.

12003
12004!*****************************************************************************80
12005!
12006!! R8COL_TOL_UNIQUE_INDEX indexes tolerably unique entries in an R8COL.
12007!
12008! Discussion:
12009!
12010! An R8COL is an M by N array of R8's, regarded as an array of N columns,
12011! each of length M.
12012!
12013! For element A(1:M,J) of the matrix, UNIQUE_INDEX(J) is the uniqueness index
12014! of A(1:M,J). That is, if A_UNIQUE contains the unique elements of A,
12015! gathered in order, then
12016!
12017! A_UNIQUE ( 1:M, UNIQUE_INDEX(J) ) = A(1:M,J)
12018!
12019! Licensing:
12020!
12021! This code is distributed under the GNU LGPL license.
12022!
12023! Modified:
12024!
12025! 17 July 2010
12026!
12027! Author:
12028!
12029! John Burkardt
12030!
12031! Parameters:
12032!
12033! Input, integer ( kind = 4 ) M, N, the number of rows and columns of A.
12034!
12035! Input, real ( kind = 8 ) A(M,N), the array.
12036!
12037! Input, real ( kind = 8 ) TOL, a tolerance for equality.
12038!
12039! Output, integer ( kind = 4 ) UNIQUE_INDEX(N), the first occurrence index.
12040!
12041 implicit none
12042
12043 integer ( kind = 4 ) m
12044 integer ( kind = 4 ) n
12045
12046 real ( kind = 8 ) a(m,n)
12047 real ( kind = 8 ) diff
12048 integer ( kind = 4 ) j1
12049 integer ( kind = 4 ) j2
12050 real ( kind = 8 ) tol
12051 integer ( kind = 4 ) unique_index(n)
12052 integer ( kind = 4 ) unique_num
12053
12054 unique_index(1:n) = -1
12055 unique_num = 0
12056
12057 do j1 = 1, n
12058
12059 if ( unique_index(j1) == -1 ) then
12060
12061 unique_num = unique_num + 1
12062 unique_index(j1) = unique_num
12063
12064 do j2 = j1 + 1, n
12065 diff = maxval( abs( a(1:m,j1) - a(1:m,j2) ) )
12066 if ( diff <= tol ) then
12067 unique_index(j2) = unique_num
12068 end if
12069 end do
12070
12071 end if
12072
12073 end do
12074
12075 return

◆ r8col_undex()

subroutine r8col_undex ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num,
integer ( kind = 4 ), dimension(unique_num)  undx,
integer ( kind = 4 ), dimension(n)  xdnu 
)

Definition at line 12077 of file R8LIB.f90.

12078
12079!*****************************************************************************80
12080!
12081!! R8COL_UNDEX returns unique sorted indexes for an R8COL.
12082!
12083! Discussion:
12084!
12085! An R8COL is an M by N array of R8's, regarded as an array of N columns,
12086! each of length M.
12087!
12088! The goal of this routine is to determine a vector UNDX,
12089! which points, to the unique elements of A, in sorted order,
12090! and a vector XDNU, which identifies, for each entry of A, the index of
12091! the unique sorted element of A.
12092!
12093! This is all done with index vectors, so that the elements of
12094! A are never moved.
12095!
12096! The first step of the algorithm requires the indexed sorting
12097! of A, which creates arrays INDX and XDNI. (If all the entries
12098! of A are unique, then these arrays are the same as UNDX and XDNU.)
12099!
12100! We then use INDX to examine the entries of A in sorted order,
12101! noting the unique entries, creating the entries of XDNU and
12102! UNDX as we go.
12103!
12104! Once this process has been completed, the object X could be
12105! replaced by a compressed object XU, containing the unique entries
12106! of X in sorted order, using the formula
12107!
12108! XU(*) = A(UNDX(*)).
12109!
12110! We could then, if we wished, reconstruct the entire vector A, or
12111! any element of it, by index, as follows:
12112!
12113! A(I) = XU(XDNU(I)).
12114!
12115! We could then replace A by the combination of XU and XDNU.
12116!
12117! Later, when we need the I-th entry of A, we can locate it as
12118! the XDNU(I)-th entry of XU.
12119!
12120! Here is an example of a vector A, the sort and inverse sort
12121! index vectors, and the unique sort and inverse unique sort vectors
12122! and the compressed unique sorted vector.
12123!
12124! I A Indx Xdni XU Undx Xdnu
12125! ----+-----+-----+-----+--------+-----+-----+
12126! 1 | 11. 1 1 | 11. 1 1
12127! 2 | 22. 3 5 | 22. 2 2
12128! 3 | 11. 6 2 | 33. 4 1
12129! 4 | 33. 9 8 | 55. 5 3
12130! 5 | 55. 2 9 | 4
12131! 6 | 11. 7 3 | 1
12132! 7 | 22. 8 6 | 2
12133! 8 | 22. 4 7 | 2
12134! 9 | 11. 5 4 | 1
12135!
12136! INDX(2) = 3 means that sorted item(2) is A(3).
12137! XDNI(2) = 5 means that A(2) is sorted item(5).
12138!
12139! UNDX(3) = 4 means that unique sorted item(3) is at A(4).
12140! XDNU(8) = 2 means that A(8) is at unique sorted item(2).
12141!
12142! XU(XDNU(I))) = A(I).
12143! XU(I) = A(UNDX(I)).
12144!
12145! Licensing:
12146!
12147! This code is distributed under the GNU LGPL license.
12148!
12149! Modified:
12150!
12151! 17 July 2010
12152!
12153! Author:
12154!
12155! John Burkardt
12156!
12157! Parameters:
12158!
12159! Input, integer ( kind = 4 ) M, the dimension of the data values.
12160!
12161! Input, integer ( kind = 4 ) N, the number of data values.
12162!
12163! Input, real ( kind = 8 ) A(M,N), the data values.
12164!
12165! Input, integer ( kind = 4 ) UNIQUE_NUM, the number of unique values
12166! in A. This value is only required for languages in which the size of
12167! UNDX must be known in advance.
12168!
12169! Output, integer ( kind = 4 ) UNDX(UNIQUE_NUM), the UNDX vector.
12170!
12171! Output, integer ( kind = 4 ) XDNU(N), the XDNU vector.
12172!
12173 implicit none
12174
12175 integer ( kind = 4 ) m
12176 integer ( kind = 4 ) n
12177 integer ( kind = 4 ) unique_num
12178
12179 real ( kind = 8 ) a(m,n)
12180 real ( kind = 8 ) diff
12181 integer ( kind = 4 ) i
12182 integer ( kind = 4 ) indx(n)
12183 integer ( kind = 4 ) j
12184 integer ( kind = 4 ) undx(unique_num)
12185 integer ( kind = 4 ) xdnu(n)
12186!
12187! Implicitly sort the array.
12188!
12189 call r8col_sort_heap_index_a ( m, n, a, indx )
12190!
12191! Walk through the implicitly sorted array.
12192!
12193 i = 1
12194 j = 1
12195 undx(j) = indx(i)
12196 xdnu(indx(i)) = j
12197
12198 do i = 2, n
12199
12200 diff = maxval( abs( a(1:m,indx(i)) - a(1:m,undx(j)) ) )
12201
12202 if ( 0.0d+00 < diff ) then
12203 j = j + 1
12204 undx(j) = indx(i)
12205 end if
12206
12207 xdnu(indx(i)) = j
12208
12209 end do
12210
12211 return

References r8col_sort_heap_index_a().

Here is the call graph for this function:

◆ r8col_uniform_abvec()

subroutine r8col_uniform_abvec ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m)  a,
real ( kind = 8 ), dimension(m)  b,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  r 
)

Definition at line 12213 of file R8LIB.f90.

12214
12215!*****************************************************************************80
12216!
12217!! R8COL_UNIFORM_ABVEC fills an R8COL with scaled pseudorandom numbers.
12218!
12219! Discussion:
12220!
12221! An R8COL is an array of R8 values, regarded as a set of column vectors.
12222!
12223! The user specifies a minimum and maximum value for each row.
12224!
12225! Licensing:
12226!
12227! This code is distributed under the GNU LGPL license.
12228!
12229! Modified:
12230!
12231! 19 December 2011
12232!
12233! Author:
12234!
12235! John Burkardt
12236!
12237! Reference:
12238!
12239! Paul Bratley, Bennett Fox, Linus Schrage,
12240! A Guide to Simulation,
12241! Springer Verlag, pages 201-202, 1983.
12242!
12243! Bennett Fox,
12244! Algorithm 647:
12245! Implementation and Relative Efficiency of Quasirandom
12246! Sequence Generators,
12247! ACM Transactions on Mathematical Software,
12248! Volume 12, Number 4, pages 362-376, 1986.
12249!
12250! Peter Lewis, Allen Goodman, James Miller,
12251! A Pseudo-Random Number Generator for the System/360,
12252! IBM Systems Journal,
12253! Volume 8, pages 136-143, 1969.
12254!
12255! Parameters:
12256!
12257! Input, integer ( kind = 4 ) M, N, the number of rows and columns in
12258! the array.
12259!
12260! Input, real ( kind = 8 ) A(M), B(M), the lower and upper limits.
12261!
12262! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
12263! should NOT be 0. On output, SEED has been updated.
12264!
12265! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
12266!
12267 implicit none
12268
12269 integer ( kind = 4 ) m
12270 integer ( kind = 4 ) n
12271
12272 real ( kind = 8 ) a(m)
12273 real ( kind = 8 ) b(m)
12274 integer ( kind = 4 ) i
12275 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
12276 integer ( kind = 4 ) j
12277 integer ( kind = 4 ) k
12278 integer ( kind = 4 ) seed
12279 real ( kind = 8 ) r(m,n)
12280
12281 do j = 1, n
12282
12283 do i = 1, m
12284
12285 k = seed / 127773
12286
12287 seed = 16807 * ( seed - k * 127773 ) - k * 2836
12288
12289 if ( seed < 0 ) then
12290 seed = seed + i4_huge
12291 end if
12292
12293 r(i,j) = a(i) &
12294 + ( b(i) - a(i) ) * real( seed, kind = 8 ) * 4.656612875d-10
12295
12296 end do
12297 end do
12298
12299 return

◆ r8col_unique_count()

subroutine r8col_unique_count ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num 
)

Definition at line 12301 of file R8LIB.f90.

12302
12303!*****************************************************************************80
12304!
12305!! R8COL_UNIQUE_COUNT counts the unique columns in an unsorted R8COL.
12306!
12307! Discussion:
12308!
12309! An R8COL is an M by N array of R8's, regarded as an array of N columns,
12310! each of length M.
12311!
12312! Because the array is unsorted, this algorithm is O(N^2).
12313!
12314! Licensing:
12315!
12316! This code is distributed under the GNU LGPL license.
12317!
12318! Modified:
12319!
12320! 17 July 2010
12321!
12322! Author:
12323!
12324! John Burkardt
12325!
12326! Parameters:
12327!
12328! Input, integer ( kind = 4 ) M, the number of rows.
12329!
12330! Input, integer ( kind = 4 ) N, the number of columns.
12331!
12332! Input, real ( kind = 8 ) A(M,N), the array of N columns of data.
12333!
12334! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
12335!
12336! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique columns.
12337!
12338 implicit none
12339
12340 integer ( kind = 4 ) m
12341 integer ( kind = 4 ) n
12342
12343 real ( kind = 8 ) a(m,n)
12344 real ( kind = 8 ) diff
12345 integer ( kind = 4 ) j1
12346 integer ( kind = 4 ) j2
12347 logical ( kind = 4 ) unique(n)
12348 integer ( kind = 4 ) unique_num
12349
12350 unique_num = 0
12351
12352 do j1 = 1, n
12353
12354 unique_num = unique_num + 1
12355 unique(j1) = .true.
12356
12357 do j2 = 1, j1 - 1
12358
12359 if ( unique(j2) ) then
12360 diff = maxval( abs( a(1:m,j1) - a(1:m,j2) ) )
12361 if ( diff == 0.0d+00 ) then
12362 unique_num = unique_num - 1
12363 unique(j1) = .false.
12364 exit
12365 end if
12366 end if
12367
12368 end do
12369
12370 end do
12371
12372 return

◆ r8col_unique_index()

subroutine r8col_unique_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 ), dimension(n)  unique_index 
)

Definition at line 12374 of file R8LIB.f90.

12375
12376!*****************************************************************************80
12377!
12378!! R8COL_UNIQUE_INDEX indexes the unique occurrence of values in an R8COL.
12379!
12380! Discussion:
12381!
12382! An R8COL is an M by N array of R8's, regarded as an array of N columns,
12383! each of length M.
12384!
12385! For element A(1:M,J) of the matrix, UNIQUE_INDEX(J) is the uniqueness index
12386! of A(1:M,J). That is, if A_UNIQUE contains the unique elements of A,
12387! gathered in order, then
12388!
12389! A_UNIQUE ( 1:M, UNIQUE_INDEX(J) ) = A(1:M,J)
12390!
12391! Licensing:
12392!
12393! This code is distributed under the GNU LGPL license.
12394!
12395! Modified:
12396!
12397! 17 July 2010
12398!
12399! Author:
12400!
12401! John Burkardt
12402!
12403! Parameters:
12404!
12405! Input, integer ( kind = 4 ) M, N, the number of rows and columns of A.
12406! The length of an "element" of A, and the number of "elements".
12407!
12408! Input, real ( kind = 8 ) A(M,N), the array.
12409!
12410! Output, integer ( kind = 4 ) UNIQUE_INDEX(N), the first occurrence index.
12411!
12412 implicit none
12413
12414 integer ( kind = 4 ) m
12415 integer ( kind = 4 ) n
12416
12417 real ( kind = 8 ) a(m,n)
12418 real ( kind = 8 ) diff
12419 integer ( kind = 4 ) j1
12420 integer ( kind = 4 ) j2
12421 integer ( kind = 4 ) unique_index(n)
12422 integer ( kind = 4 ) unique_num
12423
12424 unique_index(1:n) = -1
12425 unique_num = 0
12426
12427 do j1 = 1, n
12428
12429 if ( unique_index(j1) == -1 ) then
12430
12431 unique_num = unique_num + 1
12432 unique_index(j1) = unique_num
12433
12434 do j2 = j1 + 1, n
12435 diff = maxval( abs( a(1:m,j1) - a(1:m,j2) ) )
12436 if ( diff == 0.0d+00 ) then
12437 unique_index(j2) = unique_num
12438 end if
12439 end do
12440
12441 end if
12442
12443 end do
12444
12445 return

◆ r8col_variance()

subroutine r8col_variance ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  variance 
)

Definition at line 12447 of file R8LIB.f90.

12448
12449!*****************************************************************************80
12450!
12451!! R8COL_VARIANCE returns the variances of an R8COL.
12452!
12453! Discussion:
12454!
12455! An R8COL is an M by N array of R8's, regarded as an array of N columns,
12456! each of length M.
12457!
12458! Licensing:
12459!
12460! This code is distributed under the GNU LGPL license.
12461!
12462! Modified:
12463!
12464! 05 December 2004
12465!
12466! Author:
12467!
12468! John Burkardt
12469!
12470! Parameters:
12471!
12472! Input, integer ( kind = 4 ) M, N, the number of rows and columns in
12473! the array.
12474!
12475! Input, real ( kind = 8 ) A(M,N), the array whose variances are desired.
12476!
12477! Output, real ( kind = 8 ) VARIANCE(N), the variances of the rows.
12478!
12479 implicit none
12480
12481 integer ( kind = 4 ) m
12482 integer ( kind = 4 ) n
12483
12484 real ( kind = 8 ) a(m,n)
12485 integer ( kind = 4 ) i
12486 integer ( kind = 4 ) j
12487 real ( kind = 8 ) mean
12488 real ( kind = 8 ) variance(n)
12489
12490 do j = 1, n
12491
12492 mean = sum( a(1:m,j) ) / real( m, kind = 8 )
12493
12494 variance(j) = 0.0d+00
12495 do i = 1, m
12496 variance(j) = variance(j) + ( a(i,j) - mean )**2
12497 end do
12498
12499 if ( 1 < m ) then
12500 variance(j) = variance(j) / real( m - 1, kind = 8 )
12501 else
12502 variance(j) = 0.0d+00
12503 end if
12504
12505 end do
12506
12507 return

◆ r8int_to_i4int()

subroutine r8int_to_i4int ( real ( kind = 8 )  rmin,
real ( kind = 8 )  rmax,
real ( kind = 8 )  r,
integer ( kind = 4 )  imin,
integer ( kind = 4 )  imax,
integer ( kind = 4 )  i 
)

Definition at line 12567 of file R8LIB.f90.

12568
12569!*****************************************************************************80
12570!
12571!! R8INT_TO_I4INT maps an R8INT to an integer interval.
12572!
12573! Discussion:
12574!
12575! The formula used is
12576!
12577! I := IMIN + ( IMAX - IMIN ) * ( R - RMIN ) / ( RMAX - RMIN )
12578!
12579! Licensing:
12580!
12581! This code is distributed under the GNU LGPL license.
12582!
12583! Modified:
12584!
12585! 01 January 2001
12586!
12587! Author:
12588!
12589! John Burkardt
12590!
12591! Parameters:
12592!
12593! Input, real ( kind = 8 ) RMIN, RMAX, the range.
12594!
12595! Input, real ( kind = 8 ) R, the number to be converted.
12596!
12597! Input, integer ( kind = 4 ) IMAX, IMIN, the integer range.
12598!
12599! Output, integer ( kind = 4 ) I, the corresponding value in the
12600! range [IMIN,IMAX].
12601!
12602 implicit none
12603
12604 integer ( kind = 4 ) i
12605 integer ( kind = 4 ) imax
12606 integer ( kind = 4 ) imin
12607 real ( kind = 8 ) r
12608 real ( kind = 8 ) rmax
12609 real ( kind = 8 ) rmin
12610
12611 if ( rmax == rmin ) then
12612
12613 i = ( imax + imin ) / 2
12614
12615 else
12616
12617 i = nint( &
12618 ( ( rmax - r ) * real( imin, kind = 8 ) &
12619 + ( r - rmin ) * real( imax, kind = 8 ) ) &
12620 / ( rmax - rmin ) )
12621
12622 end if
12623
12624 return

◆ r8int_to_r8int()

subroutine r8int_to_r8int ( real ( kind = 8 )  rmin,
real ( kind = 8 )  rmax,
real ( kind = 8 )  r,
real ( kind = 8 )  r2min,
real ( kind = 8 )  r2max,
real ( kind = 8 )  r2 
)

Definition at line 12509 of file R8LIB.f90.

12510
12511!*****************************************************************************80
12512!
12513!! R8INT_TO_R8INT maps one R8INT to another.
12514!
12515! Discussion:
12516!
12517! The formula used is
12518!
12519! R2 := R2MIN + ( R2MAX - R2MIN ) * ( R - RMIN ) / ( RMAX - RMIN )
12520!
12521! Licensing:
12522!
12523! This code is distributed under the GNU LGPL license.
12524!
12525! Modified:
12526!
12527! 01 January 2001
12528!
12529! Author:
12530!
12531! John Burkardt
12532!
12533! Parameters:
12534!
12535! Input, real ( kind = 8 ) RMIN, RMAX, the first range.
12536!
12537! Input, real ( kind = 8 ) R, the number to be converted.
12538!
12539! Input, real ( kind = 8 ) R2MAX, R2MIN, the second range.
12540!
12541! Output, real ( kind = 8 ) R2, the corresponding value in
12542! the range [R2MIN,R2MAX].
12543!
12544 implicit none
12545
12546 real ( kind = 8 ) r
12547 real ( kind = 8 ) rmax
12548 real ( kind = 8 ) rmin
12549 real ( kind = 8 ) r2
12550 real ( kind = 8 ) r2max
12551 real ( kind = 8 ) r2min
12552
12553 if ( rmax == rmin ) then
12554
12555 r2 = ( r2max + r2min ) / 2.0d+00
12556
12557 else
12558
12559 r2 = ( ( ( rmax - r ) * r2min &
12560 + ( r - rmin ) * r2max ) &
12561 / ( rmax - rmin ) )
12562
12563 end if
12564
12565 return

◆ r8mat_add()

subroutine r8mat_add ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 )  alpha,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  beta,
real ( kind = 8 ), dimension(m,n)  b,
real ( kind = 8 ), dimension(m,n)  c 
)

Definition at line 12626 of file R8LIB.f90.

12627
12628!*****************************************************************************80
12629!
12630!! R8MAT_ADD computes C = alpha * A + beta * B for R8MAT's.
12631!
12632! Discussion:
12633!
12634! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12635!
12636! Licensing:
12637!
12638! This code is distributed under the GNU LGPL license.
12639!
12640! Modified:
12641!
12642! 01 December 2011
12643!
12644! Author:
12645!
12646! John Burkardt
12647!
12648! Parameters:
12649!
12650! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
12651!
12652! Input, real ( kind = 8 ) ALPHA, the multiplier for A.
12653!
12654! Input, real ( kind = 8 ) A(M,N), the first matrix.
12655!
12656! Input, real ( kind = 8 ) BETA, the multiplier for A.
12657!
12658! Input, real ( kind = 8 ) B(M,N), the second matrix.
12659!
12660! Output, real ( kind = 8 ) C(M,N), the sum of alpha*A+beta*B.
12661!
12662 implicit none
12663
12664 integer ( kind = 4 ) m
12665 integer ( kind = 4 ) n
12666
12667 real ( kind = 8 ) a(m,n)
12668 real ( kind = 8 ) alpha
12669 real ( kind = 8 ) b(m,n)
12670 real ( kind = 8 ) beta
12671 real ( kind = 8 ) c(m,n)
12672
12673 c(1:m,1:n) = alpha * a(1:m,1:n) + beta * b(1:m,1:n)
12674
12675 return

◆ r8mat_amax()

real ( kind = 8 ) function r8mat_amax ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 12677 of file R8LIB.f90.

12678
12679!*****************************************************************************80
12680!
12681!! R8MAT_AMAX returns the maximum absolute value entry of an R8MAT.
12682!
12683! Discussion:
12684!
12685! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12686!
12687! Licensing:
12688!
12689! This code is distributed under the GNU LGPL license.
12690!
12691! Modified:
12692!
12693! 21 April 2012
12694!
12695! Author:
12696!
12697! John Burkardt
12698!
12699! Parameters:
12700!
12701! Input, integer ( kind = 4 ) M, the number of rows in A.
12702!
12703! Input, integer ( kind = 4 ) N, the number of columns in A.
12704!
12705! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
12706!
12707! Output, real ( kind = 8 ) R8MAT_AMAX, the maximum absolute value
12708! entry of A.
12709!
12710 implicit none
12711
12712 integer ( kind = 4 ) m
12713 integer ( kind = 4 ) n
12714
12715 real ( kind = 8 ) a(m,n)
12716 real ( kind = 8 ) r8mat_amax
12717
12718 r8mat_amax = maxval( abs( a(1:m,1:n) ) )
12719
12720 return
r8mat_amax
real(kind=8) function r8mat_amax(m, n, a)
Definition R8LIB.f90:12678

References r8mat_amax().

Referenced by r8mat_amax().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_border_add()

subroutine r8mat_border_add ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  table,
real ( kind = 8 ), dimension(m+2,n+2)  table2 
)

Definition at line 12722 of file R8LIB.f90.

12723
12724!*****************************************************************************80
12725!
12726!! R8MAT_BORDER_ADD adds a "border" to an R8MAT.
12727!
12728! Discussion:
12729!
12730! We suppose the input data gives values of a quantity on nodes
12731! in the interior of a 2D grid, and we wish to create a new table
12732! with additional positions for the nodes that would be on the
12733! border of the 2D grid.
12734!
12735! 0 0 0 0 0 0
12736! * * * * 0 * * * * 0
12737! * * * * --> 0 * * * * 0
12738! * * * * 0 * * * * 0
12739! 0 0 0 0 0 0
12740!
12741! The illustration suggests the situation in which a 3 by 4 array
12742! is input, and a 5 by 6 array is to be output.
12743!
12744! The old data is shifted to its correct positions in the new array.
12745!
12746! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12747!
12748! Licensing:
12749!
12750! This code is distributed under the GNU LGPL license.
12751!
12752! Modified:
12753!
12754! 25 January 2005
12755!
12756! Author:
12757!
12758! John Burkardt
12759!
12760! Parameters:
12761!
12762! Input, integer ( kind = 4 ) M, the spatial dimension.
12763!
12764! Input, integer ( kind = 4 ) N, the number of points.
12765!
12766! Input, real ( kind = 8 ) TABLE(M,N), the table data.
12767!
12768! Output, real ( kind = 8 ) TABLE2(M+2,N+2), the augmented table data.
12769!
12770 implicit none
12771
12772 integer ( kind = 4 ) m
12773 integer ( kind = 4 ) n
12774
12775 real ( kind = 8 ) table(m,n)
12776 real ( kind = 8 ) table2(m+2,n+2)
12777
12778 table2(1,1:n+2) = 0.0d+00
12779 table2(m+2,1:n+2) = 0.0d+00
12780 table2(2:m+1,1) = 0.0d+00
12781 table2(2:m+1,n+2) = 0.0d+00
12782
12783 table2(2:m+1,2:n+1) = table(1:m,1:n)
12784
12785 return

◆ r8mat_border_cut()

subroutine r8mat_border_cut ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  table,
real ( kind = 8 ), dimension(m-2,n-2)  table2 
)

Definition at line 12787 of file R8LIB.f90.

12788
12789!*****************************************************************************80
12790!
12791!! R8MAT_BORDER_CUT cuts the "border" of an R8MAT.
12792!
12793! Discussion:
12794!
12795! We suppose the input data gives values of a quantity on nodes
12796! on a 2D grid, and we wish to create a new table corresponding only
12797! to those nodes in the interior of the 2D grid.
12798!
12799! 0 0 0 0 0 0
12800! 0 * * * * 0 * * * *
12801! 0 * * * * 0 -> * * * *
12802! 0 * * * * 0 * * * *
12803! 0 0 0 0 0 0
12804!
12805! The illustration suggests the situation in which a 5 by 6 array
12806! is input, and a 3 by 4 array is to be output.
12807!
12808! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12809!
12810! Licensing:
12811!
12812! This code is distributed under the GNU LGPL license.
12813!
12814! Modified:
12815!
12816! 25 January 2005
12817!
12818! Author:
12819!
12820! John Burkardt
12821!
12822! Parameters:
12823!
12824! Input, integer ( kind = 4 ) M, the spatial dimension.
12825!
12826! Input, integer ( kind = 4 ) N, the number of points.
12827!
12828! Input, real ( kind = 8 ) TABLE(M,N), the table data.
12829!
12830! Output, real ( kind = 8 ) TABLE2(M-2,N-2), the new table data.
12831!
12832 implicit none
12833
12834 integer ( kind = 4 ) m
12835 integer ( kind = 4 ) n
12836
12837 real ( kind = 8 ) table(m,n)
12838 real ( kind = 8 ) table2(m-2,n-2)
12839
12840 if ( m <= 2 .or. n <= 2 ) then
12841 return
12842 end if
12843
12844 table2(1:m-2,1:n-2) = table(2:m-1,2:n-1)
12845
12846 return

◆ r8mat_cholesky_factor()

subroutine r8mat_cholesky_factor ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  c,
integer ( kind = 4 )  flag 
)

Definition at line 12848 of file R8LIB.f90.

12849
12850!*****************************************************************************80
12851!
12852!! R8MAT_CHOLESKY_FACTOR computes the Cholesky factor of a symmetric matrix.
12853!
12854! Discussion:
12855!
12856! The matrix must be symmetric and positive semidefinite.
12857!
12858! For a positive semidefinite symmetric matrix A, the Cholesky factorization
12859! is a lower triangular matrix L such that:
12860!
12861! A = L * L'
12862!
12863! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12864!
12865! Licensing:
12866!
12867! This code is distributed under the GNU LGPL license.
12868!
12869! Modified:
12870!
12871! 08 April 2009
12872!
12873! Author:
12874!
12875! John Burkardt
12876!
12877! Parameters:
12878!
12879! Input, integer ( kind = 4 ) N, the number of rows and columns of
12880! the matrix A.
12881!
12882! Input, real ( kind = 8 ) A(N,N), the N by N matrix.
12883!
12884! Output, real ( kind = 8 ) C(N,N), the N by N lower triangular
12885! Cholesky factor.
12886!
12887! Output, integer ( kind = 4 ) FLAG:
12888! 0, no error occurred.
12889! 1, the matrix is not positive definite.
12890!
12891 implicit none
12892
12893 integer ( kind = 4 ) n
12894
12895 real ( kind = 8 ) a(n,n)
12896 real ( kind = 8 ) c(n,n)
12897 integer ( kind = 4 ) flag
12898 integer ( kind = 4 ) i
12899 integer ( kind = 4 ) j
12900 real ( kind = 8 ) sum2
12901
12902 flag = 0
12903
12904 c(1:n,1:n) = a(1:n,1:n)
12905
12906 do j = 1, n
12907
12908 c(1:j-1,j) = 0.0d+00
12909
12910 do i = j, n
12911
12912 sum2 = c(j,i) - dot_product( c(j,1:j-1), c(i,1:j-1) )
12913
12914 if ( i == j ) then
12915 if ( sum2 <= 0.0d+00 ) then
12916 flag = 1
12917 return
12918 else
12919 c(i,j) = sqrt( sum2 )
12920 end if
12921 else
12922 if ( c(j,j) /= 0.0d+00 ) then
12923 c(i,j) = sum2 / c(j,j)
12924 else
12925 c(i,j) = 0.0d+00
12926 end if
12927 end if
12928
12929 end do
12930
12931 end do
12932
12933 return

Referenced by normal_solve().

Here is the caller graph for this function:

◆ r8mat_cholesky_factor_upper()

subroutine r8mat_cholesky_factor_upper ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  c,
integer ( kind = 4 )  flag 
)

Definition at line 12935 of file R8LIB.f90.

12936
12937!*****************************************************************************80
12938!
12939!! R8MAT_CHOLESKY_FACTOR_UPPER: upper Cholesky factor of a symmetric matrix.
12940!
12941! Discussion:
12942!
12943! The matrix must be symmetric and positive semidefinite.
12944!
12945! For a positive semidefinite symmetric matrix A, the Cholesky factorization
12946! is an upper triangular matrix R such that:
12947!
12948! A = R * R'
12949!
12950! The lower Cholesky factor is a lower triangular matrix L such that
12951!
12952! A = L * L'
12953!
12954! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
12955!
12956! Licensing:
12957!
12958! This code is distributed under the GNU LGPL license.
12959!
12960! Modified:
12961!
12962! 03 August 2013
12963!
12964! Author:
12965!
12966! John Burkardt
12967!
12968! Parameters:
12969!
12970! Input, integer ( kind = 4 ) N, the number of rows and columns of
12971! the matrix A.
12972!
12973! Input, real ( kind = 8 ) A(N,N), the N by N matrix.
12974!
12975! Output, real ( kind = 8 ) C(N,N), the N by N upper triangular
12976! Cholesky factor.
12977!
12978! Output, integer ( kind = 4 ) FLAG:
12979! 0, no error occurred.
12980! 1, the matrix is not positive definite.
12981! 2, the matrix is not nonnegative definite.
12982!
12983 implicit none
12984
12985 integer ( kind = 4 ) n
12986
12987 real ( kind = 8 ) a(n,n)
12988 real ( kind = 8 ) c(n,n)
12989 integer ( kind = 4 ) flag
12990 integer ( kind = 4 ) i
12991 integer ( kind = 4 ) j
12992 real ( kind = 8 ) r8_epsilon
12993 real ( kind = 8 ) sum2
12994 real ( kind = 8 ) tol
12995
12996 flag = 0
12997
12998 c(1:n,1:n) = a(1:n,1:n)
12999
13000 do j = 1, n
13001
13002 c(j,1:j-1) = 0.0d+00
13003
13004 do i = j, n
13005
13006 sum2 = c(i,j) - dot_product( c(1:j-1,j), c(1:j-1,i) )
13007
13008 if ( i == j ) then
13009 if ( sum2 <= 0.0d+00 ) then
13010 flag = 1
13011 return
13012 else
13013 c(j,i) = sqrt( sum2 )
13014 end if
13015 else
13016 if ( c(j,j) /= 0.0d+00 ) then
13017 c(j,i) = sum2 / c(j,j)
13018 else
13019 c(j,i) = 0.0d+00
13020 end if
13021 end if
13022
13023 end do
13024
13025 end do
13026
13027 return

◆ r8mat_cholesky_inverse()

subroutine r8mat_cholesky_inverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 13029 of file R8LIB.f90.

13030
13031!*****************************************************************************80
13032!
13033!! R8MAT_CHOLESKY_INVERSE computes the inverse of a symmetric matrix.
13034!
13035! Discussion:
13036!
13037! The matrix must be symmetric and positive semidefinite.
13038!
13039! The upper triangular Cholesky factorization R is computed, so that:
13040!
13041! A = R' * R
13042!
13043! Then the inverse B is computed by
13044!
13045! B = inv ( A ) = inv ( R ) * inv ( R' )
13046!
13047! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13048!
13049! Licensing:
13050!
13051! This code is distributed under the GNU LGPL license.
13052!
13053! Modified:
13054!
13055! 21 October 2013
13056!
13057! Author:
13058!
13059! John Burkardt
13060!
13061! Parameters:
13062!
13063! Input, integer ( kind = 4 ) N, the number of rows and columns of
13064! the matrix A.
13065!
13066! Input/output, real ( kind = 8 ) A(N,N). On input, the matrix.
13067! On output, the inverse of the matrix.
13068!
13069 implicit none
13070
13071 integer ( kind = 4 ) n
13072
13073 real ( kind = 8 ) a(n,n)
13074 integer ( kind = 4 ) i
13075 integer ( kind = 4 ) j
13076 integer ( kind = 4 ) k
13077 real ( kind = 8 ) s
13078 real ( kind = 8 ) t
13079
13080 do j = 1, n
13081
13082 s = 0.0d+00
13083
13084 do k = 1, j - 1
13085 t = a(k,j) - dot_product( a(1:k-1,k), a(1:k-1,j) )
13086 t = t / a(k,k)
13087 a(k,j) = t
13088 s = s + t * t
13089 end do
13090
13091 s = a(j,j) - s
13092
13093 if ( s <= 0.0d+00 ) then
13094 write ( *, '(a)' ) ' '
13095 write ( *, '(a)' ) 'R8MAT_CHOLESKY_INVERSE - Fatal error!'
13096 write ( *, '(a)' ) ' The matrix is singular.'
13097 stop 1
13098 end if
13099
13100 a(j,j) = sqrt( s )
13101
13102 a(j+1:n,j) = 0.0d+00
13103
13104 end do
13105!
13106! Compute inverse(R).
13107!
13108 do k = 1, n
13109
13110 a(k,k) = 1.0d+00 / a(k,k)
13111 a(1:k-1,k) = - a(1:k-1,k) * a(k,k)
13112
13113 do j = k + 1, n
13114 t = a(k,j)
13115 a(k,j) = 0.0d+00
13116 a(1:k,j) = a(1:k,j) + t * a(1:k,k)
13117 end do
13118
13119 end do
13120!
13121! Form inverse(R) * (inverse(R))'.
13122!
13123 do j = 1, n
13124 do k = 1, j - 1
13125 t = a(k,j)
13126 a(1:k,k) = a(1:k,k) + t * a(1:k,j)
13127 end do
13128 t = a(j,j)
13129 a(1:j,j) = a(1:j,j) * t
13130 end do
13131!
13132! Use reflection.
13133!
13134 do i = 1, n
13135 do j = 1, i - 1
13136 a(i,j) = a(j,i)
13137 end do
13138 end do
13139
13140 return

◆ r8mat_cholesky_solve()

subroutine r8mat_cholesky_solve ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  l,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 13142 of file R8LIB.f90.

13143
13144!*****************************************************************************80
13145!
13146!! R8MAT_CHOLESKY_SOLVE solves a Cholesky factored linear system A * x = b.
13147!
13148! Discussion:
13149!
13150! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13151!
13152! This routine works with the lower triangular Cholesky factor A = L * L'.
13153!
13154! Licensing:
13155!
13156! This code is distributed under the GNU LGPL license.
13157!
13158! Modified:
13159!
13160! 07 December 2004
13161!
13162! Author:
13163!
13164! John Burkardt
13165!
13166! Parameters:
13167!
13168! Input, integer ( kind = 4 ) N, the number of rows and columns of
13169! the matrix A.
13170!
13171! Input, real ( kind = 8 ) L(N,N), the N by N lower Cholesky factor of the
13172! system matrix A.
13173!
13174! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
13175!
13176! Output, real ( kind = 8 ) X(N), the solution of the linear system.
13177!
13178 implicit none
13179
13180 integer ( kind = 4 ) n
13181
13182 real ( kind = 8 ) b(n)
13183 real ( kind = 8 ) l(n,n)
13184 real ( kind = 8 ) x(n)
13185!
13186! Solve L * y = b.
13187!
13188 call r8mat_l_solve ( n, l, b, x )
13189!
13190! Solve L' * x = y.
13191!
13192 call r8mat_lt_solve ( n, l, x, x )
13193
13194 return
r8mat_l_solve
subroutine r8mat_l_solve(n, a, b, x)
Definition R8LIB.f90:16226
r8mat_lt_solve
subroutine r8mat_lt_solve(n, a, b, x)
Definition R8LIB.f90:16353

References r8mat_l_solve(), and r8mat_lt_solve().

Referenced by normal_solve().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_cholesky_solve_upper()

subroutine r8mat_cholesky_solve_upper ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  r,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 13196 of file R8LIB.f90.

13197
13198!*****************************************************************************80
13199!
13200!! R8MAT_CHOLESKY_SOLVE_UPPER solves a Cholesky factored system A * x = b.
13201!
13202! Discussion:
13203!
13204! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13205!
13206! This routine works with the upper triangular Cholesky factor A = R' * R.
13207!
13208! Licensing:
13209!
13210! This code is distributed under the GNU LGPL license.
13211!
13212! Modified:
13213!
13214! 21 October 2013
13215!
13216! Author:
13217!
13218! John Burkardt
13219!
13220! Parameters:
13221!
13222! Input, integer ( kind = 4 ) N, the number of rows and columns of
13223! the matrix A.
13224!
13225! Input, real ( kind = 8 ) R(N,N), the N by N upper Cholesky factor of the
13226! system matrix.
13227!
13228! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
13229!
13230! Output, real ( kind = 8 ) X(N), the solution of the linear system.
13231!
13232 implicit none
13233
13234 integer ( kind = 4 ) n
13235
13236 real ( kind = 8 ) b(n)
13237 real ( kind = 8 ) r(n,n)
13238 real ( kind = 8 ) x(n)
13239!
13240! Solve R' * y = b.
13241!
13242 call r8mat_ut_solve ( n, r, b, x )
13243!
13244! Solve R * x = y.
13245!
13246 call r8mat_u_solve ( n, r, x, x )
13247
13248 return
r8mat_u_solve
subroutine r8mat_u_solve(n, a, b, x)
Definition R8LIB.f90:20506
r8mat_ut_solve
subroutine r8mat_ut_solve(n, a, b, x)
Definition R8LIB.f90:20926

References r8mat_u_solve(), and r8mat_ut_solve().

Here is the call graph for this function:

◆ r8mat_copy()

subroutine r8mat_copy ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m,n)  b 
)

Definition at line 13250 of file R8LIB.f90.

13251
13252!*****************************************************************************80
13253!
13254!! R8MAT_COPY copies an R8MAT.
13255!
13256! Discussion:
13257!
13258! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13259!
13260! Licensing:
13261!
13262! This code is distributed under the GNU LGPL license.
13263!
13264! Modified:
13265!
13266! 26 July 2008
13267!
13268! Author:
13269!
13270! John Burkardt
13271!
13272! Parameters:
13273!
13274! Input, integer ( kind = 4 ) M, N, the order of the matrix.
13275!
13276! Input, real ( kind = 8 ) A(M,N), the matrix to be copied.
13277!
13278! Output, real ( kind = 8 ) B(M,N), a copy of the matrix.
13279!
13280 implicit none
13281
13282 integer ( kind = 4 ) m
13283 integer ( kind = 4 ) n
13284
13285 real ( kind = 8 ) a(m,n)
13286 real ( kind = 8 ) b(m,n)
13287
13288 b(1:m,1:n) = a(1:m,1:n)
13289
13290 return

◆ r8mat_covariance()

subroutine r8mat_covariance ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  x,
real ( kind = 8 ), dimension(m,m)  c 
)

Definition at line 13292 of file R8LIB.f90.

13293
13294!*****************************************************************************80
13295!
13296!! R8MAT_COVARIANCE computes the sample covariance of a set of vector data.
13297!
13298! Discussion:
13299!
13300! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13301!
13302! Licensing:
13303!
13304! This code is distributed under the GNU LGPL license.
13305!
13306! Modified:
13307!
13308! 26 June 2013
13309!
13310! Author:
13311!
13312! John Burkardt.
13313!
13314! Parameters:
13315!
13316! Input, integer ( kind = 4 ) M, the size of a single data vectors.
13317!
13318! Input, integer ( kind = 4 ) N, the number of data vectors.
13319! N should be greater than 1.
13320!
13321! Input, real ( kind = 8 ) X(M,N), an array of N data vectors, each
13322! of length M.
13323!
13324! Output, real ( kind = 8 ) C(M,M), the covariance matrix for the data.
13325!
13326 implicit none
13327
13328 integer ( kind = 4 ) m
13329 integer ( kind = 4 ) n
13330
13331 real ( kind = 8 ) c(m,m)
13332 integer ( kind = 4 ) i
13333 integer ( kind = 4 ) j
13334 integer ( kind = 4 ) k
13335 real ( kind = 8 ) x(m,n)
13336 real ( kind = 8 ) x_mean(m)
13337
13338 c(1:m,1:m) = 0.0d+00
13339!
13340! Special case of N = 1.
13341!
13342 if ( n == 1 ) then
13343 do i = 1, m
13344 c(i,i) = 1.0d+00
13345 end do
13346 return
13347 end if
13348!
13349! Determine the sample means.
13350!
13351 do i = 1, m
13352 x_mean(i) = sum( x(i,1:n) ) / real( n, kind = 8 )
13353 end do
13354!
13355! Determine the sample covariance.
13356!
13357 do j = 1, m
13358 do i = 1, m
13359 do k = 1, n
13360 c(i,j) = c(i,j) + ( x(i,k) - x_mean(i) ) * ( x(j,k) - x_mean(j) )
13361 end do
13362 end do
13363 end do
13364
13365 c(1:m,1:m) = c(1:m,1:m) / real( n - 1, kind = 8 )
13366
13367 return

◆ r8mat_det()

subroutine r8mat_det ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 )  det 
)

Definition at line 13369 of file R8LIB.f90.

13370
13371!*****************************************************************************80
13372!
13373!! R8MAT_DET computes the determinant of an R8MAT.
13374!
13375! Discussion:
13376!
13377! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13378!
13379! Licensing:
13380!
13381! This code is distributed under the GNU LGPL license.
13382!
13383! Modified:
13384!
13385! 07 December 2004
13386!
13387! Author:
13388!
13389! Original FORTRAN77 version by Helmut Spaeth.
13390! FORTRAN90 version by John Burkardt.
13391!
13392! Reference:
13393!
13394! Helmut Spaeth,
13395! Cluster Analysis Algorithms
13396! for Data Reduction and Classification of Objects,
13397! Ellis Horwood, 1980, page 125-127.
13398!
13399! Parameters:
13400!
13401! Input, integer ( kind = 4 ) N, the order of the matrix.
13402!
13403! Input, real ( kind = 8 ) A(N,N), the matrix whose determinant is desired.
13404!
13405! Output, real ( kind = 8 ) DET, the determinant of the matrix.
13406!
13407 implicit none
13408
13409 integer ( kind = 4 ) n
13410
13411 real ( kind = 8 ) a(n,n)
13412 real ( kind = 8 ) b(n,n)
13413 real ( kind = 8 ) det
13414 integer ( kind = 4 ) j
13415 integer ( kind = 4 ) k
13416 integer ( kind = 4 ) m
13417 integer ( kind = 4 ) piv(1)
13418 real ( kind = 8 ) t
13419
13420 b(1:n,1:n) = a(1:n,1:n)
13421
13422 det = 1.0d+00
13423
13424 do k = 1, n
13425
13426 piv = maxloc( abs( b(k:n,k) ) )
13427
13428 m = piv(1) + k - 1
13429
13430 if ( m /= k ) then
13431 det = - det
13432 t = b(m,k)
13433 b(m,k) = b(k,k)
13434 b(k,k) = t
13435 end if
13436
13437 det = det * b(k,k)
13438
13439 if ( b(k,k) /= 0.0d+00 ) then
13440
13441 b(k+1:n,k) = -b(k+1:n,k) / b(k,k)
13442
13443 do j = k + 1, n
13444 if ( m /= k ) then
13445 t = b(m,j)
13446 b(m,j) = b(k,j)
13447 b(k,j) = t
13448 end if
13449 b(k+1:n,j) = b(k+1:n,j) + b(k+1:n,k) * b(k,j)
13450 end do
13451
13452 end if
13453
13454 end do
13455
13456 return

◆ r8mat_det_2d()

real ( kind = 8 ) function r8mat_det_2d ( real ( kind = 8 ), dimension(2,2)  a)

Definition at line 13458 of file R8LIB.f90.

13459
13460!*****************************************************************************80
13461!
13462!! R8MAT_DET_2D computes the determinant of a 2 by 2 R8MAT.
13463!
13464! Discussion:
13465!
13466! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13467!
13468! The formula for the determinant of a 2 by 2 matrix is
13469!
13470! a11 * a22 - a12 * a21.
13471!
13472! Licensing:
13473!
13474! This code is distributed under the GNU LGPL license.
13475!
13476! Modified:
13477!
13478! 01 March 1999
13479!
13480! Author:
13481!
13482! John Burkardt
13483!
13484! Parameters:
13485!
13486! Input, real ( kind = 8 ) A(2,2), the matrix whose determinant is desired.
13487!
13488! Output, real ( kind = 8 ) R8MAT_DET_2D, the determinant of the matrix.
13489!
13490 implicit none
13491
13492 real ( kind = 8 ) a(2,2)
13493 real ( kind = 8 ) r8mat_det_2d
13494
13495 r8mat_det_2d = a(1,1) * a(2,2) - a(1,2) * a(2,1)
13496
13497 return
r8mat_det_2d
real(kind=8) function r8mat_det_2d(a)
Definition R8LIB.f90:13459

References r8mat_det_2d().

Referenced by r8mat_det_2d(), and r8mat_inverse_2d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_det_3d()

real ( kind = 8 ) function r8mat_det_3d ( real ( kind = 8 ), dimension(3,3)  a)

Definition at line 13499 of file R8LIB.f90.

13500
13501!*****************************************************************************80
13502!
13503!! R8MAT_DET_3D computes the determinant of a 3 by 3 R8MAT.
13504!
13505! Discussion:
13506!
13507! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13508!
13509! The formula for the determinant of a 3 by 3 matrix is
13510!
13511! a11 * a22 * a33 - a11 * a23 * a32
13512! + a12 * a23 * a31 - a12 * a21 * a33
13513! + a13 * a21 * a32 - a13 * a22 * a31
13514!
13515! Licensing:
13516!
13517! This code is distributed under the GNU LGPL license.
13518!
13519! Modified:
13520!
13521! 01 March 1999
13522!
13523! Author:
13524!
13525! John Burkardt
13526!
13527! Parameters:
13528!
13529! Input, real ( kind = 8 ) A(3,3), the matrix whose determinant is desired.
13530!
13531! Output, real ( kind = 8 ) R8MAT_DET_3D, the determinant of the matrix.
13532!
13533 implicit none
13534
13535 real ( kind = 8 ) a(3,3)
13536 real ( kind = 8 ) r8mat_det_3d
13537
13538 r8mat_det_3d = &
13539 a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
13540 + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
13541 + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )
13542
13543 return
r8mat_det_3d
real(kind=8) function r8mat_det_3d(a)
Definition R8LIB.f90:13500

References r8mat_det_3d().

Referenced by r8mat_det_3d(), and r8mat_inverse_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_det_4d()

real ( kind = 8 ) function r8mat_det_4d ( real ( kind = 8 ), dimension(4,4)  a)

Definition at line 13545 of file R8LIB.f90.

13546
13547!*****************************************************************************80
13548!
13549!! R8MAT_DET_4D computes the determinant of a 4 by 4 R8MAT.
13550!
13551! Discussion:
13552!
13553! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13554!
13555! Licensing:
13556!
13557! This code is distributed under the GNU LGPL license.
13558!
13559! Modified:
13560!
13561! 01 March 1999
13562!
13563! Author:
13564!
13565! John Burkardt
13566!
13567! Parameters:
13568!
13569! Input, real ( kind = 8 ) A(4,4), the matrix whose determinant is desired.
13570!
13571! Output, real ( kind = 8 ) R8MAT_DET_4D, the determinant of the matrix.
13572!
13573 implicit none
13574
13575 real ( kind = 8 ) a(4,4)
13576 real ( kind = 8 ) r8mat_det_4d
13577
13578 r8mat_det_4d = &
13579 a(1,1) * ( &
13580 a(2,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
13581 - a(2,3) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) &
13582 + a(2,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) ) &
13583 - a(1,2) * ( &
13584 a(2,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
13585 - a(2,3) * ( a(3,1) * a(4,4) - a(3,4) * a(4,1) ) &
13586 + a(2,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) ) &
13587 + a(1,3) * ( &
13588 a(2,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) &
13589 - a(2,2) * ( a(3,1) * a(4,4) - a(3,4) * a(4,1) ) &
13590 + a(2,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) ) &
13591 - a(1,4) * ( &
13592 a(2,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) &
13593 - a(2,2) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) &
13594 + a(2,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) )
13595
13596 return
r8mat_det_4d
real(kind=8) function r8mat_det_4d(a)
Definition R8LIB.f90:13546

References r8mat_det_4d().

Referenced by r8mat_det_4d(), r8mat_det_5d(), and r8mat_inverse_4d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_det_5d()

real ( kind = 8 ) function r8mat_det_5d ( real ( kind = 8 ), dimension(5,5)  a)

Definition at line 13598 of file R8LIB.f90.

13599
13600!*****************************************************************************80
13601!
13602!! R8MAT_DET_5D computes the determinant of a 5 by 5 R8MAT.
13603!
13604! Discussion:
13605!
13606! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13607!
13608! Licensing:
13609!
13610! This code is distributed under the GNU LGPL license.
13611!
13612! Modified:
13613!
13614! 02 March 1999
13615!
13616! Author:
13617!
13618! John Burkardt
13619!
13620! Parameters:
13621!
13622! Input, real ( kind = 8 ) A(5,5), the matrix whose determinant is desired.
13623!
13624! Output, real ( kind = 8 ) R8MAT_DET_5D, the determinant of the matrix.
13625!
13626 implicit none
13627
13628 real ( kind = 8 ) a(5,5)
13629 real ( kind = 8 ) b(4,4)
13630 integer ( kind = 4 ) i
13631 integer ( kind = 4 ) inc
13632 integer ( kind = 4 ) j
13633 integer ( kind = 4 ) k
13634 real ( kind = 8 ) r8mat_det_4d
13635 real ( kind = 8 ) r8mat_det_5d
13636!
13637! Expand the determinant into the sum of the determinants of the
13638! five 4 by 4 matrices created by dropping row 1, and column k.
13639!
13640 r8mat_det_5d = 0.0d+00
13641
13642 do k = 1, 5
13643
13644 do i = 1, 4
13645 do j = 1, 4
13646
13647 if ( j < k ) then
13648 inc = 0
13649 else
13650 inc = 1
13651 end if
13652
13653 b(i,j) = a(i+1,j+inc)
13654
13655 end do
13656 end do
13657
13658 r8mat_det_5d = r8mat_det_5d + (-1)**( k + 1 ) * a(1,k) * r8mat_det_4d( b )
13659
13660 end do
13661
13662 return
r8mat_det_5d
real(kind=8) function r8mat_det_5d(a)
Definition R8LIB.f90:13599

References r8mat_det_4d(), and r8mat_det_5d().

Referenced by r8mat_det_5d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_diag_add_scalar()

subroutine r8mat_diag_add_scalar ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 )  s 
)

Definition at line 13664 of file R8LIB.f90.

13665
13666!*****************************************************************************80
13667!
13668!! R8MAT_DIAG_ADD_SCALAR adds a scalar to the diagonal of an R8MAT.
13669!
13670! Discussion:
13671!
13672! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13673!
13674! Licensing:
13675!
13676! This code is distributed under the GNU LGPL license.
13677!
13678! Modified:
13679!
13680! 07 December 2004
13681!
13682! Author:
13683!
13684! John Burkardt
13685!
13686! Parameters:
13687!
13688! Input, integer ( kind = 4 ) N, the number of rows and columns.
13689!
13690! Input/output, real ( kind = 8 ) A(N,N), the N by N matrix to be modified.
13691!
13692! Input, real ( kind = 8 ) S, the value to be added to the diagonal
13693! of the matrix.
13694!
13695 implicit none
13696
13697 integer ( kind = 4 ) n
13698
13699 real ( kind = 8 ) a(n,n)
13700 integer ( kind = 4 ) i
13701 real ( kind = 8 ) s
13702
13703 do i = 1, n
13704 a(i,i) = a(i,i) + s
13705 end do
13706
13707 return

◆ r8mat_diag_add_vector()

subroutine r8mat_diag_add_vector ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 13709 of file R8LIB.f90.

13710
13711!*****************************************************************************80
13712!
13713!! R8MAT_DIAG_ADD_VECTOR adds a vector to the diagonal of an R8MAT.
13714!
13715! Discussion:
13716!
13717! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13718!
13719! Licensing:
13720!
13721! This code is distributed under the GNU LGPL license.
13722!
13723! Modified:
13724!
13725! 07 December 2004
13726!
13727! Author:
13728!
13729! John Burkardt
13730!
13731! Parameters:
13732!
13733! Input, integer ( kind = 4 ) N, the number of rows and columns of
13734! the matrix.
13735!
13736! Input/output, real ( kind = 8 ) A(N,N), the N by N matrix.
13737!
13738! Input, real ( kind = 8 ) V(N), the vector to be added to the diagonal of A.
13739!
13740 implicit none
13741
13742 integer ( kind = 4 ) n
13743
13744 real ( kind = 8 ) a(n,n)
13745 integer ( kind = 4 ) i
13746 real ( kind = 8 ) v(n)
13747
13748 do i = 1, n
13749 a(i,i) = a(i,i) + v(i)
13750 end do
13751
13752 return

◆ r8mat_diag_get_vector()

subroutine r8mat_diag_get_vector ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 13754 of file R8LIB.f90.

13755
13756!*****************************************************************************80
13757!
13758!! R8MAT_DIAG_GET_VECTOR gets the value of the diagonal of an R8MAT.
13759!
13760! Discussion:
13761!
13762! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13763!
13764! Licensing:
13765!
13766! This code is distributed under the GNU LGPL license.
13767!
13768! Modified:
13769!
13770! 22 March 2001
13771!
13772! Author:
13773!
13774! John Burkardt
13775!
13776! Parameters:
13777!
13778! Input, integer ( kind = 4 ) N, the number of rows and columns of
13779! the matrix.
13780!
13781! Input, real ( kind = 8 ) A(N,N), the N by N matrix.
13782!
13783! Output, real ( kind = 8 ) V(N), the diagonal entries
13784! of the matrix.
13785!
13786 implicit none
13787
13788 integer ( kind = 4 ) n
13789
13790 real ( kind = 8 ) a(n,n)
13791 integer ( kind = 4 ) i
13792 real ( kind = 8 ) v(n)
13793
13794 do i = 1, n
13795 v(i) = a(i,i)
13796 end do
13797
13798 return

Referenced by r8mat_norm_l2().

Here is the caller graph for this function:

◆ r8mat_diag_set_scalar()

subroutine r8mat_diag_set_scalar ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 )  s 
)

Definition at line 13800 of file R8LIB.f90.

13801
13802!*****************************************************************************80
13803!
13804!! R8MAT_DIAG_SET_SCALAR sets the diagonal of an R8MAT to a scalar value.
13805!
13806! Discussion:
13807!
13808! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13809!
13810! Licensing:
13811!
13812! This code is distributed under the GNU LGPL license.
13813!
13814! Modified:
13815!
13816! 07 December 2004
13817!
13818! Author:
13819!
13820! John Burkardt
13821!
13822! Parameters:
13823!
13824! Input, integer ( kind = 4 ) N, the number of rows and columns.
13825!
13826! Input/output, real ( kind = 8 ) A(N,N), the N by N matrix to be modified.
13827!
13828! Input, real ( kind = 8 ) S, the value to be assigned to the diagonal
13829! of the matrix.
13830!
13831 implicit none
13832
13833 integer ( kind = 4 ) n
13834
13835 real ( kind = 8 ) a(n,n)
13836 integer ( kind = 4 ) i
13837 real ( kind = 8 ) s
13838
13839 do i = 1, n
13840 a(i,i) = s
13841 end do
13842
13843 return

◆ r8mat_diag_set_vector()

subroutine r8mat_diag_set_vector ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 13845 of file R8LIB.f90.

13846
13847!*****************************************************************************80
13848!
13849!! R8MAT_DIAG_SET_VECTOR sets the diagonal of an R8MAT to a vector.
13850!
13851! Discussion:
13852!
13853! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13854!
13855! Licensing:
13856!
13857! This code is distributed under the GNU LGPL license.
13858!
13859! Modified:
13860!
13861! 07 December 2004
13862!
13863! Author:
13864!
13865! John Burkardt
13866!
13867! Parameters:
13868!
13869! Input, integer ( kind = 4 ) N, the number of rows and columns.
13870!
13871! Input/output, real ( kind = 8 ) A(N,N), the N by N matrix.
13872!
13873! Input, real ( kind = 8 ) V(N), the vector to be assigned to the
13874! diagonal of A.
13875!
13876 implicit none
13877
13878 integer ( kind = 4 ) n
13879
13880 real ( kind = 8 ) a(n,n)
13881 integer ( kind = 4 ) i
13882 real ( kind = 8 ) v(n)
13883
13884 do i = 1, n
13885 a(i,i) = v(i)
13886 end do
13887
13888 return

◆ r8mat_diagonal()

subroutine r8mat_diagonal ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  diag,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 13890 of file R8LIB.f90.

13891
13892!*****************************************************************************80
13893!
13894!! R8MAT_DIAGONAL returns a diagonal matrix as an R8MAT.
13895!
13896! Discussion:
13897!
13898! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13899!
13900! Licensing:
13901!
13902! This code is distributed under the GNU LGPL license.
13903!
13904! Modified:
13905!
13906! 31 July 2013
13907!
13908! Author:
13909!
13910! John Burkardt
13911!
13912! Parameters:
13913!
13914! Input, integer ( kind = 4 ) N, the order of A.
13915!
13916! Input, real ( kind = 8 ) DIAG(N), the diagonal entries.
13917!
13918! Output, real ( kind = 8 ) A(N,N), the N by N diagonal matrix.
13919!
13920 implicit none
13921
13922 integer ( kind = 4 ) n
13923
13924 real ( kind = 8 ) a(n,n)
13925 real ( kind = 8 ) diag(n)
13926 integer ( kind = 4 ) i
13927
13928 a(1:n,1:n) = 0.0d+00
13929
13930 do i = 1, n
13931 a(i,i) = diag(i)
13932 end do
13933
13934 return

◆ r8mat_diff_frobenius()

real ( kind = 8 ) function r8mat_diff_frobenius ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a1,
real ( kind = 8 ), dimension(m,n)  a2 
)

Definition at line 13936 of file R8LIB.f90.

13937
13938!*****************************************************************************80
13939!
13940!! R8MAT_DIFF_FROBENIUS returns the Frobenius norm of an R8MAT difference.
13941!
13942! Discussion:
13943!
13944! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
13945!
13946! The Frobenius norm is defined as
13947!
13948! R8MAT_DIFF_FROBENIUS = sqrt (
13949! sum ( 1 <= I <= M ) sum ( 1 <= j <= N ) A(I,J) * A(I,J) )
13950!
13951! The matrix Frobenius norm is not derived from a vector norm, but
13952! is compatible with the vector L2 norm, so that:
13953!
13954! r8vec_norm_l2 ( A * x ) <=
13955! r8mat_diff_frobenius ( A ) * r8vec_norm_l2 ( x ).
13956!
13957! Licensing:
13958!
13959! This code is distributed under the GNU LGPL license.
13960!
13961! Modified:
13962!
13963! 24 March 2000
13964!
13965! Author:
13966!
13967! John Burkardt
13968!
13969! Parameters:
13970!
13971! Input, integer ( kind = 4 ) M, the number of rows.
13972!
13973! Input, integer ( kind = 4 ) N, the number of columns.
13974!
13975! Input, real ( kind = 8 ) A1(M,N), A2(M,N), the matrices for whose
13976! difference the Frobenius norm is desired.
13977!
13978! Output, real ( kind = 8 ) R8MAT_DIFF_FROBENIUSE, the Frobenius
13979! norm of A1 - A2.
13980!
13981 implicit none
13982
13983 integer ( kind = 4 ) m
13984 integer ( kind = 4 ) n
13985
13986 real ( kind = 8 ) a1(m,n)
13987 real ( kind = 8 ) a2(m,n)
13988 real ( kind = 8 ) r8mat_diff_frobenius
13989
13990 r8mat_diff_frobenius = sqrt( sum( ( a1(1:m,1:n) - a2(1:m,1:n) )**2 ) )
13991
13992 return
r8mat_diff_frobenius
real(kind=8) function r8mat_diff_frobenius(m, n, a1, a2)
Definition R8LIB.f90:13937

References r8mat_diff_frobenius().

Referenced by r8mat_diff_frobenius().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_expand_linear()

subroutine r8mat_expand_linear ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  x,
integer ( kind = 4 )  mfat,
integer ( kind = 4 )  nfat,
real ( kind = 8 ), dimension((m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)  xfat 
)

Definition at line 13994 of file R8LIB.f90.

13995
13996!*****************************************************************************80
13997!
13998!! R8MAT_EXPAND_LINEAR linearly interpolates new data into an R8MAT.
13999!
14000! Discussion:
14001!
14002! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14003!
14004! In this routine, the expansion is specified by giving the number
14005! of intermediate values to generate between each pair of original
14006! data rows and columns.
14007!
14008! The interpolation is not actually linear. It uses the functions
14009!
14010! 1, x, y, and xy.
14011!
14012! Licensing:
14013!
14014! This code is distributed under the GNU LGPL license.
14015!
14016! Modified:
14017!
14018! 07 December 2004
14019!
14020! Author:
14021!
14022! John Burkardt
14023!
14024! Parameters:
14025!
14026! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
14027! input data.
14028!
14029! Input, real ( kind = 8 ) X(M,N), the original data.
14030!
14031! Input, integer ( kind = 4 ) MFAT, NFAT, the number of data values
14032! to interpolate between each row, and each column, of original data values.
14033!
14034! Output, real ( kind = 8 ) XFAT(M2,N2), the fattened data, where
14035! M2 = (M-1)*(MFAT+1)+1,
14036! N2 = (N-1)*(NFAT+1)+1.
14037!
14038 implicit none
14039
14040 integer ( kind = 4 ) m
14041 integer ( kind = 4 ) mfat
14042 integer ( kind = 4 ) n
14043 integer ( kind = 4 ) nfat
14044
14045 integer ( kind = 4 ) i
14046 integer ( kind = 4 ) ihi
14047 integer ( kind = 4 ) ii
14048 integer ( kind = 4 ) iii
14049 integer ( kind = 4 ) ip1
14050 integer ( kind = 4 ) j
14051 integer ( kind = 4 ) jhi
14052 integer ( kind = 4 ) jj
14053 integer ( kind = 4 ) jjj
14054 integer ( kind = 4 ) jp1
14055 real ( kind = 8 ) s
14056 real ( kind = 8 ) t
14057 real ( kind = 8 ) x(m,n)
14058 real ( kind = 8 ) x00
14059 real ( kind = 8 ) x01
14060 real ( kind = 8 ) x10
14061 real ( kind = 8 ) x11
14062 real ( kind = 8 ) xfat((m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)
14063
14064 do i = 1, m
14065
14066 if ( i < m ) then
14067 ihi = mfat
14068 else
14069 ihi = 0
14070 end if
14071
14072 do j = 1, n
14073
14074 if ( j < n ) then
14075 jhi = nfat
14076 else
14077 jhi = 0
14078 end if
14079
14080 if ( i < m ) then
14081 ip1 = i + 1
14082 else
14083 ip1 = i
14084 end if
14085
14086 if ( j < n ) then
14087 jp1 = j + 1
14088 else
14089 jp1 = j
14090 end if
14091
14092 x00 = x(i,j)
14093 x10 = x(ip1,j)
14094 x01 = x(i,jp1)
14095 x11 = x(ip1,jp1)
14096
14097 do ii = 0, ihi
14098
14099 s = real( ii, kind = 8 ) &
14100 / real( ihi + 1, kind = 8 )
14101
14102 do jj = 0, jhi
14103
14104 t = real( jj, kind = 8 ) &
14105 / real( jhi + 1, kind = 8 )
14106
14107 iii = 1 + ( i - 1 ) * ( mfat + 1 ) + ii
14108 jjj = 1 + ( j - 1 ) * ( nfat + 1 ) + jj
14109
14110 xfat(iii,jjj) = &
14111 x00 &
14112 + s * ( x10 - x00 ) &
14113 + t * ( x01 - x00 ) &
14114 + s * t * ( x11 - x10 - x01 + x00 )
14115
14116 end do
14117
14118 end do
14119
14120 end do
14121
14122 end do
14123
14124 return

◆ r8mat_expand_linear2()

subroutine r8mat_expand_linear2 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  m2,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(m2,n2)  a2 
)

Definition at line 14126 of file R8LIB.f90.

14127
14128!*****************************************************************************80
14129!
14130!! R8MAT_EXPAND_LINEAR2 expands an R8MAT by linear interpolation.
14131!
14132! Discussion:
14133!
14134! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14135!
14136! In this version of the routine, the expansion is indicated
14137! by specifying the dimensions of the expanded array.
14138!
14139! Licensing:
14140!
14141! This code is distributed under the GNU LGPL license.
14142!
14143! Modified:
14144!
14145! 07 December 2004
14146!
14147! Author:
14148!
14149! John Burkardt
14150!
14151! Parameters:
14152!
14153! Input, integer ( kind = 4 ) M, N, the number of rows and columns in A.
14154!
14155! Input, real ( kind = 8 ) A(M,N), a "small" M by N array.
14156!
14157! Input, integer ( kind = 4 ) M2, N2, the number of rows and columns in A2.
14158!
14159! Output, real ( kind = 8 ) A2(M2,N2), the expanded array, which
14160! contains an interpolated version of the data in A.
14161!
14162 implicit none
14163
14164 integer ( kind = 4 ) m
14165 integer ( kind = 4 ) m2
14166 integer ( kind = 4 ) n
14167 integer ( kind = 4 ) n2
14168
14169 real ( kind = 8 ) a(m,n)
14170 real ( kind = 8 ) a2(m2,n2)
14171 integer ( kind = 4 ) i
14172 integer ( kind = 4 ) i1
14173 integer ( kind = 4 ) i2
14174 integer ( kind = 4 ) j
14175 integer ( kind = 4 ) j1
14176 integer ( kind = 4 ) j2
14177 real ( kind = 8 ) r
14178 real ( kind = 8 ) r1
14179 real ( kind = 8 ) r2
14180 real ( kind = 8 ) s
14181 real ( kind = 8 ) s1
14182 real ( kind = 8 ) s2
14183
14184 do i = 1, m2
14185
14186 if ( m2 == 1 ) then
14187 r = 0.5d+00
14188 else
14189 r = real( i - 1, kind = 8 ) &
14190 / real( m2 - 1, kind = 8 )
14191 end if
14192
14193 i1 = 1 + int( r * real( m - 1, kind = 8 ) )
14194 i2 = i1 + 1
14195
14196 if ( m < i2 ) then
14197 i1 = m - 1
14198 i2 = m
14199 end if
14200
14201 r1 = real( i1 - 1, kind = 8 ) &
14202 / real( m - 1, kind = 8 )
14203
14204 r2 = real( i2 - 1, kind = 8 ) &
14205 / real( m - 1, kind = 8 )
14206
14207 do j = 1, n2
14208
14209 if ( n2 == 1 ) then
14210 s = 0.5d+00
14211 else
14212 s = real( j - 1, kind = 8 ) &
14213 / real( n2 - 1, kind = 8 )
14214 end if
14215
14216 j1 = 1 + int( s * real( n - 1, kind = 8 ) )
14217 j2 = j1 + 1
14218
14219 if ( n < j2 ) then
14220 j1 = n - 1
14221 j2 = n
14222 end if
14223
14224 s1 = real( j1 - 1, kind = 8 ) &
14225 / real( n - 1, kind = 8 )
14226
14227 s2 = real( j2 - 1, kind = 8 ) &
14228 / real( n - 1, kind = 8 )
14229
14230 a2(i,j) = &
14231 ( ( r2 - r ) * ( s2 - s ) * a(i1,j1) &
14232 + ( r - r1 ) * ( s2 - s ) * a(i2,j1) &
14233 + ( r2 - r ) * ( s - s1 ) * a(i1,j2) &
14234 + ( r - r1 ) * ( s - s1 ) * a(i2,j2) ) &
14235 / ( ( r2 - r1 ) * ( s2 - s1 ) )
14236
14237 end do
14238
14239 end do
14240
14241 return

◆ r8mat_flip_cols()

subroutine r8mat_flip_cols ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m,n)  b 
)

Definition at line 14243 of file R8LIB.f90.

14244
14245!*****************************************************************************80
14246!
14247!! R8MAT_FLIP_COLS reverses the column order of an R8MAT.
14248!
14249! Licensing:
14250!
14251! This code is distributed under the GNU LGPL license.
14252!
14253! Modified:
14254!
14255! 01 November 2013
14256!
14257! Author:
14258!
14259! John Burkardt
14260!
14261! Parameters:
14262!
14263! Input, integer ( kind = 4 ) M, N, the order of the matrix.
14264!
14265! Input, real ( kind = 8 ) A(M,N), the matrix to be flipped.
14266!
14267! Output, real ( kind = 8 ) B(M,N), a copy of A, with the columns
14268! in reverse order.
14269!
14270 implicit none
14271
14272 integer ( kind = 4 ) m
14273 integer ( kind = 4 ) n
14274
14275 real ( kind = 8 ) a(m,n)
14276 real ( kind = 8 ) b(m,n)
14277
14278 b(1:m,n:1:-1) = a(1:m,1:n)
14279
14280 return

◆ r8mat_flip_rows()

subroutine r8mat_flip_rows ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m,n)  b 
)

Definition at line 14282 of file R8LIB.f90.

14283
14284!*****************************************************************************80
14285!
14286!! R8MAT_FLIP_ROWS reverses the row order of an R8MAT.
14287!
14288! Licensing:
14289!
14290! This code is distributed under the GNU LGPL license.
14291!
14292! Modified:
14293!
14294! 01 November 2013
14295!
14296! Author:
14297!
14298! John Burkardt
14299!
14300! Parameters:
14301!
14302! Input, integer ( kind = 4 ) M, N, the order of the matrix.
14303!
14304! Input, real ( kind = 8 ) A(M,N), the matrix to be flipped.
14305!
14306! Output, real ( kind = 8 ) B(M,N), a copy of A, with the rows
14307! in reverse order.
14308!
14309 implicit none
14310
14311 integer ( kind = 4 ) m
14312 integer ( kind = 4 ) n
14313
14314 real ( kind = 8 ) a(m,n)
14315 real ( kind = 8 ) b(m,n)
14316
14317 b(m:1:-1,1:n) = a(1:m,1:n)
14318
14319 return

◆ r8mat_fs()

subroutine r8mat_fs ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
integer ( kind = 4 )  info 
)

Definition at line 14321 of file R8LIB.f90.

14322
14323!*****************************************************************************80
14324!
14325!! R8MAT_FS factors and solves a system with one right hand side.
14326!
14327! Discussion:
14328!
14329! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14330!
14331! This routine differs from R8MAT_FSS in two ways:
14332! * only one right hand side is allowed;
14333! * the input matrix A is not modified.
14334!
14335! This routine uses partial pivoting, but no pivot vector is required.
14336!
14337! Licensing:
14338!
14339! This code is distributed under the GNU LGPL license.
14340!
14341! Modified:
14342!
14343! 21 January 2013
14344!
14345! Author:
14346!
14347! John Burkardt
14348!
14349! Parameters:
14350!
14351! Input, integer ( kind = 4 ) N, the order of the matrix.
14352! N must be positive.
14353!
14354! Input/output, real ( kind = 8 ) A(N,N).
14355! On input, A is the coefficient matrix of the linear system.
14356! On output, A is in unit upper triangular form, and
14357! represents the U factor of an LU factorization of the
14358! original coefficient matrix.
14359!
14360! Input/output, real ( kind = 8 ) B(N).
14361! On input, the right hand side of the linear system.
14362! On output, the solution of the linear systems.
14363!
14364! Output, integer ( kind = 4 ) INFO, singularity flag.
14365! 0, no singularity detected.
14366! nonzero, the factorization failed on the INFO-th step.
14367!
14368 implicit none
14369
14370 integer ( kind = 4 ) n
14371
14372 real ( kind = 8 ) a(n,n)
14373 real ( kind = 8 ) a2(n,n)
14374 real ( kind = 8 ) b(n)
14375 integer ( kind = 4 ) i
14376 integer ( kind = 4 ) info
14377 integer ( kind = 4 ) ipiv
14378 integer ( kind = 4 ) j
14379 integer ( kind = 4 ) jcol
14380 real ( kind = 8 ) piv
14381 real ( kind = 8 ) row(n)
14382 real ( kind = 8 ) t
14383 real ( kind = 8 ) temp
14384
14385 a2(1:n,1:n) = a(1:n,1:n)
14386
14387 info = 0
14388
14389 do jcol = 1, n
14390!
14391! Find the maximum element in column I.
14392!
14393 piv = abs( a2(jcol,jcol) )
14394 ipiv = jcol
14395 do i = jcol + 1, n
14396 if ( piv < abs( a2(i,jcol) ) ) then
14397 piv = abs( a2(i,jcol) )
14398 ipiv = i
14399 end if
14400 end do
14401
14402 if ( piv == 0.0d+00 ) then
14403 info = jcol
14404 write ( *, '(a)' ) ' '
14405 write ( *, '(a)' ) 'R8MAT_FS - Fatal error!'
14406 write ( *, '(a,i8)' ) ' Zero pivot on step ', info
14407 stop 1
14408 end if
14409!
14410! Switch rows JCOL and IPIV, and B.
14411!
14412 if ( jcol /= ipiv ) then
14413
14414 row(1:n) = a2(jcol,1:n)
14415 a2(jcol,1:n) = a2(ipiv,1:n)
14416 a2(ipiv,1:n) = row(1:n)
14417
14418 t = b(jcol)
14419 b(jcol) = b(ipiv)
14420 b(ipiv) = t
14421
14422 end if
14423!
14424! Scale the pivot row.
14425!
14426 a2(jcol,jcol+1:n) = a2(jcol,jcol+1:n) / a2(jcol,jcol)
14427 b(jcol) = b(jcol) / a2(jcol,jcol)
14428 a2(jcol,jcol) = 1.0d+00
14429!
14430! Use the pivot row to eliminate lower entries in that column.
14431!
14432 do i = jcol + 1, n
14433 if ( a2(i,jcol) /= 0.0d+00 ) then
14434 temp = - a2(i,jcol)
14435 a2(i,jcol) = 0.0d+00
14436 a2(i,jcol+1:n) = a2(i,jcol+1:n) + temp * a2(jcol,jcol+1:n)
14437 b(i) = b(i) + temp * b(jcol)
14438 end if
14439 end do
14440
14441 end do
14442!
14443! Back solve.
14444!
14445 do jcol = n, 2, -1
14446 b(1:jcol-1) = b(1:jcol-1) - a2(1:jcol-1,jcol) * b(jcol)
14447 end do
14448
14449 return

◆ r8mat_fss()

subroutine r8mat_fss ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  nb,
real ( kind = 8 ), dimension(n,nb)  b,
integer ( kind = 4 )  info 
)

Definition at line 14451 of file R8LIB.f90.

14452
14453!*****************************************************************************80
14454!
14455!! R8MAT_FSS factors and solves a system with multiple right hand sides.
14456!
14457! Discussion:
14458!
14459! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14460!
14461! This routine does not save the LU factors of the matrix, and hence cannot
14462! be used to efficiently solve multiple linear systems, or even to
14463! factor A at one time, and solve a single linear system at a later time.
14464!
14465! This routine uses partial pivoting, but no pivot vector is required.
14466!
14467! Licensing:
14468!
14469! This code is distributed under the GNU LGPL license.
14470!
14471! Modified:
14472!
14473! 28 November 2011
14474!
14475! Author:
14476!
14477! John Burkardt
14478!
14479! Parameters:
14480!
14481! Input, integer ( kind = 4 ) N, the order of the matrix.
14482! N must be positive.
14483!
14484! Input/output, real ( kind = 8 ) A(N,N).
14485! On input, A is the coefficient matrix of the linear system.
14486! On output, A is in unit upper triangular form, and
14487! represents the U factor of an LU factorization of the
14488! original coefficient matrix.
14489!
14490! Input, integer ( kind = 4 ) NB, the number of right hand sides.
14491!
14492! Input/output, real ( kind = 8 ) B(N,NB).
14493! On input, the right hand sides of the linear system.
14494! On output, the solutions of the linear systems.
14495!
14496! Output, integer ( kind = 4 ) INFO, singularity flag.
14497! 0, no singularity detected.
14498! nonzero, the factorization failed on the INFO-th step.
14499!
14500 implicit none
14501
14502 integer ( kind = 4 ) n
14503 integer ( kind = 4 ) nb
14504
14505 real ( kind = 8 ) a(n,n)
14506 real ( kind = 8 ) b(n,nb)
14507 integer ( kind = 4 ) i
14508 integer ( kind = 4 ) info
14509 integer ( kind = 4 ) ipiv
14510 integer ( kind = 4 ) j
14511 integer ( kind = 4 ) jcol
14512 real ( kind = 8 ) piv
14513 real ( kind = 8 ) row(n)
14514 real ( kind = 8 ) t(nb)
14515 real ( kind = 8 ) temp
14516
14517 info = 0
14518
14519 do jcol = 1, n
14520!
14521! Find the maximum element in column I.
14522!
14523 piv = abs( a(jcol,jcol) )
14524 ipiv = jcol
14525 do i = jcol + 1, n
14526 if ( piv < abs( a(i,jcol) ) ) then
14527 piv = abs( a(i,jcol) )
14528 ipiv = i
14529 end if
14530 end do
14531
14532 if ( piv == 0.0d+00 ) then
14533 info = jcol
14534 write ( *, '(a)' ) ' '
14535 write ( *, '(a)' ) 'R8MAT_FSS - Fatal error!'
14536 write ( *, '(a,i8)' ) ' Zero pivot on step ', info
14537 stop 1
14538 end if
14539!
14540! Switch rows JCOL and IPIV, and B.
14541!
14542 if ( jcol /= ipiv ) then
14543
14544 row(1:n) = a(jcol,1:n)
14545 a(jcol,1:n) = a(ipiv,1:n)
14546 a(ipiv,1:n) = row(1:n)
14547
14548 t(1:nb) = b(jcol,1:nb)
14549 b(jcol,1:nb) = b(ipiv,1:nb)
14550 b(ipiv,1:nb) = t(1:nb)
14551
14552 end if
14553!
14554! Scale the pivot row.
14555!
14556 a(jcol,jcol+1:n) = a(jcol,jcol+1:n) / a(jcol,jcol)
14557 b(jcol,1:nb) = b(jcol,1:nb) / a(jcol,jcol)
14558 a(jcol,jcol) = 1.0d+00
14559!
14560! Use the pivot row to eliminate lower entries in that column.
14561!
14562 do i = jcol + 1, n
14563 if ( a(i,jcol) /= 0.0d+00 ) then
14564 temp = - a(i,jcol)
14565 a(i,jcol) = 0.0d+00
14566 a(i,jcol+1:n) = a(i,jcol+1:n) + temp * a(jcol,jcol+1:n)
14567 b(i,1:nb) = b(i,1:nb) + temp * b(jcol,1:nb)
14568 end if
14569 end do
14570
14571 end do
14572!
14573! Back solve.
14574!
14575 do j = 1, nb
14576 do jcol = n, 2, -1
14577 b(1:jcol-1,j) = b(1:jcol-1,j) - a(1:jcol-1,jcol) * b(jcol,j)
14578 end do
14579 end do
14580
14581 return

Referenced by r8mat_minvm().

Here is the caller graph for this function:

◆ r8mat_givens_post()

subroutine r8mat_givens_post ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  row,
integer ( kind = 4 )  col,
real ( kind = 8 ), dimension(n,n)  g 
)

Definition at line 14583 of file R8LIB.f90.

14584
14585!*****************************************************************************80
14586!
14587!! R8MAT_GIVENS_POST computes the Givens postmultiplier rotation matrix.
14588!
14589! Discussion:
14590!
14591! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14592!
14593! The Givens post-multiplier matrix G(ROW,COL) has the property that
14594! the (ROW,COL)-th entry of A*G is zero.
14595!
14596! Licensing:
14597!
14598! This code is distributed under the GNU LGPL license.
14599!
14600! Modified:
14601!
14602! 23 April 2005
14603!
14604! Author:
14605!
14606! John Burkardt
14607!
14608! Parameters:
14609!
14610! Input, integer ( kind = 4 ) N, the order of the matrices A and G.
14611!
14612! Input, real ( kind = 8 ) A(N,N), the matrix to be operated upon.
14613!
14614! Input, integer ( kind = 4 ) ROW, COL, the row and column of the
14615! entry of A*G which is to be zeroed out.
14616!
14617! Output, real ( kind = 8 ) G(N,N), the Givens rotation matrix.
14618! G is an orthogonal matrix, that is, the inverse of
14619! G is the transpose of G.
14620!
14621 implicit none
14622
14623 integer ( kind = 4 ) n
14624
14625 real ( kind = 8 ) a(n,n)
14626 integer ( kind = 4 ) col
14627 real ( kind = 8 ) g(n,n)
14628 integer ( kind = 4 ) row
14629 real ( kind = 8 ) theta
14630
14631 call r8mat_identity ( n, g )
14632
14633 theta = atan2( a(row,col), a(row,row) )
14634
14635 g(row,row) = cos( theta )
14636 g(row,col) = -sin( theta )
14637 g(col,row) = sin( theta )
14638 g(col,col) = cos( theta )
14639
14640 return
r8mat_identity
subroutine r8mat_identity(n, a)
Definition R8LIB.f90:15169

References r8mat_identity().

Here is the call graph for this function:

◆ r8mat_givens_pre()

subroutine r8mat_givens_pre ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  row,
integer ( kind = 4 )  col,
real ( kind = 8 ), dimension(n,n)  g 
)

Definition at line 14642 of file R8LIB.f90.

14643
14644!*****************************************************************************80
14645!
14646!! R8MAT_GIVENS_PRE computes the Givens premultiplier rotation matrix.
14647!
14648! Discussion:
14649!
14650! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14651!
14652! The Givens premultiplier rotation matrix G(ROW,COL) has the
14653! property that the (ROW,COL)-th entry of G*A is zero.
14654!
14655! Licensing:
14656!
14657! This code is distributed under the GNU LGPL license.
14658!
14659! Modified:
14660!
14661! 23 April 2005
14662!
14663! Author:
14664!
14665! John Burkardt
14666!
14667! Parameters:
14668!
14669! Input, integer ( kind = 4 ) N, the order of the matrices A and G.
14670!
14671! Input, real ( kind = 8 ) A(N,N), the matrix to be operated upon.
14672!
14673! Input, integer ( kind = 4 ) ROW, COL, the row and column of the
14674! entry of the G*A which is to be zeroed out.
14675!
14676! Output, real ( kind = 8 ) G(N,N), the Givens rotation matrix.
14677! G is an orthogonal matrix, that is, the inverse of
14678! G is the transpose of G.
14679!
14680 implicit none
14681
14682 integer ( kind = 4 ) n
14683
14684 real ( kind = 8 ) a(n,n)
14685 integer ( kind = 4 ) col
14686 real ( kind = 8 ) g(n,n)
14687 integer ( kind = 4 ) row
14688 real ( kind = 8 ) theta
14689
14690 call r8mat_identity ( n, g )
14691
14692 theta = atan2( a(row,col), a(col,col) )
14693
14694 g(row,row) = cos( theta )
14695 g(row,col) = -sin( theta )
14696 g(col,row) = sin( theta )
14697 g(col,col) = cos( theta )
14698
14699 return

References r8mat_identity().

Here is the call graph for this function:

◆ r8mat_hess()

subroutine r8mat_hess ( external  fx,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n,n)  h 
)

Definition at line 14701 of file R8LIB.f90.

14702
14703!*****************************************************************************80
14704!
14705!! R8MAT_HESS approximates a Hessian matrix via finite differences.
14706!
14707! Discussion:
14708!
14709! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14710!
14711! H(I,J) = d2 F / d X(I) d X(J)
14712!
14713! The values returned by this routine will be only approximate.
14714! In some cases, they will be so poor that they are useless.
14715! However, one of the best applications of this routine is for
14716! checking your own Hessian calculations, since as Heraclitus
14717! said, you'll never get the same result twice when you differentiate
14718! a complicated expression by hand.
14719!
14720! The user function routine, here called "FX", should have the form:
14721!
14722! subroutine fx ( n, x, f )
14723! integer ( kind = 4 ) n
14724! real ( kind = 8 ) f
14725! real ( kind = 8 ) x(n)
14726!
14727! Licensing:
14728!
14729! This code is distributed under the GNU LGPL license.
14730!
14731! Modified:
14732!
14733! 11 December 2004
14734!
14735! Author:
14736!
14737! John Burkardt
14738!
14739! Parameters:
14740!
14741! Input, external FX, the name of the user function routine.
14742!
14743! Input, integer ( kind = 4 ) N, the number of variables.
14744!
14745! Input, real ( kind = 8 ) X(N), the values of the variables.
14746!
14747! Output, real ( kind = 8 ) H(N,N), the approximated N by N Hessian matrix.
14748!
14749 implicit none
14750
14751 integer ( kind = 4 ) n
14752
14753 real ( kind = 8 ) eps
14754 real ( kind = 8 ) f00
14755 real ( kind = 8 ) fmm
14756 real ( kind = 8 ) fmp
14757 real ( kind = 8 ) fpm
14758 real ( kind = 8 ) fpp
14759 external fx
14760 real ( kind = 8 ) h(n,n)
14761 integer ( kind = 4 ) i
14762 integer ( kind = 4 ) j
14763 real ( kind = 8 ) s(n)
14764 real ( kind = 8 ) x(n)
14765 real ( kind = 8 ) xi
14766 real ( kind = 8 ) xj
14767!
14768! Choose the stepsizes.
14769!
14770 eps = ( epsilon( eps ) )**0.33d+00
14771
14772 do i = 1, n
14773 s(i) = eps * max( abs( x(i) ), 1.0d+00 )
14774 end do
14775!
14776! Calculate the diagonal elements.
14777!
14778 do i = 1, n
14779
14780 xi = x(i)
14781
14782 call fx ( n, x, f00 )
14783
14784 x(i) = xi + s(i)
14785 call fx ( n, x, fpp )
14786
14787 x(i) = xi - s(i)
14788 call fx ( n, x, fmm )
14789
14790 h(i,i) = ( ( fpp - f00 ) + ( fmm - f00 ) ) / s(i)**2
14791
14792 x(i) = xi
14793
14794 end do
14795!
14796! Calculate the off diagonal elements.
14797!
14798 do i = 1, n
14799
14800 xi = x(i)
14801
14802 do j = i + 1, n
14803
14804 xj = x(j)
14805
14806 x(i) = xi + s(i)
14807 x(j) = xj + s(j)
14808 call fx ( n, x, fpp )
14809
14810 x(i) = xi + s(i)
14811 x(j) = xj - s(j)
14812 call fx ( n, x, fpm )
14813
14814 x(i) = xi - s(i)
14815 x(j) = xj + s(j)
14816 call fx ( n, x, fmp )
14817
14818 x(i) = xi - s(i)
14819 x(j) = xj - s(j)
14820 call fx ( n, x, fmm )
14821
14822 h(j,i) = ( ( fpp - fpm ) + ( fmm - fmp ) ) / ( 4.0d+00 * s(i) * s(j) )
14823
14824 h(i,j) = h(j,i)
14825
14826 x(j) = xj
14827
14828 end do
14829
14830 x(i) = xi
14831
14832 end do
14833
14834 return

◆ r8mat_house_axh()

subroutine r8mat_house_axh ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  v,
real ( kind = 8 ), dimension(n,n)  ah 
)

Definition at line 14836 of file R8LIB.f90.

14837
14838!*****************************************************************************80
14839!
14840!! R8MAT_HOUSE_AXH computes A*H where H is a compact Householder matrix.
14841!
14842! Discussion:
14843!
14844! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14845!
14846! The Householder matrix H(V) is defined by
14847!
14848! H(V) = I - 2 * v * v' / ( v' * v )
14849!
14850! This routine is not particularly efficient.
14851!
14852! Licensing:
14853!
14854! This code is distributed under the GNU LGPL license.
14855!
14856! Modified:
14857!
14858! 26 March 2000
14859!
14860! Author:
14861!
14862! John Burkardt
14863!
14864! Parameters:
14865!
14866! Input, integer ( kind = 4 ) N, the order of A.
14867!
14868! Input, real ( kind = 8 ) A(N,N), the matrix to be postmultiplied.
14869!
14870! Input, real ( kind = 8 ) V(N), a vector defining a Householder matrix.
14871!
14872! Output, real ( kind = 8 ) AH(N,N), the product A*H.
14873!
14874 implicit none
14875
14876 integer ( kind = 4 ) n
14877
14878 real ( kind = 8 ) a(n,n)
14879 real ( kind = 8 ) ah(n,n)
14880 real ( kind = 8 ) ah_temp(n,n)
14881 integer ( kind = 4 ) i
14882 integer ( kind = 4 ) j
14883 integer ( kind = 4 ) k
14884 real ( kind = 8 ) v(n)
14885 real ( kind = 8 ) v_normsq
14886
14887 v_normsq = sum( v(1:n)**2 )
14888!
14889! Compute A*H' = A*H
14890!
14891 do i = 1, n
14892 do j = 1, n
14893 ah_temp(i,j) = a(i,j)
14894 do k = 1, n
14895 ah_temp(i,j) = ah_temp(i,j) - 2.0d+00 * a(i,k) * v(k) * v(j) / v_normsq
14896 end do
14897 end do
14898 end do
14899!
14900! Copy the temporary result into AH.
14901! Doing it this way means the user can identify the input arguments A and AH.
14902!
14903 ah(1:n,1:n) = ah_temp(1:n,1:n)
14904
14905 return

Referenced by r8mat_orth_uniform().

Here is the caller graph for this function:

◆ r8mat_house_form()

subroutine r8mat_house_form ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v,
real ( kind = 8 ), dimension(n,n)  h 
)

Definition at line 14907 of file R8LIB.f90.

14908
14909!*****************************************************************************80
14910!
14911!! R8MAT_HOUSE_FORM constructs a Householder matrix from its compact form.
14912!
14913! Discussion:
14914!
14915! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14916!
14917! H(v) = I - 2 * v * v' / ( v' * v )
14918!
14919! Licensing:
14920!
14921! This code is distributed under the GNU LGPL license.
14922!
14923! Modified:
14924!
14925! 24 March 2000
14926!
14927! Author:
14928!
14929! John Burkardt
14930!
14931! Parameters:
14932!
14933! Input, integer ( kind = 4 ) N, the order of the matrix.
14934!
14935! Input, real ( kind = 8 ) V(N), the vector defining the Householder matrix.
14936!
14937! Output, real ( kind = 8 ) H(N,N), the Householder matrix.
14938!
14939 implicit none
14940
14941 integer ( kind = 4 ) n
14942
14943 real ( kind = 8 ) beta
14944 real ( kind = 8 ) h(n,n)
14945 integer ( kind = 4 ) i
14946 integer ( kind = 4 ) j
14947 real ( kind = 8 ) v(n)
14948!
14949! Compute the L2 norm of V.
14950!
14951 beta = sum( v(1:n)**2 )
14952!
14953! Form the matrix H.
14954!
14955 call r8mat_identity ( n, h )
14956
14957 do i = 1, n
14958 do j = 1, n
14959 h(i,j) = h(i,j) - 2.0d+00 * v(i) * v(j) / beta
14960 end do
14961 end do
14962
14963 return

References r8mat_identity().

Referenced by r8mat_house_post(), and r8mat_house_pre().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_house_hxa()

subroutine r8mat_house_hxa ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  v,
real ( kind = 8 ), dimension(n,n)  ha 
)

Definition at line 14965 of file R8LIB.f90.

14966
14967!*****************************************************************************80
14968!
14969!! R8MAT_HOUSE_HXA computes H*A where H is a compact Householder matrix.
14970!
14971! Discussion:
14972!
14973! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
14974!
14975! The Householder matrix H(V) is defined by
14976!
14977! H(V) = I - 2 * v * v' / ( v' * v )
14978!
14979! This routine is not particularly efficient.
14980!
14981! Licensing:
14982!
14983! This code is distributed under the GNU LGPL license.
14984!
14985! Modified:
14986!
14987! 26 March 2000
14988!
14989! Author:
14990!
14991! John Burkardt
14992!
14993! Parameters:
14994!
14995! Input, integer ( kind = 4 ) N, the order of A.
14996!
14997! Input, real ( kind = 8 ) A(N,N), the matrix to be premultiplied.
14998!
14999! Input, real ( kind = 8 ) V(N), a vector defining a Householder matrix.
15000!
15001! Output, real ( kind = 8 ) HA(N,N), the product H*A.
15002!
15003 implicit none
15004
15005 integer ( kind = 4 ) n
15006
15007 real ( kind = 8 ) a(n,n)
15008 real ( kind = 8 ) ha(n,n)
15009 real ( kind = 8 ) ha_temp(n,n)
15010 integer ( kind = 4 ) i
15011 integer ( kind = 4 ) j
15012 integer ( kind = 4 ) k
15013 real ( kind = 8 ) v(n)
15014 real ( kind = 8 ) v_normsq
15015
15016 v_normsq = sum( v(1:n)**2 )
15017!
15018! Compute A*H' = A*H
15019!
15020 do i = 1, n
15021 do j = 1, n
15022 ha_temp(i,j) = a(i,j)
15023 do k = 1, n
15024 ha_temp(i,j) = ha_temp(i,j) - 2.0d+00 * v(i) * v(k) * a(k,j) / v_normsq
15025 end do
15026 end do
15027 end do
15028!
15029! Copy the temporary result into HA.
15030! Doing it this way means the user can identify the input arguments A and HA.
15031!
15032 ha(1:n,1:n) = ha_temp(1:n,1:n)
15033
15034 return

◆ r8mat_house_post()

subroutine r8mat_house_post ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  row,
integer ( kind = 4 )  col,
real ( kind = 8 ), dimension(n,n)  h 
)

Definition at line 15036 of file R8LIB.f90.

15037
15038!*****************************************************************************80
15039!
15040!! R8MAT_HOUSE_POST computes a Householder post-multiplier matrix.
15041!
15042! Discussion:
15043!
15044! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15045!
15046! H(ROW,COL) has the property that the ROW-th column of
15047! A*H(ROW,COL) is zero from entry COL+1 to the end.
15048!
15049! In the most common case, where a QR factorization is being computed,
15050! ROW = COL.
15051!
15052! Licensing:
15053!
15054! This code is distributed under the GNU LGPL license.
15055!
15056! Modified:
15057!
15058! 23 April 2005
15059!
15060! Author:
15061!
15062! John Burkardt
15063!
15064! Parameters:
15065!
15066! Input, integer ( kind = 4 ) N, the order of the matrices.
15067!
15068! Input, real ( kind = 8 ) A(N,N), the matrix whose Householder matrix
15069! is to be computed.
15070!
15071! Input, integer ( kind = 4 ) ROW, COL, specify the location of the
15072! entry of the matrix A which is to be preserved. The entries in
15073! the same row, but higher column, will be zeroed out if
15074! A is postmultiplied by H.
15075!
15076! Output, real ( kind = 8 ) H(N,N), the Householder matrix.
15077!
15078 implicit none
15079
15080 integer ( kind = 4 ) n
15081
15082 real ( kind = 8 ) a(n,n)
15083 integer ( kind = 4 ) col
15084 real ( kind = 8 ) h(n,n)
15085 integer ( kind = 4 ) row
15086 real ( kind = 8 ) v(n)
15087 real ( kind = 8 ) w(n)
15088!
15089! Set up the vector V.
15090!
15091 w(1:col-1) = 0.0d+00
15092 w(col:n) = a(row,col:n)
15093
15094 call r8vec_house_column ( n, w, col, v )
15095!
15096! Form the matrix H(V).
15097!
15098 call r8mat_house_form ( n, v, h )
15099
15100 return
r8mat_house_form
subroutine r8mat_house_form(n, v, h)
Definition R8LIB.f90:14908
r8vec_house_column
subroutine r8vec_house_column(n, a, k, v)
Definition R8LIB.f90:30534

References r8mat_house_form(), and r8vec_house_column().

Here is the call graph for this function:

◆ r8mat_house_pre()

subroutine r8mat_house_pre ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  row,
integer ( kind = 4 )  col,
real ( kind = 8 ), dimension(n,n)  h 
)

Definition at line 15102 of file R8LIB.f90.

15103
15104!*****************************************************************************80
15105!
15106!! R8MAT_HOUSE_PRE computes a Householder pre-multiplier matrix.
15107!
15108! Discussion:
15109!
15110! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15111!
15112! H(ROW,COL) has the property that the COL-th column of
15113! H(ROW,COL)*A is zero from entry ROW+1 to the end.
15114!
15115! In the most common case, where a QR factorization is being computed,
15116! ROW = COL.
15117!
15118! Licensing:
15119!
15120! This code is distributed under the GNU LGPL license.
15121!
15122! Modified:
15123!
15124! 23 April 2005
15125!
15126! Author:
15127!
15128! John Burkardt
15129!
15130! Parameters:
15131!
15132! Input, integer ( kind = 4 ) N, the order of the matrices.
15133!
15134! Input, real ( kind = 8 ) A(N,N), the matrix whose Householder matrix
15135! is to be computed.
15136!
15137! Input, integer ( kind = 4 ) ROW, COL, specify the location of the
15138! entry of the matrix A which is to be preserved. The entries in
15139! the same column, but higher rows, will be zeroed out if A is
15140! premultiplied by H.
15141!
15142! Output, real ( kind = 8 ) H(N,N), the Householder matrix.
15143!
15144 implicit none
15145
15146 integer ( kind = 4 ) n
15147
15148 real ( kind = 8 ) a(n,n)
15149 integer ( kind = 4 ) col
15150 real ( kind = 8 ) h(n,n)
15151 integer ( kind = 4 ) row
15152 real ( kind = 8 ) v(n)
15153 real ( kind = 8 ) w(n)
15154!
15155! Set up the vector V.
15156!
15157 w(1:row-1) = 0.0d+00
15158 w(row:n) = a(row:n,col)
15159
15160 call r8vec_house_column ( n, w, row, v )
15161!
15162! Form the matrix H(V).
15163!
15164 call r8mat_house_form ( n, v, h )
15165
15166 return

References r8mat_house_form(), and r8vec_house_column().

Here is the call graph for this function:

◆ r8mat_identity()

subroutine r8mat_identity ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 15168 of file R8LIB.f90.

15169
15170!*****************************************************************************80
15171!
15172!! R8MAT_IDENTITY stores the identity matrix in an R8MAT.
15173!
15174! Discussion:
15175!
15176! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15177!
15178! Licensing:
15179!
15180! This code is distributed under the GNU LGPL license.
15181!
15182! Modified:
15183!
15184! 24 March 2000
15185!
15186! Author:
15187!
15188! John Burkardt
15189!
15190! Parameters:
15191!
15192! Input, integer ( kind = 4 ) N, the order of A.
15193!
15194! Output, real ( kind = 8 ) A(N,N), the N by N identity matrix.
15195!
15196 implicit none
15197
15198 integer ( kind = 4 ) n
15199
15200 real ( kind = 8 ) a(n,n)
15201 integer ( kind = 4 ) i
15202
15203 a(1:n,1:n) = 0.0d+00
15204
15205 do i = 1, n
15206 a(i,i) = 1.0d+00
15207 end do
15208
15209 return

Referenced by r8mat_givens_post(), r8mat_givens_pre(), r8mat_house_form(), r8mat_lu(), r8mat_poly_char(), and r8mat_power().

Here is the caller graph for this function:

◆ r8mat_in_01()

logical ( kind = 4 ) function r8mat_in_01 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 15211 of file R8LIB.f90.

15212
15213!*****************************************************************************80
15214!
15215!! R8MAT_IN_01 is TRUE if the entries of an R8MAT are in the range [0,1].
15216!
15217! Discussion:
15218!
15219! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15220!
15221! Licensing:
15222!
15223! This code is distributed under the GNU LGPL license.
15224!
15225! Modified:
15226!
15227! 06 October 2004
15228!
15229! Author:
15230!
15231! John Burkardt
15232!
15233! Parameters:
15234!
15235! Input, integer ( kind = 4 ) M, the number of rows in A.
15236!
15237! Input, integer ( kind = 4 ) N, the number of columns in A.
15238!
15239! Input, real ( kind = 8 ) A(M,N), the matrix.
15240!
15241! Output, logical ( kind = 4 ) R8MAT_IN_01, is TRUE if every entry of A is
15242! between 0 and 1.
15243!
15244 implicit none
15245
15246 integer ( kind = 4 ) m
15247 integer ( kind = 4 ) n
15248
15249 real ( kind = 8 ) a(m,n)
15250 logical ( kind = 4 ) r8mat_in_01
15251
15252 if ( any( a(1:m,1:n) < 0.0d+00 .or. 1.0d+00 < a(1:m,1:n) ) ) then
15253 r8mat_in_01 = .false.
15254 else
15255 r8mat_in_01 = .true.
15256 end if
15257
15258 return
r8mat_in_01
logical(kind=4) function r8mat_in_01(m, n, a)
Definition R8LIB.f90:15212

References r8mat_in_01().

Referenced by r8mat_in_01().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_indicator()

subroutine r8mat_indicator ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  table 
)

Definition at line 15260 of file R8LIB.f90.

15261
15262!*****************************************************************************80
15263!
15264!! R8MAT_INDICATOR sets up an "indicator" R8MAT.
15265!
15266! Discussion:
15267!
15268! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15269!
15270! The value of each entry suggests its location, as in:
15271!
15272! 11 12 13 14
15273! 21 22 23 24
15274! 31 32 33 34
15275!
15276! Licensing:
15277!
15278! This code is distributed under the GNU LGPL license.
15279!
15280! Modified:
15281!
15282! 28 May 2008
15283!
15284! Author:
15285!
15286! John Burkardt
15287!
15288! Parameters:
15289!
15290! Input, integer ( kind = 4 ) M, the number of rows of the matrix.
15291! M must be positive.
15292!
15293! Input, integer ( kind = 4 ) N, the number of columns of the matrix.
15294! N must be positive.
15295!
15296! Output, real ( kind = 8 ) TABLE(M,N), the table.
15297!
15298 implicit none
15299
15300 integer ( kind = 4 ) m
15301 integer ( kind = 4 ) n
15302
15303 integer ( kind = 4 ) fac
15304 integer ( kind = 4 ) i
15305 integer ( kind = 4 ) i4_log_10
15306 integer ( kind = 4 ) j
15307 real ( kind = 8 ) table(m,n)
15308
15309 fac = 10 ** ( i4_log_10( n ) + 1 )
15310
15311 do i = 1, m
15312 do j = 1, n
15313 table(i,j) = real( fac * i + j, kind = 8 )
15314 end do
15315 end do
15316
15317 return

◆ r8mat_insignificant()

logical ( kind = 4 ) function r8mat_insignificant ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  r,
real ( kind = 8 ), dimension(m,n)  s 
)

Definition at line 15319 of file R8LIB.f90.

15320
15321!*****************************************************************************80
15322!
15323!! R8MAT_INSIGNIFICANT determines if an R8MAT is insignificant.
15324!
15325! Discussion:
15326!
15327! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15328!
15329! Licensing:
15330!
15331! This code is distributed under the GNU LGPL license.
15332!
15333! Modified:
15334!
15335! 26 November 2011
15336!
15337! Author:
15338!
15339! John Burkardt
15340!
15341! Parameters:
15342!
15343! Input, integer ( kind = 4 ) M, N, the dimension of the matrices.
15344!
15345! Input, real ( kind = 8 ) R(M,N), the vector to be compared against.
15346!
15347! Input, real ( kind = 8 ) S(M,N), the vector to be compared.
15348!
15349! Output, logical ( kind = 4 ) R8MAT_INSIGNIFICANT, is TRUE if S is
15350! insignificant compared to R.
15351!
15352 implicit none
15353
15354 integer ( kind = 4 ) m
15355 integer ( kind = 4 ) n
15356
15357 integer ( kind = 4 ) i
15358 integer ( kind = 4 ) j
15359 real ( kind = 8 ) r(m,n)
15360 logical ( kind = 4 ) r8mat_insignificant
15361 real ( kind = 8 ) s(m,n)
15362 real ( kind = 8 ) t
15363 real ( kind = 8 ) tol
15364 logical ( kind = 4 ) value
15365
15366 value = .true.
15367
15368 do j = 1, n
15369 do i = 1, m
15370
15371 t = r(i,j) + s(i,j)
15372 tol = epsilon( r(i,j) ) * abs( r(i,j) )
15373
15374 if ( tol < abs( r(i,j) - t ) ) then
15375 value = .false.
15376 exit
15377 end if
15378
15379 end do
15380 end do
15381
15382 r8mat_insignificant = value
15383
15384 return
r8mat_insignificant
logical(kind=4) function r8mat_insignificant(m, n, r, s)
Definition R8LIB.f90:15320

References r8mat_insignificant().

Referenced by r8mat_insignificant().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_inverse_2d()

subroutine r8mat_inverse_2d ( real ( kind = 8 ), dimension(2,2)  a,
real ( kind = 8 ), dimension(2,2)  b,
real ( kind = 8 )  det 
)

Definition at line 15386 of file R8LIB.f90.

15387
15388!*****************************************************************************80
15389!
15390!! R8MAT_INVERSE_2D inverts a 2 by 2 R8MAT using Cramer's rule.
15391!
15392! Discussion:
15393!
15394! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15395!
15396! If the determinant is zero, then A is singular, and does not have an
15397! inverse. In that case, B is simply set to zero, and a
15398! message is printed.
15399!
15400! If the determinant is nonzero, then its value is roughly an estimate
15401! of how nonsingular the matrix A is.
15402!
15403! Licensing:
15404!
15405! This code is distributed under the GNU LGPL license.
15406!
15407! Modified:
15408!
15409! 29 November 1998
15410!
15411! Author:
15412!
15413! John Burkardt
15414!
15415! Parameters:
15416!
15417! Input, real ( kind = 8 ) A(2,2), the matrix to be inverted.
15418!
15419! Output, real ( kind = 8 ) B(2,2), the inverse of the matrix A.
15420!
15421! Output, real ( kind = 8 ) DET, the determinant of the matrix A.
15422!
15423 implicit none
15424
15425 real ( kind = 8 ) a(2,2)
15426 real ( kind = 8 ) b(2,2)
15427 real ( kind = 8 ) det
15428 real ( kind = 8 ) r8mat_det_2d
15429!
15430! Compute the determinant of A.
15431!
15432 det = r8mat_det_2d( a )
15433
15434 if ( det == 0.0d+00 ) then
15435
15436 b(1:2,1:2) = 0.0d+00
15437
15438 else
15439
15440 b(1,1) = a(2,2) / det
15441 b(1,2) = -a(1,2) / det
15442 b(2,1) = -a(2,1) / det
15443 b(2,2) = a(1,1) / det
15444
15445 end if
15446
15447 return

References r8mat_det_2d().

Here is the call graph for this function:

◆ r8mat_inverse_3d()

subroutine r8mat_inverse_3d ( real ( kind = 8 ), dimension(3,3)  a,
real ( kind = 8 ), dimension(3,3)  b,
real ( kind = 8 )  det 
)

Definition at line 15449 of file R8LIB.f90.

15450
15451!*****************************************************************************80
15452!
15453!! R8MAT_INVERSE_3D inverts a 3 by 3 R8MAT using Cramer's rule.
15454!
15455! Discussion:
15456!
15457! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15458!
15459! If the determinant is zero, then A is singular, and does not have an
15460! inverse. In that case, B is simply set to zero, and a
15461! message is printed.
15462!
15463! If the determinant is nonzero, then its value is roughly an estimate
15464! of how nonsingular the matrix A is.
15465!
15466! Licensing:
15467!
15468! This code is distributed under the GNU LGPL license.
15469!
15470! Modified:
15471!
15472! 29 November 1998
15473!
15474! Author:
15475!
15476! John Burkardt
15477!
15478! Parameters:
15479!
15480! Input, real ( kind = 8 ) A(3,3), the matrix to be inverted.
15481!
15482! Output, real ( kind = 8 ) B(3,3), the inverse of the matrix A.
15483!
15484! Output, real ( kind = 8 ) DET, the determinant of the matrix A.
15485!
15486 implicit none
15487
15488 real ( kind = 8 ) a(3,3)
15489 real ( kind = 8 ) b(3,3)
15490 real ( kind = 8 ) det
15491 real ( kind = 8 ) r8mat_det_3d
15492!
15493! Compute the determinant of A.
15494!
15495 det = r8mat_det_3d( a )
15496!
15497! If the determinant is zero, bail out.
15498!
15499 if ( det == 0.0d+00 ) then
15500 b(1:3,1:3) = 0.0d+00
15501 return
15502 end if
15503!
15504! Compute the entries of the inverse matrix using an explicit
15505! formula.
15506!
15507 b(1,1) = ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) / det
15508 b(1,2) = -( a(1,2) * a(3,3) - a(1,3) * a(3,2) ) / det
15509 b(1,3) = ( a(1,2) * a(2,3) - a(1,3) * a(2,2) ) / det
15510
15511 b(2,1) = -( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) / det
15512 b(2,2) = ( a(1,1) * a(3,3) - a(1,3) * a(3,1) ) / det
15513 b(2,3) = -( a(1,1) * a(2,3) - a(1,3) * a(2,1) ) / det
15514
15515 b(3,1) = ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) / det
15516 b(3,2) = -( a(1,1) * a(3,2) - a(1,2) * a(3,1) ) / det
15517 b(3,3) = ( a(1,1) * a(2,2) - a(1,2) * a(2,1) ) / det
15518
15519 return

References r8mat_det_3d().

Referenced by r8poly2_ex2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_inverse_4d()

subroutine r8mat_inverse_4d ( real ( kind = 8 ), dimension(4,4)  a,
real ( kind = 8 ), dimension(4,4)  b,
real ( kind = 8 )  det 
)

Definition at line 15521 of file R8LIB.f90.

15522
15523!*****************************************************************************80
15524!
15525!! R8MAT_INVERSE_4D inverts a 4 by 4 R8MAT using Cramer's rule.
15526!
15527! Discussion:
15528!
15529! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15530!
15531! If the determinant is zero, then A is singular, and does not have an
15532! inverse. In that case, B is simply set to zero, and a
15533! message is printed.
15534!
15535! If the determinant is nonzero, then its value is roughly an estimate
15536! of how nonsingular the matrix A is.
15537!
15538! Licensing:
15539!
15540! This code is distributed under the GNU LGPL license.
15541!
15542! Modified:
15543!
15544! 13 July 1999
15545!
15546! Author:
15547!
15548! John Burkardt
15549!
15550! Parameters:
15551!
15552! Input, real ( kind = 8 ) A(4,4), the matrix to be inverted.
15553!
15554! Output, real ( kind = 8 ) B(4,4), the inverse of the matrix A.
15555!
15556! Output, real ( kind = 8 ) DET, the determinant of the matrix A.
15557!
15558 implicit none
15559
15560 real ( kind = 8 ) a(4,4)
15561 real ( kind = 8 ) b(4,4)
15562 real ( kind = 8 ) det
15563 real ( kind = 8 ) r8mat_det_4d
15564!
15565! Compute the determinant of A.
15566!
15567 det = r8mat_det_4d( a )
15568!
15569! If the determinant is zero, bail out.
15570!
15571 if ( det == 0.0d+00 ) then
15572
15573 b(1:4,1:4) = 0.0d+00
15574
15575 return
15576 end if
15577!
15578! Compute the entries of the inverse matrix using an explicit formula.
15579!
15580 b(1,1) = +( &
15581 + a(2,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
15582 + a(2,3) * ( a(3,4) * a(4,2) - a(3,2) * a(4,4) ) &
15583 + a(2,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) &
15584 ) / det
15585
15586 b(2,1) = -( &
15587 + a(2,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
15588 + a(2,3) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) &
15589 + a(2,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) &
15590 ) / det
15591
15592 b(3,1) = +( &
15593 + a(2,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) &
15594 + a(2,2) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) &
15595 + a(2,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) &
15596 ) / det
15597
15598 b(4,1) = -( &
15599 + a(2,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) &
15600 + a(2,2) * ( a(3,3) * a(4,1) - a(3,1) * a(4,3) ) &
15601 + a(2,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) &
15602 ) / det
15603
15604 b(1,2) = -( &
15605 + a(1,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
15606 + a(1,3) * ( a(3,4) * a(4,2) - a(3,2) * a(4,4) ) &
15607 + a(1,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) &
15608 ) / det
15609
15610 b(2,2) = +( &
15611 + a(1,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) &
15612 + a(1,3) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) &
15613 + a(1,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) &
15614 ) / det
15615
15616 b(3,2) = -( &
15617 + a(1,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) &
15618 + a(1,2) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) &
15619 + a(1,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) &
15620 ) / det
15621
15622 b(4,2) = +( &
15623 + a(1,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) &
15624 + a(1,2) * ( a(3,3) * a(4,1) - a(3,1) * a(4,3) ) &
15625 + a(1,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) &
15626 ) / det
15627
15628 b(1,3) = +( &
15629 + a(1,2) * ( a(2,3) * a(4,4) - a(2,4) * a(4,3) ) &
15630 + a(1,3) * ( a(2,4) * a(4,2) - a(2,2) * a(4,4) ) &
15631 + a(1,4) * ( a(2,2) * a(4,3) - a(2,3) * a(4,2) ) &
15632 ) / det
15633
15634 b(2,3) = -( &
15635 + a(1,1) * ( a(2,3) * a(4,4) - a(2,4) * a(4,3) ) &
15636 + a(1,3) * ( a(2,4) * a(4,1) - a(2,1) * a(4,4) ) &
15637 + a(1,4) * ( a(2,1) * a(4,3) - a(2,3) * a(4,1) ) &
15638 ) / det
15639
15640 b(3,3) = +( &
15641 + a(1,1) * ( a(2,2) * a(4,4) - a(2,4) * a(4,2) ) &
15642 + a(1,2) * ( a(2,4) * a(4,1) - a(2,1) * a(4,4) ) &
15643 + a(1,4) * ( a(2,1) * a(4,2) - a(2,2) * a(4,1) ) &
15644 ) / det
15645
15646 b(4,3) = -( &
15647 + a(1,1) * ( a(2,2) * a(4,3) - a(2,3) * a(4,2) ) &
15648 + a(1,2) * ( a(2,3) * a(4,1) - a(2,1) * a(4,3) ) &
15649 + a(1,3) * ( a(2,1) * a(4,2) - a(2,2) * a(4,1) ) &
15650 ) / det
15651
15652 b(1,4) = -( &
15653 + a(1,2) * ( a(2,3) * a(3,4) - a(2,4) * a(3,3) ) &
15654 + a(1,3) * ( a(2,4) * a(3,2) - a(2,2) * a(3,4) ) &
15655 + a(1,4) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
15656 ) / det
15657
15658 b(2,4) = +( &
15659 + a(1,1) * ( a(2,3) * a(3,4) - a(2,4) * a(3,3) ) &
15660 + a(1,3) * ( a(2,4) * a(3,1) - a(2,1) * a(3,4) ) &
15661 + a(1,4) * ( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) &
15662 ) / det
15663
15664 b(3,4) = -( &
15665 + a(1,1) * ( a(2,2) * a(3,4) - a(2,4) * a(3,2) ) &
15666 + a(1,2) * ( a(2,4) * a(3,1) - a(2,1) * a(3,4) ) &
15667 + a(1,4) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) &
15668 ) / det
15669
15670 b(4,4) = +( &
15671 + a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
15672 + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
15673 + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) &
15674 ) / det
15675
15676 return

References r8mat_det_4d().

Here is the call graph for this function:

◆ r8mat_is_identity()

subroutine r8mat_is_identity ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 )  error_frobenius 
)

Definition at line 15678 of file R8LIB.f90.

15679
15680!*****************************************************************************80
15681!
15682!! R8MAT_IS_IDENTITY determines if an R8MAT is the identity.
15683!
15684! Discussion:
15685!
15686! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15687!
15688! The routine returns the Frobenius norm of A - I.
15689!
15690! Licensing:
15691!
15692! This code is distributed under the GNU LGPL license.
15693!
15694! Modified:
15695!
15696! 02 November 2007
15697!
15698! Author:
15699!
15700! John Burkardt
15701!
15702! Parameters:
15703!
15704! Input, integer ( kind = 4 ) N, the order of the matrix.
15705!
15706! Input, real ( kind = 8 ) A(N,N), the matrix.
15707!
15708! Output, real ( kind = 8 ) ERROR_FROBENIUS, the Frobenius norm
15709! of the difference matrix A - I, which would be exactly zero
15710! if A were the identity matrix.
15711!
15712 implicit none
15713
15714 integer ( kind = 4 ) n
15715
15716 real ( kind = 8 ) a(n,n)
15717 real ( kind = 8 ) error_frobenius
15718 integer ( kind = 4 ) i
15719 integer ( kind = 4 ) j
15720 real ( kind = 8 ) value
15721
15722 error_frobenius = 0.0d+00
15723
15724 do i = 1, n
15725 do j = 1, n
15726 if ( i == j ) then
15727 error_frobenius = error_frobenius + ( a(i,j) - 1.0d+00 )**2
15728 else
15729 error_frobenius = error_frobenius + a(i,j)**2
15730 end if
15731 end do
15732 end do
15733
15734 error_frobenius = sqrt( error_frobenius )
15735
15736 return

◆ r8mat_is_nonnegative()

subroutine r8mat_is_nonnegative ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
logical ( kind = 4 )  ival 
)

Definition at line 15738 of file R8LIB.f90.

15739
15740!*****************************************************************************80
15741!
15742!! R8MAT_IS_NONNEGATIVE checks whether an R8MAT is nonnegative.
15743!
15744! Discussion:
15745!
15746! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15747!
15748! Licensing:
15749!
15750! This code is distributed under the GNU LGPL license.
15751!
15752! Modified:
15753!
15754! 16 October 2013
15755!
15756! Author:
15757!
15758! John Burkardt
15759!
15760! Parameters:
15761!
15762! Input, integer ( kind = 4 ) M, N, the row and column dimensions of
15763! the matrix. M and N must be positive.
15764!
15765! Input, real ( kind = 8 ) A(M,N), the matrix.
15766!
15767! Output, logical ( kind = 4 ) IVAL:
15768! TRUE, the matrix is nonnegative.
15769! FALSE, at least one element of A is less than 0.
15770!
15771 implicit none
15772
15773 integer ( kind = 4 ) m
15774 integer ( kind = 4 ) n
15775
15776 real ( kind = 8 ) a(m,n)
15777 logical ( kind = 4 ) ival
15778
15779 ival = all( 0.0d+00 <= a(1:m,1:n) )
15780
15781 return

◆ r8mat_is_symmetric()

subroutine r8mat_is_symmetric ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 )  error_frobenius 
)

Definition at line 15783 of file R8LIB.f90.

15784
15785!*****************************************************************************80
15786!
15787!! R8MAT_IS_SYMMETRIC checks an R8MAT for symmetry.
15788!
15789! Discussion:
15790!
15791! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15792!
15793! Licensing:
15794!
15795! This code is distributed under the GNU LGPL license.
15796!
15797! Modified:
15798!
15799! 16 October 2007
15800!
15801! Author:
15802!
15803! John Burkardt
15804!
15805! Parameters:
15806!
15807! Input, integer ( kind = 4 ) M, N, the order of the matrix.
15808!
15809! Input, real ( kind = 8 ) A(M,N), the matrix.
15810!
15811! Output, real ( kind = 8 ) ERROR_FROBENIUS, measures the
15812! Frobenius norm of ( A - A' ), which would be zero if the matrix
15813! were exactly symmetric.
15814!
15815 implicit none
15816
15817 integer ( kind = 4 ) m
15818 integer ( kind = 4 ) n
15819
15820 real ( kind = 8 ) a(m,n)
15821 real ( kind = 8 ) error_frobenius
15822 real ( kind = 8 ) value
15823
15824 if ( m /= n ) then
15825
15826 value = huge( value )
15827
15828 else
15829
15830 value = sqrt &
15831 ( &
15832 sum &
15833 ( &
15834 ( &
15835 abs( a(1:m,1:n) - transpose( a(1:m,1:n) ) ) &
15836 ) ** 2 &
15837 ) &
15838 )
15839
15840 end if
15841
15842 error_frobenius = value
15843
15844 return

◆ r8mat_jac()

subroutine r8mat_jac ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 )  eps,
external  fx,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(m,n)  fprime 
)

Definition at line 15846 of file R8LIB.f90.

15847
15848!*****************************************************************************80
15849!
15850!! R8MAT_JAC estimates a dense jacobian matrix of the function FX.
15851!
15852! Discussion:
15853!
15854! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15855!
15856! FPRIME(I,J) = d F(I) / d X(J).
15857!
15858! The jacobian is assumed to be dense, and the LINPACK/LAPACK
15859! double precision general matrix storage mode ("DGE") is used.
15860!
15861! Forward differences are used, requiring N+1 function evaluations.
15862!
15863! Values of EPS have typically been chosen between
15864! sqrt ( EPSMCH ) and sqrt ( sqrt ( EPSMCH ) ) where EPSMCH is the
15865! machine tolerance.
15866!
15867! If EPS is too small, then F(X+EPS) will be the same as
15868! F(X), and the jacobian will be full of zero entries.
15869!
15870! If EPS is too large, the finite difference estimate will
15871! be inaccurate.
15872!
15873! Licensing:
15874!
15875! This code is distributed under the GNU LGPL license.
15876!
15877! Modified:
15878!
15879! 11 December 2004
15880!
15881! Author:
15882!
15883! John Burkardt
15884!
15885! Parameters:
15886!
15887! Input, integer ( kind = 4 ) M, the number of functions.
15888!
15889! Input, integer ( kind = 4 ) N, the number of variables.
15890!
15891! Input, real ( kind = 8 ) EPS, a tolerance to be used for shifting the
15892! X values during the finite differencing. No single value
15893! of EPS will be reliable for all vectors X and functions FX.
15894!
15895! Input, external FX, the name of the user written
15896! routine which evaluates the function at a given point X, of the form:
15897! subroutine fx ( m, n, x, f )
15898! integer ( kind = 4 ) m
15899! integer ( kind = 4 ) n
15900! real ( kind = 8 ) f(m)
15901! real ( kind = 8 ) x(n)
15902! f(1:m) = ...
15903! return
15904! end
15905!
15906! Input, real ( kind = 8 ) X(N), the point where the jacobian
15907! is to be estimated.
15908!
15909! Output, real ( kind = 8 ) FPRIME(M,N), the M by N estimated jacobian
15910! matrix.
15911!
15912 implicit none
15913
15914 integer ( kind = 4 ) m
15915 integer ( kind = 4 ) n
15916
15917 real ( kind = 8 ) del
15918 real ( kind = 8 ) eps
15919 real ( kind = 8 ) fprime(m,n)
15920 external fx
15921 integer ( kind = 4 ) j
15922 real ( kind = 8 ) x(n)
15923 real ( kind = 8 ) xsave
15924 real ( kind = 8 ) work1(m)
15925 real ( kind = 8 ) work2(m)
15926!
15927! Evaluate the function at the base point, X.
15928!
15929 call fx ( m, n, x, work2 )
15930!
15931! Now, one by one, vary each component J of the base point X, and
15932! estimate DF(I)/DX(J) = ( F(X+) - F(X) )/ DEL.
15933!
15934 do j = 1, n
15935
15936 xsave = x(j)
15937 del = eps * ( 1.0d+00 + abs( x(j) ) )
15938 x(j) = x(j) + del
15939 call fx ( m, n, x, work1 )
15940 x(j) = xsave
15941 fprime(1:m,j) = ( work1(1:m) - work2(1:m) ) / del
15942
15943 end do
15944
15945 return

◆ r8mat_kronecker()

subroutine r8mat_kronecker ( integer ( kind = 4 )  m1,
integer ( kind = 4 )  n1,
real ( kind = 8 ), dimension(m1,n1)  a,
integer ( kind = 4 )  m2,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(m2,n2)  b,
real ( kind = 8 ), dimension(m1*m2,n1*n2)  c 
)

Definition at line 15947 of file R8LIB.f90.

15948
15949!*****************************************************************************80
15950!
15951!! R8MAT_KRONECKER computes the Kronecker product of two R8MAT's.
15952!
15953! Discussion:
15954!
15955! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
15956!
15957! If A is an M1 by N1 array, and B is an M2 by N2 array, then
15958! the Kronecker product of A and B is an M1*M2 by N1*N2 array
15959! C(I,J) = A(I1,J1) * B(I2,J2)
15960! where
15961! I1 = ( I - 1 ) / M2 + 1
15962! I2 = mod ( I - 1, M2 ) + 1
15963! J1 = ( J - 1 ) / N2 + 1
15964! J2 = mod ( J - 1, N2 ) + 1
15965!
15966! Licensing:
15967!
15968! This code is distributed under the GNU LGPL license.
15969!
15970! Modified:
15971!
15972! 01 December 2013
15973!
15974! Author:
15975!
15976! John Burkardt
15977!
15978! Parameters:
15979!
15980! Input, integer ( kind = 4 ) M1, N1, the order of the first matrix.
15981!
15982! Input, real ( kind = 8 ) A(M1,N1), the first matrix.
15983!
15984! Input, integer ( kind = 4 ) M2, N2, the order of the second matrix.
15985!
15986! Input, real ( kind = 8 ) B(M2,N2), the second matrix.
15987!
15988! Output, real ( kind = 8 ) C(M1*M2,N1*N2), the Kronecker product.
15989!
15990 implicit none
15991
15992 integer ( kind = 4 ) m1
15993 integer ( kind = 4 ) m2
15994 integer ( kind = 4 ) n1
15995 integer ( kind = 4 ) n2
15996
15997 real ( kind = 8 ) a(m1,n1)
15998 real ( kind = 8 ) b(m2,n2)
15999 real ( kind = 8 ) c(m1*m2,n1*n2)
16000 integer ( kind = 4 ) i
16001 integer ( kind = 4 ) i0
16002 integer ( kind = 4 ) i1
16003 integer ( kind = 4 ) i2
16004 integer ( kind = 4 ) j
16005 integer ( kind = 4 ) j0
16006 integer ( kind = 4 ) j1
16007 integer ( kind = 4 ) j2
16008
16009 do j1 = 1, n1
16010 do i1 = 1, m1
16011 i0 = ( i1 - 1 ) * m2
16012 j0 = ( j1 - 1 ) * n2
16013 j = j0
16014 do j2 = 1, n2
16015 j = j + 1
16016 i = i0
16017 do i2 = 1, m2
16018 i = i + 1
16019 c(i,j) = a(i1,j1) * b(i2,j2)
16020 end do
16021 end do
16022 end do
16023 end do
16024
16025 return

◆ r8mat_l1_inverse()

subroutine r8mat_l1_inverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  b 
)

Definition at line 16275 of file R8LIB.f90.

16276
16277!*****************************************************************************80
16278!
16279!! R8MAT_L1_INVERSE inverts a unit lower triangular R8MAT.
16280!
16281! Discussion:
16282!
16283! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16284!
16285! A unit lower triangular matrix is a matrix with only 1's on the main
16286! diagonal, and only 0's above the main diagonal.
16287!
16288! The inverse of a unit lower triangular matrix is also
16289! a unit lower triangular matrix.
16290!
16291! This routine can invert a matrix in place, that is, with no extra
16292! storage. If the matrix is stored in A, then the call
16293!
16294! call r8mat_l1_inverse ( n, a, a )
16295!
16296! will result in A being overwritten by its inverse.
16297!
16298! Licensing:
16299!
16300! This code is distributed under the GNU LGPL license.
16301!
16302! Modified:
16303!
16304! 05 December 2004
16305!
16306! Author:
16307!
16308! John Burkardt
16309!
16310! Reference:
16311!
16312! Albert Nijenhuis, Herbert Wilf,
16313! Combinatorial Algorithms for Computers and Calculators,
16314! Academic Press, 1978,
16315! ISBN: 0-12-519260-6,
16316! LC: QA164.N54.
16317!
16318! Parameters:
16319!
16320! Input, integer ( kind = 4 ) N, number of rows and columns in the matrix.
16321!
16322! Input, real ( kind = 8 ) A(N,N), the unit lower triangular matrix.
16323!
16324! Output, real ( kind = 8 ) B(N,N), the inverse matrix.
16325!
16326 implicit none
16327
16328 integer ( kind = 4 ) n
16329
16330 real ( kind = 8 ) a(n,n)
16331 real ( kind = 8 ) b(n,n)
16332 integer ( kind = 4 ) i
16333 integer ( kind = 4 ) j
16334
16335 do i = 1, n
16336
16337 do j = 1, n
16338
16339 if ( i < j ) then
16340 b(i,j) = 0.0d+00
16341 else if ( j == i ) then
16342 b(i,j) = 1.0d+00
16343 else
16344 b(i,j) = -dot_product( a(i,1:i-1), b(1:i-1,j) )
16345 end if
16346
16347 end do
16348 end do
16349
16350 return

◆ r8mat_l_inverse()

subroutine r8mat_l_inverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  b 
)

Definition at line 16027 of file R8LIB.f90.

16028
16029!*****************************************************************************80
16030!
16031!! R8MAT_L_INVERSE inverts a lower triangular R8MAT.
16032!
16033! Discussion:
16034!
16035! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16036!
16037! A lower triangular matrix is a matrix whose only nonzero entries
16038! occur on or below the diagonal.
16039!
16040! The inverse of a lower triangular matrix is a lower triangular matrix.
16041!
16042! Licensing:
16043!
16044! This code is distributed under the GNU LGPL license.
16045!
16046! Modified:
16047!
16048! 12 December 2004
16049!
16050! Author:
16051!
16052! John Burkardt
16053!
16054! Reference:
16055!
16056! Albert Nijenhuis, Herbert Wilf,
16057! Combinatorial Algorithms for Computers and Calculators,
16058! Academic Press, 1978,
16059! ISBN: 0-12-519260-6,
16060! LC: QA164.N54.
16061!
16062! Parameters:
16063!
16064! Input, integer ( kind = 4 ) N, number of rows and columns in the matrix.
16065!
16066! Input, real ( kind = 8 ) A(N,N), the lower triangular matrix.
16067!
16068! Output, real ( kind = 8 ) B(N,N), the inverse matrix.
16069!
16070 implicit none
16071
16072 integer ( kind = 4 ) n
16073
16074 real ( kind = 8 ) a(n,n)
16075 real ( kind = 8 ) b(n,n)
16076 integer ( kind = 4 ) i
16077 integer ( kind = 4 ) j
16078
16079 do j = 1, n
16080
16081 do i = 1, n
16082
16083 if ( i < j ) then
16084 b(i,j) = 0.0d+00
16085 else if ( j == i ) then
16086 b(i,j) = 1.0d+00 / a(i,j)
16087 else
16088 b(i,j) = - dot_product( a(i,1:i-1), b(1:i-1,j) ) / a(i,i)
16089 end if
16090
16091 end do
16092 end do
16093
16094 return

◆ r8mat_l_print()

subroutine r8mat_l_print ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
character ( len = * )  title 
)

Definition at line 16096 of file R8LIB.f90.

16097
16098!*****************************************************************************80
16099!
16100!! R8MAT_L_PRINT prints a lower triangular R8MAT.
16101!
16102! Discussion:
16103!
16104! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16105!
16106! Example:
16107!
16108! M = 5, N = 5
16109! A = (/ 11, 21, 31, 41, 51, 22, 32, 42, 52, 33, 43, 53, 44, 54, 55 /)
16110!
16111! 11
16112! 21 22
16113! 31 32 33
16114! 41 42 43 44
16115! 51 52 53 54 55
16116!
16117! Licensing:
16118!
16119! This code is distributed under the GNU LGPL license.
16120!
16121! Modified:
16122!
16123! 23 April 2005
16124!
16125! Author:
16126!
16127! John Burkardt
16128!
16129! Parameters:
16130!
16131! Input, integer ( kind = 4 ) M, the number of rows in A.
16132!
16133! Input, integer ( kind = 4 ) N, the number of columns in A.
16134!
16135! Input, real ( kind = 8 ) A(*), the M by N matrix. Only the lower
16136! triangular elements are stored, in column major order.
16137!
16138! Input, character ( len = * ) TITLE, a title.
16139!
16140 implicit none
16141
16142 integer ( kind = 4 ) m
16143 integer ( kind = 4 ) n
16144
16145 real ( kind = 8 ) a(*)
16146 integer ( kind = 4 ) i
16147 integer ( kind = 4 ) indx(10)
16148 integer ( kind = 4 ) j
16149 integer ( kind = 4 ) jhi
16150 integer ( kind = 4 ) jlo
16151 integer ( kind = 4 ) jmax
16152 integer ( kind = 4 ) nn
16153 integer ( kind = 4 ) size
16154 character ( len = * ) title
16155
16156 write ( *, '(a)' ) ' '
16157 write ( *, '(a)' ) trim( title )
16158
16159 jmax = min( n, m )
16160
16161 if ( m <= n ) then
16162 size = ( m * ( m + 1 ) ) / 2
16163 else if ( n < m ) then
16164 size = ( n * ( n + 1 ) ) / 2 + ( m - n ) * n
16165 end if
16166
16167 if ( all( a(1:size) == aint( a(1:size) ) ) ) then
16168
16169 nn = 10
16170
16171 do jlo = 1, jmax, nn
16172 jhi = min( jlo + nn - 1, m, jmax )
16173 write ( *, '(a)' ) ' '
16174 write ( *, '(a8,10i8)' ) ' Col ', ( j, j = jlo, jhi )
16175 write ( *, '(a6)' ) ' Row '
16176 do i = jlo, m
16177 jhi = min( jlo + nn - 1, i, jmax )
16178 do j = jlo, jhi
16179 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j - 1 ) ) / 2
16180 end do
16181 write ( *, '(i8,10i8)' ) i, int( a(indx(1:jhi+1-jlo)) )
16182 end do
16183 end do
16184
16185 else if ( maxval( abs( a(1:size) ) ) < 1000000.0d+00 ) then
16186
16187 nn = 5
16188
16189 do jlo = 1, jmax, nn
16190 jhi = min( jlo + nn - 1, m - 1, jmax )
16191 write ( *, '(a)' ) ' '
16192 write ( *, '(8x,5(i8,6x))' ) ( j, j = jlo, jhi )
16193 write ( *, '(a)' ) ' '
16194 do i = jlo, m
16195 jhi = min( jlo + nn - 1, i, jmax )
16196 do j = jlo, jhi
16197 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j - 1 ) ) / 2
16198 end do
16199 write ( *, '(i8,5f14.6)' ) i, a(indx(1:jhi+1-jlo))
16200 end do
16201 end do
16202
16203 else
16204
16205 nn = 5
16206
16207 do jlo = 1, jmax, nn
16208 jhi = min( jlo + nn - 1, m - 1, jmax )
16209 write ( *, '(a)' ) ' '
16210 write ( *, '(8x,5(i8,6x))' ) ( j, j = jlo, jhi )
16211 write ( *, '(a)' ) ' '
16212 do i = jlo, m
16213 jhi = min( jlo + nn - 1, i, jmax )
16214 do j = jlo, jhi
16215 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j - 1 ) ) / 2
16216 end do
16217 write ( *, '(i8,5g14.6)' ) i, a(indx(1:jhi+1-jlo))
16218 end do
16219 end do
16220
16221 end if
16222
16223 return

◆ r8mat_l_solve()

subroutine r8mat_l_solve ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 16225 of file R8LIB.f90.

16226
16227!*****************************************************************************80
16228!
16229!! R8MAT_L_SOLVE solves a lower triangular linear system.
16230!
16231! Discussion:
16232!
16233! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16234!
16235! Licensing:
16236!
16237! This code is distributed under the GNU LGPL license.
16238!
16239! Modified:
16240!
16241! 07 December 2004
16242!
16243! Author:
16244!
16245! John Burkardt
16246!
16247! Parameters:
16248!
16249! Input, integer ( kind = 4 ) N, the number of rows and columns of
16250! the matrix A.
16251!
16252! Input, real ( kind = 8 ) A(N,N), the N by N lower triangular matrix.
16253!
16254! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
16255!
16256! Output, real ( kind = 8 ) X(N), the solution of the linear system.
16257!
16258 implicit none
16259
16260 integer ( kind = 4 ) n
16261
16262 real ( kind = 8 ) a(n,n)
16263 real ( kind = 8 ) b(n)
16264 integer ( kind = 4 ) i
16265 real ( kind = 8 ) x(n)
16266!
16267! Solve L * x = b.
16268!
16269 do i = 1, n
16270 x(i) = ( b(i) - dot_product( a(i,1:i-1), x(1:i-1) ) ) / a(i,i)
16271 end do
16272
16273 return

Referenced by r8mat_cholesky_solve().

Here is the caller graph for this function:

◆ r8mat_lt_solve()

subroutine r8mat_lt_solve ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 16352 of file R8LIB.f90.

16353
16354!*****************************************************************************80
16355!
16356!! R8MAT_LT_SOLVE solves a transposed lower triangular linear system.
16357!
16358! Discussion:
16359!
16360! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16361!
16362! Given the lower triangular matrix A, the linear system to be solved is:
16363!
16364! A' * x = b
16365!
16366! Licensing:
16367!
16368! This code is distributed under the GNU LGPL license.
16369!
16370! Modified:
16371!
16372! 07 December 2004
16373!
16374! Author:
16375!
16376! John Burkardt
16377!
16378! Parameters:
16379!
16380! Input, integer ( kind = 4 ) N, the number of rows and columns
16381! of the matrix.
16382!
16383! Input, real ( kind = 8 ) A(N,N), the N by N lower triangular matrix.
16384!
16385! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
16386!
16387! Output, real ( kind = 8 ) X(N), the solution of the linear system.
16388!
16389 implicit none
16390
16391 integer ( kind = 4 ) n
16392
16393 real ( kind = 8 ) a(n,n)
16394 real ( kind = 8 ) b(n)
16395 integer ( kind = 4 ) i
16396 real ( kind = 8 ) x(n)
16397!
16398! Solve L'*x = b.
16399!
16400 do i = n, 1, -1
16401 x(i) = ( b(i) - dot_product( x(i+1:n), a(i+1:n,i) ) ) / a(i,i)
16402 end do
16403
16404 return

Referenced by r8mat_cholesky_solve().

Here is the caller graph for this function:

◆ r8mat_lu()

subroutine r8mat_lu ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m,m)  l,
real ( kind = 8 ), dimension(m,m)  p,
real ( kind = 8 ), dimension(m,n)  u 
)

Definition at line 16406 of file R8LIB.f90.

16407
16408!*****************************************************************************80
16409!
16410!! R8MAT_LU computes the LU factorization of a rectangular R8MAT.
16411!
16412! Discussion:
16413!
16414! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16415!
16416! The routine is given an M by N matrix A, and produces
16417!
16418! L, an M by M unit lower triangular matrix,
16419! U, an M by N upper triangular matrix, and
16420! P, an M by M permutation matrix P,
16421!
16422! so that
16423!
16424! A = P' * L * U.
16425!
16426! Licensing:
16427!
16428! This code is distributed under the GNU LGPL license.
16429!
16430! Modified:
16431!
16432! 05 December 2004
16433!
16434! Author:
16435!
16436! John Burkardt
16437!
16438! Parameters:
16439!
16440! Input, integer ( kind = 4 ) M, the number of rows in A.
16441!
16442! Input, integer ( kind = 4 ) N, the number of columns in A.
16443!
16444! Input, real ( kind = 8 ) A(M,N), the M by N matrix to be factored.
16445!
16446! Output, real ( kind = 8 ) L(M,M), the M by M unit lower triangular factor.
16447!
16448! Output, real ( kind = 8 ) P(M,M), the M by M permutation matrix.
16449!
16450! Output, real ( kind = 8 ) U(M,N), the M by N upper triangular factor.
16451!
16452 implicit none
16453
16454 integer ( kind = 4 ) m
16455 integer ( kind = 4 ) n
16456
16457 real ( kind = 8 ) a(m,n)
16458 integer ( kind = 4 ) i
16459 integer ( kind = 4 ) ipiv
16460 integer ( kind = 4 ) j
16461 real ( kind = 8 ) l(m,m)
16462 real ( kind = 8 ) p(m,m)
16463 real ( kind = 8 ) pivot
16464 real ( kind = 8 ) u(m,n)
16465
16466! Initialize:
16467!
16468! U:=A
16469! L:=Identity
16470! P:=Identity
16471!
16472 u(1:m,1:n) = a(1:m,1:n)
16473
16474 call r8mat_identity ( m, l )
16475
16476 p(1:m,1:m) = l(1:m,1:m)
16477!
16478! On step J, find the pivot row, IPIV, and the pivot value PIVOT.
16479!
16480 do j = 1, min( m - 1, n )
16481
16482 pivot = 0.0d+00
16483 ipiv = 0
16484
16485 do i = j, m
16486
16487 if ( pivot < abs( u(i,j) ) ) then
16488 pivot = abs( u(i,j) )
16489 ipiv = i
16490 end if
16491
16492 end do
16493!
16494! Unless IPIV is zero, swap rows J and IPIV.
16495!
16496 if ( ipiv /= 0 ) then
16497
16498 call r8row_swap ( m, n, u, j, ipiv )
16499
16500 call r8row_swap ( m, m, l, j, ipiv )
16501
16502 call r8row_swap ( m, m, p, j, ipiv )
16503!
16504! Zero out the entries in column J, from row J+1 to M.
16505!
16506 do i = j + 1, m
16507
16508 if ( u(i,j) /= 0.0d+00 ) then
16509
16510 l(i,j) = u(i,j) / u(j,j)
16511
16512 u(i,j) = 0.0d+00
16513
16514 u(i,j+1:n) = u(i,j+1:n) - l(i,j) * u(j,j+1:n)
16515
16516 end if
16517
16518 end do
16519
16520 end if
16521
16522 end do
16523
16524 return

References r8mat_identity(), and r8row_swap().

Here is the call graph for this function:

◆ r8mat_max()

real ( kind = 8 ) function r8mat_max ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16526 of file R8LIB.f90.

16527
16528!*****************************************************************************80
16529!
16530!! R8MAT_MAX returns the maximum entry of an R8MAT.
16531!
16532! Discussion:
16533!
16534! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16535!
16536! Licensing:
16537!
16538! This code is distributed under the GNU LGPL license.
16539!
16540! Modified:
16541!
16542! 11 December 2004
16543!
16544! Author:
16545!
16546! John Burkardt
16547!
16548! Parameters:
16549!
16550! Input, integer ( kind = 4 ) M, the number of rows in A.
16551!
16552! Input, integer ( kind = 4 ) N, the number of columns in A.
16553!
16554! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
16555!
16556! Output, real ( kind = 8 ) R8MAT_MAX, the maximum entry of A.
16557!
16558 implicit none
16559
16560 integer ( kind = 4 ) m
16561 integer ( kind = 4 ) n
16562
16563 real ( kind = 8 ) a(m,n)
16564 real ( kind = 8 ) r8mat_max
16565
16566 r8mat_max = maxval( a(1:m,1:n) )
16567
16568 return
r8mat_max
real(kind=8) function r8mat_max(m, n, a)
Definition R8LIB.f90:16527

References r8mat_max().

Referenced by r8mat_max().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_max_index()

subroutine r8mat_max_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j 
)

Definition at line 16570 of file R8LIB.f90.

16571
16572!*****************************************************************************80
16573!
16574!! R8MAT_MAX_INDEX returns the location of the maximum entry of an R8MAT.
16575!
16576! Discussion:
16577!
16578! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16579!
16580! Licensing:
16581!
16582! This code is distributed under the GNU LGPL license.
16583!
16584! Modified:
16585!
16586! 11 December 2004
16587!
16588! Author:
16589!
16590! John Burkardt
16591!
16592! Parameters:
16593!
16594! Input, integer ( kind = 4 ) M, the number of rows in A.
16595!
16596! Input, integer ( kind = 4 ) N, the number of columns in A.
16597!
16598! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
16599!
16600! Output, integer ( kind = 4 ) I, J, the indices of the maximum entry of A.
16601!
16602 implicit none
16603
16604 integer ( kind = 4 ) m
16605 integer ( kind = 4 ) n
16606
16607 real ( kind = 8 ) a(m,n)
16608 integer ( kind = 4 ) i
16609 integer ( kind = 4 ) ii
16610 integer ( kind = 4 ) j
16611 integer ( kind = 4 ) jj
16612
16613 i = -1
16614 j = -1
16615
16616 do jj = 1, n
16617 do ii = 1, m
16618 if ( ii == 1 .and. jj == 1 ) then
16619 i = ii
16620 j = jj
16621 else if ( a(i,j) < a(ii,jj) ) then
16622 i = ii
16623 j = jj
16624 end if
16625 end do
16626 end do
16627
16628 return

◆ r8mat_maxcol_minrow()

real ( kind = 8 ) function r8mat_maxcol_minrow ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16630 of file R8LIB.f90.

16631
16632!*****************************************************************************80
16633!
16634!! R8MAT_MAXCOL_MINROW gets the maximum column minimum row of an M by N R8MAT.
16635!
16636! Discussion:
16637!
16638! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16639!
16640! R8MAT_MAXCOL_MINROW = max ( 1 <= I <= N ) ( min ( 1 <= J <= M ) A(I,J) )
16641!
16642! For a given matrix, R8MAT_MAXCOL_MINROW <= R8MAT_MINROW_MAXCOL.
16643!
16644! Licensing:
16645!
16646! This code is distributed under the GNU LGPL license.
16647!
16648! Modified:
16649!
16650! 11 December 2004
16651!
16652! Author:
16653!
16654! John Burkardt
16655!
16656! Parameters:
16657!
16658! Input, integer ( kind = 4 ) M, the number of rows in A.
16659!
16660! Input, integer ( kind = 4 ) N, the number of columns in A.
16661!
16662! Input, real ( kind = 8 ) A(M,N), the matrix.
16663!
16664! Output, real ( kind = 8 ) R8MAT_MAXCOL_MINROW, the maximum column
16665! minimum row entry of A.
16666!
16667 implicit none
16668
16669 integer ( kind = 4 ) m
16670 integer ( kind = 4 ) n
16671
16672 real ( kind = 8 ) a(m,n)
16673 integer ( kind = 4 ) i
16674 real ( kind = 8 ) r8mat_maxcol_minrow
16675 real ( kind = 8 ) r8mat_minrow
16676
16677 r8mat_maxcol_minrow = 0.0d+00
16678
16679 do i = 1, m
16680
16681 r8mat_minrow = minval( a(i,1:n) )
16682
16683 if ( i == 1 ) then
16684 r8mat_maxcol_minrow = r8mat_minrow
16685 else
16686 r8mat_maxcol_minrow = max( r8mat_maxcol_minrow, r8mat_minrow )
16687 end if
16688
16689 end do
16690
16691 return
r8mat_maxcol_minrow
real(kind=8) function r8mat_maxcol_minrow(m, n, a)
Definition R8LIB.f90:16631

References r8mat_maxcol_minrow().

Referenced by r8mat_maxcol_minrow().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_maxrow_mincol()

real ( kind = 8 ) function r8mat_maxrow_mincol ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16693 of file R8LIB.f90.

16694
16695!*****************************************************************************80
16696!
16697!! R8MAT_MAXROW_MINCOL gets the maximum row minimum column of an M by N R8MAT.
16698!
16699! Discussion:
16700!
16701! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16702!
16703! R8MAT_MAXROW_MINCOL = max ( 1 <= J <= N ) ( min ( 1 <= I <= M ) A(I,J) )
16704!
16705! For a given matrix, R8MAT_MAXROW_MINCOL <= R8MAT_MINCOL_MAXROW.
16706!
16707! Licensing:
16708!
16709! This code is distributed under the GNU LGPL license.
16710!
16711! Modified:
16712!
16713! 11 December 2004
16714!
16715! Author:
16716!
16717! John Burkardt
16718!
16719! Parameters:
16720!
16721! Input, integer ( kind = 4 ) M, the number of rows in A.
16722!
16723! Input, integer ( kind = 4 ) N, the number of columns in A.
16724!
16725! Input, real ( kind = 8 ) A(M,N), the matrix.
16726!
16727! Output, real ( kind = 8 ) R8MAT_MAXROW_MINCOL, the maximum row
16728! minimum column entry of A.
16729!
16730 implicit none
16731
16732 integer ( kind = 4 ) m
16733 integer ( kind = 4 ) n
16734
16735 real ( kind = 8 ) a(m,n)
16736 integer ( kind = 4 ) j
16737 real ( kind = 8 ) r8mat_maxrow_mincol
16738 real ( kind = 8 ) r8mat_mincol
16739
16740 r8mat_maxrow_mincol = 0.0d+00
16741
16742 do j = 1, n
16743
16744 r8mat_mincol = minval( a(1:m,j) )
16745
16746 if ( j == 1 ) then
16747 r8mat_maxrow_mincol = r8mat_mincol
16748 else
16749 r8mat_maxrow_mincol = max( r8mat_maxrow_mincol, r8mat_mincol )
16750 end if
16751
16752 end do
16753
16754 return
r8mat_maxrow_mincol
real(kind=8) function r8mat_maxrow_mincol(m, n, a)
Definition R8LIB.f90:16694

References r8mat_maxrow_mincol().

Referenced by r8mat_maxrow_mincol().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_mean()

real ( kind = 8 ) function r8mat_mean ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16756 of file R8LIB.f90.

16757
16758!*****************************************************************************80
16759!
16760!! R8MAT_MEAN returns the mean of an M by N R8MAT.
16761!
16762! Discussion:
16763!
16764! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16765!
16766! Licensing:
16767!
16768! This code is distributed under the GNU LGPL license.
16769!
16770! Modified:
16771!
16772! 03 September 2013
16773!
16774! Author:
16775!
16776! John Burkardt
16777!
16778! Parameters:
16779!
16780! Input, integer ( kind = 4 ) M, the number of rows in A.
16781!
16782! Input, integer ( kind = 4 ) N, the number of columns in A.
16783!
16784! Input, real ( kind = 8 ) A(M,N), the matrix.
16785!
16786! Output, real ( kind = 8 ) R8MAT_MEAN, the minimum entry of A.
16787!
16788 implicit none
16789
16790 integer ( kind = 4 ) m
16791 integer ( kind = 4 ) n
16792
16793 real ( kind = 8 ) a(m,n)
16794 real ( kind = 8 ) r8mat_mean
16795
16796 r8mat_mean = sum( a(1:m,1:n) ) / real( m * n, kind = 8 )
16797
16798 return
r8mat_mean
real(kind=8) function r8mat_mean(m, n, a)
Definition R8LIB.f90:16757

References r8mat_mean().

Referenced by r8mat_mean().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_min()

real ( kind = 8 ) function r8mat_min ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16800 of file R8LIB.f90.

16801
16802!*****************************************************************************80
16803!
16804!! R8MAT_MIN returns the minimum entry of an M by N R8MAT.
16805!
16806! Discussion:
16807!
16808! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16809!
16810! Licensing:
16811!
16812! This code is distributed under the GNU LGPL license.
16813!
16814! Modified:
16815!
16816! 12 December 2004
16817!
16818! Author:
16819!
16820! John Burkardt
16821!
16822! Parameters:
16823!
16824! Input, integer ( kind = 4 ) M, the number of rows in A.
16825!
16826! Input, integer ( kind = 4 ) N, the number of columns in A.
16827!
16828! Input, real ( kind = 8 ) A(M,N), the matrix.
16829!
16830! Output, real ( kind = 8 ) R8MAT_MIN, the minimum entry of A.
16831!
16832 implicit none
16833
16834 integer ( kind = 4 ) m
16835 integer ( kind = 4 ) n
16836
16837 real ( kind = 8 ) a(m,n)
16838 real ( kind = 8 ) r8mat_min
16839
16840 r8mat_min = minval( a(1:m,1:n) )
16841
16842 return
r8mat_min
real(kind=8) function r8mat_min(m, n, a)
Definition R8LIB.f90:16801

References r8mat_min().

Referenced by r8mat_min().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_min_index()

subroutine r8mat_min_index ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j 
)

Definition at line 16844 of file R8LIB.f90.

16845
16846!*****************************************************************************80
16847!
16848!! R8MAT_MIN_INDEX returns the location of the minimum entry of an R8MAT.
16849!
16850! Discussion:
16851!
16852! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16853!
16854! Licensing:
16855!
16856! This code is distributed under the GNU LGPL license.
16857!
16858! Modified:
16859!
16860! 11 December 2004
16861!
16862! Author:
16863!
16864! John Burkardt
16865!
16866! Parameters:
16867!
16868! Input, integer ( kind = 4 ) M, the number of rows in A.
16869!
16870! Input, integer ( kind = 4 ) N, the number of columns in A.
16871!
16872! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
16873!
16874! Output, integer ( kind = 4 ) I, J, the indices of the minimum entry of A.
16875!
16876 implicit none
16877
16878 integer ( kind = 4 ) m
16879 integer ( kind = 4 ) n
16880
16881 real ( kind = 8 ) a(m,n)
16882 integer ( kind = 4 ) i
16883 integer ( kind = 4 ) ii
16884 integer ( kind = 4 ) j
16885 integer ( kind = 4 ) jj
16886
16887 i = -1
16888 j = -1
16889
16890 do jj = 1, n
16891 do ii = 1, m
16892 if ( ii == 1 .and. jj == 1 ) then
16893 i = ii
16894 j = jj
16895 else if ( a(ii,jj) < a(i,j) ) then
16896 i = ii
16897 j = jj
16898 end if
16899 end do
16900 end do
16901
16902 return

◆ r8mat_mincol_maxrow()

real ( kind = 8 ) function r8mat_mincol_maxrow ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16904 of file R8LIB.f90.

16905
16906!*****************************************************************************80
16907!
16908!! R8MAT_MINCOL_MAXROW gets the minimum column maximum row of an M by N R8MAT.
16909!
16910! Discussion:
16911!
16912! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16913!
16914! R8MAT_MINCOL_MAXROW = min ( 1 <= I <= N ) ( max ( 1 <= J <= M ) A(I,J) )
16915!
16916! For a given matrix, R8MAT_MAXROW_MINCOL <= R8MAT_MINCOL_MAXROW.
16917!
16918! Licensing:
16919!
16920! This code is distributed under the GNU LGPL license.
16921!
16922! Modified:
16923!
16924! 12 December 2004
16925!
16926! Author:
16927!
16928! John Burkardt
16929!
16930! Parameters:
16931!
16932! Input, integer ( kind = 4 ) M, the number of rows in A.
16933!
16934! Input, integer ( kind = 4 ) N, the number of columns in A.
16935!
16936! Input, real ( kind = 8 ) A(M,N), the matrix.
16937!
16938! Output, real ( kind = 8 ) R8MAT_MINCOL_MAXROW, the minimum column
16939! maximum row entry of A.
16940!
16941 implicit none
16942
16943 integer ( kind = 4 ) m
16944 integer ( kind = 4 ) n
16945
16946 real ( kind = 8 ) a(m,n)
16947 integer ( kind = 4 ) i
16948 real ( kind = 8 ) r8mat_mincol_maxrow
16949 real ( kind = 8 ) r8mat_maxrow
16950
16951 r8mat_mincol_maxrow = 0.0d+00
16952
16953 do i = 1, m
16954
16955 r8mat_maxrow = maxval( a(i,1:n) )
16956
16957 if ( i == 1 ) then
16958 r8mat_mincol_maxrow = r8mat_maxrow
16959 else
16960 r8mat_mincol_maxrow = min( r8mat_mincol_maxrow, r8mat_maxrow )
16961 end if
16962
16963 end do
16964
16965 return
r8mat_mincol_maxrow
real(kind=8) function r8mat_mincol_maxrow(m, n, a)
Definition R8LIB.f90:16905

References r8mat_mincol_maxrow().

Referenced by r8mat_mincol_maxrow().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_minrow_maxcol()

real ( kind = 8 ) function r8mat_minrow_maxcol ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 16967 of file R8LIB.f90.

16968
16969!*****************************************************************************80
16970!
16971!! R8MAT_MINROW_MAXCOL gets the minimum row maximum column of an M by N R8MAT.
16972!
16973! Discussion:
16974!
16975! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
16976!
16977! R8MAT_MINROW_MAXCOL = min ( 1 <= J <= N ) ( max ( 1 <= I <= M ) A(I,J) )
16978!
16979! For a given matrix, R8MAT_MAXCOL_MINROW <= R8MAT_MINROW_MAXCOL.
16980!
16981! Licensing:
16982!
16983! This code is distributed under the GNU LGPL license.
16984!
16985! Modified:
16986!
16987! 12 December 2004
16988!
16989! Author:
16990!
16991! John Burkardt
16992!
16993! Parameters:
16994!
16995! Input, integer ( kind = 4 ) M, the number of rows in A.
16996!
16997! Input, integer ( kind = 4 ) N, the number of columns in A.
16998!
16999! Input, real ( kind = 8 ) A(M,N), the matrix.
17000!
17001! Output, real ( kind = 8 ) R8MAT_MINROW_MAXCOL, the minimum row
17002! maximum column entry of A.
17003!
17004 implicit none
17005
17006 integer ( kind = 4 ) m
17007 integer ( kind = 4 ) n
17008
17009 real ( kind = 8 ) a(m,n)
17010 integer ( kind = 4 ) j
17011 real ( kind = 8 ) r8mat_minrow_maxcol
17012 real ( kind = 8 ) r8mat_maxcol
17013
17014 r8mat_minrow_maxcol = 0.0d+00
17015
17016 do j = 1, n
17017
17018 r8mat_maxcol = maxval( a(1:m,j) )
17019
17020 if ( j == 1 ) then
17021 r8mat_minrow_maxcol = r8mat_maxcol
17022 else
17023 r8mat_minrow_maxcol = min( r8mat_minrow_maxcol, r8mat_maxcol )
17024 end if
17025
17026 end do
17027
17028 return
r8mat_minrow_maxcol
real(kind=8) function r8mat_minrow_maxcol(m, n, a)
Definition R8LIB.f90:16968

References r8mat_minrow_maxcol().

Referenced by r8mat_minrow_maxcol().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_minvm()

subroutine r8mat_minvm ( integer ( kind = 4 )  n1,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(n1,n1)  a,
real ( kind = 8 ), dimension(n1,n2)  b,
real ( kind = 8 ), dimension(n1,n2)  c 
)

Definition at line 17030 of file R8LIB.f90.

17031
17032!*****************************************************************************80
17033!
17034!! R8MAT_MINVM computes inverse(A) * B for R8MAT's.
17035!
17036! Discussion:
17037!
17038! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17039!
17040! Licensing:
17041!
17042! This code is distributed under the GNU LGPL license.
17043!
17044! Modified:
17045!
17046! 28 November 2011
17047!
17048! Author:
17049!
17050! John Burkardt
17051!
17052! Parameters:
17053!
17054! Input, integer ( kind = 4 ) N1, N2, the order of the matrices.
17055!
17056! Input, real ( kind = 8 ) A(N1,N1), B(N1,N2), the matrices.
17057!
17058! Output, real ( kind = 8 ) C(N1,N2), the result, C = inverse(A) * B.
17059!
17060 implicit none
17061
17062 integer ( kind = 4 ) n1
17063 integer ( kind = 4 ) n2
17064
17065 real ( kind = 8 ) a(n1,n1)
17066 real ( kind = 8 ) alu(n1,n1)
17067 real ( kind = 8 ) b(n1,n2)
17068 real ( kind = 8 ) c(n1,n2)
17069 integer ( kind = 4 ) info
17070
17071 alu(1:n1,1:n1) = a(1:n1,1:n1)
17072 c(1:n1,1:n2) = b(1:n1,1:n2)
17073
17074 call r8mat_fss ( n1, alu, n2, c, info )
17075
17076 if ( info /= 0 ) then
17077 write ( *, '(a)' ) ' '
17078 write ( *, '(a)' ) 'R8MAT_MINVM - Fatal error!'
17079 write ( *, '(a)' ) ' The matrix A was numerically singular.'
17080 stop 1
17081 end if
17082
17083 return
r8mat_fss
subroutine r8mat_fss(n, a, nb, b, info)
Definition R8LIB.f90:14452

References r8mat_fss().

Here is the call graph for this function:

◆ r8mat_mm()

subroutine r8mat_mm ( integer ( kind = 4 )  n1,
integer ( kind = 4 )  n2,
integer ( kind = 4 )  n3,
real ( kind = 8 ), dimension(n1,n2)  a,
real ( kind = 8 ), dimension(n2,n3)  b,
real ( kind = 8 ), dimension(n1,n3)  c 
)

Definition at line 17085 of file R8LIB.f90.

17086
17087!*****************************************************************************80
17088!
17089!! R8MAT_MM multiplies two R8MAT's.
17090!
17091! Discussion:
17092!
17093! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17094!
17095! In FORTRAN90, this operation is more efficiently done by the
17096! command:
17097!
17098! C(1:N1,1:N3) = MATMUL ( A(1:N1,1;N2), B(1:N2,1:N3) )
17099!
17100! Licensing:
17101!
17102! This code is distributed under the GNU LGPL license.
17103!
17104! Modified:
17105!
17106! 12 December 2004
17107!
17108! Author:
17109!
17110! John Burkardt
17111!
17112! Parameters:
17113!
17114! Input, integer ( kind = 4 ) N1, N2, N3, the order of the matrices.
17115!
17116! Input, real ( kind = 8 ) A(N1,N2), B(N2,N3), the matrices to multiply.
17117!
17118! Output, real ( kind = 8 ) C(N1,N3), the product matrix C = A * B.
17119!
17120 implicit none
17121
17122 integer ( kind = 4 ) n1
17123 integer ( kind = 4 ) n2
17124 integer ( kind = 4 ) n3
17125
17126 real ( kind = 8 ) a(n1,n2)
17127 real ( kind = 8 ) b(n2,n3)
17128 real ( kind = 8 ) c(n1,n3)
17129
17130 c(1:n1,1:n3) = matmul( a(1:n1,1:n2), b(1:n2,1:n3) )
17131
17132 return

◆ r8mat_mmt()

subroutine r8mat_mmt ( integer ( kind = 4 )  n1,
integer ( kind = 4 )  n2,
integer ( kind = 4 )  n3,
real ( kind = 8 ), dimension(n1,n2)  a,
real ( kind = 8 ), dimension(n3,n2)  b,
real ( kind = 8 ), dimension(n1,n3)  c 
)

Definition at line 17134 of file R8LIB.f90.

17135
17136!*****************************************************************************80
17137!
17138!! R8MAT_MMT computes C = A * B' for two R8MAT's.
17139!
17140! Discussion:
17141!
17142! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17143!
17144! In FORTRAN90, this operation is more efficiently done by the
17145! command:
17146!
17147! C(1:N1,1:N3) = matmul ( A(1:N1,1;N2) ), transpose ( B(1:N3,1:N2) ) )
17148!
17149! Licensing:
17150!
17151! This code is distributed under the GNU LGPL license.
17152!
17153! Modified:
17154!
17155! 13 November 2012
17156!
17157! Author:
17158!
17159! John Burkardt
17160!
17161! Parameters:
17162!
17163! Input, integer ( kind = 4 ) N1, N2, N3, the order of the matrices.
17164!
17165! Input, real ( kind = 8 ) A(N1,N2), B(N3,N2), the matrices to multiply.
17166!
17167! Output, real ( kind = 8 ) C(N1,N3), the product matrix C = A * B.
17168!
17169 implicit none
17170
17171 integer ( kind = 4 ) n1
17172 integer ( kind = 4 ) n2
17173 integer ( kind = 4 ) n3
17174
17175 real ( kind = 8 ) a(n1,n2)
17176 real ( kind = 8 ) b(n3,n2)
17177 real ( kind = 8 ) c(n1,n3)
17178
17179 c(1:n1,1:n3) = matmul( &
17180 a(1:n1,1:n2), &
17181 transpose( b(1:n3,1:n2) ) &
17182 )
17183
17184 return

◆ r8mat_mtm()

subroutine r8mat_mtm ( integer ( kind = 4 )  n1,
integer ( kind = 4 )  n2,
integer ( kind = 4 )  n3,
real ( kind = 8 ), dimension(n2,n1)  a,
real ( kind = 8 ), dimension(n2,n3)  b,
real ( kind = 8 ), dimension(n1,n3)  c 
)

Definition at line 17186 of file R8LIB.f90.

17187
17188!*****************************************************************************80
17189!
17190!! R8MAT_MTM computes C = A' * B for two R8MAT's.
17191!
17192! Discussion:
17193!
17194! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17195!
17196! In FORTRAN90, this operation is more efficiently done by the
17197! command:
17198!
17199! C(1:N1,1:N3) = matmul ( transpose ( A(1:N2,1;N1) ), B(1:N2,1:N3) )
17200!
17201! Licensing:
17202!
17203! This code is distributed under the GNU LGPL license.
17204!
17205! Modified:
17206!
17207! 07 September 2012
17208!
17209! Author:
17210!
17211! John Burkardt
17212!
17213! Parameters:
17214!
17215! Input, integer ( kind = 4 ) N1, N2, N3, the order of the matrices.
17216!
17217! Input, real ( kind = 8 ) A(N2,N1), B(N2,N3), the matrices to multiply.
17218!
17219! Output, real ( kind = 8 ) C(N1,N3), the product matrix C = A * B.
17220!
17221 implicit none
17222
17223 integer ( kind = 4 ) n1
17224 integer ( kind = 4 ) n2
17225 integer ( kind = 4 ) n3
17226
17227 real ( kind = 8 ) a(n2,n1)
17228 real ( kind = 8 ) b(n2,n3)
17229 real ( kind = 8 ) c(n1,n3)
17230
17231 c(1:n1,1:n3) = matmul( transpose( a(1:n2,1:n1) ), b(1:n2,1:n3) )
17232
17233 return

◆ r8mat_mtv()

subroutine r8mat_mtv ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  x,
real ( kind = 8 ), dimension(n)  y 
)

Definition at line 17235 of file R8LIB.f90.

17236
17237!*****************************************************************************80
17238!
17239!! R8MAT_MTV multiplies a transposed matrix times a vector
17240!
17241! Discussion:
17242!
17243! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17244!
17245! Licensing:
17246!
17247! This code is distributed under the GNU LGPL license.
17248!
17249! Modified:
17250!
17251! 12 December 2004
17252!
17253! Author:
17254!
17255! John Burkardt
17256!
17257! Parameters:
17258!
17259! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
17260! the matrix.
17261!
17262! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
17263!
17264! Input, real ( kind = 8 ) X(M), the vector to be multiplied by A.
17265!
17266! Output, real ( kind = 8 ) Y(N), the product A'*X.
17267!
17268 implicit none
17269
17270 integer ( kind = 4 ) m
17271 integer ( kind = 4 ) n
17272
17273 real ( kind = 8 ) a(m,n)
17274 real ( kind = 8 ) x(m)
17275 real ( kind = 8 ) y(n)
17276
17277 y(1:n) = matmul( transpose( a(1:m,1:n) ), x(1:m) )
17278
17279 return

◆ r8mat_mv()

subroutine r8mat_mv ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(m)  y 
)

Definition at line 17281 of file R8LIB.f90.

17282
17283!*****************************************************************************80
17284!
17285!! R8MAT_MV multiplies a matrix times a vector.
17286!
17287! Discussion:
17288!
17289! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17290!
17291! In FORTRAN90, this operation can be more efficiently carried
17292! out by the command
17293!
17294! Y(1:M) = MATMUL ( A(1:M,1:N), X(1:N) )
17295!
17296! Licensing:
17297!
17298! This code is distributed under the GNU LGPL license.
17299!
17300! Modified:
17301!
17302! 12 December 2004
17303!
17304! Author:
17305!
17306! John Burkardt
17307!
17308! Parameters:
17309!
17310! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
17311! the matrix.
17312!
17313! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
17314!
17315! Input, real ( kind = 8 ) X(N), the vector to be multiplied by A.
17316!
17317! Output, real ( kind = 8 ) Y(M), the product A*X.
17318!
17319 implicit none
17320
17321 integer ( kind = 4 ) m
17322 integer ( kind = 4 ) n
17323
17324 real ( kind = 8 ) a(m,n)
17325 integer ( kind = 4 ) i
17326 integer ( kind = 4 ) j
17327 real ( kind = 8 ) x(n)
17328 real ( kind = 8 ) y(m)
17329
17330 y(1:m) = matmul( a(1:m,1:n), x(1:n) )
17331
17332 return

◆ r8mat_nint()

subroutine r8mat_nint ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17334 of file R8LIB.f90.

17335
17336!*****************************************************************************80
17337!
17338!! R8MAT_NINT rounds the entries of an R8MAT.
17339!
17340! Discussion:
17341!
17342! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17343!
17344! Licensing:
17345!
17346! This code is distributed under the GNU LGPL license.
17347!
17348! Modified:
17349!
17350! 12 December 2004
17351!
17352! Author:
17353!
17354! John Burkardt
17355!
17356! Parameters:
17357!
17358! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
17359!
17360! Input/output, real ( kind = 8 ) A(M,N), the matrix to be NINT'ed.
17361!
17362 implicit none
17363
17364 integer ( kind = 4 ) m
17365 integer ( kind = 4 ) n
17366
17367 real ( kind = 8 ) a(m,n)
17368
17369 a(1:m,1:n) = real( nint( a(1:m,1:n) ), kind = 8 )
17370
17371 return

◆ r8mat_nonzeros()

integer ( kind = 4 ) function r8mat_nonzeros ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17373 of file R8LIB.f90.

17374
17375!*****************************************************************************80
17376!
17377!! R8MAT_NONZEROS counts the nonzeros in an R8MAT.
17378!
17379! Discussion:
17380!
17381! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17382!
17383! Licensing:
17384!
17385! This code is distributed under the GNU LGPL license.
17386!
17387! Modified:
17388!
17389! 31 August 2014
17390!
17391! Author:
17392!
17393! John Burkardt
17394!
17395! Parameters:
17396!
17397! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
17398!
17399! Input, real ( kind = 8 ) A(M,N), the matrix.
17400!
17401! Output, integer ( kind = 4 ) R8MAT_NONZEROS, the number of nonzeros.
17402!
17403 implicit none
17404
17405 integer ( kind = 4 ) m
17406 integer ( kind = 4 ) n
17407
17408 real ( kind = 8 ) a(m,n)
17409 integer ( kind = 4 ) i
17410 integer ( kind = 4 ) j
17411 integer ( kind = 4 ) r8mat_nonzeros
17412 integer ( kind = 4 ) value
17413
17414 value = 0
17415 do j = 1, n
17416 do i = 1, m
17417 if ( a(i,j) /= 0.0d+00 ) then
17418 value = value + 1
17419 end if
17420 end do
17421 end do
17422
17423 r8mat_nonzeros = value
17424
17425 return
r8mat_nonzeros
integer(kind=4) function r8mat_nonzeros(m, n, a)
Definition R8LIB.f90:17374

References r8mat_nonzeros().

Referenced by r8mat_nonzeros().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_eis()

real ( kind = 8 ) function r8mat_norm_eis ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17427 of file R8LIB.f90.

17428
17429!*****************************************************************************80
17430!
17431!! R8MAT_NORM_EIS returns the EISPACK norm of an R8MAT.
17432!
17433! Discussion:
17434!
17435! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17436!
17437! The EISPACK norm is defined as:
17438!
17439! R8MAT_NORM_EIS =
17440! sum ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) )
17441!
17442! Licensing:
17443!
17444! This code is distributed under the GNU LGPL license.
17445!
17446! Modified:
17447!
17448! 11 December 2004
17449!
17450! Author:
17451!
17452! John Burkardt
17453!
17454! Parameters:
17455!
17456! Input, integer ( kind = 4 ) M, the number of rows in A.
17457!
17458! Input, integer ( kind = 4 ) N, the number of columns in A.
17459!
17460! Input, real ( kind = 8 ) A(M,N), the matrix whose EISPACK norm is desired.
17461!
17462! Output, real ( kind = 8 ) R8MAT_NORM_EIS, the EISPACK norm of A.
17463!
17464 implicit none
17465
17466 integer ( kind = 4 ) m
17467 integer ( kind = 4 ) n
17468
17469 real ( kind = 8 ) a(m,n)
17470 real ( kind = 8 ) r8mat_norm_eis
17471
17472 r8mat_norm_eis = sum( abs( a(1:m,1:n) ) )
17473
17474 return
r8mat_norm_eis
real(kind=8) function r8mat_norm_eis(m, n, a)
Definition R8LIB.f90:17428

References r8mat_norm_eis().

Referenced by r8mat_norm_eis().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_fro()

real ( kind = 8 ) function r8mat_norm_fro ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17476 of file R8LIB.f90.

17477
17478!*****************************************************************************80
17479!
17480!! R8MAT_NORM_FRO returns the Frobenius norm of an R8MAT.
17481!
17482! Discussion:
17483!
17484! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17485!
17486! The Frobenius norm is defined as
17487!
17488! R8MAT_NORM_FRO = sqrt (
17489! sum ( 1 <= I <= M ) sum ( 1 <= j <= N ) A(I,J) * A(I,J) )
17490!
17491! The matrix Frobenius norm is not derived from a vector norm, but
17492! is compatible with the vector L2 norm, so that:
17493!
17494! r8vec_norm_l2 ( A * x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ).
17495!
17496! Licensing:
17497!
17498! This code is distributed under the GNU LGPL license.
17499!
17500! Modified:
17501!
17502! 24 March 2000
17503!
17504! Author:
17505!
17506! John Burkardt
17507!
17508! Parameters:
17509!
17510! Input, integer ( kind = 4 ) M, the number of rows in A.
17511!
17512! Input, integer ( kind = 4 ) N, the number of columns in A.
17513!
17514! Input, real ( kind = 8 ) A(M,N), the matrix whose Frobenius
17515! norm is desired.
17516!
17517! Output, real ( kind = 8 ) R8MAT_NORM_FRO, the Frobenius norm of A.
17518!
17519 implicit none
17520
17521 integer ( kind = 4 ) m
17522 integer ( kind = 4 ) n
17523
17524 real ( kind = 8 ) a(m,n)
17525 real ( kind = 8 ) r8mat_norm_fro
17526
17527 r8mat_norm_fro = sqrt( sum( a(1:m,1:n)**2 ) )
17528
17529 return
r8mat_norm_fro
real(kind=8) function r8mat_norm_fro(m, n, a)
Definition R8LIB.f90:17477

References r8mat_norm_fro().

Referenced by r8mat_norm_fro(), and r8mat_symm_jacobi().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_fro_affine()

real ( kind = 8 ) function r8mat_norm_fro_affine ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a1,
real ( kind = 8 ), dimension(m,n)  a2 
)

Definition at line 17531 of file R8LIB.f90.

17532
17533!*****************************************************************************80
17534!
17535!! R8MAT_NORM_FRO_AFFINE returns the Frobenius norm of an R8MAT difference.
17536!
17537! Discussion:
17538!
17539! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17540!
17541! The Frobenius norm is defined as
17542!
17543! R8MAT_NORM_FRO = sqrt (
17544! sum ( 1 <= I <= M ) sum ( 1 <= j <= N ) A(I,J) * A(I,J) )
17545!
17546! The matrix Frobenius norm is not derived from a vector norm, but
17547! is compatible with the vector L2 norm, so that:
17548!
17549! r8vec_norm_l2 ( A * x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ).
17550!
17551! Licensing:
17552!
17553! This code is distributed under the GNU LGPL license.
17554!
17555! Modified:
17556!
17557! 24 March 2000
17558!
17559! Author:
17560!
17561! John Burkardt
17562!
17563! Parameters:
17564!
17565! Input, integer ( kind = 4 ) M, the number of rows.
17566!
17567! Input, integer ( kind = 4 ) N, the number of columns.
17568!
17569! Input, real ( kind = 8 ) A1(M,N), A2(M,N), the matrices for whose
17570! difference the Frobenius norm is desired.
17571!
17572! Output, real ( kind = 8 ) R8MAT_NORM_FRO_AFFINE, the Frobenius
17573! norm of A1 - A2.
17574!
17575 implicit none
17576
17577 integer ( kind = 4 ) m
17578 integer ( kind = 4 ) n
17579
17580 real ( kind = 8 ) a1(m,n)
17581 real ( kind = 8 ) a2(m,n)
17582 real ( kind = 8 ) r8mat_norm_fro_affine
17583
17584 r8mat_norm_fro_affine = sqrt( sum( ( a1(1:m,1:n) - a2(1:m,1:n) )**2 ) )
17585
17586 return
r8mat_norm_fro_affine
real(kind=8) function r8mat_norm_fro_affine(m, n, a1, a2)
Definition R8LIB.f90:17532

References r8mat_norm_fro_affine().

Referenced by r8mat_norm_fro_affine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_l1()

real ( kind = 8 ) function r8mat_norm_l1 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17588 of file R8LIB.f90.

17589
17590!*****************************************************************************80
17591!
17592!! R8MAT_NORM_L1 returns the matrix L1 norm of an R8MAT.
17593!
17594! Discussion:
17595!
17596! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17597!
17598! The matrix L1 norm is defined as:
17599!
17600! R8MAT_NORM_L1 = max ( 1 <= J <= N )
17601! sum ( 1 <= I <= M ) abs ( A(I,J) ).
17602!
17603! The matrix L1 norm is derived from the vector L1 norm, and
17604! satisifies:
17605!
17606! r8vec_norm_l1 ( A * x ) <= r8mat_norm_l1 ( A ) * r8vec_norm_l1 ( x ).
17607!
17608! Licensing:
17609!
17610! This code is distributed under the GNU LGPL license.
17611!
17612! Modified:
17613!
17614! 11 December 2004
17615!
17616! Author:
17617!
17618! John Burkardt
17619!
17620! Parameters:
17621!
17622! Input, integer ( kind = 4 ) M, the number of rows in A.
17623!
17624! Input, integer ( kind = 4 ) N, the number of columns in A.
17625!
17626! Input, real ( kind = 8 ) A(M,N), the matrix whose L1 norm is desired.
17627!
17628! Output, real ( kind = 8 ) R8MAT_NORM_L1, the L1 norm of A.
17629!
17630 implicit none
17631
17632 integer ( kind = 4 ) m
17633 integer ( kind = 4 ) n
17634
17635 real ( kind = 8 ) a(m,n)
17636 real ( kind = 8 ) col_sum
17637 integer ( kind = 4 ) j
17638 real ( kind = 8 ) r8mat_norm_l1
17639
17640 r8mat_norm_l1 = 0.0d+00
17641
17642 do j = 1, n
17643 col_sum = sum( abs( a(1:m,j) ) )
17644 r8mat_norm_l1 = max( r8mat_norm_l1, col_sum )
17645 end do
17646
17647 return
r8mat_norm_l1
real(kind=8) function r8mat_norm_l1(m, n, a)
Definition R8LIB.f90:17589

References r8mat_norm_l1().

Referenced by r8mat_norm_l1().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_l2()

real ( kind = 8 ) function r8mat_norm_l2 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17649 of file R8LIB.f90.

17650
17651!*****************************************************************************80
17652!
17653!! R8MAT_NORM_L2 returns the matrix L2 norm of an R8MAT.
17654!
17655! Discussion:
17656!
17657! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17658!
17659! The matrix L2 norm is defined as:
17660!
17661! R8MAT_NORM_L2 = sqrt ( max ( 1 <= I <= M ) LAMBDA(I) )
17662!
17663! where LAMBDA contains the eigenvalues of A * A'.
17664!
17665! The matrix L2 norm is derived from the vector L2 norm, and
17666! satisifies:
17667!
17668! r8vec_norm_l2 ( A * x ) <= r8mat_norm_l2 ( A ) * r8vec_norm_l2 ( x ).
17669!
17670! Licensing:
17671!
17672! This code is distributed under the GNU LGPL license.
17673!
17674! Modified:
17675!
17676! 19 March 2001
17677!
17678! Author:
17679!
17680! John Burkardt
17681!
17682! Parameters:
17683!
17684! Input, integer ( kind = 4 ) M, the number of rows in A.
17685!
17686! Input, integer ( kind = 4 ) N, the number of columns in A.
17687!
17688! Input, real ( kind = 8 ) A(M,N), the matrix whose L2 norm is desired.
17689!
17690! Output, real ( kind = 8 ) R8MAT_NORM_L2, the L2 norm of A.
17691!
17692 implicit none
17693
17694 integer ( kind = 4 ) m
17695 integer ( kind = 4 ) n
17696
17697 real ( kind = 8 ) a(m,n)
17698 real ( kind = 8 ) b(m,m)
17699 real ( kind = 8 ) diag(m)
17700 real ( kind = 8 ) r8mat_norm_l2
17701!
17702! Compute B = A * A'.
17703!
17704 b(1:m,1:m) = matmul( a(1:m,1:n), transpose( a(1:m,1:n) ) )
17705!
17706! Diagonalize B.
17707!
17708 call r8mat_symm_jacobi ( m, b )
17709!
17710! Find the maximum eigenvalue, and take its square root.
17711!
17712 call r8mat_diag_get_vector ( m, b, diag )
17713
17714 r8mat_norm_l2 = sqrt( maxval( diag(1:m) ) )
17715
17716 return
r8mat_norm_l2
real(kind=8) function r8mat_norm_l2(m, n, a)
Definition R8LIB.f90:17650
r8mat_diag_get_vector
subroutine r8mat_diag_get_vector(n, a, v)
Definition R8LIB.f90:13755
r8mat_symm_jacobi
subroutine r8mat_symm_jacobi(n, a)
Definition R8LIB.f90:19846

References r8mat_diag_get_vector(), r8mat_norm_l2(), and r8mat_symm_jacobi().

Referenced by r8mat_norm_l2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_norm_li()

real ( kind = 8 ) function r8mat_norm_li ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 17718 of file R8LIB.f90.

17719
17720!*****************************************************************************80
17721!
17722!! R8MAT_NORM_LI returns the matrix L-oo norm of an R8MAT.
17723!
17724! Discussion:
17725!
17726! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17727!
17728! The matrix L-oo norm is defined as:
17729!
17730! R8MAT_NORM_LI = max ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) ).
17731!
17732! The matrix L-oo norm is derived from the vector L-oo norm,
17733! and satisifies:
17734!
17735! r8vec_norm_li ( A * x ) <= r8mat_norm_li ( A ) * r8vec_norm_li ( x ).
17736!
17737! Licensing:
17738!
17739! This code is distributed under the GNU LGPL license.
17740!
17741! Modified:
17742!
17743! 11 December 2004
17744!
17745! Author:
17746!
17747! John Burkardt
17748!
17749! Parameters:
17750!
17751! Input, integer ( kind = 4 ) M, the number of rows in A.
17752!
17753! Input, integer ( kind = 4 ) N, the number of columns in A.
17754!
17755! Input, real ( kind = 8 ) A(M,N), the matrix whose L-oo
17756! norm is desired.
17757!
17758! Output, real ( kind = 8 ) R8MAT_NORM_LI, the L-oo norm of A.
17759!
17760 implicit none
17761
17762 integer ( kind = 4 ) m
17763 integer ( kind = 4 ) n
17764
17765 real ( kind = 8 ) a(m,n)
17766 integer ( kind = 4 ) i
17767 real ( kind = 8 ) r8mat_norm_li
17768 real ( kind = 8 ) row_sum
17769
17770 r8mat_norm_li = 0.0d+00
17771
17772 do i = 1, m
17773 row_sum = sum( abs( a(i,1:n) ) )
17774 r8mat_norm_li = max( r8mat_norm_li, row_sum )
17775 end do
17776
17777 return
r8mat_norm_li
real(kind=8) function r8mat_norm_li(m, n, a)
Definition R8LIB.f90:17719

References r8mat_norm_li().

Referenced by r8mat_norm_li().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_normal_01()

subroutine r8mat_normal_01 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  r 
)

Definition at line 17779 of file R8LIB.f90.

17780
17781!*****************************************************************************80
17782!
17783!! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
17784!
17785! Discussion:
17786!
17787! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17788!
17789! Licensing:
17790!
17791! This code is distributed under the GNU LGPL license.
17792!
17793! Modified:
17794!
17795! 12 November 2010
17796!
17797! Author:
17798!
17799! John Burkardt
17800!
17801! Reference:
17802!
17803! Paul Bratley, Bennett Fox, Linus Schrage,
17804! A Guide to Simulation,
17805! Second Edition,
17806! Springer, 1987,
17807! ISBN: 0387964673,
17808! LC: QA76.9.C65.B73.
17809!
17810! Bennett Fox,
17811! Algorithm 647:
17812! Implementation and Relative Efficiency of Quasirandom
17813! Sequence Generators,
17814! ACM Transactions on Mathematical Software,
17815! Volume 12, Number 4, December 1986, pages 362-376.
17816!
17817! Pierre L'Ecuyer,
17818! Random Number Generation,
17819! in Handbook of Simulation,
17820! edited by Jerry Banks,
17821! Wiley, 1998,
17822! ISBN: 0471134031,
17823! LC: T57.62.H37.
17824!
17825! Peter Lewis, Allen Goodman, James Miller,
17826! A Pseudo-Random Number Generator for the System/360,
17827! IBM Systems Journal,
17828! Volume 8, 1969, pages 136-143.
17829!
17830! Parameters:
17831!
17832! Input, integer ( kind = 4 ) M, N, the number of rows and columns
17833! in the array.
17834!
17835! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
17836! should NOT be 0. On output, SEED has been updated.
17837!
17838! Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
17839!
17840 implicit none
17841
17842 integer ( kind = 4 ) m
17843 integer ( kind = 4 ) n
17844
17845 integer ( kind = 4 ) seed
17846 real ( kind = 8 ) r(m,n)
17847
17848 call r8vec_normal_01 ( m * n, seed, r )
17849
17850 return
r8vec_normal_01
subroutine r8vec_normal_01(n, seed, x)
Definition R8LIB.f90:33649

References r8vec_normal_01().

Here is the call graph for this function:

◆ r8mat_nullspace()

subroutine r8mat_nullspace ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  nullspace_size,
real ( kind = 8 ), dimension(n,nullspace_size)  nullspace 
)

Definition at line 17852 of file R8LIB.f90.

17853
17854!*****************************************************************************80
17855!
17856!! R8MAT_NULLSPACE computes the nullspace of a matrix.
17857!
17858! Discussion:
17859!
17860! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17861!
17862! Let A be an MxN matrix.
17863!
17864! If X is an N-vector, and A*X = 0, then X is a null vector of A.
17865!
17866! The set of all null vectors of A is called the nullspace of A.
17867!
17868! The 0 vector is always in the null space.
17869!
17870! If the 0 vector is the only vector in the nullspace of A, then A
17871! is said to have maximum column rank. (Because A*X=0 can be regarded
17872! as a linear combination of the columns of A). In particular, if A
17873! is square, and has maximum column rank, it is nonsingular.
17874!
17875! The dimension of the nullspace is the number of linearly independent
17876! vectors that span the nullspace. If A has maximum column rank,
17877! its nullspace has dimension 0.
17878!
17879! This routine uses the reduced row echelon form of A to determine
17880! a set of NULLSPACE_SIZE independent null vectors.
17881!
17882! Licensing:
17883!
17884! This code is distributed under the GNU LGPL license.
17885!
17886! Modified:
17887!
17888! 02 October 2008
17889!
17890! Author:
17891!
17892! John Burkardt
17893!
17894! Parameters:
17895!
17896! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
17897! the matrix A.
17898!
17899! Input, real ( kind = 8 ) A(M,N), the matrix to be analyzed.
17900!
17901! Input, integer ( kind = 4 ) NULLSPACE_SIZE, the size of the nullspace.
17902!
17903! Output, real ( kind = 8 ) NULLSPACE(N,NULLSPACE_SIZE), vectors that
17904! span the nullspace.
17905!
17906 implicit none
17907
17908 integer ( kind = 4 ) m
17909 integer ( kind = 4 ) n
17910 integer ( kind = 4 ) nullspace_size
17911
17912 real ( kind = 8 ) a(m,n)
17913 integer ( kind = 4 ) col(n)
17914 integer ( kind = 4 ) i
17915 integer ( kind = 4 ) i2
17916 integer ( kind = 4 ) j
17917 integer ( kind = 4 ) j2
17918 real ( kind = 8 ) nullspace(n,nullspace_size)
17919 integer ( kind = 4 ) row(m)
17920 real ( kind = 8 ) rref(m,n)
17921!
17922! Make a copy of A.
17923!
17924 rref(1:m,1:n) = a(1:m,1:n)
17925!
17926! Get the reduced row echelon form of A.
17927!
17928 call r8mat_rref ( m, n, rref )
17929!
17930! Note in ROW the columns of the leading nonzeros.
17931! COL(J) = +J if there is a leading 1 in that column, and -J otherwise.
17932!
17933 row(1:m) = 0
17934
17935 do j = 1, n
17936 col(j) = - j
17937 end do
17938
17939 do i = 1, m
17940 do j = 1, n
17941 if ( rref(i,j) == 1.0d+00 ) then
17942 row(i) = j
17943 col(j) = j
17944 exit
17945 end if
17946 end do
17947 end do
17948
17949 nullspace(1:n,1:nullspace_size) = 0.0d+00
17950
17951 j2 = 0
17952!
17953! If column J does not contain a leading 1, then it contains
17954! information about a null vector.
17955!
17956 do j = 1, n
17957
17958 if ( col(j) < 0 ) then
17959
17960 j2 = j2 + 1
17961
17962 do i = 1, m
17963 if ( rref(i,j) /= 0.0d+00 ) then
17964 i2 = row(i)
17965 nullspace(i2,j2) = - rref(i,j)
17966 end if
17967 end do
17968
17969 nullspace(j,j2) = 1.0d+00
17970
17971 end if
17972
17973 end do
17974
17975 return
r8mat_rref
subroutine r8mat_rref(m, n, a)
Definition R8LIB.f90:19130

References r8mat_rref().

Here is the call graph for this function:

◆ r8mat_nullspace_size()

subroutine r8mat_nullspace_size ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  nullspace_size 
)

Definition at line 17977 of file R8LIB.f90.

17978
17979!*****************************************************************************80
17980!
17981!! R8MAT_NULLSPACE_SIZE computes the size of the nullspace of a matrix.
17982!
17983! Discussion:
17984!
17985! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
17986!
17987! Let A be an MxN matrix.
17988!
17989! If X is an N-vector, and A*X = 0, then X is a null vector of A.
17990!
17991! The set of all null vectors of A is called the nullspace of A.
17992!
17993! The 0 vector is always in the null space.
17994!
17995! If the 0 vector is the only vector in the nullspace of A, then A
17996! is said to have maximum column rank. (Because A*X=0 can be regarded
17997! as a linear combination of the columns of A). In particular, if A
17998! is square, and has maximum column rank, it is nonsingular.
17999!
18000! The dimension of the nullspace is the number of linearly independent
18001! vectors that span the nullspace. If A has maximum column rank,
18002! its nullspace has dimension 0.
18003!
18004! This routine ESTIMATES the dimension of the nullspace. Cases of
18005! singularity that depend on exact arithmetic will probably be missed.
18006!
18007! The nullspace will be estimated by counting the leading 1's in the
18008! reduced row echelon form of A, and subtracting this from N.
18009!
18010! Licensing:
18011!
18012! This code is distributed under the GNU LGPL license.
18013!
18014! Modified:
18015!
18016! 02 October 2008
18017!
18018! Author:
18019!
18020! John Burkardt
18021!
18022! Parameters:
18023!
18024! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
18025! the matrix A.
18026!
18027! Input, real ( kind = 8 ) A(M,N), the matrix to be analyzed.
18028!
18029! Output, integer ( kind = 4 ) NULLSPACE_SIZE, the estimated size
18030! of the nullspace.
18031!
18032 implicit none
18033
18034 integer ( kind = 4 ) m
18035 integer ( kind = 4 ) n
18036
18037 real ( kind = 8 ) a(m,n)
18038 integer ( kind = 4 ) i
18039 integer ( kind = 4 ) j
18040 integer ( kind = 4 ) leading
18041 integer ( kind = 4 ) nullspace_size
18042 real ( kind = 8 ) rref(m,n)
18043!
18044! Get the reduced row echelon form of A.
18045!
18046 rref(1:m,1:n) = a(1:m,1:n)
18047
18048 call r8mat_rref ( m, n, rref )
18049!
18050! Count the leading 1's in A.
18051!
18052 leading = 0
18053 do i = 1, m
18054 do j = 1, n
18055 if ( rref(i,j) == 1.0d+00 ) then
18056 leading = leading + 1
18057 exit
18058 end if
18059 end do
18060 end do
18061
18062 nullspace_size = n - leading
18063
18064 return

References r8mat_rref().

Here is the call graph for this function:

◆ r8mat_orth_uniform()

subroutine r8mat_orth_uniform ( integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 18066 of file R8LIB.f90.

18067
18068!*****************************************************************************80
18069!
18070!! R8MAT_ORTH_UNIFORM returns a random orthogonal R8MAT.
18071!
18072! Discussion:
18073!
18074! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18075!
18076! Thanks to Eugene Petrov, B I Stepanov Institute of Physics,
18077! National Academy of Sciences of Belarus, for convincingly
18078! pointing out the severe deficiencies of an earlier version of
18079! this routine.
18080!
18081! Essentially, the computation involves saving the Q factor of the
18082! QR factorization of a matrix whose entries are normally distributed.
18083! However, it is only necessary to generate this matrix a column at
18084! a time, since it can be shown that when it comes time to annihilate
18085! the subdiagonal elements of column K, these (transformed) elements of
18086! column K are still normally distributed random values. Hence, there
18087! is no need to generate them at the beginning of the process and
18088! transform them K-1 times.
18089!
18090! For computational efficiency, the individual Householder transformations
18091! could be saved, as recommended in the reference, instead of being
18092! accumulated into an explicit matrix format.
18093!
18094! Properties:
18095!
18096! The inverse of A is equal to A'.
18097!
18098! A * A' = A' * A = I.
18099!
18100! Columns and rows of A have unit Euclidean norm.
18101!
18102! Distinct pairs of columns of A are orthogonal.
18103!
18104! Distinct pairs of rows of A are orthogonal.
18105!
18106! The L2 vector norm of A*x = the L2 vector norm of x for any vector x.
18107!
18108! The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B.
18109!
18110! The determinant of A is +1 or -1.
18111!
18112! All the eigenvalues of A have modulus 1.
18113!
18114! All singular values of A are 1.
18115!
18116! All entries of A are between -1 and 1.
18117!
18118! Licensing:
18119!
18120! This code is distributed under the GNU LGPL license.
18121!
18122! Modified:
18123!
18124! 04 November 2004
18125!
18126! Author:
18127!
18128! John Burkardt
18129!
18130! Reference:
18131!
18132! Pete Stewart,
18133! Efficient Generation of Random Orthogonal Matrices With an Application
18134! to Condition Estimators,
18135! SIAM Journal on Numerical Analysis,
18136! Volume 17, Number 3, June 1980, pages 403-409.
18137!
18138! Parameters:
18139!
18140! Input, integer ( kind = 4 ) N, the order of A.
18141!
18142! Input/output, integer ( kind = 4 ) SEED, a seed for the random
18143! number generator.
18144!
18145! Output, real ( kind = 8 ) A(N,N), the orthogonal matrix.
18146!
18147 implicit none
18148
18149 integer ( kind = 4 ) n
18150
18151 real ( kind = 8 ) a(n,n)
18152 integer ( kind = 4 ) i
18153 integer ( kind = 4 ) j
18154 real ( kind = 8 ) r8_normal_01
18155 integer ( kind = 4 ) seed
18156 real ( kind = 8 ) v(n)
18157 real ( kind = 8 ) x(n)
18158!
18159! Start with A = the identity matrix.
18160!
18161 do i = 1, n
18162 do j = 1, n
18163 if ( i == j ) then
18164 a(i,j) = 1.0d+00
18165 else
18166 a(i,j) = 0.0d+00
18167 end if
18168 end do
18169 end do
18170!
18171! Now behave as though we were computing the QR factorization of
18172! some other random matrix. Generate the N elements of the first column,
18173! compute the Householder matrix H1 that annihilates the subdiagonal elements,
18174! and set A := A * H1' = A * H.
18175!
18176! On the second step, generate the lower N-1 elements of the second column,
18177! compute the Householder matrix H2 that annihilates them,
18178! and set A := A * H2' = A * H2 = H1 * H2.
18179!
18180! On the N-1 step, generate the lower 2 elements of column N-1,
18181! compute the Householder matrix HN-1 that annihilates them, and
18182! and set A := A * H(N-1)' = A * H(N-1) = H1 * H2 * ... * H(N-1).
18183! This is our random orthogonal matrix.
18184!
18185 do j = 1, n - 1
18186!
18187! Set the vector that represents the J-th column to be annihilated.
18188!
18189 x(1:j-1) = 0.0d+00
18190
18191 do i = j, n
18192 x(i) = r8_normal_01( seed )
18193 end do
18194!
18195! Compute the vector V that defines a Householder transformation matrix
18196! H(V) that annihilates the subdiagonal elements of X.
18197!
18198 call r8vec_house_column ( n, x, j, v )
18199!
18200! Postmultiply the matrix A by H'(V) = H(V).
18201!
18202 call r8mat_house_axh ( n, a, v, a )
18203
18204 end do
18205
18206 return
r8mat_house_axh
subroutine r8mat_house_axh(n, a, v, ah)
Definition R8LIB.f90:14837

References r8_normal_01(), r8mat_house_axh(), and r8vec_house_column().

Here is the call graph for this function:

◆ r8mat_plot()

subroutine r8mat_plot ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
character ( len = * )  title 
)

Definition at line 18208 of file R8LIB.f90.

18209
18210!*****************************************************************************80
18211!
18212!! R8MAT_PLOT "plots" an R8MAT, with an optional title.
18213!
18214! Discussion:
18215!
18216! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18217!
18218! Licensing:
18219!
18220! This code is distributed under the GNU LGPL license.
18221!
18222! Modified:
18223!
18224! 12 December 2004
18225!
18226! Author:
18227!
18228! John Burkardt
18229!
18230! Parameters:
18231!
18232! Input, integer ( kind = 4 ) M, the number of rows in A.
18233!
18234! Input, integer ( kind = 4 ) N, the number of columns in A.
18235!
18236! Input, real ( kind = 8 ) A(M,N), the matrix.
18237!
18238! Input, character ( len = * ) TITLE, a title.
18239!
18240 implicit none
18241
18242 integer ( kind = 4 ) m
18243 integer ( kind = 4 ) n
18244
18245 real ( kind = 8 ) a(m,n)
18246 integer ( kind = 4 ) i
18247 integer ( kind = 4 ) j
18248 integer ( kind = 4 ) jhi
18249 integer ( kind = 4 ) jlo
18250 character r8mat_plot_symbol
18251 character ( len = 70 ) string
18252 character ( len = * ) title
18253
18254 write ( *, '(a)' ) ' '
18255 write ( *, '(a)' ) trim( title )
18256
18257 do jlo = 1, n, 70
18258 jhi = min( jlo + 70-1, n )
18259 write ( *, '(a)' ) ' '
18260 write ( *, '(8x,2x,70i1)' ) ( mod( j, 10 ), j = jlo, jhi )
18261 write ( *, '(a)' ) ' '
18262
18263 do i = 1, m
18264 do j = jlo, jhi
18265 string(j+1-jlo:j+1-jlo) = r8mat_plot_symbol( a(i,j) )
18266 end do
18267 write ( *, '(i8,2x,a)' ) i, string(1:jhi+1-jlo)
18268 end do
18269 end do
18270
18271 return
r8mat_plot_symbol
character function r8mat_plot_symbol(r)
Definition R8LIB.f90:18274

◆ r8mat_plot_symbol()

character function r8mat_plot_symbol ( real ( kind = 8 )  r)

Definition at line 18273 of file R8LIB.f90.

18274
18275!*****************************************************************************80
18276!
18277!! R8MAT_PLOT_SYMBOL returns a symbol for an element of an R8MAT.
18278!
18279! Discussion:
18280!
18281! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18282!
18283! Licensing:
18284!
18285! This code is distributed under the GNU LGPL license.
18286!
18287! Modified:
18288!
18289! 12 December 2004
18290!
18291! Author:
18292!
18293! John Burkardt
18294!
18295! Parameters:
18296!
18297! Input, real ( kind = 8 ) R, a value whose symbol is desired.
18298!
18299! Output, character R8MAT_PLOT_SYMBOL, is
18300! '-' if R is negative,
18301! '0' if R is zero,
18302! '+' if R is positive.
18303!
18304 implicit none
18305
18306 character r8mat_plot_symbol
18307 real ( kind = 8 ) r
18308
18309 if ( r < 0.0d+00 ) then
18310 r8mat_plot_symbol = '-'
18311 else if ( r == 0.0d+00 ) then
18312 r8mat_plot_symbol = '0'
18313 else if ( 0.0d+00 < r ) then
18314 r8mat_plot_symbol = '+'
18315 end if
18316
18317 return

References r8mat_plot_symbol().

Referenced by r8mat_plot_symbol().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_poly_char()

subroutine r8mat_poly_char ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(0:n)  p 
)

Definition at line 18319 of file R8LIB.f90.

18320
18321!*****************************************************************************80
18322!
18323!! R8MAT_POLY_CHAR computes the characteristic polynomial of an R8MAT.
18324!
18325! Discussion:
18326!
18327! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18328!
18329! Licensing:
18330!
18331! This code is distributed under the GNU LGPL license.
18332!
18333! Modified:
18334!
18335! 15 March 2001
18336!
18337! Author:
18338!
18339! John Burkardt
18340!
18341! Parameters:
18342!
18343! Input, integer ( kind = 4 ) N, the order of the matrix A.
18344!
18345! Input, real ( kind = 8 ) A(N,N), the N by N matrix.
18346!
18347! Output, real ( kind = 8 ) P(0:N), the coefficients of the characteristic
18348! polynomial of A. P(N) contains the coefficient of X^N
18349! (which will be 1), P(I) contains the coefficient of X^I,
18350! and P(0) contains the constant term.
18351!
18352 implicit none
18353
18354 integer ( kind = 4 ) n
18355
18356 real ( kind = 8 ) a(n,n)
18357 integer ( kind = 4 ) i
18358 integer ( kind = 4 ) order
18359 real ( kind = 8 ) p(0:n)
18360 real ( kind = 8 ) r8mat_trace
18361 real ( kind = 8 ) trace
18362 real ( kind = 8 ) work1(n,n)
18363 real ( kind = 8 ) work2(n,n)
18364!
18365! Initialize WORK1 to the identity matrix.
18366!
18367 call r8mat_identity ( n, work1 )
18368
18369 p(n) = 1.0d+00
18370
18371 do order = n - 1, 0, -1
18372!
18373! Work2 = A * WORK1.
18374!
18375 work2(1:n,1:n) = matmul( a(1:n,1:n), work1(1:n,1:n) )
18376!
18377! Take the trace.
18378!
18379 trace = r8mat_trace( n, work2 )
18380!
18381! P(ORDER) = -Trace ( WORK2 ) / ( N - ORDER )
18382!
18383 p(order) = -trace / real( n - order, kind = 8 )
18384!
18385! WORK1 := WORK2 + P(ORDER) * Identity.
18386!
18387 work1(1:n,1:n) = work2(1:n,1:n)
18388
18389 do i = 1, n
18390 work1(i,i) = work1(i,i) + p(order)
18391 end do
18392
18393 end do
18394
18395 return
r8mat_trace
real(kind=8) function r8mat_trace(n, a)
Definition R8LIB.f90:20150

References r8mat_identity(), and r8mat_trace().

Here is the call graph for this function:

◆ r8mat_power()

subroutine r8mat_power ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 )  npow,
real ( kind = 8 ), dimension(n,n)  b 
)

Definition at line 18397 of file R8LIB.f90.

18398
18399!*****************************************************************************80
18400!
18401!! R8MAT_POWER computes a nonnegative power of an R8MAT.
18402!
18403! Discussion:
18404!
18405! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18406!
18407! The algorithm is:
18408!
18409! B = I
18410! do NPOW times:
18411! B = A * B
18412! end
18413!
18414! Licensing:
18415!
18416! This code is distributed under the GNU LGPL license.
18417!
18418! Modified:
18419!
18420! 23 April 2005
18421!
18422! Author:
18423!
18424! John Burkardt
18425!
18426! Parameters:
18427!
18428! Input, integer ( kind = 4 ) N, the order of A.
18429!
18430! Input, real ( kind = 8 ) A(N,N), the matrix to be raised to a power.
18431!
18432! Input, integer ( kind = 4 ) NPOW, the power to which A is to be raised.
18433! NPOW must be nonnegative.
18434!
18435! Output, real ( kind = 8 ) B(N,N), the value of A^NPOW.
18436!
18437 implicit none
18438
18439 integer ( kind = 4 ) n
18440
18441 real ( kind = 8 ) a(n,n)
18442 real ( kind = 8 ) b(n,n)
18443 integer ( kind = 4 ) ipow
18444 integer ( kind = 4 ) npow
18445
18446 if ( npow < 0 ) then
18447 write ( *, '(a)' ) ' '
18448 write ( *, '(a)' ) 'R8MAT_POWER - Fatal error!'
18449 write ( *, '(a)' ) ' Input value of NPOW < 0.'
18450 write ( *, '(a,i8)' ) ' NPOW = ', npow
18451 stop 1
18452 end if
18453
18454 call r8mat_identity ( n, b )
18455
18456 do ipow = 1, npow
18457 b(1:n,1:n) = matmul( a(1:n,1:n), b(1:n,1:n) )
18458 end do
18459
18460 return

References r8mat_identity().

Here is the call graph for this function:

◆ r8mat_power_method()

subroutine r8mat_power_method ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 )  r,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 18462 of file R8LIB.f90.

18463
18464!*****************************************************************************80
18465!
18466!! R8MAT_POWER_METHOD applies the power method to an R8MAT.
18467!
18468! Discussion:
18469!
18470! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18471!
18472! If the power method has not converged, then calling the routine
18473! again immediately with the output from the previous call will
18474! continue the iteration.
18475!
18476! Licensing:
18477!
18478! This code is distributed under the GNU LGPL license.
18479!
18480! Modified:
18481!
18482! 06 February 2001
18483!
18484! Author:
18485!
18486! John Burkardt
18487!
18488! Parameters:
18489!
18490! Input, integer ( kind = 4 ) N, the order of A.
18491!
18492! Input, real ( kind = 8 ) A(N,N), the matrix.
18493!
18494! Output, real ( kind = 8 ) R, the estimated eigenvalue.
18495!
18496! Input/output, real ( kind = 8 ) V(N), on input, an estimate
18497! for the eigenvector. On output, an improved estimate for the
18498! eigenvector.
18499!
18500 implicit none
18501
18502 integer ( kind = 4 ) n
18503
18504 real ( kind = 8 ) a(n,n)
18505 real ( kind = 8 ) av(n)
18506 real ( kind = 8 ) eps
18507 integer ( kind = 4 ) it
18508 real ( kind = 8 ), parameter :: it_eps = 0.0001d+00
18509 integer ( kind = 4 ), parameter :: it_max = 100
18510 integer ( kind = 4 ), parameter :: it_min = 10
18511 integer ( kind = 4 ) j
18512 real ( kind = 8 ) r
18513 real ( kind = 8 ) r2
18514 real ( kind = 8 ) r_old
18515 real ( kind = 8 ) v(n)
18516
18517 eps = sqrt( epsilon( 1.0d+00 ) )
18518
18519 r = sqrt( sum( v(1:n)**2 ) )
18520
18521 if ( r == 0.0d+00 ) then
18522 v(1:n) = 1.0d+00
18523 r = sqrt( real( n, kind = 8 ) )
18524 end if
18525
18526 v(1:n) = v(1:n) / r
18527
18528 do it = 1, it_max
18529
18530 av(1:n) = matmul( a(1:n,1:n), v(1:n) )
18531
18532 r_old = r
18533 r = sqrt( sum( av(1:n)**2 ) )
18534
18535 if ( it_min < it ) then
18536 if ( abs( r - r_old ) <= it_eps * ( 1.0d+00 + abs( r ) ) ) then
18537 exit
18538 end if
18539 end if
18540
18541 v(1:n) = av(1:n)
18542
18543 if ( r /= 0.0d+00 ) then
18544 v(1:n) = v(1:n) / r
18545 end if
18546!
18547! Perturb V a bit, to avoid cases where the initial guess is exactly
18548! the eigenvector of a smaller eigenvalue.
18549!
18550 if ( it < it_max / 2 ) then
18551 j = 1 + mod( it - 1, n )
18552 v(j) = v(j) + eps * ( 1.0d+00 + abs( v(j) ) )
18553 r2 = sqrt( sum( v(1:n)**2 ) )
18554 v(1:n) = v(1:n) / r2
18555 end if
18556
18557 end do
18558
18559 return

◆ r8mat_print()

subroutine r8mat_print ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
character ( len = * )  title 
)

Definition at line 18561 of file R8LIB.f90.

18562
18563!*****************************************************************************80
18564!
18565!! R8MAT_PRINT prints an R8MAT.
18566!
18567! Discussion:
18568!
18569! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18570!
18571! Licensing:
18572!
18573! This code is distributed under the GNU LGPL license.
18574!
18575! Modified:
18576!
18577! 12 September 2004
18578!
18579! Author:
18580!
18581! John Burkardt
18582!
18583! Parameters:
18584!
18585! Input, integer ( kind = 4 ) M, the number of rows in A.
18586!
18587! Input, integer ( kind = 4 ) N, the number of columns in A.
18588!
18589! Input, real ( kind = 8 ) A(M,N), the matrix.
18590!
18591! Input, character ( len = * ) TITLE, a title.
18592!
18593 implicit none
18594
18595 integer ( kind = 4 ) m
18596 integer ( kind = 4 ) n
18597
18598 real ( kind = 8 ) a(m,n)
18599 character ( len = * ) title
18600
18601 call r8mat_print_some ( m, n, a, 1, 1, m, n, title )
18602
18603 return
r8mat_print_some
subroutine r8mat_print_some(m, n, a, ilo, jlo, ihi, jhi, title)
Definition R8LIB.f90:18606

References r8mat_print_some().

Here is the call graph for this function:

◆ r8mat_print2()

subroutine r8mat_print2 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 18714 of file R8LIB.f90.

18715
18716!*****************************************************************************80
18717!
18718!! R8MAT_PRINT2 prints an R8MAT.
18719!
18720! Discussion:
18721!
18722! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18723!
18724! Licensing:
18725!
18726! This code is distributed under the GNU LGPL license.
18727!
18728! Modified:
18729!
18730! 27 August 2002
18731!
18732! Author:
18733!
18734! John Burkardt
18735!
18736! Parameters:
18737!
18738! Input, integer ( kind = 4 ) M, the number of rows of A.
18739!
18740! Input, integer ( kind = 4 ) N, the number of columns of A.
18741!
18742! Input, real ( kind = 8 ) A(M,N), the M by N matrix to be printed.
18743!
18744 implicit none
18745
18746 integer ( kind = 4 ) m
18747 integer ( kind = 4 ) n
18748
18749 real ( kind = 8 ) a(m,n)
18750 real ( kind = 8 ) amax
18751 real ( kind = 8 ) amin
18752 integer ( kind = 4 ) i
18753 character ( len = 10 ) iform
18754 integer ( kind = 4 ) ihi
18755 integer ( kind = 4 ) ilo
18756 logical ( kind = 4 ) integ
18757 integer ( kind = 4 ) j
18758 integer ( kind = 4 ) jhi
18759 integer ( kind = 4 ) jlo
18760 integer ( kind = 4 ) lmax
18761 integer ( kind = 4 ) npline
18762 real ( kind = 8 ) r8_log_10
18763!
18764! Check if all entries are integral.
18765!
18766 integ = .true.
18767
18768 do i = 1, m
18769 do j = 1, n
18770
18771 if ( integ ) then
18772 if ( a(i,j) /= real( int( a(i,j) ), kind = 8 ) ) then
18773 integ = .false.
18774 end if
18775 end if
18776
18777 end do
18778 end do
18779!
18780! Find the maximum and minimum entries.
18781!
18782 amax = maxval( a(1:m,1:n) )
18783 amin = minval( a(1:m,1:n) )
18784!
18785! Use the information about the maximum size of an entry to
18786! compute an intelligent format for use with integer entries.
18787!
18788! Later, we might also do this for real matrices.
18789!
18790 lmax = int( r8_log_10( amax ) )
18791
18792 if ( integ ) then
18793 npline = 79 / ( lmax + 3 )
18794 write ( iform, '(''('',i2,''I'',i2,'')'')' ) npline, lmax+3
18795 else
18796 npline = 5
18797 iform = ' '
18798 end if
18799!
18800! Print a scalar quantity.
18801!
18802 if ( m == 1 .and. n == 1 ) then
18803
18804 if ( integ ) then
18805 write ( *, iform ) int( a(1,1) )
18806 else
18807 write ( *, '(2x,g14.6)' ) a(1,1)
18808 end if
18809!
18810! Column vector of length M,
18811!
18812 else if ( n == 1 ) then
18813
18814 do ilo = 1, m, npline
18815
18816 ihi = min( ilo+npline-1, m )
18817
18818 if ( integ ) then
18819 write ( *, iform ) ( int( a(i,1) ), i = ilo, ihi )
18820 else
18821 write ( *, '(2x,5g14.6)' ) a(ilo:ihi,1)
18822 end if
18823
18824 end do
18825!
18826! Row vector of length N,
18827!
18828 else if ( m == 1 ) then
18829
18830 do jlo = 1, n, npline
18831
18832 jhi = min( jlo+npline-1, n )
18833
18834 if ( integ ) then
18835 write ( *, iform ) int( a(1,jlo:jhi) )
18836 else
18837 write ( *, '(2x,5g14.6)' ) a(1,jlo:jhi)
18838 end if
18839
18840 end do
18841!
18842! M by N Array
18843!
18844 else
18845
18846 do jlo = 1, n, npline
18847
18848 jhi = min( jlo+npline-1, n )
18849
18850 if ( npline < n ) then
18851 write ( *, '(a)' ) ' '
18852 write ( *, '(a,i8,a,i8)' ) 'Matrix columns ', jlo, ' to ', jhi
18853 write ( *, '(a)' ) ' '
18854 end if
18855
18856 do i = 1, m
18857
18858 if ( integ ) then
18859 write ( *, iform ) int( a(i,jlo:jhi) )
18860 else
18861 write ( *, '(2x,5g14.6)' ) a(i,jlo:jhi)
18862 end if
18863
18864 end do
18865 end do
18866
18867 end if
18868
18869 return

References r8_log_10().

Here is the call graph for this function:

◆ r8mat_print_some()

subroutine r8mat_print_some ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  ilo,
integer ( kind = 4 )  jlo,
integer ( kind = 4 )  ihi,
integer ( kind = 4 )  jhi,
character ( len = * )  title 
)

Definition at line 18605 of file R8LIB.f90.

18606
18607!*****************************************************************************80
18608!
18609!! R8MAT_PRINT_SOME prints some of an R8MAT.
18610!
18611! Discussion:
18612!
18613! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18614!
18615! Licensing:
18616!
18617! This code is distributed under the GNU LGPL license.
18618!
18619! Modified:
18620!
18621! 10 September 2009
18622!
18623! Author:
18624!
18625! John Burkardt
18626!
18627! Parameters:
18628!
18629! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
18630!
18631! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
18632!
18633! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
18634!
18635! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
18636!
18637! Input, character ( len = * ) TITLE, a title.
18638!
18639 implicit none
18640
18641 integer ( kind = 4 ), parameter :: incx = 5
18642 integer ( kind = 4 ) m
18643 integer ( kind = 4 ) n
18644
18645 real ( kind = 8 ) a(m,n)
18646 character ( len = 14 ) ctemp(incx)
18647 integer ( kind = 4 ) i
18648 integer ( kind = 4 ) i2hi
18649 integer ( kind = 4 ) i2lo
18650 integer ( kind = 4 ) ihi
18651 integer ( kind = 4 ) ilo
18652 integer ( kind = 4 ) inc
18653 integer ( kind = 4 ) j
18654 integer ( kind = 4 ) j2
18655 integer ( kind = 4 ) j2hi
18656 integer ( kind = 4 ) j2lo
18657 integer ( kind = 4 ) jhi
18658 integer ( kind = 4 ) jlo
18659 character ( len = * ) title
18660
18661 write ( *, '(a)' ) ' '
18662 write ( *, '(a)' ) trim( title )
18663
18664 if ( m <= 0 .or. n <= 0 ) then
18665 write ( *, '(a)' ) ' '
18666 write ( *, '(a)' ) ' (None)'
18667 return
18668 end if
18669
18670 do j2lo = max( jlo, 1 ), min( jhi, n ), incx
18671
18672 j2hi = j2lo + incx - 1
18673 j2hi = min( j2hi, n )
18674 j2hi = min( j2hi, jhi )
18675
18676 inc = j2hi + 1 - j2lo
18677
18678 write ( *, '(a)' ) ' '
18679
18680 do j = j2lo, j2hi
18681 j2 = j + 1 - j2lo
18682 write ( ctemp(j2), '(i8,6x)' ) j
18683 end do
18684
18685 write ( *, '('' Col '',5a14)' ) ctemp(1:inc)
18686 write ( *, '(a)' ) ' Row'
18687 write ( *, '(a)' ) ' '
18688
18689 i2lo = max( ilo, 1 )
18690 i2hi = min( ihi, m )
18691
18692 do i = i2lo, i2hi
18693
18694 do j2 = 1, inc
18695
18696 j = j2lo - 1 + j2
18697
18698 if ( a(i,j) == real( int( a(i,j) ), kind = 8 ) ) then
18699 write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
18700 else
18701 write ( ctemp(j2), '(g14.6)' ) a(i,j)
18702 end if
18703
18704 end do
18705
18706 write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )
18707
18708 end do
18709
18710 end do
18711
18712 return

Referenced by r8mat_print().

Here is the caller graph for this function:

◆ r8mat_ref()

subroutine r8mat_ref ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 18871 of file R8LIB.f90.

18872
18873!*****************************************************************************80
18874!
18875!! R8MAT_REF computes the row echelon form of a matrix.
18876!
18877! Discussion:
18878!
18879! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18880!
18881! A matrix is in row echelon form if:
18882!
18883! * The first nonzero entry in each row is 1.
18884!
18885! * The leading 1 in a given row occurs in a column to
18886! the right of the leading 1 in the previous row.
18887!
18888! * Rows which are entirely zero must occur last.
18889!
18890! Example:
18891!
18892! Input matrix:
18893!
18894! 1.0 3.0 0.0 2.0 6.0 3.0 1.0
18895! -2.0 -6.0 0.0 -2.0 -8.0 3.0 1.0
18896! 3.0 9.0 0.0 0.0 6.0 6.0 2.0
18897! -1.0 -3.0 0.0 1.0 0.0 9.0 3.0
18898!
18899! Output matrix:
18900!
18901! 1.0 3.0 0.0 2.0 6.0 3.0 1.0
18902! 0.0 0.0 0.0 1.0 2.0 4.5 1.5
18903! 0.0 0.0 0.0 0.0 0.0 1.0 0.3
18904! 0.0 0.0 0.0 0.0 0.0 0.0 0.0
18905!
18906! Licensing:
18907!
18908! This code is distributed under the GNU LGPL license.
18909!
18910! Modified:
18911!
18912! 02 October 2008
18913!
18914! Author:
18915!
18916! John Burkardt
18917!
18918! Parameters:
18919!
18920! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
18921! the matrix A.
18922!
18923! Input/output, real ( kind = 8 ) A(M,N). On input, the matrix to be
18924! analyzed. On output, the REF form of the matrix.
18925!
18926 implicit none
18927
18928 integer ( kind = 4 ) m
18929 integer ( kind = 4 ) n
18930
18931 real ( kind = 8 ) a(m,n)
18932 integer ( kind = 4 ) i
18933 integer ( kind = 4 ) j
18934 integer ( kind = 4 ) lead
18935 integer ( kind = 4 ) r
18936 real ( kind = 8 ) temp
18937
18938 lead = 1
18939
18940 do r = 1, m
18941
18942 if ( n < lead ) then
18943 exit
18944 end if
18945
18946 i = r
18947
18948 do while ( a(i,lead) == 0.0d+00 )
18949
18950 i = i + 1
18951
18952 if ( m < i ) then
18953 i = r
18954 lead = lead + 1
18955 if ( n < lead ) then
18956 lead = -1
18957 exit
18958 end if
18959 end if
18960
18961 end do
18962
18963 if ( lead < 0 ) then
18964 exit
18965 end if
18966
18967 do j = 1, n
18968 temp = a(i,j)
18969 a(i,j) = a(r,j)
18970 a(r,j) = temp
18971 end do
18972
18973 a(r,1:n) = a(r,1:n) / a(r,lead)
18974
18975 do i = r + 1, m
18976 a(i,1:n) = a(i,1:n) - a(i,lead) * a(r,1:n)
18977 end do
18978
18979 lead = lead + 1
18980
18981 end do
18982
18983 return

◆ r8mat_rms()

real ( kind = 8 ) function r8mat_rms ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 18985 of file R8LIB.f90.

18986
18987!*****************************************************************************80
18988!
18989!! R8MAT_RMS returns the RMS norm of an R8MAT.
18990!
18991! Discussion:
18992!
18993! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
18994!
18995! The matrix RMS norm is defined as:
18996!
18997! R8MAT_RMS = sqrt (
18998! sum ( 1 <= I <= M ) sum ( 1 <= J <= N ) A(I,J)^2 / M / N ).
18999!
19000! Licensing:
19001!
19002! This code is distributed under the GNU LGPL license.
19003!
19004! Modified:
19005!
19006! 14 December 2011
19007!
19008! Author:
19009!
19010! John Burkardt
19011!
19012! Parameters:
19013!
19014! Input, integer ( kind = 4 ) M, N, the dimensions of the matrix.
19015!
19016! Input, real ( kind = 8 ) A(M,N), the matrix.
19017!
19018! Output, real ( kind = 8 ) R8MAT_RMS, the RMS norm of A.
19019!
19020 implicit none
19021
19022 integer ( kind = 4 ) m
19023 integer ( kind = 4 ) n
19024
19025 real ( kind = 8 ) a(m,n)
19026 real ( kind = 8 ) r8mat_rms
19027
19028 r8mat_rms = sqrt( sum( a(1:m,1:n)**2 ) / m / n )
19029
19030 return
r8mat_rms
real(kind=8) function r8mat_rms(m, n, a)
Definition R8LIB.f90:18986

References r8mat_rms().

Referenced by r8mat_rms().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_row_copy()

subroutine r8mat_row_copy ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
integer ( kind = 4 )  i,
real ( kind = 8 ), dimension(n)  v,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 19032 of file R8LIB.f90.

19033
19034!*****************************************************************************80
19035!
19036!! R8MAT_ROW_COPY copies a vector into a row of an R8MAT.
19037!
19038! Discussion:
19039!
19040! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19041!
19042! Licensing:
19043!
19044! This code is distributed under the GNU LGPL license.
19045!
19046! Modified:
19047!
19048! 30 June 2014
19049!
19050! Author:
19051!
19052! John Burkardt
19053!
19054! Parameters:
19055!
19056! Input, integer ( kind = 4 ) M, N, the order of the matrix.
19057!
19058! Input, integer ( kind = 4 ) I, the index of the row.
19059! 1 <= I <= M.
19060!
19061! Input, real ( kind = 8 ) V(N), the row to be copied.
19062!
19063! Input/output, real ( kind = 8 ) A(M,N), the matrix into which
19064! the row is to be copied.
19065!
19066 implicit none
19067
19068 integer ( kind = 4 ) m
19069 integer ( kind = 4 ) n
19070
19071 real ( kind = 8 ) a(m,n)
19072 integer ( kind = 4 ) i
19073 real ( kind = 8 ) v(n)
19074
19075 a(i,1:n) = v(1:n)
19076
19077 return

◆ r8mat_row_set()

subroutine r8mat_row_set ( integer ( kind = 4 )  i,
real ( kind = 8 ), dimension(n)  r,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 19079 of file R8LIB.f90.

19080
19081!*****************************************************************************80
19082!
19083!! R8MAT_ROW_SET copies a vector into a row of an R8MAT.
19084!
19085! Discussion:
19086!
19087! Because I try to avoid using "leading dimensions", which allow
19088! a user to set aside too much space for an array, but then
19089! still put things in the right place, I need to use a routine
19090! like this when I occasionally have to deal with arrays that
19091! are not "tight".
19092!
19093! Licensing:
19094!
19095! This code is distributed under the GNU LGPL license.
19096!
19097! Modified:
19098!
19099! 15 February 2014
19100!
19101! Author:
19102!
19103! John Burkardt
19104!
19105! Parameters:
19106!
19107! Input, integer ( kind = 4 ) I, the row index.
19108!
19109! Input, real ( kind = 8 ) R(N), the vector.
19110!
19111! Input, integer ( kind = 4 ) M, N, the number of rows and
19112! columns of the matrix.
19113!
19114! Input/output, real ( kind = 8 ) A(M,N), the matrix to be updated.
19115!
19116 implicit none
19117
19118 integer ( kind = 4 ) m
19119 integer ( kind = 4 ) n
19120
19121 real ( kind = 8 ) a(m,n)
19122 integer ( kind = 4 ) i
19123 real ( kind = 8 ) r(n)
19124
19125 a(i,1:n) = r(1:n)
19126
19127 return

◆ r8mat_rref()

subroutine r8mat_rref ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 19129 of file R8LIB.f90.

19130
19131!*****************************************************************************80
19132!
19133!! R8MAT_RREF computes the reduced row echelon form of a matrix.
19134!
19135! Discussion:
19136!
19137! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19138!
19139! A matrix is in row echelon form if:
19140!
19141! * The first nonzero entry in each row is 1.
19142!
19143! * The leading 1 in a given row occurs in a column to
19144! the right of the leading 1 in the previous row.
19145!
19146! * Rows which are entirely zero must occur last.
19147!
19148! The matrix is in reduced row echelon form if, in addition to
19149! the first three conditions, it also satisfies:
19150!
19151! * Each column containing a leading 1 has no other nonzero entries.
19152!
19153! Example:
19154!
19155! Input matrix:
19156!
19157! 1.0 3.0 0.0 2.0 6.0 3.0 1.0
19158! -2.0 -6.0 0.0 -2.0 -8.0 3.0 1.0
19159! 3.0 9.0 0.0 0.0 6.0 6.0 2.0
19160! -1.0 -3.0 0.0 1.0 0.0 9.0 3.0
19161!
19162! Output matrix:
19163!
19164! 1.0 3.0 0.0 0.0 2.0 0.0 0.0
19165! 0.0 0.0 0.0 1.0 2.0 0.0 0.0
19166! 0.0 0.0 0.0 0.0 0.0 1.0 0.3
19167! 0.0 0.0 0.0 0.0 0.0 0.0 0.0
19168!
19169! Licensing:
19170!
19171! This code is distributed under the GNU LGPL license.
19172!
19173! Modified:
19174!
19175! 02 October 2008
19176!
19177! Author:
19178!
19179! John Burkardt
19180!
19181! Parameters:
19182!
19183! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
19184! the matrix A.
19185!
19186! Input/output, real ( kind = 8 ) A(M,N). On input, the matrix to be
19187! analyzed. On output, the RREF form of the matrix.
19188!
19189 implicit none
19190
19191 integer ( kind = 4 ) m
19192 integer ( kind = 4 ) n
19193
19194 real ( kind = 8 ) a(m,n)
19195 integer ( kind = 4 ) i
19196 integer ( kind = 4 ) j
19197 integer ( kind = 4 ) lead
19198 integer ( kind = 4 ) r
19199 real ( kind = 8 ) temp
19200
19201 lead = 1
19202
19203 do r = 1, m
19204
19205 if ( n < lead ) then
19206 exit
19207 end if
19208
19209 i = r
19210
19211 do while ( a(i,lead) == 0.0d+00 )
19212
19213 i = i + 1
19214
19215 if ( m < i ) then
19216 i = r
19217 lead = lead + 1
19218 if ( n < lead ) then
19219 lead = -1
19220 exit
19221 end if
19222 end if
19223
19224 end do
19225
19226 if ( lead < 0 ) then
19227 exit
19228 end if
19229
19230 do j = 1, n
19231 temp = a(i,j)
19232 a(i,j) = a(r,j)
19233 a(r,j) = temp
19234 end do
19235
19236 a(r,1:n) = a(r,1:n) / a(r,lead)
19237
19238 do i = 1, m
19239 if ( i /= r ) then
19240 a(i,1:n) = a(i,1:n) - a(i,lead) * a(r,1:n)
19241 end if
19242 end do
19243
19244 lead = lead + 1
19245
19246 end do
19247
19248 return

Referenced by r8mat_nullspace(), and r8mat_nullspace_size().

Here is the caller graph for this function:

◆ r8mat_scale()

subroutine r8mat_scale ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 )  s,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 19250 of file R8LIB.f90.

19251
19252!*****************************************************************************80
19253!
19254!! R8MAT_SCALE multiplies an R8MAT by a scalar.
19255!
19256! Discussion:
19257!
19258! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19259!
19260! Licensing:
19261!
19262! This code is distributed under the GNU LGPL license.
19263!
19264! Modified:
19265!
19266! 01 December 2011
19267!
19268! Author:
19269!
19270! John Burkardt
19271!
19272! Parameters:
19273!
19274! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
19275!
19276! Input, real ( kind = 8 ) S, the scale factor.
19277!
19278! Input/output, real ( kind = 8 ) A(M,N), the matrix to be scaled.
19279!
19280 implicit none
19281
19282 integer ( kind = 4 ) m
19283 integer ( kind = 4 ) n
19284
19285 real ( kind = 8 ) a(m,n)
19286 real ( kind = 8 ) s
19287
19288 a(1:m,1:n) = a(1:m,1:n) * s
19289
19290 return

◆ r8mat_solve()

subroutine r8mat_solve ( integer ( kind = 4 )  n,
integer ( kind = 4 )  rhs_num,
real ( kind = 8 ), dimension(n,n+rhs_num)  a,
integer ( kind = 4 )  info 
)

Definition at line 19292 of file R8LIB.f90.

19293
19294!*****************************************************************************80
19295!
19296!! R8MAT_SOLVE uses Gauss-Jordan elimination to solve an N by N linear system.
19297!
19298! Discussion:
19299!
19300! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19301!
19302! Licensing:
19303!
19304! This code is distributed under the GNU LGPL license.
19305!
19306! Modified:
19307!
19308! 06 August 2009
19309!
19310! Author:
19311!
19312! John Burkardt
19313!
19314! Parameters:
19315!
19316! Input, integer ( kind = 4 ) N, the order of the matrix.
19317!
19318! Input, integer ( kind = 4 ) RHS_NUM, the number of right hand sides.
19319! RHS_NUM must be at least 0.
19320!
19321! Input/output, real ( kind = 8 ) A(N,N+RHS_NUM), contains in rows and
19322! columns 1 to N the coefficient matrix, and in columns N+1 through
19323! N+RHS_NUM, the right hand sides. On output, the coefficient matrix
19324! area has been destroyed, while the right hand sides have
19325! been overwritten with the corresponding solutions.
19326!
19327! Output, integer ( kind = 4 ) INFO, singularity flag.
19328! 0, the matrix was not singular, the solutions were computed;
19329! J, factorization failed on step J, and the solutions could not
19330! be computed.
19331!
19332 implicit none
19333
19334 integer ( kind = 4 ) n
19335 integer ( kind = 4 ) rhs_num
19336
19337 real ( kind = 8 ) a(n,n+rhs_num)
19338 real ( kind = 8 ) apivot
19339 real ( kind = 8 ) factor
19340 integer ( kind = 4 ) i
19341 integer ( kind = 4 ) info
19342 integer ( kind = 4 ) ipivot
19343 integer ( kind = 4 ) j
19344 real ( kind = 8 ) t(n+rhs_num)
19345
19346 info = 0
19347
19348 do j = 1, n
19349!
19350! Choose a pivot row.
19351!
19352 ipivot = j
19353 apivot = a(j,j)
19354
19355 do i = j + 1, n
19356 if ( abs( apivot ) < abs( a(i,j) ) ) then
19357 apivot = a(i,j)
19358 ipivot = i
19359 end if
19360 end do
19361
19362 if ( apivot == 0.0d+00 ) then
19363 info = j
19364 return
19365 end if
19366!
19367! The pivot row moves into the J-th row.
19368!
19369 if ( ipivot /= j ) then
19370 t( 1:n+rhs_num) = a(ipivot,1:n+rhs_num)
19371 a(ipivot,1:n+rhs_num) = a(j, 1:n+rhs_num)
19372 a(j, 1:n+rhs_num) = t( 1:n+rhs_num)
19373 end if
19374!
19375! A(J,J) becomes 1.
19376!
19377 a(j,j) = 1.0d+00
19378 a(j,j+1:n+rhs_num) = a(j,j+1:n+rhs_num) / apivot
19379!
19380! A(I,J) becomes 0.
19381!
19382 do i = 1, n
19383
19384 if ( i /= j ) then
19385 factor = a(i,j)
19386 a(i,j) = 0.0d+00
19387 a(i,j+1:n+rhs_num) = a(i,j+1:n+rhs_num) - factor * a(j,j+1:n+rhs_num)
19388 end if
19389
19390 end do
19391
19392 end do
19393
19394 return

◆ r8mat_solve2()

subroutine r8mat_solve2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 )  ierror 
)

Definition at line 19537 of file R8LIB.f90.

19538
19539!*****************************************************************************80
19540!
19541!! R8MAT_SOLVE2 computes the solution of an N by N linear system.
19542!
19543! Discussion:
19544!
19545! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19546!
19547! The linear system may be represented as
19548!
19549! A*X = B
19550!
19551! If the linear system is singular, but consistent, then the routine will
19552! still produce a solution.
19553!
19554! Licensing:
19555!
19556! This code is distributed under the GNU LGPL license.
19557!
19558! Modified:
19559!
19560! 29 October 2005
19561!
19562! Author:
19563!
19564! John Burkardt
19565!
19566! Parameters:
19567!
19568! Input, integer ( kind = 4 ) N, the number of equations.
19569!
19570! Input/output, real ( kind = 8 ) A(N,N).
19571! On input, A is the coefficient matrix to be inverted.
19572! On output, A has been overwritten.
19573!
19574! Input/output, real ( kind = 8 ) B(N).
19575! On input, B is the right hand side of the system.
19576! On output, B has been overwritten.
19577!
19578! Output, real ( kind = 8 ) X(N), the solution of the linear system.
19579!
19580! Output, integer ( kind = 4 ) IERROR.
19581! 0, no error detected.
19582! 1, consistent singularity.
19583! 2, inconsistent singularity.
19584!
19585 implicit none
19586
19587 integer ( kind = 4 ) n
19588
19589 real ( kind = 8 ) a(n,n)
19590 real ( kind = 8 ) amax
19591 real ( kind = 8 ) b(n)
19592 integer ( kind = 4 ) i
19593 integer ( kind = 4 ) ierror
19594 integer ( kind = 4 ) imax
19595 integer ( kind = 4 ) ipiv(n)
19596 integer ( kind = 4 ) j
19597 integer ( kind = 4 ) k
19598 real ( kind = 8 ) x(n)
19599
19600 ierror = 0
19601
19602 ipiv(1:n) = 0
19603 x(1:n) = 0.0d+00
19604!
19605! Process the matrix.
19606!
19607 do k = 1, n
19608!
19609! In column K:
19610! Seek the row IMAX with the properties that:
19611! IMAX has not already been used as a pivot;
19612! A(IMAX,K) is larger in magnitude than any other candidate.
19613!
19614 amax = 0.0d+00
19615 imax = 0
19616 do i = 1, n
19617 if ( ipiv(i) == 0 ) then
19618 if ( amax < abs( a(i,k) ) ) then
19619 imax = i
19620 amax = abs( a(i,k) )
19621 end if
19622 end if
19623 end do
19624!
19625! If you found a pivot row IMAX, then,
19626! eliminate the K-th entry in all rows that have not been used for pivoting.
19627!
19628 if ( imax /= 0 ) then
19629
19630 ipiv(imax) = k
19631 a(imax,k+1:n) = a(imax,k+1:n) / a(imax,k)
19632 b(imax) = b(imax) / a(imax,k)
19633 a(imax,k) = 1.0d+00
19634
19635 do i = 1, n
19636
19637 if ( ipiv(i) == 0 ) then
19638 a(i,k+1:n) = a(i,k+1:n) - a(i,k) * a(imax,k+1:n)
19639 b(i) = b(i) - a(i,k) * b(imax)
19640 a(i,k) = 0.0d+00
19641 end if
19642
19643 end do
19644
19645 end if
19646
19647 end do
19648!
19649! Now, every row with nonzero IPIV begins with a 1, and
19650! all other rows are all zero. Begin solution.
19651!
19652 do j = n, 1, -1
19653
19654 imax = 0
19655 do k = 1, n
19656 if ( ipiv(k) == j ) then
19657 imax = k
19658 end if
19659 end do
19660
19661 if ( imax == 0 ) then
19662
19663 x(j) = 0.0d+00
19664
19665 if ( b(j) == 0.0d+00 ) then
19666 ierror = 1
19667 write ( *, '(a)' ) ' '
19668 write ( *, '(a)' ) 'R8MAT_SOLVE2 - Warning:'
19669 write ( *, '(a,i8)' ) ' Consistent singularity, equation = ', j
19670 else
19671 ierror = 2
19672 write ( *, '(a)' ) ' '
19673 write ( *, '(a)' ) 'R8MAT_SOLVE2 - Error:'
19674 write ( *, '(a,i8)' ) ' Inconsistent singularity, equation = ', j
19675 end if
19676
19677 else
19678
19679 x(j) = b(imax)
19680
19681 do i = 1, n
19682 if ( i /= imax ) then
19683 b(i) = b(i) - a(i,j) * x(j)
19684 end if
19685 end do
19686
19687 end if
19688
19689 end do
19690
19691 return

◆ r8mat_solve_2d()

subroutine r8mat_solve_2d ( real ( kind = 8 ), dimension(2,2)  a,
real ( kind = 8 ), dimension(2)  b,
real ( kind = 8 )  det,
real ( kind = 8 ), dimension(2)  x 
)

Definition at line 19396 of file R8LIB.f90.

19397
19398!*****************************************************************************80
19399!
19400!! R8MAT_SOLVE_2D solves a 2 by 2 linear system using Cramer's rule.
19401!
19402! Discussion:
19403!
19404! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19405!
19406! If the determinant DET is returned as zero, then the matrix A is
19407! singular, and does not have an inverse. In that case, X is
19408! returned as the zero vector.
19409!
19410! If DET is nonzero, then its value is roughly an estimate
19411! of how nonsingular the matrix A is.
19412!
19413! Licensing:
19414!
19415! This code is distributed under the GNU LGPL license.
19416!
19417! Modified:
19418!
19419! 16 November 2005
19420!
19421! Author:
19422!
19423! John Burkardt
19424!
19425! Parameters:
19426!
19427! Input, real ( kind = 8 ) A(2,2), the matrix.
19428!
19429! Input, real ( kind = 8 ) B(2), the right hand side.
19430!
19431! Output, real ( kind = 8 ) DET, the determinant of the matrix A.
19432!
19433! Output, real ( kind = 8 ) X(2), the solution of the system,
19434! if DET is nonzero.
19435!
19436 implicit none
19437
19438 real ( kind = 8 ) a(2,2)
19439 real ( kind = 8 ) b(2)
19440 real ( kind = 8 ) det
19441 real ( kind = 8 ) x(2)
19442!
19443! Compute the determinant.
19444!
19445 det = a(1,1) * a(2,2) - a(1,2) * a(2,1)
19446!
19447! If the determinant is zero, bail out.
19448!
19449 if ( det == 0.0d+00 ) then
19450 x(1:2) = 0.0d+00
19451 return
19452 end if
19453!
19454! Compute the solution.
19455!
19456 x(1) = ( a(2,2) * b(1) - a(1,2) * b(2) ) / det
19457 x(2) = ( -a(2,1) * b(1) + a(1,1) * b(2) ) / det
19458
19459 return

◆ r8mat_solve_3d()

subroutine r8mat_solve_3d ( real ( kind = 8 ), dimension(3,3)  a,
real ( kind = 8 ), dimension(3)  b,
real ( kind = 8 )  det,
real ( kind = 8 ), dimension(3)  x 
)

Definition at line 19461 of file R8LIB.f90.

19462
19463!*****************************************************************************80
19464!
19465!! R8MAT_SOLVE_3D solves a 3 by 3 linear system using Cramer's rule.
19466!
19467! Discussion:
19468!
19469! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19470!
19471! If the determinant DET is returned as zero, then the matrix A is
19472! singular, and does not have an inverse. In that case, X is
19473! returned as the zero vector.
19474!
19475! If DET is nonzero, then its value is roughly an estimate
19476! of how nonsingular the matrix A is.
19477!
19478! Licensing:
19479!
19480! This code is distributed under the GNU LGPL license.
19481!
19482! Modified:
19483!
19484! 05 December 2006
19485!
19486! Author:
19487!
19488! John Burkardt
19489!
19490! Parameters:
19491!
19492! Input, real ( kind = 8 ) A(3,3), the matrix.
19493!
19494! Input, real ( kind = 8 ) B(3), the right hand side.
19495!
19496! Output, real ( kind = 8 ) DET, the determinant of the matrix A.
19497!
19498! Output, real ( kind = 8 ) X(3), the solution of the system,
19499! if DET is nonzero.
19500!
19501 implicit none
19502
19503 real ( kind = 8 ) a(3,3)
19504 real ( kind = 8 ) b(3)
19505 real ( kind = 8 ) det
19506 real ( kind = 8 ) x(3)
19507!
19508! Compute the determinant.
19509!
19510 det = a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
19511 + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
19512 + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )
19513!
19514! If the determinant is zero, bail out.
19515!
19516 if ( det == 0.0d+00 ) then
19517 x(1:3) = 0.0d+00
19518 return
19519 end if
19520!
19521! Compute the solution.
19522!
19523 x(1) = ( ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) * b(1) &
19524 - ( a(1,2) * a(3,3) - a(1,3) * a(3,2) ) * b(2) &
19525 + ( a(1,2) * a(2,3) - a(1,3) * a(2,2) ) * b(3) ) / det
19526
19527 x(2) = ( - ( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) * b(1) &
19528 + ( a(1,1) * a(3,3) - a(1,3) * a(3,1) ) * b(2) &
19529 - ( a(1,1) * a(2,3) - a(1,3) * a(2,1) ) * b(3) ) / det
19530
19531 x(3) = ( ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) * b(1) &
19532 - ( a(1,1) * a(3,2) - a(1,2) * a(3,1) ) * b(2) &
19533 + ( a(1,1) * a(2,2) - a(1,2) * a(2,1) ) * b(3) ) / det
19534
19535 return

◆ r8mat_sub()

subroutine r8mat_sub ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m,n)  b,
real ( kind = 8 ), dimension(m,n)  c 
)

Definition at line 19693 of file R8LIB.f90.

19694
19695!*****************************************************************************80
19696!
19697!! R8MAT_SUB computes the difference of two R8MAT's.
19698!
19699! Discussion:
19700!
19701! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19702!
19703! Licensing:
19704!
19705! This code is distributed under the GNU LGPL license.
19706!
19707! Modified:
19708!
19709! 22 November 2013
19710!
19711! Author:
19712!
19713! John Burkardt
19714!
19715! Parameters:
19716!
19717! Input, integer ( kind = 4 ) M, N, the order of the matrices.
19718!
19719! Input, real ( kind = 8 ) A(M,N), B(M,N), the matrices.
19720!
19721! Output, real ( kind = 8 ) C(M,N), the result A - B.
19722!
19723 implicit none
19724
19725 integer ( kind = 4 ) m
19726 integer ( kind = 4 ) n
19727
19728 real ( kind = 8 ) a(m,n)
19729 real ( kind = 8 ) b(m,n)
19730 real ( kind = 8 ) c(m,n)
19731
19732 c(1:m,1:n) = a(1:m,1:n) - b(1:m,1:n)
19733
19734 return

◆ r8mat_sum()

real ( kind = 8 ) function r8mat_sum ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 19736 of file R8LIB.f90.

19737
19738!*****************************************************************************80
19739!
19740!! R8MAT_SUM returns the sum of the entries of an R8MAT.
19741!
19742! Discussion:
19743!
19744! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19745!
19746! In FORTRAN90, this facility is offered by the built in
19747! SUM function:
19748!
19749! R8MAT_SUM ( M, N, A ) = SUM ( A(1:M,1:N) )
19750!
19751! Licensing:
19752!
19753! This code is distributed under the GNU LGPL license.
19754!
19755! Modified:
19756!
19757! 04 January 2012
19758!
19759! Author:
19760!
19761! John Burkardt
19762!
19763! Parameters:
19764!
19765! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
19766!
19767! Input, real ( kind = 8 ) A(N), the array.
19768!
19769! Output, real ( kind = 8 ) R8MAT_SUM, the sum of the entries.
19770!
19771 implicit none
19772
19773 integer ( kind = 4 ) m
19774 integer ( kind = 4 ) n
19775
19776 real ( kind = 8 ) a(m,n)
19777 real ( kind = 8 ) r8mat_sum
19778
19779 r8mat_sum = sum( a(1:m,1:n) )
19780
19781 return
r8mat_sum
real(kind=8) function r8mat_sum(m, n, a)
Definition R8LIB.f90:19737

References r8mat_sum().

Referenced by r8mat_sum().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_symm_eigen()

subroutine r8mat_symm_eigen ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n,n)  q,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 19783 of file R8LIB.f90.

19784
19785!*****************************************************************************80
19786!
19787!! R8MAT_SYMM_EIGEN returns a symmetric matrix with given eigensystem.
19788!
19789! Discussion:
19790!
19791! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19792!
19793! The user must supply the desired eigenvalue vector, and the desired
19794! eigenvector matrix. The eigenvector matrix must be orthogonal. A
19795! suitable random orthogonal matrix can be generated by R8MAT_ORTH_UNIFORM.
19796!
19797! Licensing:
19798!
19799! This code is distributed under the GNU LGPL license.
19800!
19801! Modified:
19802!
19803! 18 October 2005
19804!
19805! Author:
19806!
19807! John Burkardt
19808!
19809! Parameters:
19810!
19811! Input, integer ( kind = 4 ) N, the order of A.
19812!
19813! Input, real ( kind = 8 ) X(N), the desired eigenvalues for the matrix.
19814!
19815! Input, real ( kind = 8 ) Q(N,N), the eigenvector matrix of A.
19816!
19817! Output, real ( kind = 8 ) A(N,N), a symmetric matrix with
19818! eigenvalues X and eigenvectors the columns of Q.
19819!
19820 implicit none
19821
19822 integer ( kind = 4 ) n
19823
19824 real ( kind = 8 ) a(n,n)
19825 integer ( kind = 4 ) i
19826 integer ( kind = 4 ) j
19827 integer ( kind = 4 ) k
19828 real ( kind = 8 ) q(n,n)
19829 real ( kind = 8 ) x(n)
19830!
19831! Set A = Q * Lambda * Q'.
19832!
19833 a(1:n,1:n) = 0.0d+00
19834
19835 do i = 1, n
19836 do j = 1, n
19837 do k = 1, n
19838 a(i,j) = a(i,j) + q(i,k) * x(k) * q(j,k)
19839 end do
19840 end do
19841 end do
19842
19843 return

◆ r8mat_symm_jacobi()

subroutine r8mat_symm_jacobi ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 19845 of file R8LIB.f90.

19846
19847!*****************************************************************************80
19848!
19849!! R8MAT_SYMM_JACOBI applies Jacobi eigenvalue iteration to a symmetric matrix.
19850!
19851! Discussion:
19852!
19853! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
19854!
19855! This code was modified so that it treats as zero the off-diagonal
19856! elements that are sufficiently close to, but not exactly, zero.
19857!
19858! Licensing:
19859!
19860! This code is distributed under the GNU LGPL license.
19861!
19862! Modified:
19863!
19864! 09 June 2003
19865!
19866! Author:
19867!
19868! John Burkardt
19869!
19870! Parameters:
19871!
19872! Input, integer ( kind = 4 ) N, the order of A.
19873!
19874! Input/output, real ( kind = 8 ) A(N,N), a symmetric N by N matrix.
19875! On output, the matrix has been overwritten by an approximately
19876! diagonal matrix, with the eigenvalues on the diagonal.
19877!
19878 implicit none
19879
19880 integer ( kind = 4 ) n
19881
19882 real ( kind = 8 ) a(n,n)
19883 real ( kind = 8 ) c
19884 real ( kind = 8 ) r8mat_norm_fro
19885 real ( kind = 8 ), parameter :: eps = 0.00001d+00
19886 integer ( kind = 4 ) i
19887 integer ( kind = 4 ) it
19888 integer ( kind = 4 ), parameter :: it_max = 100
19889 integer ( kind = 4 ) j
19890 integer ( kind = 4 ) k
19891 real ( kind = 8 ) norm_fro
19892 real ( kind = 8 ) s
19893 real ( kind = 8 ) sum2
19894 real ( kind = 8 ) t
19895 real ( kind = 8 ) t1
19896 real ( kind = 8 ) t2
19897 real ( kind = 8 ) u
19898
19899 norm_fro = r8mat_norm_fro( n, n, a )
19900
19901 it = 0
19902
19903 do
19904
19905 it = it + 1
19906
19907 do i = 1, n
19908 do j = 1, i - 1
19909
19910 if ( eps * norm_fro < abs( a(i,j) ) + abs( a(j,i) ) ) then
19911
19912 u = ( a(j,j) - a(i,i) ) / ( a(i,j) + a(j,i) )
19913
19914 t = sign( 1.0d+00, u ) / ( abs( u ) + sqrt( u * u + 1.0d+00 ) )
19915 c = 1.0d+00 / sqrt( t * t + 1.0d+00 )
19916 s = t * c
19917!
19918! A -> A * Q.
19919!
19920 do k = 1, n
19921 t1 = a(i,k)
19922 t2 = a(j,k)
19923 a(i,k) = t1 * c - t2 * s
19924 a(j,k) = t1 * s + t2 * c
19925 end do
19926!
19927! A -> QT * A
19928!
19929 do k = 1, n
19930 t1 = a(k,i)
19931 t2 = a(k,j)
19932 a(k,i) = c * t1 - s * t2
19933 a(k,j) = s * t1 + c * t2
19934 end do
19935
19936 end if
19937 end do
19938 end do
19939!
19940! Test the size of the off-diagonal elements.
19941!
19942 sum2 = 0.0d+00
19943 do i = 1, n
19944 do j = 1, i - 1
19945 sum2 = sum2 + abs( a(i,j) )
19946 end do
19947 end do
19948
19949 if ( sum2 <= eps * ( norm_fro + 1.0d+00 ) ) then
19950 exit
19951 end if
19952
19953 if ( it_max <= it ) then
19954 exit
19955 end if
19956
19957 end do
19958
19959 return

References r8mat_norm_fro().

Referenced by r8mat_norm_l2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_to_r8cmat()

subroutine r8mat_to_r8cmat ( integer ( kind = 4 )  lda,
integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a1,
real ( kind = 8 ), dimension(lda,n)  a2 
)

Definition at line 19961 of file R8LIB.f90.

19962
19963!*****************************************************************************80
19964!
19965!! R8MAT_TO_R8CMAT transfers data from an R8MAT to an R8CMAT.
19966!
19967! Discussion:
19968!
19969! An R8MAT is an MxN array of R8's,
19970! accessible as a vector:
19971! (I,J) -> (I+J*M).
19972! or as a doubly-dimensioned array, if declared A(M,N):
19973! (I,J) -> A(I,J)
19974!
19975! An R8CMAT is an MxN array of R8's, stored with a leading dimension LD,
19976! accessible as a vector:
19977! (I,J) -> (I+J*LD).
19978! or as a doubly-dimensioned array, if declared A(LD,N):
19979! (I,J) -> A(I,J)
19980!
19981! Licensing:
19982!
19983! This code is distributed under the GNU LGPL license.
19984!
19985! Modified:
19986!
19987! 19 March 2014
19988!
19989! Author:
19990!
19991! John Burkardt
19992!
19993! Parameters:
19994!
19995! Input, integer ( kind = 4 ) LDA, the leading dimension of A2.
19996!
19997! Input, integer ( kind = 4 ) M, the number of rows of data.
19998! M <= LDA.
19999!
20000! Input, integer ( kind = 4 ) N, the number of columns of data.
20001!
20002! Input, real ( kind = 8 ) A1(M,N), the matrix to be copied.
20003!
20004! Output, real ( kind = 8 ) A2(LDA,N), contains a copy of the
20005! information in A1, in the MxN submatrix.
20006!
20007 implicit none
20008
20009 integer ( kind = 4 ) lda
20010 integer ( kind = 4 ) m
20011 integer ( kind = 4 ) n
20012
20013 real ( kind = 8 ) a1(m,n)
20014 real ( kind = 8 ) a2(lda,n)
20015
20016 a2(1:m,1:n) = a1(1:m,1:n)
20017
20018 return

◆ r8mat_to_r8plu()

subroutine r8mat_to_r8plu ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
integer ( kind = 4 )  info 
)

Definition at line 20020 of file R8LIB.f90.

20021
20022!*****************************************************************************80
20023!
20024!! R8MAT_TO_R8PLU factors a general R8MAT.
20025!
20026! Discussion:
20027!
20028! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20029!
20030! This routine is a simplified version of the LINPACK routine DGEFA.
20031!
20032! Licensing:
20033!
20034! This code is distributed under the GNU LGPL license.
20035!
20036! Modified:
20037!
20038! 09 December 2004
20039!
20040! Author:
20041!
20042! John Burkardt
20043!
20044! Reference:
20045!
20046! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
20047! LINPACK User's Guide,
20048! SIAM, 1979,
20049! ISBN13: 978-0-898711-72-1.
20050!
20051! Parameters:
20052!
20053! Input, integer ( kind = 4 ) N, the order of the matrix.
20054! N must be positive.
20055!
20056! Input, real ( kind = 8 ) A(N,N), the matrix to be factored.
20057!
20058! Output, integer ( kind = 4 ) PIVOT(N), a vector of pivot indices.
20059!
20060! Output, real ( kind = 8 ) LU(N,N), an upper triangular matrix U and
20061! the multipliers L which were used to obtain it. The factorization
20062! can be written A = L * U, where L is a product of permutation and
20063! unit lower triangular matrices and U is upper triangular.
20064!
20065! Output, integer ( kind = 4 ) INFO, singularity flag.
20066! 0, no singularity detected.
20067! nonzero, the factorization failed on the INFO-th step.
20068!
20069 implicit none
20070
20071 integer ( kind = 4 ) n
20072
20073 real ( kind = 8 ) a(n,n)
20074 integer ( kind = 4 ) i
20075 integer ( kind = 4 ) info
20076 integer ( kind = 4 ) pivot(n)
20077 integer ( kind = 4 ) j
20078 integer ( kind = 4 ) k
20079 integer ( kind = 4 ) l
20080 real ( kind = 8 ) lu(n,n)
20081 real ( kind = 8 ) temp
20082
20083 lu(1:n,1:n) = a(1:n,1:n)
20084
20085 info = 0
20086
20087 do k = 1, n - 1
20088!
20089! Find L, the index of the pivot row.
20090!
20091 l = k
20092 do i = k + 1, n
20093 if ( abs( lu(l,k) ) < abs( lu(i,k) ) ) then
20094 l = i
20095 end if
20096 end do
20097
20098 pivot(k) = l
20099!
20100! If the pivot index is zero, the algorithm has failed.
20101!
20102 if ( lu(l,k) == 0.0d+00 ) then
20103 info = k
20104 write ( *, '(a)' ) ' '
20105 write ( *, '(a)' ) 'R8MAT_TO_R8PLU - Fatal error!'
20106 write ( *, '(a,i8)' ) ' Zero pivot on step ', info
20107 return
20108 end if
20109!
20110! Interchange rows L and K if necessary.
20111!
20112 if ( l /= k ) then
20113 temp = lu(l,k)
20114 lu(l,k) = lu(k,k)
20115 lu(k,k) = temp
20116 end if
20117!
20118! Normalize the values that lie below the pivot entry A(K,K).
20119!
20120 lu(k+1:n,k) = -lu(k+1:n,k) / lu(k,k)
20121!
20122! Row elimination with column indexing.
20123!
20124 do j = k + 1, n
20125
20126 if ( l /= k ) then
20127 temp = lu(l,j)
20128 lu(l,j) = lu(k,j)
20129 lu(k,j) = temp
20130 end if
20131
20132 lu(k+1:n,j) = lu(k+1:n,j) + lu(k+1:n,k) * lu(k,j)
20133
20134 end do
20135
20136 end do
20137
20138 pivot(n) = n
20139
20140 if ( lu(n,n) == 0.0d+00 ) then
20141 info = n
20142 write ( *, '(a)' ) ' '
20143 write ( *, '(a)' ) 'R8MAT_TO_R8PLU - Fatal error!'
20144 write ( *, '(a,i8)' ) ' Zero pivot on step ', info
20145 end if
20146
20147 return

◆ r8mat_trace()

real ( kind = 8 ) function r8mat_trace ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 20149 of file R8LIB.f90.

20150
20151!*****************************************************************************80
20152!
20153!! R8MAT_TRACE computes the trace of an R8MAT.
20154!
20155! Discussion:
20156!
20157! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20158!
20159! The trace of a square matrix is the sum of the diagonal elements.
20160!
20161! Licensing:
20162!
20163! This code is distributed under the GNU LGPL license.
20164!
20165! Modified:
20166!
20167! 20 July 1999
20168!
20169! Author:
20170!
20171! John Burkardt
20172!
20173! Parameters:
20174!
20175! Input, integer ( kind = 4 ) N, the order of the matrix A.
20176!
20177! Input, real ( kind = 8 ) A(N,N), the matrix whose trace is desired.
20178!
20179! Output, real ( kind = 8 ) R8MAT_TRACE, the trace of the matrix.
20180!
20181 implicit none
20182
20183 integer ( kind = 4 ) n
20184
20185 real ( kind = 8 ) a(n,n)
20186 integer ( kind = 4 ) i
20187 real ( kind = 8 ) r8mat_trace
20188
20189 r8mat_trace = 0.0d+00
20190 do i = 1, n
20191 r8mat_trace = r8mat_trace + a(i,i)
20192 end do
20193
20194 return

References r8mat_trace().

Referenced by r8mat_poly_char(), and r8mat_trace().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_transpose()

subroutine r8mat_transpose ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n,m)  at 
)

Definition at line 20196 of file R8LIB.f90.

20197
20198!*****************************************************************************80
20199!
20200!! R8MAT_TRANSPOSE makes a transposed copy of an R8MAT.
20201!
20202! Discussion:
20203!
20204! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20205!
20206! FORTRAN90 provides the transpose ( ) function which should be preferred
20207! over this routine.
20208!
20209! Licensing:
20210!
20211! This code is distributed under the GNU LGPL license.
20212!
20213! Modified:
20214!
20215! 13 June 2011
20216!
20217! Author:
20218!
20219! John Burkardt
20220!
20221! Parameters:
20222!
20223! Input, integer ( kind = 4 ) M, N, the number of rows and columns
20224! of the matrix A.
20225!
20226! Input, real ( kind = 8 ) A(N,N), the matrix to be transposed.
20227!
20228! Output, real ( kind = 8 ) AT(N,M), the matrix to be transposed.
20229!
20230 implicit none
20231
20232 integer ( kind = 4 ) m
20233 integer ( kind = 4 ) n
20234
20235 real ( kind = 8 ) a(m,n)
20236 real ( kind = 8 ) at(n,m)
20237 integer ( kind = 4 ) i
20238 integer ( kind = 4 ) j
20239
20240 at = transpose( a )
20241
20242 return

◆ r8mat_transpose_in_place()

subroutine r8mat_transpose_in_place ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 20244 of file R8LIB.f90.

20245
20246!*****************************************************************************80
20247!
20248!! R8MAT_TRANSPOSE_IN_PLACE transposes an R8MAT in place.
20249!
20250! Discussion:
20251!
20252! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20253!
20254! Licensing:
20255!
20256! This code is distributed under the GNU LGPL license.
20257!
20258! Modified:
20259!
20260! 27 June 2008
20261!
20262! Author:
20263!
20264! John Burkardt
20265!
20266! Parameters:
20267!
20268! Input, integer ( kind = 4 ) N, the number of rows and columns
20269! of the matrix A.
20270!
20271! Input/output, real ( kind = 8 ) A(N,N), the matrix to be transposed.
20272!
20273 implicit none
20274
20275 integer ( kind = 4 ) n
20276
20277 real ( kind = 8 ) a(n,n)
20278 integer ( kind = 4 ) i
20279 integer ( kind = 4 ) j
20280 real ( kind = 8 ) t
20281
20282 do j = 1, n
20283 do i = 1, j - 1
20284 t = a(i,j)
20285 a(i,j) = a(j,i)
20286 a(j,i) = t
20287 end do
20288 end do
20289
20290 return

◆ r8mat_transpose_print()

subroutine r8mat_transpose_print ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
character ( len = * )  title 
)

Definition at line 20292 of file R8LIB.f90.

20293
20294!*****************************************************************************80
20295!
20296!! R8MAT_TRANSPOSE_PRINT prints an R8MAT, transposed.
20297!
20298! Discussion:
20299!
20300! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20301!
20302! Licensing:
20303!
20304! This code is distributed under the GNU LGPL license.
20305!
20306! Modified:
20307!
20308! 14 June 2004
20309!
20310! Author:
20311!
20312! John Burkardt
20313!
20314! Parameters:
20315!
20316! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
20317!
20318! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
20319!
20320! Input, character ( len = * ) TITLE, a title.
20321!
20322 implicit none
20323
20324 integer ( kind = 4 ) m
20325 integer ( kind = 4 ) n
20326
20327 real ( kind = 8 ) a(m,n)
20328 character ( len = * ) title
20329
20330 call r8mat_transpose_print_some ( m, n, a, 1, 1, m, n, title )
20331
20332 return
r8mat_transpose_print_some
subroutine r8mat_transpose_print_some(m, n, a, ilo, jlo, ihi, jhi, title)
Definition R8LIB.f90:20335

References r8mat_transpose_print_some().

Here is the call graph for this function:

◆ r8mat_transpose_print_some()

subroutine r8mat_transpose_print_some ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  ilo,
integer ( kind = 4 )  jlo,
integer ( kind = 4 )  ihi,
integer ( kind = 4 )  jhi,
character ( len = * )  title 
)

Definition at line 20334 of file R8LIB.f90.

20335
20336!*****************************************************************************80
20337!
20338!! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed.
20339!
20340! Discussion:
20341!
20342! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20343!
20344! Licensing:
20345!
20346! This code is distributed under the GNU LGPL license.
20347!
20348! Modified:
20349!
20350! 10 September 2009
20351!
20352! Author:
20353!
20354! John Burkardt
20355!
20356! Parameters:
20357!
20358! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
20359!
20360! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
20361!
20362! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
20363!
20364! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
20365!
20366! Input, character ( len = * ) TITLE, a title.
20367!
20368 implicit none
20369
20370 integer ( kind = 4 ), parameter :: incx = 5
20371 integer ( kind = 4 ) m
20372 integer ( kind = 4 ) n
20373
20374 real ( kind = 8 ) a(m,n)
20375 character ( len = 14 ) ctemp(incx)
20376 integer ( kind = 4 ) i
20377 integer ( kind = 4 ) i2
20378 integer ( kind = 4 ) i2hi
20379 integer ( kind = 4 ) i2lo
20380 integer ( kind = 4 ) ihi
20381 integer ( kind = 4 ) ilo
20382 integer ( kind = 4 ) inc
20383 integer ( kind = 4 ) j
20384 integer ( kind = 4 ) j2hi
20385 integer ( kind = 4 ) j2lo
20386 integer ( kind = 4 ) jhi
20387 integer ( kind = 4 ) jlo
20388 character ( len = * ) title
20389
20390 write ( *, '(a)' ) ' '
20391 write ( *, '(a)' ) trim( title )
20392
20393 if ( m <= 0 .or. n <= 0 ) then
20394 write ( *, '(a)' ) ' '
20395 write ( *, '(a)' ) ' (None)'
20396 return
20397 end if
20398
20399 do i2lo = max( ilo, 1 ), min( ihi, m ), incx
20400
20401 i2hi = i2lo + incx - 1
20402 i2hi = min( i2hi, m )
20403 i2hi = min( i2hi, ihi )
20404
20405 inc = i2hi + 1 - i2lo
20406
20407 write ( *, '(a)' ) ' '
20408
20409 do i = i2lo, i2hi
20410 i2 = i + 1 - i2lo
20411 write ( ctemp(i2), '(i8,6x)' ) i
20412 end do
20413
20414 write ( *, '('' Row '',5a14)' ) ctemp(1:inc)
20415 write ( *, '(a)' ) ' Col'
20416 write ( *, '(a)' ) ' '
20417
20418 j2lo = max( jlo, 1 )
20419 j2hi = min( jhi, n )
20420
20421 do j = j2lo, j2hi
20422
20423 do i2 = 1, inc
20424 i = i2lo - 1 + i2
20425 write ( ctemp(i2), '(g14.6)' ) a(i,j)
20426 end do
20427
20428 write ( *, '(i5,a,5a14)' ) j, ':', ( ctemp(i), i = 1, inc )
20429
20430 end do
20431
20432 end do
20433
20434 return

Referenced by r8mat_transpose_print().

Here is the caller graph for this function:

◆ r8mat_u1_inverse()

subroutine r8mat_u1_inverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  b 
)

Definition at line 20555 of file R8LIB.f90.

20556
20557!*****************************************************************************80
20558!
20559!! R8MAT_U1_INVERSE inverts a unit upper triangular R8MAT.
20560!
20561! Discussion:
20562!
20563! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20564!
20565! A unit upper triangular matrix is a matrix with only 1's on the main
20566! diagonal, and only 0's below the main diagonal.
20567!
20568! The inverse of a unit upper triangular matrix is also
20569! a unit upper triangular matrix.
20570!
20571! This routine can invert a matrix in place, that is, with no extra
20572! storage. If the matrix is stored in A, then the call
20573!
20574! call r8mat_u1_inverse ( n, a, a )
20575!
20576! will result in A being overwritten by its inverse.
20577!
20578! Licensing:
20579!
20580! This code is distributed under the GNU LGPL license.
20581!
20582! Modified:
20583!
20584! 11 December 2004
20585!
20586! Author:
20587!
20588! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf.
20589! FORTRAN90 version by John Burkardt,
20590!
20591! Reference:
20592!
20593! Albert Nijenhuis, Herbert Wilf,
20594! Combinatorial Algorithms for Computers and Calculators,
20595! Academic Press, 1978,
20596! ISBN: 0-12-519260-6,
20597! LC: QA164.N54.
20598!
20599! Parameters:
20600!
20601! Input, integer ( kind = 4 ) N, number of rows and columns in the matrix.
20602!
20603! Input, real ( kind = 8 ) A(N,N), the unit upper triangular matrix.
20604!
20605! Output, real ( kind = 8 ) B(N,N), the inverse matrix.
20606!
20607 implicit none
20608
20609 integer ( kind = 4 ) n
20610
20611 real ( kind = 8 ) a(n,n)
20612 real ( kind = 8 ) b(n,n)
20613 integer ( kind = 4 ) i
20614 integer ( kind = 4 ) j
20615
20616 do j = n, 1, -1
20617
20618 do i = n, 1, -1
20619
20620 if ( j < i ) then
20621 b(i,j) = 0.0d+00
20622 else if ( i == j ) then
20623 b(i,j) = 1.0d+00
20624 else
20625 b(i,j) = -dot_product( a(i,i+1:j), b(i+1:j,j) )
20626 end if
20627
20628 end do
20629 end do
20630
20631 return

◆ r8mat_u_inverse()

subroutine r8mat_u_inverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n,n)  b 
)

Definition at line 20436 of file R8LIB.f90.

20437
20438!*****************************************************************************80
20439!
20440!! R8MAT_U_INVERSE inverts an upper triangular R8MAT.
20441!
20442! Discussion:
20443!
20444! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20445!
20446! An upper triangular matrix is a matrix whose only nonzero entries
20447! occur on or above the diagonal.
20448!
20449! The inverse of an upper triangular matrix is an upper triangular matrix.
20450!
20451! Licensing:
20452!
20453! This code is distributed under the GNU LGPL license.
20454!
20455! Modified:
20456!
20457! 11 December 2004
20458!
20459! Author:
20460!
20461! John Burkardt
20462!
20463! Reference:
20464!
20465! Albert Nijenhuis, Herbert Wilf,
20466! Combinatorial Algorithms for Computers and Calculators,
20467! Academic Press, 1978,
20468! ISBN: 0-12-519260-6,
20469! LC: QA164.N54.
20470!
20471! Parameters:
20472!
20473! Input, integer ( kind = 4 ) N, number of rows and columns in the matrix.
20474!
20475! Input, real ( kind = 8 ) A(N,N), the upper triangular matrix.
20476!
20477! Output, real ( kind = 8 ) B(N,N), the inverse matrix.
20478!
20479 implicit none
20480
20481 integer ( kind = 4 ) n
20482
20483 real ( kind = 8 ) a(n,n)
20484 real ( kind = 8 ) b(n,n)
20485 integer ( kind = 4 ) i
20486 integer ( kind = 4 ) j
20487
20488 do j = n, 1, -1
20489
20490 do i = n, 1, -1
20491
20492 if ( j < i ) then
20493 b(i,j) = 0.0d+00
20494 else if ( i == j ) then
20495 b(i,j) = 1.0d+00 / a(i,j)
20496 else
20497 b(i,j) = - dot_product( a(i,i+1:j), b(i+1:j,j) ) / a(i,i)
20498 end if
20499
20500 end do
20501 end do
20502
20503 return

◆ r8mat_u_solve()

subroutine r8mat_u_solve ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 20505 of file R8LIB.f90.

20506
20507!*****************************************************************************80
20508!
20509!! R8MAT_U_SOLVE solves an upper triangular linear system.
20510!
20511! Discussion:
20512!
20513! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20514!
20515! Licensing:
20516!
20517! This code is distributed under the GNU LGPL license.
20518!
20519! Modified:
20520!
20521! 21 October 2013
20522!
20523! Author:
20524!
20525! John Burkardt
20526!
20527! Parameters:
20528!
20529! Input, integer ( kind = 4 ) N, the number of rows and columns of
20530! the matrix A.
20531!
20532! Input, real ( kind = 8 ) A(N,N), the N by N upper triangular matrix.
20533!
20534! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
20535!
20536! Output, real ( kind = 8 ) X(N), the solution of the linear system.
20537!
20538 implicit none
20539
20540 integer ( kind = 4 ) n
20541
20542 real ( kind = 8 ) a(n,n)
20543 real ( kind = 8 ) b(n)
20544 integer ( kind = 4 ) i
20545 real ( kind = 8 ) x(n)
20546!
20547! Solve U * x = b.
20548!
20549 do i = n, 1, -1
20550 x(i) = ( b(i) - dot_product( a(i,i+1:n), x(i+1:n) ) ) / a(i,i)
20551 end do
20552
20553 return

Referenced by r8mat_cholesky_solve_upper().

Here is the caller graph for this function:

◆ r8mat_uniform_01()

subroutine r8mat_uniform_01 ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  r 
)

Definition at line 20633 of file R8LIB.f90.

20634
20635!*****************************************************************************80
20636!
20637!! R8MAT_UNIFORM_01 fills an R8MAT with unit pseudorandom numbers.
20638!
20639! Discussion:
20640!
20641! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20642!
20643! Licensing:
20644!
20645! This code is distributed under the GNU LGPL license.
20646!
20647! Modified:
20648!
20649! 11 August 2004
20650!
20651! Author:
20652!
20653! John Burkardt
20654!
20655! Reference:
20656!
20657! Paul Bratley, Bennett Fox, Linus Schrage,
20658! A Guide to Simulation,
20659! Springer Verlag, pages 201-202, 1983.
20660!
20661! Bennett Fox,
20662! Algorithm 647:
20663! Implementation and Relative Efficiency of Quasirandom
20664! Sequence Generators,
20665! ACM Transactions on Mathematical Software,
20666! Volume 12, Number 4, pages 362-376, 1986.
20667!
20668! Peter Lewis, Allen Goodman, James Miller,
20669! A Pseudo-Random Number Generator for the System/360,
20670! IBM Systems Journal,
20671! Volume 8, pages 136-143, 1969.
20672!
20673! Parameters:
20674!
20675! Input, integer ( kind = 4 ) M, N, the number of rows and columns in
20676! the array.
20677!
20678! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
20679! should NOT be 0. On output, SEED has been updated.
20680!
20681! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
20682!
20683 implicit none
20684
20685 integer ( kind = 4 ) m
20686 integer ( kind = 4 ) n
20687
20688 integer ( kind = 4 ) i
20689 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
20690 integer ( kind = 4 ) j
20691 integer ( kind = 4 ) k
20692 integer ( kind = 4 ) seed
20693 real ( kind = 8 ) r(m,n)
20694
20695 do j = 1, n
20696
20697 do i = 1, m
20698
20699 k = seed / 127773
20700
20701 seed = 16807 * ( seed - k * 127773 ) - k * 2836
20702
20703 if ( seed < 0 ) then
20704 seed = seed + i4_huge
20705 end if
20706
20707 r(i,j) = real( seed, kind = 8 ) * 4.656612875d-10
20708
20709 end do
20710 end do
20711
20712 return

Referenced by r8col_duplicates().

Here is the caller graph for this function:

◆ r8mat_uniform_ab()

subroutine r8mat_uniform_ab ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  r 
)

Definition at line 20714 of file R8LIB.f90.

20715
20716!*****************************************************************************80
20717!
20718!! R8MAT_UNIFORM_AB returns a scaled pseudorandom R8MAT.
20719!
20720! Discussion:
20721!
20722! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20723!
20724! A <= R(I,J) <= B.
20725!
20726! Licensing:
20727!
20728! This code is distributed under the GNU LGPL license.
20729!
20730! Modified:
20731!
20732! 31 May 2007
20733!
20734! Author:
20735!
20736! John Burkardt
20737!
20738! Reference:
20739!
20740! Paul Bratley, Bennett Fox, Linus Schrage,
20741! A Guide to Simulation,
20742! Second Edition,
20743! Springer, 1987,
20744! ISBN: 0387964673,
20745! LC: QA76.9.C65.B73.
20746!
20747! Bennett Fox,
20748! Algorithm 647:
20749! Implementation and Relative Efficiency of Quasirandom
20750! Sequence Generators,
20751! ACM Transactions on Mathematical Software,
20752! Volume 12, Number 4, December 1986, pages 362-376.
20753!
20754! Pierre L'Ecuyer,
20755! Random Number Generation,
20756! in Handbook of Simulation,
20757! edited by Jerry Banks,
20758! Wiley, 1998,
20759! ISBN: 0471134031,
20760! LC: T57.62.H37.
20761!
20762! Peter Lewis, Allen Goodman, James Miller,
20763! A Pseudo-Random Number Generator for the System/360,
20764! IBM Systems Journal,
20765! Volume 8, Number 2, 1969, pages 136-143.
20766!
20767! Parameters:
20768!
20769! Input, integer ( kind = 4 ) M, N, the number of rows and columns
20770! in the array.
20771!
20772! Input, real ( kind = 8 ) A, B, the lower and upper limits.
20773!
20774! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
20775! should NOT be 0. On output, SEED has been updated.
20776!
20777! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
20778!
20779 implicit none
20780
20781 integer ( kind = 4 ) m
20782 integer ( kind = 4 ) n
20783
20784 real ( kind = 8 ) a
20785 real ( kind = 8 ) b
20786 integer ( kind = 4 ) i
20787 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
20788 integer ( kind = 4 ) j
20789 integer ( kind = 4 ) k
20790 integer ( kind = 4 ) seed
20791 real ( kind = 8 ) r(m,n)
20792
20793 if ( seed == 0 ) then
20794 write ( *, '(a)' ) ' '
20795 write ( *, '(a)' ) 'R8MAT_UNIFORM_AB - Fatal error!'
20796 write ( *, '(a)' ) ' Input value of SEED = 0.'
20797 stop 1
20798 end if
20799
20800 do j = 1, n
20801
20802 do i = 1, m
20803
20804 k = seed / 127773
20805
20806 seed = 16807 * ( seed - k * 127773 ) - k * 2836
20807
20808 if ( seed < 0 ) then
20809 seed = seed + i4_huge
20810 end if
20811
20812 r(i,j) = a + ( b - a ) * real( seed, kind = 8 ) * 4.656612875d-10
20813
20814 end do
20815 end do
20816
20817 return

◆ r8mat_uniform_abvec()

subroutine r8mat_uniform_abvec ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m)  a,
real ( kind = 8 ), dimension(m)  b,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m,n)  r 
)

Definition at line 20819 of file R8LIB.f90.

20820
20821!*****************************************************************************80
20822!
20823!! R8MAT_UNIFORM_ABVEC returns a scaled pseudorandom R8MAT.
20824!
20825! Discussion:
20826!
20827! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20828!
20829! A(I) <= R(I,J) <= B(I)
20830!
20831! Licensing:
20832!
20833! This code is distributed under the GNU LGPL license.
20834!
20835! Modified:
20836!
20837! 02 October 2012
20838!
20839! Author:
20840!
20841! John Burkardt
20842!
20843! Reference:
20844!
20845! Paul Bratley, Bennett Fox, Linus Schrage,
20846! A Guide to Simulation,
20847! Second Edition,
20848! Springer, 1987,
20849! ISBN: 0387964673,
20850! LC: QA76.9.C65.B73.
20851!
20852! Bennett Fox,
20853! Algorithm 647:
20854! Implementation and Relative Efficiency of Quasirandom
20855! Sequence Generators,
20856! ACM Transactions on Mathematical Software,
20857! Volume 12, Number 4, December 1986, pages 362-376.
20858!
20859! Pierre L'Ecuyer,
20860! Random Number Generation,
20861! in Handbook of Simulation,
20862! edited by Jerry Banks,
20863! Wiley, 1998,
20864! ISBN: 0471134031,
20865! LC: T57.62.H37.
20866!
20867! Peter Lewis, Allen Goodman, James Miller,
20868! A Pseudo-Random Number Generator for the System/360,
20869! IBM Systems Journal,
20870! Volume 8, Number 2, 1969, pages 136-143.
20871!
20872! Parameters:
20873!
20874! Input, integer ( kind = 4 ) M, N, the number of rows and columns
20875! in the array.
20876!
20877! Input, real ( kind = 8 ) A(M), B(M), the lower and upper limits.
20878!
20879! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
20880! should NOT be 0. On output, SEED has been updated.
20881!
20882! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
20883!
20884 implicit none
20885
20886 integer ( kind = 4 ) m
20887 integer ( kind = 4 ) n
20888
20889 real ( kind = 8 ) a(m)
20890 real ( kind = 8 ) b(m)
20891 integer ( kind = 4 ) i
20892 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
20893 integer ( kind = 4 ) j
20894 integer ( kind = 4 ) k
20895 integer ( kind = 4 ) seed
20896 real ( kind = 8 ) r(m,n)
20897
20898 if ( seed == 0 ) then
20899 write ( *, '(a)' ) ' '
20900 write ( *, '(a)' ) 'R8MAT_UNIFORM_ABVEC - Fatal error!'
20901 write ( *, '(a)' ) ' Input value of SEED = 0.'
20902 stop 1
20903 end if
20904
20905 do j = 1, n
20906
20907 do i = 1, m
20908
20909 k = seed / 127773
20910
20911 seed = 16807 * ( seed - k * 127773 ) - k * 2836
20912
20913 if ( seed < 0 ) then
20914 seed = seed + i4_huge
20915 end if
20916
20917 r(i,j) = a(i) + ( b(i) - a(i) ) * real( seed, kind = 8 ) &
20918 * 4.656612875d-10
20919
20920 end do
20921 end do
20922
20923 return

◆ r8mat_ut_solve()

subroutine r8mat_ut_solve ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n,n)  a,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 20925 of file R8LIB.f90.

20926
20927!*****************************************************************************80
20928!
20929!! R8MAT_UT_SOLVE solves a transposed upper triangular linear system.
20930!
20931! Discussion:
20932!
20933! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20934!
20935! Given the upper triangular matrix A, the linear system to be solved is:
20936!
20937! A' * x = b
20938!
20939! Licensing:
20940!
20941! This code is distributed under the GNU LGPL license.
20942!
20943! Modified:
20944!
20945! 21 October 2013
20946!
20947! Author:
20948!
20949! John Burkardt
20950!
20951! Parameters:
20952!
20953! Input, integer ( kind = 4 ) N, the number of rows and columns
20954! of the matrix.
20955!
20956! Input, real ( kind = 8 ) A(N,N), the N by N upper triangular matrix.
20957!
20958! Input, real ( kind = 8 ) B(N), the right hand side of the linear system.
20959!
20960! Output, real ( kind = 8 ) X(N), the solution of the linear system.
20961!
20962 implicit none
20963
20964 integer ( kind = 4 ) n
20965
20966 real ( kind = 8 ) a(n,n)
20967 real ( kind = 8 ) b(n)
20968 integer ( kind = 4 ) i
20969 real ( kind = 8 ) x(n)
20970!
20971! Solve U' * x = b.
20972!
20973 do i = 1, n
20974 x(i) = ( b(i) - dot_product( x(1:i-1), a(1:i-1,i) ) ) / a(i,i)
20975 end do
20976
20977 return

Referenced by r8mat_cholesky_solve_upper().

Here is the caller graph for this function:

◆ r8mat_vand2()

subroutine r8mat_vand2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 20979 of file R8LIB.f90.

20980
20981!*****************************************************************************80
20982!
20983!! R8MAT_VAND2 returns the N by N row Vandermonde matrix A.
20984!
20985! Discussion:
20986!
20987! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
20988!
20989! The row Vandermonde matrix returned by this routine reads "across"
20990! rather than down. In particular, each row begins with a 1, followed by
20991! some value X, followed by successive powers of X.
20992!
20993! Formula:
20994!
20995! A(I,J) = X(I)^(J-1)
20996!
20997! Properties:
20998!
20999! A is nonsingular if, and only if, the X values are distinct.
21000!
21001! The determinant of A is
21002!
21003! det(A) = product ( 2 <= I <= N ) (
21004! product ( 1 <= J <= I-1 ) ( ( X(I) - X(J) ) ) ).
21005!
21006! The matrix A is generally ill-conditioned.
21007!
21008! Example:
21009!
21010! N = 5, X = (2, 3, 4, 5, 6)
21011!
21012! 1 2 4 8 16
21013! 1 3 9 27 81
21014! 1 4 16 64 256
21015! 1 5 25 125 625
21016! 1 6 36 216 1296
21017!
21018! Licensing:
21019!
21020! This code is distributed under the GNU LGPL license.
21021!
21022! Modified:
21023!
21024! 01 March 1999
21025!
21026! Author:
21027!
21028! John Burkardt
21029!
21030! Parameters:
21031!
21032! Input, integer ( kind = 4 ) N, the order of the matrix desired.
21033!
21034! Input, real ( kind = 8 ) X(N), the values that define A.
21035!
21036! Output, real ( kind = 8 ) A(N,N), the N by N row Vandermonde matrix.
21037!
21038 implicit none
21039
21040 integer ( kind = 4 ) n
21041
21042 real ( kind = 8 ) a(n,n)
21043 integer ( kind = 4 ) i
21044 integer ( kind = 4 ) j
21045 real ( kind = 8 ) x(n)
21046
21047 do i = 1, n
21048 do j = 1, n
21049
21050 if ( j == 1 .and. x(i) == 0.0d+00 ) then
21051 a(i,j) = 1.0d+00
21052 else
21053 a(i,j) = x(i)**(j-1)
21054 end if
21055
21056 end do
21057 end do
21058
21059 return

◆ r8mat_vtmv()

real ( kind = 8 ) function r8mat_vtmv ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m)  x,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(n)  y 
)

Definition at line 21061 of file R8LIB.f90.

21062
21063!*****************************************************************************80
21064!
21065!! R8MAT_VTMV multiplies computes the scalar x' * A * y.
21066!
21067! Discussion:
21068!
21069! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
21070!
21071! Licensing:
21072!
21073! This code is distributed under the GNU LGPL license.
21074!
21075! Modified:
21076!
21077! 10 June 2013
21078!
21079! Author:
21080!
21081! John Burkardt
21082!
21083! Parameters:
21084!
21085! Input, integer ( kind = 4 ) M, N, the number of rows and columns of
21086! the matrix.
21087!
21088! Input, real ( kind = 8 ) X(N), the first vector factor.
21089!
21090! Input, real ( kind = 8 ) A(M,N), the M by N matrix.
21091!
21092! Input, real ( kind = 8 ) Y(M), the second vector factor.
21093!
21094! Output, real ( kind = 8 ) R8MAT_VTMV, the value of X' * A * Y.
21095!
21096 implicit none
21097
21098 integer ( kind = 4 ) m
21099 integer ( kind = 4 ) n
21100
21101 real ( kind = 8 ) a(m,n)
21102 real ( kind = 8 ) r8mat_vtmv
21103 real ( kind = 8 ) x(m)
21104 real ( kind = 8 ) y(n)
21105
21106 r8mat_vtmv = dot_product( x(1:m), matmul( a(1:m,1:n), y(1:n) ) )
21107
21108 return
r8mat_vtmv
real(kind=8) function r8mat_vtmv(m, n, x, a, y)
Definition R8LIB.f90:21062

References r8mat_vtmv().

Referenced by r8mat_vtmv().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8mat_zero()

subroutine r8mat_zero ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 21110 of file R8LIB.f90.

21111
21112!*****************************************************************************80
21113!
21114!! R8MAT_ZERO zeroes an R8MAT.
21115!
21116! Discussion:
21117!
21118! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
21119!
21120! Licensing:
21121!
21122! This code is distributed under the GNU LGPL license.
21123!
21124! Modified:
21125!
21126! 18 July 2010
21127!
21128! Author:
21129!
21130! John Burkardt
21131!
21132! Parameters:
21133!
21134! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
21135!
21136! Output, real ( kind = 8 ) A(M,N), the matrix of zeroes.
21137!
21138 implicit none
21139
21140 integer ( kind = 4 ) m
21141 integer ( kind = 4 ) n
21142
21143 real ( kind = 8 ) a(m,n)
21144
21145 a(1:m,1:n) = 0.0d+00
21146
21147 return

◆ r8plu_det()

subroutine r8plu_det ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
real ( kind = 8 )  det 
)

Definition at line 21149 of file R8LIB.f90.

21150
21151!*****************************************************************************80
21152!
21153!! R8PLU_DET computes the determinant of an R8PLU matrix.
21154!
21155! Discussion:
21156!
21157! The matrix should have been factored by R8MAT_TO_R8PLU.
21158!
21159! Licensing:
21160!
21161! This code is distributed under the GNU LGPL license.
21162!
21163! Modified:
21164!
21165! 09 December 2004
21166!
21167! Author:
21168!
21169! John Burkardt
21170!
21171! Reference:
21172!
21173! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
21174! LINPACK User's Guide,
21175! SIAM, 1979,
21176! ISBN13: 978-0-898711-72-1.
21177!
21178! Parameters:
21179!
21180! Input, integer ( kind = 4 ) N, the order of the matrix.
21181! N must be positive.
21182!
21183! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector computed
21184! by R8MAT_TO_R8PLU.
21185!
21186! Input, real ( kind = 8 ) LU(N,N), the LU factors computed
21187! by R8MAT_TO_R8PLU.
21188!
21189! Output, real ( kind = 8 ) DET, the determinant of the matrix.
21190!
21191 implicit none
21192
21193 integer ( kind = 4 ) n
21194
21195 real ( kind = 8 ) det
21196 integer ( kind = 4 ) i
21197 real ( kind = 8 ) lu(n,n)
21198 integer ( kind = 4 ) pivot(n)
21199
21200 det = 1.0d+00
21201
21202 do i = 1, n
21203 det = det * lu(i,i)
21204 if ( pivot(i) /= i ) then
21205 det = -det
21206 end if
21207 end do
21208
21209 return

◆ r8plu_inverse()

subroutine r8plu_inverse ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
real ( kind = 8 ), dimension(n,n)  a_inverse 
)

Definition at line 21211 of file R8LIB.f90.

21212
21213!*****************************************************************************80
21214!
21215!! R8PLU_INVERSE computes the inverse of an R8PLU matrix.
21216!
21217! Discussion:
21218!
21219! The matrix should have been factored by R8MAT_TO_R8PLU.
21220!
21221! Licensing:
21222!
21223! This code is distributed under the GNU LGPL license.
21224!
21225! Modified:
21226!
21227! 09 December 2004
21228!
21229! Author:
21230!
21231! John Burkardt
21232!
21233! Parameters:
21234!
21235! Input, integer ( kind = 4 ) N, the order of the matrix A.
21236!
21237! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector from
21238! R8MAT_TO_R8PLU.
21239!
21240! Input, real ( kind = 8 ) LU(N,N), the LU factors computed by
21241! R8MAT_TO_R8PLU.
21242!
21243! Output, real ( kind = 8 ) A_INVERSE(N,N), the inverse of the original
21244! matrix A that was factored by R8MAT_TO_R8PLU.
21245!
21246 implicit none
21247
21248 integer ( kind = 4 ) n
21249
21250 real ( kind = 8 ) a_inverse(n,n)
21251 integer ( kind = 4 ) i
21252 real ( kind = 8 ) lu(n,n)
21253 integer ( kind = 4 ) pivot(n)
21254 integer ( kind = 4 ) j
21255 integer ( kind = 4 ) k
21256 real ( kind = 8 ) temp
21257 real ( kind = 8 ) work(n)
21258
21259 a_inverse(1:n,1:n) = lu(1:n,1:n)
21260!
21261! Compute Inverse(U).
21262!
21263 do k = 1, n
21264
21265 a_inverse(k,k) = 1.0d+00 / a_inverse(k,k)
21266 a_inverse(1:k-1,k) = -a_inverse(1:k-1,k) * a_inverse(k,k)
21267
21268 do j = k + 1, n
21269
21270 temp = a_inverse(k,j)
21271 a_inverse(k,j) = 0.0d+00
21272 a_inverse(1:k,j) = a_inverse(1:k,j) + temp * a_inverse(1:k,k)
21273
21274 end do
21275
21276 end do
21277!
21278! Form Inverse(U) * Inverse(L).
21279!
21280 do k = n - 1, 1, -1
21281
21282 work(k+1:n) = a_inverse(k+1:n,k)
21283 a_inverse(k+1:n,k) = 0.0d+00
21284
21285 do j = k + 1, n
21286 a_inverse(1:n,k) = a_inverse(1:n,k) + a_inverse(1:n,j) * work(j)
21287 end do
21288
21289 if ( pivot(k) /= k ) then
21290
21291 do i = 1, n
21292 temp = a_inverse(i,k)
21293 a_inverse(i,k) = a_inverse(i,pivot(k))
21294 a_inverse(i,pivot(k)) = temp
21295 end do
21296
21297 end if
21298
21299 end do
21300
21301 return

◆ r8plu_mul()

subroutine r8plu_mul ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 21303 of file R8LIB.f90.

21304
21305!*****************************************************************************80
21306!
21307!! R8PLU_MUL computes A * x using the PLU factors of A.
21308!
21309! Discussion:
21310!
21311! It is assumed that R8MAT_TO_R8PLU has computed the PLU factors of
21312! the matrix A.
21313!
21314! Licensing:
21315!
21316! This code is distributed under the GNU LGPL license.
21317!
21318! Modified:
21319!
21320! 09 December 2004
21321!
21322! Author:
21323!
21324! John Burkardt
21325!
21326! Parameters:
21327!
21328! Input, integer ( kind = 4 ) N, the order of the matrix.
21329! N must be positive.
21330!
21331! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector computed
21332! by R8MAT_TO_R8PLU.
21333!
21334! Input, real ( kind = 8 ) LU(N,N), the matrix factors computed by
21335! R8MAT_TO_R8PLU.
21336!
21337! Input, real ( kind = 8 ) X(N), the vector to be multiplied.
21338!
21339! Output, real ( kind = 8 ) B(N), the result of the multiplication.
21340!
21341 implicit none
21342
21343 integer ( kind = 4 ) n
21344
21345 real ( kind = 8 ) b(n)
21346 integer ( kind = 4 ) j
21347 integer ( kind = 4 ) k
21348 real ( kind = 8 ) lu(n,n)
21349 integer ( kind = 4 ) pivot(n)
21350 real ( kind = 8 ) temp
21351 real ( kind = 8 ) x(n)
21352
21353 b(1:n) = x(1:n)
21354!
21355! Y = U * X.
21356!
21357 do j = 1, n
21358 b(1:j-1) = b(1:j-1) + lu(1:j-1,j) * b(j)
21359 b(j) = lu(j,j) * b(j)
21360 end do
21361!
21362! B = PL * Y = PL * U * X = A * x.
21363!
21364 do j = n - 1, 1, -1
21365
21366 b(j+1:n) = b(j+1:n) - lu(j+1:n,j) * b(j)
21367
21368 k = pivot(j)
21369
21370 if ( k /= j ) then
21371 temp = b(k)
21372 b(k) = b(j)
21373 b(j) = temp
21374 end if
21375
21376 end do
21377
21378 return

◆ r8plu_sol()

subroutine r8plu_sol ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
real ( kind = 8 ), dimension(n)  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 21380 of file R8LIB.f90.

21381
21382!*****************************************************************************80
21383!
21384!! R8PLU_SOL solves a linear system A*x=b from the PLU factors.
21385!
21386! Discussion:
21387!
21388! The PLU factors should have been computed by R8MAT_TO_R8PLU.
21389!
21390! Licensing:
21391!
21392! This code is distributed under the GNU LGPL license.
21393!
21394! Modified:
21395!
21396! 09 December 2004
21397!
21398! Author:
21399!
21400! John Burkardt
21401!
21402! Parameters:
21403!
21404! Input, integer ( kind = 4 ) N, the order of the matrix.
21405!
21406! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector from R8MAT_TO_R8PLU.
21407!
21408! Input, real ( kind = 8 ) LU(N,N), the LU factors from R8MAT_TO_R8PLU.
21409!
21410! Input, real ( kind = 8 ) B(N), the right hand side vector.
21411!
21412! Output, real ( kind = 8 ) X(N), the solution vector.
21413!
21414 implicit none
21415
21416 integer ( kind = 4 ) n
21417
21418 real ( kind = 8 ) b(n)
21419 integer ( kind = 4 ) pivot(n)
21420 integer ( kind = 4 ) j
21421 integer ( kind = 4 ) k
21422 real ( kind = 8 ) lu(n,n)
21423 real ( kind = 8 ) temp
21424 real ( kind = 8 ) x(n)
21425!
21426! Solve PL * Y = B.
21427!
21428 x(1:n) = b(1:n)
21429
21430 do k = 1, n - 1
21431
21432 j = pivot(k)
21433
21434 if ( j /= k ) then
21435 temp = x(j)
21436 x(j) = x(k)
21437 x(k) = temp
21438 end if
21439
21440 x(k+1:n) = x(k+1:n) + lu(k+1:n,k) * x(k)
21441
21442 end do
21443!
21444! Solve U * X = Y.
21445!
21446 do k = n, 1, -1
21447 x(k) = x(k) / lu(k,k)
21448 x(1:k-1) = x(1:k-1) - lu(1:k-1,k) * x(k)
21449 end do
21450
21451 return

◆ r8plu_to_r8mat()

subroutine r8plu_to_r8mat ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  pivot,
real ( kind = 8 ), dimension(n,n)  lu,
real ( kind = 8 ), dimension(n,n)  a 
)

Definition at line 21453 of file R8LIB.f90.

21454
21455!*****************************************************************************80
21456!
21457!! R8PLU_TO_R8MAT recovers the matrix A that was factored by R8MAT_TO_R8PLU.
21458!
21459! Licensing:
21460!
21461! This code is distributed under the GNU LGPL license.
21462!
21463! Modified:
21464!
21465! 09 December 2004
21466!
21467! Author:
21468!
21469! John Burkardt
21470!
21471! Parameters:
21472!
21473! Input, integer ( kind = 4 ) N, the order of the matrix.
21474! N must be positive.
21475!
21476! Input, integer ( kind = 4 ) PIVOT(N), the pivot vector computed
21477! by R8MAT_TO_R8PLU.
21478!
21479! Input, real ( kind = 8 ) LU(N,N), the matrix factors computed by
21480! R8MAT_TO_R8PLU.
21481!
21482! Output, real ( kind = 8 ) A(N,N), the matrix whose factors are
21483! represented by LU and PIVOT.
21484!
21485 implicit none
21486
21487 integer ( kind = 4 ) n
21488
21489 real ( kind = 8 ) a(n,n)
21490 integer ( kind = 4 ) i
21491 real ( kind = 8 ) lu(n,n)
21492 integer ( kind = 4 ) pivot(n)
21493 integer ( kind = 4 ) j
21494 integer ( kind = 4 ) k
21495 real ( kind = 8 ) temp
21496
21497 a(1:n,1:n) = 0.0d+00
21498 do i = 1, n
21499 a(i,i) = 1.0d+00
21500 end do
21501
21502 do j = 1, n
21503
21504 do i = 1, n
21505 a(1:i-1,j) = a(1:i-1,j) + lu(1:i-1,i) * a(i,j)
21506 a(i,j) = lu(i,i) * a(i,j)
21507 end do
21508!
21509! B = PL * Y = PL * U * X = A * x.
21510!
21511 do i = n - 1, 1, -1
21512
21513 a(i+1:n,j) = a(i+1:n,j) - lu(i+1:n,i) * a(i,j)
21514
21515 k = pivot(i)
21516
21517 if ( k /= i ) then
21518 temp = a(k,j)
21519 a(k,j) = a(i,j)
21520 a(i,j) = temp
21521 end if
21522
21523 end do
21524
21525 end do
21526
21527 return

◆ r8poly2_ex()

subroutine r8poly2_ex ( real ( kind = 8 )  x1,
real ( kind = 8 )  y1,
real ( kind = 8 )  x2,
real ( kind = 8 )  y2,
real ( kind = 8 )  x3,
real ( kind = 8 )  y3,
real ( kind = 8 )  x,
real ( kind = 8 )  y,
integer ( kind = 4 )  ierror 
)

Definition at line 22570 of file R8LIB.f90.

22571
22572!*****************************************************************************80
22573!
22574!! R8POLY2_EX finds the extremal point of a parabola determined by three points.
22575!
22576! Licensing:
22577!
22578! This code is distributed under the GNU LGPL license.
22579!
22580! Modified:
22581!
22582! 05 December 2004
22583!
22584! Author:
22585!
22586! John Burkardt
22587!
22588! Parameters:
22589!
22590! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of
22591! three points on the parabola. X1, X2 and X3 must be distinct.
22592!
22593! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal point
22594! of the parabola, and the value of the parabola at that point.
22595!
22596! Output, integer ( kind = 4 ) IERROR, error flag.
22597! 0, no error.
22598! 1, two of the X values are equal.
22599! 2, the data lies on a straight line; there is no finite extremal
22600! point.
22601!
22602 implicit none
22603
22604 real ( kind = 8 ) bot
22605 integer ( kind = 4 ) ierror
22606 real ( kind = 8 ) x
22607 real ( kind = 8 ) x1
22608 real ( kind = 8 ) x2
22609 real ( kind = 8 ) x3
22610 real ( kind = 8 ) y
22611 real ( kind = 8 ) y1
22612 real ( kind = 8 ) y2
22613 real ( kind = 8 ) y3
22614
22615 ierror = 0
22616
22617 if ( x1 == x2 .or. x2 == x3 .or. x3 == x1 ) then
22618 ierror = 1
22619 return
22620 end if
22621
22622 if ( y1 == y2 .and. y2 == y3 .and. y3 == y1 ) then
22623 x = x1
22624 y = y1
22625 return
22626 end if
22627
22628 bot = ( x2 - x3 ) * y1 - ( x1 - x3 ) * y2 + ( x1 - x2 ) * y3
22629
22630 if ( bot == 0.0d+00 ) then
22631 ierror = 2
22632 return
22633 end if
22634
22635 x = 0.5d+00 * ( &
22636 x1**2 * ( y3 - y2 ) &
22637 + x2**2 * ( y1 - y3 ) &
22638 + x3**2 * ( y2 - y1 ) ) / bot
22639
22640 y = ( &
22641 ( x - x2 ) * ( x - x3 ) * ( x2 - x3 ) * y1 &
22642 - ( x - x1 ) * ( x - x3 ) * ( x1 - x3 ) * y2 &
22643 + ( x - x1 ) * ( x - x2 ) * ( x1 - x2 ) * y3 ) / &
22644 ( ( x1 - x2 ) * ( x2 - x3 ) * ( x1 - x3 ) )
22645
22646 return

◆ r8poly2_ex2()

subroutine r8poly2_ex2 ( real ( kind = 8 )  x1,
real ( kind = 8 )  y1,
real ( kind = 8 )  x2,
real ( kind = 8 )  y2,
real ( kind = 8 )  x3,
real ( kind = 8 )  y3,
real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
integer ( kind = 4 )  ierror 
)

Definition at line 22648 of file R8LIB.f90.

22649
22650!*****************************************************************************80
22651!
22652!! R8POLY2_EX2 finds extremal point of a parabola determined by three points.
22653!
22654! Licensing:
22655!
22656! This code is distributed under the GNU LGPL license.
22657!
22658! Modified:
22659!
22660! 29 October 1998
22661!
22662! Author:
22663!
22664! John Burkardt
22665!
22666! Parameters:
22667!
22668! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, the coordinates of
22669! three points on the parabola. X1, X2 and X3 must be distinct.
22670!
22671! Output, real ( kind = 8 ) X, Y, the X coordinate of the extremal
22672! point of the parabola, and the value of the parabola at that point.
22673!
22674! Output, real ( kind = 8 ) A, B, C, the coefficients that define the
22675! parabola: P(X) = A * X * X + B * X + C.
22676!
22677! Output, integer ( kind = 4 ) IERROR, error flag.
22678! 0, no error.
22679! 1, two of the X values are equal.
22680! 2, the data lies on a straight line; there is no finite extremal
22681! point.
22682!
22683 implicit none
22684
22685 real ( kind = 8 ) a
22686 real ( kind = 8 ) b
22687 real ( kind = 8 ) c
22688 real ( kind = 8 ) det
22689 integer ( kind = 4 ) ierror
22690 real ( kind = 8 ) v(3,3)
22691 real ( kind = 8 ) w(3,3)
22692 real ( kind = 8 ) x
22693 real ( kind = 8 ) x1
22694 real ( kind = 8 ) x2
22695 real ( kind = 8 ) x3
22696 real ( kind = 8 ) y
22697 real ( kind = 8 ) y1
22698 real ( kind = 8 ) y2
22699 real ( kind = 8 ) y3
22700
22701 ierror = 0
22702
22703 if ( x1 == x2 .or. x2 == x3 .or. x3 == x1 ) then
22704 ierror = 1
22705 return
22706 end if
22707
22708 if ( y1 == y2 .and. y2 == y3 .and. y3 == y1 ) then
22709 x = x1
22710 y = y1
22711 return
22712 end if
22713!
22714! Set up the Vandermonde matrix.
22715!
22716 v(1,1) = 1.0d+00
22717 v(1,2) = x1
22718 v(1,3) = x1 * x1
22719
22720 v(2,1) = 1.0d+00
22721 v(2,2) = x2
22722 v(2,3) = x2 * x2
22723
22724 v(3,1) = 1.0d+00
22725 v(3,2) = x3
22726 v(3,3) = x3 * x3
22727!
22728! Get the inverse.
22729!
22730 call r8mat_inverse_3d ( v, w, det )
22731!
22732! Compute the parabolic coefficients.
22733!
22734 c = w(1,1) * y1 + w(1,2) * y2 + w(1,3) * y3
22735 b = w(2,1) * y1 + w(2,2) * y2 + w(2,3) * y3
22736 a = w(3,1) * y1 + w(3,2) * y2 + w(3,3) * y3
22737!
22738! Determine the extremal point.
22739!
22740 if ( a == 0.0d+00 ) then
22741 ierror = 2
22742 return
22743 end if
22744
22745 x = -b / ( 2.0d+00 * a )
22746 y = a * x * x + b * x + c
22747
22748 return
r8mat_inverse_3d
subroutine r8mat_inverse_3d(a, b, det)
Definition R8LIB.f90:15450

References r8mat_inverse_3d().

Here is the call graph for this function:

◆ r8poly2_root()

subroutine r8poly2_root ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
complex ( kind = 8 )  r1,
complex ( kind = 8 )  r2 
)

Definition at line 22750 of file R8LIB.f90.

22751
22752!*****************************************************************************80
22753!
22754!! R8POLY2_ROOT returns the two roots of a quadratic polynomial.
22755!
22756! Discussion:
22757!
22758! The polynomial has the form:
22759!
22760! A * X * X + B * X + C = 0
22761!
22762! Licensing:
22763!
22764! This code is distributed under the GNU LGPL license.
22765!
22766! Modified:
22767!
22768! 10 December 2004
22769!
22770! Author:
22771!
22772! John Burkardt
22773!
22774! Parameters:
22775!
22776! Input, real ( kind = 8 ) A, B, C, the coefficients of the polynomial.
22777! A must not be zero.
22778!
22779! Output, complex ( kind = 8 ) R1, R2, the roots of the polynomial, which
22780! might be real and distinct, real and equal, or complex conjugates.
22781!
22782 implicit none
22783
22784 real ( kind = 8 ) a
22785 real ( kind = 8 ) b
22786 real ( kind = 8 ) c
22787 complex ( kind = 8 ) disc
22788 complex ( kind = 8 ) q
22789 complex ( kind = 8 ) r1
22790 complex ( kind = 8 ) r2
22791
22792 if ( a == 0.0d+00 ) then
22793 write ( *, '(a)' ) ' '
22794 write ( *, '(a)' ) 'R8POLY2_ROOT - Fatal error!'
22795 write ( *, '(a)' ) ' The coefficient A is zero.'
22796 stop 1
22797 end if
22798
22799 disc = b * b - 4.0d+00 * a * c
22800 q = -0.5d+00 * ( b + sign( 1.0d+00, b ) * sqrt( disc ) )
22801 r1 = q / a
22802 r2 = c / q
22803
22804 return

◆ r8poly2_rroot()

subroutine r8poly2_rroot ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
real ( kind = 8 )  r1,
real ( kind = 8 )  r2 
)

Definition at line 22806 of file R8LIB.f90.

22807
22808!*****************************************************************************80
22809!
22810!! R8POLY2_RROOT returns the real parts of the roots of a quadratic polynomial.
22811!
22812! Example:
22813!
22814! A B C roots R1 R2
22815! -- -- -- ------------------ -- --
22816! 1 -4 3 1 3 1 3
22817! 1 0 4 2*i - 2*i 0 0
22818! 2 -6 5 3 + i 3 - i 3 3
22819!
22820! Licensing:
22821!
22822! This code is distributed under the GNU LGPL license.
22823!
22824! Modified:
22825!
22826! 10 December 2004
22827!
22828! Author:
22829!
22830! John Burkardt
22831!
22832! Parameters:
22833!
22834! Input, real ( kind = 8 ) A, B, C, the coefficients of the quadratic
22835! polynomial A * X * X + B * X + C = 0 whose roots are desired.
22836! A must not be zero.
22837!
22838! Output, real ( kind = 8 ) R1, R2, the real parts of the roots
22839! of the polynomial.
22840!
22841 implicit none
22842
22843 real ( kind = 8 ) a
22844 real ( kind = 8 ) b
22845 real ( kind = 8 ) c
22846 real ( kind = 8 ) disc
22847 real ( kind = 8 ) q
22848 real ( kind = 8 ) r1
22849 real ( kind = 8 ) r2
22850
22851 if ( a == 0.0d+00 ) then
22852 write ( *, '(a)' ) ' '
22853 write ( *, '(a)' ) 'R8POLY2_RROOT - Fatal error!'
22854 write ( *, '(a)' ) ' The coefficient A is zero.'
22855 stop 1
22856 end if
22857
22858 disc = b * b - 4.0d+00 * a * c
22859 disc = max( disc, 0.0d+00 )
22860
22861 q = ( b + sign( 1.0d+00, b ) * sqrt( disc ) )
22862 r1 = -0.5d+00 * q / a
22863 r2 = -2.0d+00 * c / q
22864
22865 return

◆ r8poly2_val()

subroutine r8poly2_val ( real ( kind = 8 )  x1,
real ( kind = 8 )  y1,
real ( kind = 8 )  x2,
real ( kind = 8 )  y2,
real ( kind = 8 )  x3,
real ( kind = 8 )  y3,
real ( kind = 8 )  x,
real ( kind = 8 )  y,
real ( kind = 8 )  yp,
real ( kind = 8 )  ypp 
)

Definition at line 22867 of file R8LIB.f90.

22868
22869!*****************************************************************************80
22870!
22871!! R8POLY2_VAL evaluates a parabola defined by three data values.
22872!
22873! Licensing:
22874!
22875! This code is distributed under the GNU LGPL license.
22876!
22877! Modified:
22878!
22879! 10 December 2004
22880!
22881! Author:
22882!
22883! John Burkardt
22884!
22885! Parameters:
22886!
22887! Input, real ( kind = 8 ) X1, Y1, X2, Y2, X3, Y3, three pairs of data.
22888! If the X values are distinct, then all the Y values represent
22889! actual values of the parabola.
22890!
22891! Three special cases are allowed:
22892!
22893! X1 == X2 /= X3: Y2 is the derivative at X1;
22894! X1 /= X2 == X3: Y3 is the derivative at X3;
22895! X1 == X2 == X3: Y2 is the derivative at X1, and
22896! Y3 is the second derivative at X1.
22897!
22898! Input, real ( kind = 8 ) X, an abscissa at which the parabola is to be
22899! evaluated.
22900!
22901! Output, real ( kind = 8 ) Y, YP, YPP, the values of the parabola and
22902! its first and second derivatives at X.
22903!
22904 implicit none
22905
22906 integer ( kind = 4 ) distinct
22907 real ( kind = 8 ) dif1
22908 real ( kind = 8 ) dif2
22909 real ( kind = 8 ) x
22910 real ( kind = 8 ) x1
22911 real ( kind = 8 ) x2
22912 real ( kind = 8 ) x3
22913 real ( kind = 8 ) y
22914 real ( kind = 8 ) y1
22915 real ( kind = 8 ) y2
22916 real ( kind = 8 ) y3
22917 real ( kind = 8 ) yp
22918 real ( kind = 8 ) ypp
22919!
22920! If any X's are equal, put them and the Y data first.
22921!
22922 if ( x1 == x2 .and. x2 == x3 ) then
22923 distinct = 1
22924 else if ( x1 == x2 ) then
22925 distinct = 2
22926 else if ( x1 == x3 ) then
22927 write ( *, '(a)' ) ' '
22928 write ( *, '(a)' ) 'R8POLY2_VAL - Fatal error!'
22929 write ( *, '(a)' ) ' X1 = X3 =/= X2.'
22930 write ( *, '(a,g14.6)' ) ' X1 = ', x1
22931 write ( *, '(a,g14.6)' ) ' X2 = ', x2
22932 write ( *, '(a,g14.6)' ) ' X3 = ', x3
22933 stop 1
22934 else if ( x2 == x3 ) then
22935 distinct = 2
22936 call r8_swap ( x1, x2 )
22937 call r8_swap ( x2, x3 )
22938 call r8_swap ( y1, y2 )
22939 call r8_swap ( y2, y3 )
22940 else
22941 distinct = 3
22942 end if
22943!
22944! Set up the coefficients.
22945!
22946 if ( distinct == 1 ) then
22947
22948 dif1 = y2
22949 dif2 = 0.5d+00 * y3
22950
22951 else if ( distinct == 2 ) then
22952
22953 dif1 = y2
22954 dif2 = ( ( y3 - y1 ) / ( x3 - x1 ) - y2 ) / ( x3 - x2 )
22955
22956 else if ( distinct == 3 ) then
22957
22958 dif1 = ( y2 - y1 ) / ( x2 - x1 )
22959 dif2 = ( ( y3 - y1 ) / ( x3 - x1 ) &
22960 - ( y2 - y1 ) / ( x2 - x1 ) ) / ( x3 - x2 )
22961
22962 end if
22963!
22964! Evaluate.
22965!
22966 y = y1 + ( x - x1 ) * dif1 + ( x - x1 ) * ( x - x2 ) * dif2
22967 yp = dif1 + ( 2.0d+00 * x - x1 - x2 ) * dif2
22968 ypp = 2.0d+00 * dif2
22969
22970 return
r8_swap
subroutine r8_swap(x, y)
Definition R8LIB.f90:5881

References r8_swap().

Here is the call graph for this function:

◆ r8poly2_val2()

subroutine r8poly2_val2 ( integer ( kind = 4 )  dim_num,
integer ( kind = 4 )  ndata,
real ( kind = 8 ), dimension(ndata)  tdata,
real ( kind = 8 ), dimension(dim_num,ndata)  ydata,
integer ( kind = 4 )  left,
real ( kind = 8 )  tval,
real ( kind = 8 ), dimension(dim_num)  yval 
)

Definition at line 22972 of file R8LIB.f90.

22973
22974!*****************************************************************************80
22975!
22976!! R8POLY2_VAL2 evaluates a parabolic interpolant through tabular data.
22977!
22978! Discussion:
22979!
22980! This routine is a utility routine used by OVERHAUSER_SPLINE_VAL.
22981! It constructs the parabolic interpolant through the data in
22982! 3 consecutive entries of a table and evaluates this interpolant
22983! at a given abscissa value.
22984!
22985! Licensing:
22986!
22987! This code is distributed under the GNU LGPL license.
22988!
22989! Modified:
22990!
22991! 10 December 2004
22992!
22993! Author:
22994!
22995! John Burkardt
22996!
22997! Parameters:
22998!
22999! Input, integer ( kind = 4 ) DIM_NUM, the dimension of a single data point.
23000! DIM_NUM must be at least 1.
23001!
23002! Input, integer ( kind = 4 ) NDATA, the number of data points.
23003! NDATA must be at least 3.
23004!
23005! Input, real ( kind = 8 ) TDATA(NDATA), the abscissas of the data points.
23006! The values in TDATA must be in strictly ascending order.
23007!
23008! Input, real ( kind = 8 ) YDATA(DIM_NUM,NDATA), the data points
23009! corresponding to the abscissas.
23010!
23011! Input, integer ( kind = 4 ) LEFT, the location of the first of the three
23012! consecutive data points through which the parabolic interpolant
23013! must pass. 1 <= LEFT <= NDATA - 2.
23014!
23015! Input, real ( kind = 8 ) TVAL, the value of T at which the parabolic
23016! interpolant is to be evaluated. Normally, TDATA(1) <= TVAL <= T(NDATA),
23017! and the data will be interpolated. For TVAL outside this range,
23018! extrapolation will be used.
23019!
23020! Output, real ( kind = 8 ) YVAL(DIM_NUM), the value of the parabolic
23021! interpolant at TVAL.
23022!
23023 implicit none
23024
23025 integer ( kind = 4 ) ndata
23026 integer ( kind = 4 ) dim_num
23027
23028 real ( kind = 8 ) dif1
23029 real ( kind = 8 ) dif2
23030 integer ( kind = 4 ) i
23031 integer ( kind = 4 ) left
23032 real ( kind = 8 ) t1
23033 real ( kind = 8 ) t2
23034 real ( kind = 8 ) t3
23035 real ( kind = 8 ) tval
23036 real ( kind = 8 ) tdata(ndata)
23037 real ( kind = 8 ) ydata(dim_num,ndata)
23038 real ( kind = 8 ) y1
23039 real ( kind = 8 ) y2
23040 real ( kind = 8 ) y3
23041 real ( kind = 8 ) yval(dim_num)
23042!
23043! Check.
23044!
23045 if ( left < 1 .or. ndata-2 < left ) then
23046 write ( *, '(a)' ) ' '
23047 write ( *, '(a)' ) 'R8POLY2_VAL2 - Fatal error!'
23048 write ( *, '(a)' ) ' LEFT < 1 or NDATA-2 < LEFT.'
23049 write ( *, '(a,i8)' ) ' LEFT = ', left
23050 stop 1
23051 end if
23052
23053 if ( dim_num < 1 ) then
23054 write ( *, '(a)' ) ' '
23055 write ( *, '(a)' ) 'R8POLY2_VAL2 - Fatal error!'
23056 write ( *, '(a)' ) ' DIM_NUM < 1.'
23057 write ( *, '(a,i8)' ) ' DIM_NUM = ', dim_num
23058 stop 1
23059 end if
23060!
23061! Copy out the three abscissas.
23062!
23063 t1 = tdata(left)
23064 t2 = tdata(left+1)
23065 t3 = tdata(left+2)
23066
23067 if ( t2 <= t1 .or. t3 <= t2 ) then
23068 write ( *, '(a)' ) ' '
23069 write ( *, '(a)' ) 'R8POLY2_VAL2 - Fatal error!'
23070 write ( *, '(a)' ) ' T2 <= T1 or T3 <= T2.'
23071 write ( *, '(a,g14.6)' ) ' T1 = ', t1
23072 write ( *, '(a,g14.6)' ) ' T2 = ', t2
23073 write ( *, '(a,g14.6)' ) ' T3 = ', t3
23074 stop 1
23075 end if
23076!
23077! Construct and evaluate a parabolic interpolant for the data
23078! in each dimension.
23079!
23080 do i = 1, dim_num
23081
23082 y1 = ydata(i,left)
23083 y2 = ydata(i,left+1)
23084 y3 = ydata(i,left+2)
23085
23086 dif1 = ( y2 - y1 ) / ( t2 - t1 )
23087 dif2 = ( ( y3 - y1 ) / ( t3 - t1 ) &
23088 - ( y2 - y1 ) / ( t2 - t1 ) ) / ( t3 - t2 )
23089
23090 yval(i) = y1 + ( tval - t1 ) * ( dif1 + ( tval - t2 ) * dif2 )
23091
23092 end do
23093
23094 return

◆ r8poly3_root()

subroutine r8poly3_root ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
real ( kind = 8 )  d,
complex ( kind = 8 )  r1,
complex ( kind = 8 )  r2,
complex ( kind = 8 )  r3 
)

Definition at line 23096 of file R8LIB.f90.

23097
23098!*****************************************************************************80
23099!
23100!! R8POLY3_ROOT returns the three roots of a cubic polynomial.
23101!
23102! Discussion:
23103!
23104! The polynomial has the form
23105!
23106! A * X^3 + B * X^2 + C * X + D = 0
23107!
23108! Licensing:
23109!
23110! This code is distributed under the GNU LGPL license.
23111!
23112! Modified:
23113!
23114! 10 December 2004
23115!
23116! Parameters:
23117!
23118! Input, real ( kind = 8 ) A, B, C, D, the coefficients of the polynomial.
23119! A must not be zero.
23120!
23121! Output, complex ( kind = 8 ) R1, R2, R3, the roots of the polynomial, which
23122! will include at least one real root.
23123!
23124 implicit none
23125
23126 real ( kind = 8 ) a
23127 real ( kind = 8 ) b
23128 real ( kind = 8 ) c
23129 real ( kind = 8 ) d
23130 complex ( kind = 8 ) i
23131 complex ( kind = 8 ) one
23132 real ( kind = 8 ) q
23133 real ( kind = 8 ) r
23134 complex ( kind = 8 ) r1
23135 complex ( kind = 8 ) r2
23136 complex ( kind = 8 ) r3
23137 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
23138 real ( kind = 8 ) s1
23139 real ( kind = 8 ) s2
23140 real ( kind = 8 ) temp
23141 real ( kind = 8 ) theta
23142
23143 if ( a == 0.0d+00 ) then
23144 write ( *, '(a)' ) ' '
23145 write ( *, '(a)' ) 'R8POLY3_ROOT - Fatal error!'
23146 write ( *, '(a)' ) ' A must not be zero!'
23147 stop 1
23148 end if
23149
23150 one = cmplx( 1.0d+00, 0.0d+00, kind = 8 )
23151 i = sqrt( -one )
23152
23153 q = ( ( b / a )**2 - 3.0d+00 * ( c / a ) ) / 9.0d+00
23154
23155 r = ( 2.0d+00 * ( b / a )**3 - 9.0d+00 * ( b / a ) * ( c / a ) &
23156 + 27.0d+00 * ( d / a ) ) / 54.0d+00
23157
23158 if ( r * r < q * q * q ) then
23159
23160 theta = acos( r / sqrt( q**3 ) )
23161 r1 = -2.0d+00 * sqrt( q ) * cos( theta / 3.0d+00 )
23162 r2 = -2.0d+00 * sqrt( q ) * cos( ( theta + 2.0d+00 * r8_pi ) / 3.0d+00 )
23163 r3 = -2.0d+00 * sqrt( q ) * cos( ( theta + 4.0d+00 * r8_pi ) / 3.0d+00 )
23164
23165 else if ( q * q * q <= r * r ) then
23166
23167 temp = -r + sqrt( r**2 - q**3 )
23168 s1 = sign( 1.0d+00, temp ) * ( abs( temp ) )**(1.0d+00/3.0d+00)
23169
23170 temp = -r - sqrt( r**2 - q**3 )
23171 s2 = sign( 1.0d+00, temp ) * ( abs( temp ) )**(1.0d+00/3.0d+00)
23172
23173 r1 = s1 + s2
23174 r2 = -0.5d+00 * ( s1 + s2 ) + i * 0.5d+00 * sqrt( 3.0d+00 ) * ( s1 - s2 )
23175 r3 = -0.5d+00 * ( s1 + s2 ) - i * 0.5d+00 * sqrt( 3.0d+00 ) * ( s1 - s2 )
23176
23177 end if
23178
23179 r1 = r1 - b / ( 3.0d+00 * a )
23180 r2 = r2 - b / ( 3.0d+00 * a )
23181 r3 = r3 - b / ( 3.0d+00 * a )
23182
23183 return

References r8_pi().

Referenced by r8poly4_root().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8poly4_root()

subroutine r8poly4_root ( real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 )  c,
real ( kind = 8 )  d,
real ( kind = 8 )  e,
complex ( kind = 8 )  r1,
complex ( kind = 8 )  r2,
complex ( kind = 8 )  r3,
complex ( kind = 8 )  r4 
)

Definition at line 23185 of file R8LIB.f90.

23186
23187!*****************************************************************************80
23188!
23189!! R8POLY4_ROOT returns the four roots of a quartic polynomial.
23190!
23191! Discussion:
23192!
23193! The polynomial has the form:
23194!
23195! A * X^4 + B * X^3 + C * X^2 + D * X + E = 0
23196!
23197! Licensing:
23198!
23199! This code is distributed under the GNU LGPL license.
23200!
23201! Modified:
23202!
23203! 10 December 2004
23204!
23205! Parameters:
23206!
23207! Input, real ( kind = 8 ) A, B, C, D, the coefficients of the polynomial.
23208! A must not be zero.
23209!
23210! Output, complex ( kind = 8 ) R1, R2, R3, R4, the roots of the polynomial.
23211!
23212 implicit none
23213
23214 real ( kind = 8 ) a
23215 real ( kind = 8 ) a3
23216 real ( kind = 8 ) a4
23217 real ( kind = 8 ) b
23218 real ( kind = 8 ) b3
23219 real ( kind = 8 ) b4
23220 real ( kind = 8 ) c
23221 real ( kind = 8 ) c3
23222 real ( kind = 8 ) c4
23223 real ( kind = 8 ) d
23224 real ( kind = 8 ) d3
23225 real ( kind = 8 ) d4
23226 real ( kind = 8 ) e
23227 complex ( kind = 8 ) p
23228 complex ( kind = 8 ) q
23229 complex ( kind = 8 ) r
23230 complex ( kind = 8 ) r1
23231 complex ( kind = 8 ) r2
23232 complex ( kind = 8 ) r3
23233 complex ( kind = 8 ) r4
23234 complex ( kind = 8 ) zero
23235
23236 zero = cmplx( 0.0d+00, 0.0d+00, kind = 8 )
23237
23238 if ( a == 0.0d+00 ) then
23239 write ( *, '(a)' ) ' '
23240 write ( *, '(a)' ) 'R8POLY4_ROOT - Fatal error!'
23241 write ( *, '(a)') ' A must not be zero!'
23242 stop 1
23243 end if
23244
23245 a4 = b / a
23246 b4 = c / a
23247 c4 = d / a
23248 d4 = e / a
23249!
23250! Set the coefficients of the resolvent cubic equation.
23251!
23252 a3 = 1.0d+00
23253 b3 = -b4
23254 c3 = a4 * c4 - 4.0d+00 * d4
23255 d3 = -a4 * a4 * d4 + 4.0d+00 * b4 * d4 - c4 * c4
23256!
23257! Find the roots of the resolvent cubic.
23258!
23259 call r8poly3_root ( a3, b3, c3, d3, r1, r2, r3 )
23260!
23261! Choose one root of the cubic, here R1.
23262!
23263! Set R = sqrt ( 0.25D+00 * A4**2 - B4 + R1 )
23264!
23265 r = sqrt( 0.25d+00 * a4**2 - b4 + r1 )
23266
23267 if ( r /= zero ) then
23268
23269 p = sqrt( 0.75d+00 * a4**2 - r**2 - 2.0d+00 * b4 &
23270 + 0.25d+00 * ( 4.0d+00 * a4 * b4 - 8.0d+00 * c4 - a4**3 ) / r )
23271
23272 q = sqrt( 0.75d+00 * a4**2 - r**2 - 2.0d+00 * b4 &
23273 - 0.25d+00 * ( 4.0d+00 * a4 * b4 - 8.0d+00 * c4 - a4**3 ) / r )
23274
23275 else
23276
23277 p = sqrt( 0.75d+00 * a4**2 - 2.0d+00 * b4 &
23278 + 2.0d+00 * sqrt( r1**2 - 4.0d+00 * d4 ) )
23279
23280 q = sqrt( 0.75d+00 * a4**2 - 2.0d+00 * b4 &
23281 - 2.0d+00 * sqrt( r1**2 - 4.0d+00 * d4 ) )
23282
23283 end if
23284!
23285! Set the roots.
23286!
23287 r1 = -0.25d+00 * a4 + 0.5d+00 * r + 0.5d+00 * p
23288 r2 = -0.25d+00 * a4 + 0.5d+00 * r - 0.5d+00 * p
23289 r3 = -0.25d+00 * a4 - 0.5d+00 * r + 0.5d+00 * q
23290 r4 = -0.25d+00 * a4 - 0.5d+00 * r - 0.5d+00 * q
23291
23292 return
r8poly3_root
subroutine r8poly3_root(a, b, c, d, r1, r2, r3)
Definition R8LIB.f90:23097

References r8poly3_root().

Here is the call graph for this function:

◆ r8poly_degree()

subroutine r8poly_degree ( integer ( kind = 4 )  na,
real ( kind = 8 ), dimension(0:na)  a,
integer ( kind = 4 )  degree 
)

Definition at line 21529 of file R8LIB.f90.

21530
21531!*****************************************************************************80
21532!
21533!! R8POLY_DEGREE returns the degree of a polynomial.
21534!
21535! Discussion:
21536!
21537! The degree of a polynomial is the index of the highest power
21538! of X with a nonzero coefficient.
21539!
21540! The degree of a constant polynomial is 0. The degree of the
21541! zero polynomial is debatable, but this routine returns the
21542! degree as 0.
21543!
21544! Licensing:
21545!
21546! This code is distributed under the GNU LGPL license.
21547!
21548! Modified:
21549!
21550! 21 March 2001
21551!
21552! Author:
21553!
21554! John Burkardt
21555!
21556! Parameters:
21557!
21558! Input, integer ( kind = 4 ) NA, the dimension of A.
21559!
21560! Input, real ( kind = 8 ) A(0:NA), the coefficients of the polynomials.
21561!
21562! Output, integer ( kind = 4 ) DEGREE, the degree of A.
21563!
21564 implicit none
21565
21566 integer ( kind = 4 ) na
21567
21568 real ( kind = 8 ) a(0:na)
21569 integer ( kind = 4 ) degree
21570
21571 degree = na
21572
21573 do while ( 0 < degree )
21574
21575 if ( a(degree) /= 0.0d+00 ) then
21576 return
21577 end if
21578
21579 degree = degree - 1
21580
21581 end do
21582
21583 return

Referenced by r8poly_print().

Here is the caller graph for this function:

◆ r8poly_deriv()

subroutine r8poly_deriv ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(0:n)  c,
integer ( kind = 4 )  p,
real ( kind = 8 ), dimension(0:*)  cp 
)

Definition at line 21585 of file R8LIB.f90.

21586
21587!*****************************************************************************80
21588!
21589!! R8POLY_DERIV returns the derivative of a polynomial.
21590!
21591! Licensing:
21592!
21593! This code is distributed under the GNU LGPL license.
21594!
21595! Modified:
21596!
21597! 21 February 2002
21598!
21599! Author:
21600!
21601! John Burkardt
21602!
21603! Parameters:
21604!
21605! Input, integer ( kind = 4 ) N, the degree of the polynomial.
21606!
21607! Input, real ( kind = 8 ) C(0:N), the polynomial coefficients.
21608! C(I) is the coefficient of X^I.
21609!
21610! Input, integer ( kind = 4 ) P, the order of the derivative.
21611! 0 means no derivative is taken.
21612! 1 means first derivative,
21613! 2 means second derivative and so on.
21614! Values of P less than 0 are meaningless. Values of P greater
21615! than N are meaningful, but the code will behave as though the
21616! value of P was N+1.
21617!
21618! Output, real ( kind = 8 ) CP(0:N-P), the polynomial coefficients of
21619! the derivative.
21620!
21621 implicit none
21622
21623 integer ( kind = 4 ) n
21624
21625 real ( kind = 8 ) c(0:n)
21626 real ( kind = 8 ) cp(0:*)
21627 real ( kind = 8 ) cp_temp(0:n)
21628 integer ( kind = 4 ) d
21629 integer ( kind = 4 ) i
21630 integer ( kind = 4 ) p
21631
21632 if ( n < p ) then
21633 return
21634 end if
21635
21636 cp_temp(0:n) = c(0:n)
21637
21638 do d = 1, p
21639 do i = 0, n - d
21640 cp_temp(i) = real( i + 1, kind = 8 ) * cp_temp(i+1)
21641 end do
21642 cp_temp(n-d+1) = 0.0d+00
21643 end do
21644
21645 cp(0:n-p) = cp_temp(0:n-p)
21646
21647 return

◆ r8poly_lagrange_0()

subroutine r8poly_lagrange_0 ( integer ( kind = 4 )  npol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 )  xval,
real ( kind = 8 )  wval 
)

Definition at line 21649 of file R8LIB.f90.

21650
21651!*****************************************************************************80
21652!
21653!! R8POLY_LAGRANGE_0 evaluates the Lagrange factor at a point.
21654!
21655! Formula:
21656!
21657! W(X) = Product ( 1 <= I <= NPOL ) ( X - XPOL(I) )
21658!
21659! Discussion:
21660!
21661! For a set of points XPOL(I), 1 <= I <= NPOL, the IPOL-th Lagrange basis
21662! polynomial L(IPOL)(X), has the property:
21663!
21664! L(IPOL)( XPOL(J) ) = delta ( IPOL, J )
21665!
21666! and may be expressed as:
21667!
21668! L(IPOL)(X) = W(X) / ( ( X - XPOL(IPOL) ) * W'(XPOL(IPOL)) )
21669!
21670! Licensing:
21671!
21672! This code is distributed under the GNU LGPL license.
21673!
21674! Modified:
21675!
21676! 21 February 2002
21677!
21678! Author:
21679!
21680! John Burkardt
21681!
21682! Parameters:
21683!
21684! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
21685! NPOL must be at least 1.
21686!
21687! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas, which
21688! should be distinct.
21689!
21690! Input, real ( kind = 8 ) XVAL, the point at which the Lagrange
21691! factor is to be evaluated.
21692!
21693! Output, real ( kind = 8 ) WVAL, the value of the Lagrange factor at XVAL.
21694!
21695 implicit none
21696
21697 integer ( kind = 4 ) npol
21698
21699 real ( kind = 8 ) wval
21700 real ( kind = 8 ) xpol(npol)
21701 real ( kind = 8 ) xval
21702
21703 wval = product( xval - xpol(1:npol) )
21704
21705 return

◆ r8poly_lagrange_1()

subroutine r8poly_lagrange_1 ( integer ( kind = 4 )  npol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 )  xval,
real ( kind = 8 )  dwdx 
)

Definition at line 21707 of file R8LIB.f90.

21708
21709!*****************************************************************************80
21710!
21711!! R8POLY_LAGRANGE_1 evaluates the first derivative of the Lagrange factor.
21712!
21713! Formula:
21714!
21715! W(XPOL(1:NPOL))(X) = Product ( 1 <= I <= NPOL ) ( X - XPOL(I) )
21716!
21717! W'(XPOL(1:NPOL))(X)
21718! = Sum ( 1 <= J <= NPOL ) Product ( I /= J ) ( X - XPOL(I) )
21719!
21720! We also have the recursion:
21721!
21722! W'(XPOL(1:NPOL))(X) = d/dX ( ( X - XPOL(NPOL) ) * W(XPOL(1:NPOL-1))(X) )
21723! = W(XPOL(1:NPOL-1))(X)
21724! + ( X - XPOL(NPOL) ) * W'(XPOL(1:NPOL-1))(X)
21725!
21726! Licensing:
21727!
21728! This code is distributed under the GNU LGPL license.
21729!
21730! Modified:
21731!
21732! 29 January 2004
21733!
21734! Author:
21735!
21736! John Burkardt
21737!
21738! Parameters:
21739!
21740! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
21741!
21742! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas, which should
21743! be distinct.
21744!
21745! Input, real ( kind = 8 ) XVAL, the point at which the Lagrange
21746! factor is to be evaluated.
21747!
21748! Output, real ( kind = 8 ) DWDX, the derivative of W with respect to X.
21749!
21750 implicit none
21751
21752 integer ( kind = 4 ) npol
21753
21754 real ( kind = 8 ) dwdx
21755 integer ( kind = 4 ) i
21756 real ( kind = 8 ) w
21757 real ( kind = 8 ) xpol(npol)
21758 real ( kind = 8 ) xval
21759
21760 dwdx = 0.0d+00
21761 w = 1.0d+00
21762
21763 do i = 1, npol
21764
21765 dwdx = w + ( xval - xpol(i) ) * dwdx
21766 w = w * ( xval - xpol(i) )
21767
21768 end do
21769
21770 return

◆ r8poly_lagrange_2()

subroutine r8poly_lagrange_2 ( integer ( kind = 4 )  npol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 )  xval,
real ( kind = 8 )  dw2dx2 
)

Definition at line 21772 of file R8LIB.f90.

21773
21774!*****************************************************************************80
21775!
21776!! R8POLY_LAGRANGE_2 evaluates the second derivative of the Lagrange factor.
21777!
21778! Formula:
21779!
21780! W(X) = Product ( 1 <= I <= NPOL ) ( X - XPOL(I) )
21781!
21782! W'(X) = Sum ( 1 <= J <= NPOL )
21783! Product ( I /= J ) ( X - XPOL(I) )
21784!
21785! W"(X) = Sum ( 1 <= K <= NPOL )
21786! Sum ( J =/ K )
21787! Product ( I /= K, J ) ( X - XPOL(I) )
21788!
21789! For a set of points XPOL(I), 1 <= I <= NPOL, the IPOL-th Lagrange basis
21790! polynomial L(IPOL)(X), has the property:
21791!
21792! L(IPOL)( XPOL(J) ) = delta ( IPOL, J )
21793!
21794! and may be expressed as:
21795!
21796! L(IPOL)(X) = W(X) / ( ( X - XPOL(IPOL) ) * W'(XPOL(IPOL)) )
21797!
21798! Licensing:
21799!
21800! This code is distributed under the GNU LGPL license.
21801!
21802! Modified:
21803!
21804! 21 February 2002
21805!
21806! Author:
21807!
21808! John Burkardt
21809!
21810! Parameters:
21811!
21812! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
21813! NPOL must be at least 1.
21814!
21815! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas, which should
21816! be distinct.
21817!
21818! Input, real ( kind = 8 ) XVAL, the point at which the Lagrange
21819! factor is to be evaluated.
21820!
21821! Output, real ( kind = 8 ) DW2DX2, the second derivative of W
21822! with respect to XVAL.
21823!
21824 implicit none
21825
21826 integer ( kind = 4 ) npol
21827
21828 real ( kind = 8 ) dw2dx2
21829 integer ( kind = 4 ) i
21830 integer ( kind = 4 ) j
21831 integer ( kind = 4 ) k
21832 real ( kind = 8 ) term
21833 real ( kind = 8 ) xpol(npol)
21834 real ( kind = 8 ) xval
21835
21836 dw2dx2 = 0.0d+00
21837
21838 do k = 1, npol
21839
21840 do j = 1, npol
21841
21842 if ( j /= k ) then
21843 term = 1.0d+00
21844
21845 do i = 1, npol
21846 if ( i /= j .and. i /= k ) then
21847 term = term * ( xval - xpol(i) )
21848 end if
21849 end do
21850
21851 dw2dx2 = dw2dx2 + term
21852
21853 end if
21854
21855 end do
21856
21857 end do
21858
21859 return

◆ r8poly_lagrange_coef()

subroutine r8poly_lagrange_coef ( integer ( kind = 4 )  npol,
integer ( kind = 4 )  ipol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 ), dimension(0:npol-1)  pcof 
)

Definition at line 21861 of file R8LIB.f90.

21862
21863!*****************************************************************************80
21864!
21865!! R8POLY_LAGRANGE_COEF returns the coefficients of a Lagrange polynomial.
21866!
21867! Discussion:
21868!
21869! Given distinct abscissas XPOL(1:NPOL), the IPOL-th Lagrange
21870! polynomial L(IPOL)(X) is defined as the polynomial of degree
21871! NPOL - 1 which is 1 at XPOL(IPOL) and 0 at the NPOL - 1 other
21872! abscissas.
21873!
21874! A formal representation is:
21875!
21876! L(IPOL)(X) = Product ( 1 <= I <= NPOL, I /= IPOL )
21877! ( X - X(I) ) / ( X(IPOL) - X(I) )
21878!
21879! However sometimes it is desirable to be able to write down
21880! the standard polynomial coefficients of L(IPOL)(X).
21881!
21882! Licensing:
21883!
21884! This code is distributed under the GNU LGPL license.
21885!
21886! Modified:
21887!
21888! 18 May 1999
21889!
21890! Author:
21891!
21892! John Burkardt
21893!
21894! Parameters:
21895!
21896! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
21897! NPOL must be at least 1.
21898!
21899! Input, integer ( kind = 4 ) IPOL, the index of the polynomial to evaluate.
21900! IPOL must be between 1 and NPOL.
21901!
21902! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas of the
21903! Lagrange polynomials. The entries in XPOL must be distinct.
21904!
21905! Output, real ( kind = 8 ) PCOF(0:NPOL-1), the standard polynomial
21906! coefficients of the IPOL-th Lagrange polynomial:
21907! L(IPOL)(X) = SUM ( 0 <= I <= NPOL-1 ) PCOF(I) * X^I
21908!
21909 implicit none
21910
21911 integer ( kind = 4 ) npol
21912
21913 integer ( kind = 4 ) i
21914 integer ( kind = 4 ) indx
21915 integer ( kind = 4 ) ipol
21916 integer ( kind = 4 ) j
21917 real ( kind = 8 ) pcof(0:npol-1)
21918 logical ( kind = 4 ) r8vec_distinct
21919 real ( kind = 8 ) xpol(npol)
21920!
21921! Make sure IPOL is legal.
21922!
21923 if ( ipol < 1 .or. npol < ipol ) then
21924 write ( *, '(a)' ) ' '
21925 write ( *, '(a)' ) 'R8POLY_LAGRANGE_COEF - Fatal error!'
21926 write ( *, '(a)' ) ' 1 <= IPOL <= NPOL is required.'
21927 write ( *, '(a,i8)' ) ' IPOL = ', ipol
21928 write ( *, '(a,i8)' ) ' NPOL = ', npol
21929 stop 1
21930 end if
21931!
21932! Check that the abscissas are distinct.
21933!
21934 if ( .not. r8vec_distinct( npol, xpol ) ) then
21935 write ( *, '(a)' ) ' '
21936 write ( *, '(a)' ) 'R8POLY_LAGRANGE_COEF - Fatal error!'
21937 write ( *, '(a)' ) ' Two or more entries of XPOL are equal:'
21938 stop 1
21939 end if
21940
21941 pcof(0) = 1.0d+00
21942 pcof(1:npol-1) = 0.0d+00
21943
21944 indx = 0
21945
21946 do i = 1, npol
21947
21948 if ( i /= ipol ) then
21949
21950 indx = indx + 1
21951
21952 do j = indx, 0, -1
21953
21954 pcof(j) = -xpol(i) * pcof(j) / ( xpol(ipol) - xpol(i) )
21955
21956 if ( 0 < j ) then
21957 pcof(j) = pcof(j) + pcof(j-1) / ( xpol(ipol) - xpol(i) )
21958 end if
21959
21960 end do
21961
21962 end if
21963
21964 end do
21965
21966 return
r8vec_distinct
logical(kind=4) function r8vec_distinct(n, a)
Definition R8LIB.f90:28782

◆ r8poly_lagrange_factor()

subroutine r8poly_lagrange_factor ( integer ( kind = 4 )  npol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 )  xval,
real ( kind = 8 )  wval,
real ( kind = 8 )  dwdx 
)

Definition at line 21968 of file R8LIB.f90.

21969
21970!*****************************************************************************80
21971!
21972!! R8POLY_LAGRANGE_FACTOR evaluates the polynomial Lagrange factor at a point.
21973!
21974! Formula:
21975!
21976! W(X) = Product ( 1 <= I <= NPOL ) ( X - XPOL(I) )
21977!
21978! Discussion:
21979!
21980! Suppose F(X) is at least N times continuously differentiable in the
21981! interval [A,B]. Pick NPOL distinct points XPOL(I) in [A,B] and compute
21982! the interpolating polynomial P(X) of order NPOL ( and degree NPOL-1)
21983! which passes through all the points ( XPOL(I), F(XPOL(I)) ).
21984! Then in the interval [A,B], the maximum error
21985!
21986! abs ( F(X) - P(X) )
21987!
21988! is bounded by:
21989!
21990! C * FNMAX * W(X)
21991!
21992! where
21993!
21994! C is a constant,
21995! FNMAX is the maximum value of the NPOL-th derivative of F in [A,B],
21996! W(X) is the Lagrange factor.
21997!
21998! Thus, the value of W(X) is useful as part of an estimated bound
21999! for the interpolation error.
22000!
22001! Note that the Chebyshev abscissas have the property that they minimize
22002! the value of W(X) over the interval [A,B]. Hence, if the abscissas may
22003! be chosen arbitrarily, the Chebyshev abscissas have this advantage over
22004! other choices.
22005!
22006! For a set of points XPOL(I), 1 <= I <= NPOL, the IPOL-th Lagrange basis
22007! polynomial L(IPOL)(X), has the property:
22008!
22009! L(IPOL)( XPOL(J) ) = delta ( IPOL, J )
22010!
22011! and may be expressed as:
22012!
22013! L(IPOL)(X) = W(X) / ( ( X - XPOL(IPOL) ) * W'(XPOL(IPOL)) )
22014!
22015! Licensing:
22016!
22017! This code is distributed under the GNU LGPL license.
22018!
22019! Modified:
22020!
22021! 18 May 1999
22022!
22023! Author:
22024!
22025! John Burkardt
22026!
22027! Parameters:
22028!
22029! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
22030! NPOL must be at least 1.
22031!
22032! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas, which should
22033! be distinct.
22034!
22035! Input, real ( kind = 8 ) XVAL, the point at which the Lagrange
22036! factor is to be evaluated.
22037!
22038! Output, real ( kind = 8 ) WVAL, the value of the Lagrange factor at XVAL.
22039!
22040! Output, real ( kind = 8 ) DWDX, the derivative of W with respect to XVAL.
22041!
22042 implicit none
22043
22044 integer ( kind = 4 ) npol
22045
22046 real ( kind = 8 ) dwdx
22047 integer ( kind = 4 ) i
22048 integer ( kind = 4 ) j
22049 real ( kind = 8 ) term
22050 real ( kind = 8 ) wval
22051 real ( kind = 8 ) xpol(npol)
22052 real ( kind = 8 ) xval
22053
22054 wval = product( xval - xpol(1:npol) )
22055
22056 dwdx = 0.0d+00
22057
22058 do i = 1, npol
22059
22060 term = 1.0d+00
22061
22062 do j = 1, npol
22063 if ( i /= j ) then
22064 term = term * ( xval - xpol(j) )
22065 end if
22066 end do
22067
22068 dwdx = dwdx + term
22069
22070 end do
22071
22072 return

◆ r8poly_lagrange_val()

subroutine r8poly_lagrange_val ( integer ( kind = 4 )  npol,
integer ( kind = 4 )  ipol,
real ( kind = 8 ), dimension(npol)  xpol,
real ( kind = 8 )  xval,
real ( kind = 8 )  pval,
real ( kind = 8 )  dpdx 
)

Definition at line 22074 of file R8LIB.f90.

22075
22076!*****************************************************************************80
22077!
22078!! R8POLY_LAGRANGE_VAL evaluates the IPOL-th Lagrange polynomial.
22079!
22080! Discussion:
22081!
22082! Given NPOL distinct abscissas, XPOL(1:NPOL), the IPOL-th Lagrange
22083! polynomial L(IPOL)(X) is defined as the polynomial of degree
22084! NPOL - 1 which is 1 at XPOL(IPOL) and 0 at the NPOL - 1 other
22085! abscissas.
22086!
22087! A formal representation is:
22088!
22089! L(IPOL)(X) = Product ( 1 <= I <= NPOL, I /= IPOL )
22090! ( X - X(I) ) / ( X(IPOL) - X(I) )
22091!
22092! Licensing:
22093!
22094! This code is distributed under the GNU LGPL license.
22095!
22096! Modified:
22097!
22098! 18 May 1999
22099!
22100! Author:
22101!
22102! John Burkardt
22103!
22104! Parameters:
22105!
22106! Input, integer ( kind = 4 ) NPOL, the number of abscissas.
22107! NPOL must be at least 1.
22108!
22109! Input, integer ( kind = 4 ) IPOL, the index of the polynomial to evaluate.
22110! IPOL must be between 1 and NPOL.
22111!
22112! Input, real ( kind = 8 ) XPOL(NPOL), the abscissas of the Lagrange
22113! polynomials. The entries in XPOL must be distinct.
22114!
22115! Input, real ( kind = 8 ) XVAL, the point at which the IPOL-th
22116! Lagrange polynomial is to be evaluated.
22117!
22118! Output, real ( kind = 8 ) PVAL, the value of the IPOL-th Lagrange
22119! polynomial at XVAL.
22120!
22121! Output, real ( kind = 8 ) DPDX, the derivative of the IPOL-th
22122! Lagrange polynomial at XVAL.
22123!
22124 implicit none
22125
22126 integer ( kind = 4 ) npol
22127
22128 real ( kind = 8 ) dpdx
22129 integer ( kind = 4 ) i
22130 integer ( kind = 4 ) ipol
22131 integer ( kind = 4 ) j
22132 real ( kind = 8 ) p2
22133 real ( kind = 8 ) pval
22134 logical ( kind = 4 ) r8vec_distinct
22135 real ( kind = 8 ) xpol(npol)
22136 real ( kind = 8 ) xval
22137!
22138! Make sure IPOL is legal.
22139!
22140 if ( ipol < 1 .or. npol < ipol ) then
22141 write ( *, '(a)' ) ' '
22142 write ( *, '(a)' ) 'R8POLY_LAGRANGE_VAL - Fatal error!'
22143 write ( *, '(a)' ) ' 1 <= IPOL <= NPOL is required.'
22144 write ( *, '(a,i8)' ) ' IPOL = ', ipol
22145 stop 1
22146 end if
22147!
22148! Check that the abscissas are distinct.
22149!
22150 if ( .not. r8vec_distinct( npol, xpol ) ) then
22151 write ( *, '(a)' ) ' '
22152 write ( *, '(a)' ) 'R8POLY_LAGRANGE_VAL - Fatal error!'
22153 write ( *, '(a)' ) ' Two or more entries of XPOL are equal:'
22154 stop 1
22155 end if
22156!
22157! Evaluate the polynomial.
22158!
22159 pval = 1.0d+00
22160
22161 do i = 1, npol
22162
22163 if ( i /= ipol ) then
22164
22165 pval = pval * ( xval - xpol(i) ) / ( xpol(ipol) - xpol(i) )
22166
22167 end if
22168
22169 end do
22170!
22171! Evaluate the derivative, which can be found by summing up the result
22172! of differentiating one factor at a time, successively.
22173!
22174 dpdx = 0.0d+00
22175
22176 do i = 1, npol
22177
22178 if ( i /= ipol ) then
22179
22180 p2 = 1.0d+00
22181 do j = 1, npol
22182
22183 if ( j == i ) then
22184 p2 = p2 / ( xpol(ipol) - xpol(j) )
22185 else if ( j /= ipol ) then
22186 p2 = p2 * ( xval - xpol(j) ) / ( xpol(ipol) - xpol(j) )
22187 end if
22188
22189 end do
22190
22191 dpdx = dpdx + p2
22192
22193 end if
22194
22195 end do
22196
22197 return

◆ r8poly_order()

subroutine r8poly_order ( integer ( kind = 4 )  na,
real ( kind = 8 ), dimension(0:na)  a,
integer ( kind = 4 )  order 
)

Definition at line 22199 of file R8LIB.f90.

22200
22201!*****************************************************************************80
22202!
22203!! R8POLY_ORDER returns the order of a polynomial.
22204!
22205! Discussion:
22206!
22207! The order of a polynomial is one more than the degree.
22208!
22209! The order of a constant polynomial is 1. The order of the
22210! zero polynomial is debatable, but this routine returns the
22211! order as 1.
22212!
22213! Licensing:
22214!
22215! This code is distributed under the GNU LGPL license.
22216!
22217! Modified:
22218!
22219! 19 April 2005
22220!
22221! Author:
22222!
22223! John Burkardt
22224!
22225! Parameters:
22226!
22227! Input, integer ( kind = 4 ) NA, the dimension of A.
22228!
22229! Input, real ( kind = 8 ) A(0:NA), the coefficients of the polynomials.
22230!
22231! Output, integer ( kind = 4 ) ORDER, the order of A.
22232!
22233 implicit none
22234
22235 integer ( kind = 4 ) na
22236
22237 real ( kind = 8 ) a(0:na)
22238 integer ( kind = 4 ) order
22239
22240 order = na + 1
22241
22242 do while ( 1 < order )
22243
22244 if ( a(order-1) /= 0.0d+00 ) then
22245 return
22246 end if
22247
22248 order = order - 1
22249
22250 end do
22251
22252 return

◆ r8poly_print()

subroutine r8poly_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(0:n)  a,
character ( len = * )  title 
)

Definition at line 22254 of file R8LIB.f90.

22255
22256!*****************************************************************************80
22257!
22258!! R8POLY_PRINT prints out a polynomial.
22259!
22260! Licensing:
22261!
22262! This code is distributed under the GNU LGPL license.
22263!
22264! Modified:
22265!
22266! 30 October 2005
22267!
22268! Author:
22269!
22270! John Burkardt
22271!
22272! Parameters:
22273!
22274! Input, integer ( kind = 4 ) N, the dimension of A.
22275!
22276! Input, real ( kind = 8 ) A(0:N), the polynomial coefficients.
22277! A(0) is the constant term and
22278! A(N) is the coefficient of X^N.
22279!
22280! Input, character ( len = * ) TITLE, a title.
22281!
22282 implicit none
22283
22284 integer ( kind = 4 ) n
22285
22286 real ( kind = 8 ) a(0:n)
22287 integer ( kind = 4 ) i
22288 real ( kind = 8 ) mag
22289 integer ( kind = 4 ) n2
22290 character plus_minus
22291 character ( len = * ) title
22292
22293 write ( *, '(a)' ) ' '
22294 write ( *, '(a)' ) trim( title )
22295 write ( *, '(a)' ) ' '
22296
22297 call r8poly_degree ( n, a, n2 )
22298
22299 if ( n2 <= 0 ) then
22300 write ( *, '( '' p(x) = 0'' )' )
22301 return
22302 end if
22303
22304 if ( a(n2) < 0.0d+00 ) then
22305 plus_minus = '-'
22306 else
22307 plus_minus = ' '
22308 end if
22309
22310 mag = abs( a(n2) )
22311
22312 if ( 2 <= n2 ) then
22313 write ( *, '( '' p(x) = '', a1, g14.6, '' * x ^ '', i3 )' ) &
22314 plus_minus, mag, n2
22315 else if ( n2 == 1 ) then
22316 write ( *, '( '' p(x) = '', a1, g14.6, '' * x'' )' ) &
22317 plus_minus, mag
22318 else if ( n2 == 0 ) then
22319 write ( *, '( '' p(x) = '', a1, g14.6 )' ) plus_minus, mag
22320 end if
22321
22322 do i = n2-1, 0, -1
22323
22324 if ( a(i) < 0.0d+00 ) then
22325 plus_minus = '-'
22326 else
22327 plus_minus = '+'
22328 end if
22329
22330 mag = abs( a(i) )
22331
22332 if ( mag /= 0.0d+00 ) then
22333
22334 if ( 2 <= i ) then
22335 write ( *, ' ( '' '', a1, g14.6, '' * x ^ '', i3 )' ) &
22336 plus_minus, mag, i
22337 else if ( i == 1 ) then
22338 write ( *, ' ( '' '', a1, g14.6, '' * x'' )' ) plus_minus, mag
22339 else if ( i == 0 ) then
22340 write ( *, ' ( '' '', a1, g14.6 )' ) plus_minus, mag
22341 end if
22342 end if
22343
22344 end do
22345
22346 return
r8poly_degree
subroutine r8poly_degree(na, a, degree)
Definition R8LIB.f90:21530

References r8poly_degree().

Here is the call graph for this function:

◆ r8poly_shift()

subroutine r8poly_shift ( real ( kind = 8 )  scale,
real ( kind = 8 )  shift,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(0:n)  poly_cof 
)

Definition at line 22348 of file R8LIB.f90.

22349
22350!*****************************************************************************80
22351!
22352!! R8POLY_SHIFT adjusts the coefficients of a polynomial for a new argument.
22353!
22354! Discussion:
22355!
22356! Assuming P(X) is a polynomial in the argument X, of the form:
22357!
22358! P(X) =
22359! C(N) * X^N
22360! + ...
22361! + C(1) * X
22362! + C(0),
22363!
22364! and that Z is related to X by the formula:
22365!
22366! Z = SCALE * X + SHIFT
22367!
22368! then this routine computes coefficients C for the polynomial Q(Z):
22369!
22370! Q(Z) =
22371! C(N) * Z^N
22372! + ...
22373! + C(1) * Z
22374! + C(0)
22375!
22376! so that:
22377!
22378! Q(Z(X)) = P(X)
22379!
22380! Example:
22381!
22382! P(X) = 2 * X^2 - X + 6
22383!
22384! Z = 2.0 * X + 3.0
22385!
22386! Q(Z) = 0.5 * Z^2 - 3.5 * Z + 12
22387!
22388! Q(Z(X)) = 0.5 * ( 4.0 * X^2 + 12.0 * X + 9 )
22389! - 3.5 * ( 2.0 * X + 3 )
22390! + 12
22391!
22392! = 2.0 * X^2 - 1.0 * X + 6
22393!
22394! = P(X)
22395!
22396! Licensing:
22397!
22398! This code is distributed under the GNU LGPL license.
22399!
22400! Modified:
22401!
22402! 05 October 1999
22403!
22404! Reference:
22405!
22406! William Press, Brian Flannery, Saul Teukolsky, William Vetterling,
22407! Numerical Recipes: The Art of Scientific Computing,
22408! Cambridge University Press.
22409!
22410! Parameters:
22411!
22412! Input, real ( kind = 8 ) SHIFT, SCALE, the shift and scale applied to X,
22413! so that Z = SCALE * X + SHIFT.
22414!
22415! Input, integer ( kind = 4 ) N, the number of coefficients.
22416!
22417! Input/output, real ( kind = 8 ) POLY_COF(0:N).
22418! On input, the coefficient array in terms of the X variable.
22419! On output, the coefficient array in terms of the Z variable.
22420!
22421 implicit none
22422
22423 integer ( kind = 4 ) n
22424
22425 integer ( kind = 4 ) i
22426 integer ( kind = 4 ) j
22427 real ( kind = 8 ) poly_cof(0:n)
22428 real ( kind = 8 ) scale
22429 real ( kind = 8 ) shift
22430
22431 do i = 1, n
22432 poly_cof(i:n) = poly_cof(i:n) / scale
22433 end do
22434
22435 do i = 0, n - 1
22436 do j = n - 1, i, -1
22437 poly_cof(j) = poly_cof(j) - shift * poly_cof(j+1)
22438 end do
22439 end do
22440
22441 return

◆ r8poly_value()

subroutine r8poly_value ( integer ( kind = 4 )  m,
real ( kind = 8 ), dimension(0:m)  c,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  p 
)

Definition at line 22443 of file R8LIB.f90.

22444
22445!*****************************************************************************80
22446!
22447!! R8POLY_VALUE evaluates a polynomial using Horner's method.
22448!
22449! Discussion:
22450!
22451! The polynomial
22452!
22453! p(x) = c0 + c1 * x + c2 * x^2 + ... + cm * x^m
22454!
22455! is to be evaluated at the vector of values X.
22456!
22457! Licensing:
22458!
22459! This code is distributed under the GNU LGPL license.
22460!
22461! Modified:
22462!
22463! 16 September 2012
22464!
22465! Author:
22466!
22467! John Burkardt
22468!
22469! Parameters:
22470!
22471! Input, integer ( kind = 4 ) M, the degree.
22472!
22473! Input, real ( kind = 8 ) C(0:M), the polynomial coefficients.
22474! C(I) is the coefficient of X^I.
22475!
22476! Input, integer ( kind = 4 ) N, the number of evaluation points.
22477!
22478! Input, real ( kind = 8 ) X(N), the evaluation points.
22479!
22480! Output, real ( kind = 8 ) P(N), the polynomial values.
22481!
22482 implicit none
22483
22484 integer ( kind = 4 ) m
22485 integer ( kind = 4 ) n
22486
22487 real ( kind = 8 ) c(0:m)
22488 integer ( kind = 4 ) i
22489 real ( kind = 8 ) p(n)
22490 real ( kind = 8 ) x(n)
22491
22492 p(1:n) = c(m)
22493 do i = m - 1, 0, -1
22494 p(1:n) = p(1:n) * x(1:n) + c(i)
22495 end do
22496
22497 return

◆ r8poly_value_2d()

subroutine r8poly_value_2d ( integer ( kind = 4 )  m,
real ( kind = 8 ), dimension(*)  c,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 ), dimension(n)  p 
)

Definition at line 22499 of file R8LIB.f90.

22500
22501!*****************************************************************************80
22502!
22503!! R8POLY_VALUE_2D evaluates a polynomial in 2 variables, X and Y.
22504!
22505! Discussion:
22506!
22507! We assume the polynomial is of total degree M, and has the form:
22508!
22509! p(x,y) = c00
22510! + c10 * x + c01 * y
22511! + c20 * x^2 + c11 * xy + c02 * y^2
22512! + ...
22513! + cm0 * x^(m) + ... + c0m * y^m.
22514!
22515! Licensing:
22516!
22517! This code is distributed under the GNU LGPL license.
22518!
22519! Modified:
22520!
22521! 31 August 2012
22522!
22523! Author:
22524!
22525! John Burkardt
22526!
22527! Parameters:
22528!
22529! Input, integer ( kind = 4 ) M, the degree of the polynomial.
22530!
22531! Input, real ( kind = 8 ) C(T(M+1)), the polynomial coefficients.
22532! C(1) is the constant term. T(M+1) is the M+1-th triangular number.
22533! The coefficients are stored consistent with the following ordering
22534! of monomials: 1, X, Y, X^2, XY, Y^2, X^3, X^2Y, XY^2, Y^3, X^4, ...
22535!
22536! Input, integer ( kind = 4 ) N, the number of evaluation points.
22537!
22538! Input, real ( kind = 8 ) X(N), Y(N), the evaluation points.
22539!
22540! Output, real ( kind = 8 ) P(N), the value of the polynomial at the
22541! evaluation points.
22542!
22543 implicit none
22544
22545 integer ( kind = 4 ) n
22546
22547 real ( kind = 8 ) c(*)
22548 integer ( kind = 4 ) ex
22549 integer ( kind = 4 ) ey
22550 integer ( kind = 4 ) j
22551 integer ( kind = 4 ) m
22552 real ( kind = 8 ) p(n)
22553 integer ( kind = 4 ) s
22554 real ( kind = 8 ) x(n)
22555 real ( kind = 8 ) y(n)
22556
22557 p(1:n) = 0.0d+00
22558
22559 j = 0
22560 do s = 0, m
22561 do ex = s, 0, -1
22562 ey = s - ex
22563 j = j + 1
22564 p(1:n) = p(1:n) + c(j) * x(1:n) ** ex * y(1:n) ** ey
22565 end do
22566 end do
22567
22568 return

◆ r8r8_compare()

integer ( kind = 4 ) function r8r8_compare ( real ( kind = 8 )  x1,
real ( kind = 8 )  y1,
real ( kind = 8 )  x2,
real ( kind = 8 )  y2 
)

Definition at line 23294 of file R8LIB.f90.

23295
23296!*****************************************************************************80
23297!
23298!! R8R8_COMPARE compares two R8R8's.
23299!
23300! Discussion:
23301!
23302! An R8R8 is simply a pair of R8 values, stored separately.
23303!
23304! Licensing:
23305!
23306! This code is distributed under the GNU LGPL license.
23307!
23308! Modified:
23309!
23310! 14 May 2005
23311!
23312! Author:
23313!
23314! John Burkardt
23315!
23316! Parameters:
23317!
23318! Input, real ( kind = 8 ) X1, Y1, the first vector.
23319!
23320! Input, real ( kind = 8 ) X2, Y2, the second vector.
23321!
23322! Output, integer ( kind = 4 ) R8R8_COMPARE:
23323! -1, (X1,Y1) < (X2,Y2);
23324! 0, (X1,Y1) = (X2,Y2);
23325! +1, (X1,Y1) > (X2,Y2).
23326!
23327 implicit none
23328
23329 integer ( kind = 4 ) compare
23330 integer ( kind = 4 ) r8r8_compare
23331 real ( kind = 8 ) x1
23332 real ( kind = 8 ) x2
23333 real ( kind = 8 ) y1
23334 real ( kind = 8 ) y2
23335
23336 if ( x1 < x2 ) then
23337 compare = -1
23338 else if ( x2 < x1 ) then
23339 compare = +1
23340 else if ( y1 < y2 ) then
23341 compare = -1
23342 else if ( y2 < y1 ) then
23343 compare = +1
23344 else
23345 compare = 0
23346 end if
23347
23348 r8r8_compare = compare
23349
23350 return
r8r8_compare
integer(kind=4) function r8r8_compare(x1, y1, x2, y2)
Definition R8LIB.f90:23295

References r8r8_compare().

Referenced by r8r8_compare().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8r8_print()

subroutine r8r8_print ( real ( kind = 8 )  a1,
real ( kind = 8 )  a2,
character ( len = * )  title 
)

Definition at line 23352 of file R8LIB.f90.

23353
23354!*****************************************************************************80
23355!
23356!! R8R8_PRINT prints an R8R8.
23357!
23358! Discussion:
23359!
23360! An R8R8 is simply a pair of R8R8's, stored separately.
23361!
23362! A format is used which suggests a coordinate pair:
23363!
23364! Example:
23365!
23366! Center : ( 1.23, 7.45 )
23367!
23368! Licensing:
23369!
23370! This code is distributed under the GNU LGPL license.
23371!
23372! Modified:
23373!
23374! 29 October 2005
23375!
23376! Author:
23377!
23378! John Burkardt
23379!
23380! Parameters:
23381!
23382! Input, real ( kind = 8 ) A1, A2, the coordinates of the vector.
23383!
23384! Input, character ( len = * ) TITLE, a title.
23385!
23386 implicit none
23387
23388 real ( kind = 8 ) a1
23389 real ( kind = 8 ) a2
23390 character ( len = * ) title
23391
23392 if ( 0 < len_trim( title ) ) then
23393 write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1 )' ) &
23394 trim( title ), ' : (', a1, ',', a2, ')'
23395 else
23396 write ( *, '( 2x, a1, g14.6, a1, g14.6, a1 )' ) '(', a1, ',', a2, ')'
23397 end if
23398
23399 return

◆ r8r8r8_compare()

integer ( kind = 4 ) function r8r8r8_compare ( real ( kind = 8 )  x1,
real ( kind = 8 )  y1,
real ( kind = 8 )  z1,
real ( kind = 8 )  x2,
real ( kind = 8 )  y2,
real ( kind = 8 )  z2 
)

Definition at line 23401 of file R8LIB.f90.

23402
23403!*****************************************************************************80
23404!
23405!! R8R8R8_COMPARE compares two R8R8R8's.
23406!
23407! Discussion:
23408!
23409! An R8R8R8 is simply 3 R8 values, stored as scalars.
23410!
23411! Licensing:
23412!
23413! This code is distributed under the GNU LGPL license.
23414!
23415! Modified:
23416!
23417! 14 May 2005
23418!
23419! Author:
23420!
23421! John Burkardt
23422!
23423! Parameters:
23424!
23425! Input, real ( kind = 8 ) X1, Y1, Z1, the first vector.
23426!
23427! Input, real ( kind = 8 ) X2, Y2, Z2, the second vector.
23428!
23429! Output, integer ( kind = 4 ) R8R8R8_COMPARE:
23430! -1, (X1,Y1,Z1) < (X2,Y2,Z2);
23431! 0, (X1,Y1,Z1) = (X2,Y2,Z2);
23432! +1, (X1,Y1,Z1) > (X2,Y2,Z2).
23433!
23434 implicit none
23435
23436 integer ( kind = 4 ) compare
23437 integer ( kind = 4 ) r8r8r8_compare
23438 real ( kind = 8 ) x1
23439 real ( kind = 8 ) x2
23440 real ( kind = 8 ) y1
23441 real ( kind = 8 ) y2
23442 real ( kind = 8 ) z1
23443 real ( kind = 8 ) z2
23444
23445 if ( x1 < x2 ) then
23446 compare = -1
23447 else if ( x2 < x1 ) then
23448 compare = +1
23449 else if ( y1 < y2 ) then
23450 compare = -1
23451 else if ( y2 < y1 ) then
23452 compare = +1
23453 else if ( z1 < z2 ) then
23454 compare = -1
23455 else if ( z2 < z1 ) then
23456 compare = +1
23457 else
23458 compare = 0
23459 end if
23460
23461 r8r8r8_compare = compare
23462
23463 return
r8r8r8_compare
integer(kind=4) function r8r8r8_compare(x1, y1, z1, x2, y2, z2)
Definition R8LIB.f90:23402

References r8r8r8_compare().

Referenced by r8r8r8_compare().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8r8r8vec_index_insert_unique()

subroutine r8r8r8vec_index_insert_unique ( integer ( kind = 4 )  n_max,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n_max)  x,
real ( kind = 8 ), dimension(n_max)  y,
real ( kind = 8 ), dimension(n_max)  z,
integer ( kind = 4 ), dimension(n_max)  indx,
real ( kind = 8 )  xval,
real ( kind = 8 )  yval,
real ( kind = 8 )  zval,
integer ( kind = 4 )  ival,
integer ( kind = 4 )  ierror 
)

Definition at line 23465 of file R8LIB.f90.

23467
23468!*****************************************************************************80
23469!
23470!! R8R8R8VEC_INDEX_INSERT_UNIQUE inserts unique R8R8R in an indexed sorted list.
23471!
23472! Discussion:
23473!
23474! An R8R8R8VEC is set of N R8R8R8 items.
23475!
23476! An R8R8R8 is simply 3 R8 values, stored as scalars.
23477!
23478! If the input value does not occur in the current list, it is added,
23479! and N, X, Y, Z and INDX are updated.
23480!
23481! Licensing:
23482!
23483! This code is distributed under the GNU LGPL license.
23484!
23485! Modified:
23486!
23487! 06 December 2004
23488!
23489! Author:
23490!
23491! John Burkardt
23492!
23493! Parameters:
23494!
23495! Input, integer ( kind = 4 ) N_MAX, the maximum size of the list.
23496!
23497! Input/output, integer ( kind = 4 ) N, the size of the list.
23498!
23499! Input/output, real ( kind = 8 ) X(N), Y(N), Z(N), the R8R8R8 vector.
23500!
23501! Input/output, integer ( kind = 4 ) INDX(N), the sort index of the list.
23502!
23503! Input, real ( kind = 8 ) XVAL, YVAL, ZVAL, the value to be inserted
23504! if it is not already in the list.
23505!
23506! Output, integer ( kind = 4 ) IVAL, the index in X, Y, Z corresponding
23507! to the value XVAL, YVAL, ZVAL.
23508!
23509! Output, integer ( kind = 4 ) IERROR, 0 for no error, 1 if an error
23510! occurred.
23511!
23512 implicit none
23513
23514 integer ( kind = 4 ) n_max
23515
23516 integer ( kind = 4 ) equal
23517 integer ( kind = 4 ) ierror
23518 integer ( kind = 4 ) indx(n_max)
23519 integer ( kind = 4 ) ival
23520 integer ( kind = 4 ) less
23521 integer ( kind = 4 ) more
23522 integer ( kind = 4 ) n
23523 real ( kind = 8 ) x(n_max)
23524 real ( kind = 8 ) xval
23525 real ( kind = 8 ) y(n_max)
23526 real ( kind = 8 ) yval
23527 real ( kind = 8 ) z(n_max)
23528 real ( kind = 8 ) zval
23529
23530 ierror = 0
23531
23532 if ( n <= 0 ) then
23533
23534 if ( n_max <= 0 ) then
23535 ierror = 1
23536 write ( *, '(a)' ) ' '
23537 write ( *, '(a)' ) 'R8R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
23538 write ( *, '(a)' ) ' Not enough space to store new data.'
23539 return
23540 end if
23541
23542 n = 1
23543 x(1) = xval
23544 y(1) = yval
23545 z(1) = zval
23546 indx(1) = 1
23547 ival = 1
23548 return
23549
23550 end if
23551!
23552! Does ( XVAL, YVAL, ZVAL ) already occur in ( X, Y, Z)?
23553!
23554 call r8r8r8vec_index_search ( n, x, y, z, indx, xval, yval, zval, &
23555 less, equal, more )
23556
23557 if ( equal == 0 ) then
23558
23559 if ( n_max <= n ) then
23560 ierror = 1
23561 write ( *, '(a)' ) ' '
23562 write ( *, '(a)' ) 'R8R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
23563 write ( *, '(a)' ) ' Not enough space to store new data.'
23564 return
23565 end if
23566
23567 x(n+1) = xval
23568 y(n+1) = yval
23569 z(n+1) = zval
23570 ival = n + 1
23571 indx(n+1:more+1:-1) = indx(n:more:-1)
23572 indx(more) = n + 1
23573 n = n + 1
23574
23575 else
23576
23577 ival = indx(equal)
23578
23579 end if
23580
23581 return
r8r8r8vec_index_search
subroutine r8r8r8vec_index_search(n, x, y, z, indx, xval, yval, zval, less, equal, more)
Definition R8LIB.f90:23585

References r8r8r8vec_index_search().

Here is the call graph for this function:

◆ r8r8r8vec_index_search()

subroutine r8r8r8vec_index_search ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 ), dimension(n)  z,
integer ( kind = 4 ), dimension(n)  indx,
real ( kind = 8 )  xval,
real ( kind = 8 )  yval,
real ( kind = 8 )  zval,
integer ( kind = 4 )  less,
integer ( kind = 4 )  equal,
integer ( kind = 4 )  more 
)

Definition at line 23583 of file R8LIB.f90.

23585
23586!*****************************************************************************80
23587!
23588!! R8R8R8VEC_INDEX_SEARCH searches for R8R8R8 value in an indexed sorted list.
23589!
23590! Discussion:
23591!
23592! An R8R8R8VEC is set of N R8R8R8 items.
23593!
23594! An R8R8R8 is simply 3 R8 values, stored as scalars.
23595!
23596! Licensing:
23597!
23598! This code is distributed under the GNU LGPL license.
23599!
23600! Modified:
23601!
23602! 14 May 2005
23603!
23604! Author:
23605!
23606! John Burkardt
23607!
23608! Parameters:
23609!
23610! Input, integer ( kind = 4 ) N, the size of the list.
23611!
23612! Input, real ( kind = 8 ) X(N), Y(N), Z(N), the list.
23613!
23614! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
23615!
23616! Input, real ( kind = 8 ) XVAL, YVAL, ZVAL, the value to be sought.
23617!
23618! Output, integer ( kind = 4 ) LESS, EQUAL, MORE, the indexes in INDX of the
23619! entries of X that are just less than, equal to, and just greater
23620! than XVAL. If XVAL does not occur in X, then EQUAL is zero.
23621! If XVAL is the minimum entry of X, then LESS is 0. If XVAL
23622! is the greatest entry of X, then MORE is N+1.
23623!
23624 implicit none
23625
23626 integer ( kind = 4 ) n
23627
23628 integer ( kind = 4 ) compare
23629 integer ( kind = 4 ) r8r8r8_compare
23630 integer ( kind = 4 ) equal
23631 integer ( kind = 4 ) hi
23632 integer ( kind = 4 ) indx(n)
23633 integer ( kind = 4 ) less
23634 integer ( kind = 4 ) lo
23635 integer ( kind = 4 ) mid
23636 integer ( kind = 4 ) more
23637 real ( kind = 8 ) x(n)
23638 real ( kind = 8 ) xhi
23639 real ( kind = 8 ) xlo
23640 real ( kind = 8 ) xmid
23641 real ( kind = 8 ) xval
23642 real ( kind = 8 ) y(n)
23643 real ( kind = 8 ) yhi
23644 real ( kind = 8 ) ylo
23645 real ( kind = 8 ) ymid
23646 real ( kind = 8 ) yval
23647 real ( kind = 8 ) z(n)
23648 real ( kind = 8 ) zhi
23649 real ( kind = 8 ) zlo
23650 real ( kind = 8 ) zmid
23651 real ( kind = 8 ) zval
23652
23653 if ( n <= 0 ) then
23654 less = 0
23655 equal = 0
23656 more = 0
23657 return
23658 end if
23659
23660 lo = 1
23661 hi = n
23662
23663 xlo = x(indx(lo))
23664 ylo = y(indx(lo))
23665 zlo = z(indx(lo))
23666
23667 xhi = x(indx(hi))
23668 yhi = y(indx(hi))
23669 zhi = z(indx(hi))
23670
23671 compare = r8r8r8_compare( xval, yval, zval, xlo, ylo, zlo )
23672
23673 if ( compare == -1 ) then
23674 less = 0
23675 equal = 0
23676 more = 1
23677 return
23678 else if ( compare == 0 ) then
23679 less = 0
23680 equal = 1
23681 more = 2
23682 return
23683 end if
23684
23685 compare = r8r8r8_compare( xval, yval, zval, xhi, yhi, zhi )
23686
23687 if ( compare == 1 ) then
23688 less = n
23689 equal = 0
23690 more = n + 1
23691 return
23692 else if ( compare == 0 ) then
23693 less = n - 1
23694 equal = n
23695 more = n + 1
23696 return
23697 end if
23698
23699 do
23700
23701 if ( lo + 1 == hi ) then
23702 less = lo
23703 equal = 0
23704 more = hi
23705 return
23706 end if
23707
23708 mid = ( lo + hi ) / 2
23709 xmid = x(indx(mid))
23710 ymid = y(indx(mid))
23711 zmid = z(indx(mid))
23712
23713 compare = r8r8r8_compare( xval, yval, zval, xmid, ymid, zmid )
23714
23715 if ( compare == 0 ) then
23716 equal = mid
23717 less = mid - 1
23718 more = mid + 1
23719 return
23720 else if ( compare == -1 ) then
23721 hi = mid
23722 else if ( compare == +1 ) then
23723 lo = mid
23724 end if
23725
23726 end do
23727
23728 return

Referenced by r8r8r8vec_index_insert_unique().

Here is the caller graph for this function:

◆ r8r8vec_index_insert_unique()

subroutine r8r8vec_index_insert_unique ( integer ( kind = 4 )  n_max,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n_max)  x,
real ( kind = 8 ), dimension(n_max)  y,
integer ( kind = 4 ), dimension(n_max)  indx,
real ( kind = 8 )  xval,
real ( kind = 8 )  yval,
integer ( kind = 4 )  ival,
integer ( kind = 4 )  ierror 
)

Definition at line 23730 of file R8LIB.f90.

23732
23733!*****************************************************************************80
23734!
23735!! R8R8VEC_INDEX_INSERT_UNIQUE inserts a unique R8R8 in an indexed sorted list.
23736!
23737! Discussion:
23738!
23739! An R8R8VEC is set of N R8R8 items.
23740!
23741! An R8R8 is simply 2 R8 values, stored as scalars.
23742!
23743! If the input value does not occur in the current list, it is added,
23744! and N, X, Y and INDX are updated.
23745!
23746! Licensing:
23747!
23748! This code is distributed under the GNU LGPL license.
23749!
23750! Modified:
23751!
23752! 06 December 2004
23753!
23754! Author:
23755!
23756! John Burkardt
23757!
23758! Parameters:
23759!
23760! Input, integer ( kind = 4 ) N_MAX, the maximum size of the list.
23761!
23762! Input/output, integer ( kind = 4 ) N, the size of the list.
23763!
23764! Input/output, real ( kind = 8 ) X(N), Y(N), the list of R8R8 vectors.
23765!
23766! Input/output, integer ( kind = 4 ) INDX(N), the sort index of the list.
23767!
23768! Input, real ( kind = 8 ) XVAL, YVAL, the value to be inserted if it is
23769! not already in the list.
23770!
23771! Output, integer ( kind = 4 ) IVAL, the index in X, Y corresponding to the
23772! value XVAL, YVAL.
23773!
23774! Output, integer ( kind = 4 ) IERROR, 0 for no error, 1 if an
23775! error occurred.
23776!
23777 implicit none
23778
23779 integer ( kind = 4 ) n_max
23780
23781 integer ( kind = 4 ) equal
23782 integer ( kind = 4 ) ierror
23783 integer ( kind = 4 ) indx(n_max)
23784 integer ( kind = 4 ) ival
23785 integer ( kind = 4 ) less
23786 integer ( kind = 4 ) more
23787 integer ( kind = 4 ) n
23788 real ( kind = 8 ) x(n_max)
23789 real ( kind = 8 ) xval
23790 real ( kind = 8 ) y(n_max)
23791 real ( kind = 8 ) yval
23792
23793 ierror = 0
23794
23795 if ( n <= 0 ) then
23796
23797 if ( n_max <= 0 ) then
23798 ierror = 1
23799 write ( *, '(a)' ) ' '
23800 write ( *, '(a)' ) 'R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
23801 write ( *, '(a)' ) ' Not enough space to store new data.'
23802 return
23803 end if
23804
23805 n = 1
23806 x(1) = xval
23807 y(1) = yval
23808 indx(1) = 1
23809 ival = 1
23810 return
23811
23812 end if
23813!
23814! Does ( XVAL, YVAL ) already occur in ( X, Y )?
23815!
23816 call r8r8vec_index_search ( n, x, y, indx, xval, yval, less, equal, more )
23817
23818 if ( equal == 0 ) then
23819
23820 if ( n_max <= n ) then
23821 ierror = 1
23822 write ( *, '(a)' ) ' '
23823 write ( *, '(a)' ) 'R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
23824 write ( *, '(a)' ) ' Not enough space to store new data.'
23825 return
23826 end if
23827
23828 x(n+1) = xval
23829 y(n+1) = yval
23830 ival = n + 1
23831 indx(n+1:more+1:-1) = indx(n:more:-1)
23832 indx(more) = n + 1
23833 n = n + 1
23834
23835 else
23836
23837 ival = indx(equal)
23838
23839 end if
23840
23841 return
r8r8vec_index_search
subroutine r8r8vec_index_search(n, x, y, indx, xval, yval, less, equal, more)
Definition R8LIB.f90:23845

References r8r8vec_index_search().

Here is the call graph for this function:

◆ r8r8vec_index_search()

subroutine r8r8vec_index_search ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
integer ( kind = 4 ), dimension(n)  indx,
real ( kind = 8 )  xval,
real ( kind = 8 )  yval,
integer ( kind = 4 )  less,
integer ( kind = 4 )  equal,
integer ( kind = 4 )  more 
)

Definition at line 23843 of file R8LIB.f90.

23845
23846!*****************************************************************************80
23847!
23848!! R8R8VEC_INDEX_SEARCH searches for an R8R8 in an indexed sorted list.
23849!
23850! Discussion:
23851!
23852! An R8R8VEC is set of N R8R8 items.
23853!
23854! An R8R8 is simply 2 R8 values, stored as scalars.
23855!
23856! Licensing:
23857!
23858! This code is distributed under the GNU LGPL license.
23859!
23860! Modified:
23861!
23862! 14 May 2005
23863!
23864! Author:
23865!
23866! John Burkardt
23867!
23868! Parameters:
23869!
23870! Input, integer ( kind = 4 ) N, the size of the current list.
23871!
23872! Input, real ( kind = 8 ) X(N), Y(N), the list.
23873!
23874! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
23875!
23876! Input, real ( kind = 8 ) XVAL, YVAL, the value to be sought.
23877!
23878! Output, integer ( kind = 4 ) LESS, EQUAL, MORE, the indexes in INDX of the
23879! entries of X that are just less than, equal to, and just greater
23880! than XVAL. If XVAL does not occur in X, then EQUAL is zero.
23881! If XVAL is the minimum entry of X, then LESS is 0. If XVAL
23882! is the greatest entry of X, then MORE is N+1.
23883!
23884 implicit none
23885
23886 integer ( kind = 4 ) n
23887
23888 integer ( kind = 4 ) compare
23889 integer ( kind = 4 ) r8r8_compare
23890 integer ( kind = 4 ) equal
23891 integer ( kind = 4 ) hi
23892 integer ( kind = 4 ) indx(n)
23893 integer ( kind = 4 ) less
23894 integer ( kind = 4 ) lo
23895 integer ( kind = 4 ) mid
23896 integer ( kind = 4 ) more
23897 real ( kind = 8 ) x(n)
23898 real ( kind = 8 ) xhi
23899 real ( kind = 8 ) xlo
23900 real ( kind = 8 ) xmid
23901 real ( kind = 8 ) xval
23902 real ( kind = 8 ) y(n)
23903 real ( kind = 8 ) yhi
23904 real ( kind = 8 ) ylo
23905 real ( kind = 8 ) ymid
23906 real ( kind = 8 ) yval
23907
23908 if ( n <= 0 ) then
23909 less = 0
23910 equal = 0
23911 more = 0
23912 return
23913 end if
23914
23915 lo = 1
23916 hi = n
23917
23918 xlo = x(indx(lo))
23919 ylo = y(indx(lo))
23920
23921 xhi = x(indx(hi))
23922 yhi = y(indx(hi))
23923
23924 compare = r8r8_compare( xval, yval, xlo, ylo )
23925
23926 if ( compare == -1 ) then
23927 less = 0
23928 equal = 0
23929 more = 1
23930 return
23931 else if ( compare == 0 ) then
23932 less = 0
23933 equal = 1
23934 more = 2
23935 return
23936 end if
23937
23938 compare = r8r8_compare( xval, yval, xhi, yhi )
23939
23940 if ( compare == 1 ) then
23941 less = n
23942 equal = 0
23943 more = n + 1
23944 return
23945 else if ( compare == 0 ) then
23946 less = n - 1
23947 equal = n
23948 more = n + 1
23949 return
23950 end if
23951
23952 do
23953
23954 if ( lo + 1 == hi ) then
23955 less = lo
23956 equal = 0
23957 more = hi
23958 return
23959 end if
23960
23961 mid = ( lo + hi ) / 2
23962 xmid = x(indx(mid))
23963 ymid = y(indx(mid))
23964
23965 compare = r8r8_compare( xval, yval, xmid, ymid )
23966
23967 if ( compare == 0 ) then
23968 equal = mid
23969 less = mid - 1
23970 more = mid + 1
23971 return
23972 else if ( compare == -1 ) then
23973 hi = mid
23974 else if ( compare == +1 ) then
23975 lo = mid
23976 end if
23977
23978 end do
23979
23980 return

Referenced by r8r8vec_index_insert_unique().

Here is the caller graph for this function:

◆ r8row_compare()

subroutine r8row_compare ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j,
integer ( kind = 4 )  value 
)

Definition at line 23982 of file R8LIB.f90.

23983
23984!*****************************************************************************80
23985!
23986!! R8ROW_COMPARE compares rows in an R8ROW.
23987!
23988! Discussion:
23989!
23990! An R8ROW is an M by N array of R8's, regarded as an array of M rows,
23991! each of length N.
23992!
23993! Example:
23994!
23995! Input:
23996!
23997! M = 4, N = 3, I = 2, J = 4
23998!
23999! A = (
24000! 1 5 9
24001! 2 6 10
24002! 3 7 11
24003! 4 8 12 )
24004!
24005! Output:
24006!
24007! VALUE = -1
24008!
24009! Licensing:
24010!
24011! This code is distributed under the GNU LGPL license.
24012!
24013! Modified:
24014!
24015! 21 May 2012
24016!
24017! Author:
24018!
24019! John Burkardt
24020!
24021! Parameters:
24022!
24023! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24024!
24025! Input, real ( kind = 8 ) A(M,N), the M by N array.
24026!
24027! Input, integer ( kind = 4 ) I, J, the rows to be compared.
24028! I and J must be between 1 and M.
24029!
24030! Output, integer ( kind = 4 ) VALUE, the results of the comparison:
24031! -1, row I < row J,
24032! 0, row I = row J,
24033! +1, row J < row I.
24034!
24035 implicit none
24036
24037 integer ( kind = 4 ) m
24038 integer ( kind = 4 ) n
24039
24040 real ( kind = 8 ) a(m,n)
24041 integer ( kind = 4 ) i
24042 integer ( kind = 4 ) j
24043 integer ( kind = 4 ) k
24044 integer ( kind = 4 ) value
24045!
24046! Check.
24047!
24048 if ( i < 1 .or. m < i ) then
24049 write ( *, '(a)' ) ' '
24050 write ( *, '(a)' ) 'R8ROW_COMPARE - Fatal error!'
24051 write ( *, '(a)' ) ' Row index I is out of bounds.'
24052 write ( *, '(a,i8)' ) ' I = ', i
24053 stop 1
24054 end if
24055
24056 if ( j < 1 .or. m < j ) then
24057 write ( *, '(a)' ) ' '
24058 write ( *, '(a)' ) 'R8ROW_COMPARE - Fatal error!'
24059 write ( *, '(a)' ) ' Row index J is out of bounds.'
24060 write ( *, '(a,i8)' ) ' J = ', j
24061 stop 1
24062 end if
24063
24064 value = 0
24065
24066 if ( i == j ) then
24067 return
24068 end if
24069
24070 k = 1
24071
24072 do while ( k <= n )
24073
24074 if ( a(i,k) < a(j,k) ) then
24075 value = -1
24076 return
24077 else if ( a(j,k) < a(i,k) ) then
24078 value = +1
24079 return
24080 end if
24081
24082 k = k + 1
24083
24084 end do
24085
24086 return

Referenced by r8row_sort_heap_a(), and r8row_sort_heap_index_a().

Here is the caller graph for this function:

◆ r8row_max()

subroutine r8row_max ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  amax 
)

Definition at line 24088 of file R8LIB.f90.

24089
24090!*****************************************************************************80
24091!
24092!! R8ROW_MAX returns the maximums of an R8ROW.
24093!
24094! Discussion:
24095!
24096! An R8ROW is an M by N array of R8 values, regarded
24097! as an array of M rows of length N.
24098!
24099! Example:
24100!
24101! A =
24102! 1 2 3
24103! 2 6 7
24104!
24105! MAX =
24106! 3
24107! 7
24108!
24109! Licensing:
24110!
24111! This code is distributed under the GNU LGPL license.
24112!
24113! Modified:
24114!
24115! 10 October 2004
24116!
24117! Author:
24118!
24119! John Burkardt
24120!
24121! Parameters:
24122!
24123! Input, integer ( kind = 4 ) M, N, the number of rows and columns
24124! in the array.
24125!
24126! Input, real ( kind = 8 ) A(M,N), the array to be examined.
24127!
24128! Output, real ( kind = 8 ) AMAX(M), the maximums of the rows.
24129!
24130 implicit none
24131
24132 integer ( kind = 4 ) m
24133 integer ( kind = 4 ) n
24134
24135 real ( kind = 8 ) a(m,n)
24136 real ( kind = 8 ) amax(m)
24137 integer ( kind = 4 ) i
24138 integer ( kind = 4 ) j
24139
24140 do i = 1, m
24141
24142 amax(i) = a(i,1)
24143 do j = 2, n
24144 if ( amax(i) < a(i,j) ) then
24145 amax(i) = a(i,j)
24146 end if
24147 end do
24148
24149 end do
24150
24151 return

◆ r8row_mean()

subroutine r8row_mean ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  mean 
)

Definition at line 24153 of file R8LIB.f90.

24154
24155!*****************************************************************************80
24156!
24157!! R8ROW_MEAN returns the means of an R8ROW.
24158!
24159! Discussion:
24160!
24161! An R8ROW is an M by N array of R8 values, regarded
24162! as an array of M rows of length N.
24163!
24164! Example:
24165!
24166! A =
24167! 1 2 3
24168! 2 6 7
24169!
24170! MEAN =
24171! 2
24172! 5
24173!
24174! Licensing:
24175!
24176! This code is distributed under the GNU LGPL license.
24177!
24178! Modified:
24179!
24180! 10 October 2004
24181!
24182! Author:
24183!
24184! John Burkardt
24185!
24186! Parameters:
24187!
24188! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24189!
24190! Input, real ( kind = 8 ) A(M,N), the array to be examined.
24191!
24192! Output, real ( kind = 8 ) MEAN(M), the means, or averages, of the rows.
24193!
24194 implicit none
24195
24196 integer ( kind = 4 ) m
24197 integer ( kind = 4 ) n
24198
24199 real ( kind = 8 ) a(m,n)
24200 integer ( kind = 4 ) i
24201 real ( kind = 8 ) mean(m)
24202
24203 do i = 1, m
24204 mean(i) = sum( a(i,1:n) ) / real( n, kind = 8 )
24205 end do
24206
24207 return

◆ r8row_min()

subroutine r8row_min ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  amin 
)

Definition at line 24209 of file R8LIB.f90.

24210
24211!*****************************************************************************80
24212!
24213!! R8ROW_MIN returns the minimums of an R8ROW.
24214!
24215! Discussion:
24216!
24217! An R8ROW is an M by N array of R8 values, regarded
24218! as an array of M rows of length N.
24219!
24220! Example:
24221!
24222! A =
24223! 1 2 3
24224! 2 6 7
24225!
24226! MIN =
24227! 1
24228! 2
24229!
24230! Licensing:
24231!
24232! This code is distributed under the GNU LGPL license.
24233!
24234! Modified:
24235!
24236! 10 October 2004
24237!
24238! Author:
24239!
24240! John Burkardt
24241!
24242! Parameters:
24243!
24244! Input, integer ( kind = 4 ) M, N, the number of rows and columns
24245! in the array.
24246!
24247! Input, real ( kind = 8 ) A(M,N), the array to be examined.
24248!
24249! Output, real ( kind = 8 ) AMIN(M), the minimums of the rows.
24250!
24251 implicit none
24252
24253 integer ( kind = 4 ) m
24254 integer ( kind = 4 ) n
24255
24256 real ( kind = 8 ) a(m,n)
24257 real ( kind = 8 ) amin(m)
24258 integer ( kind = 4 ) i
24259 integer ( kind = 4 ) j
24260
24261 do i = 1, m
24262
24263 amin(i) = a(i,1)
24264 do j = 2, n
24265 if ( a(i,j) < amin(i) ) then
24266 amin(i) = a(i,j)
24267 end if
24268 end do
24269
24270 end do
24271
24272 return

◆ r8row_part_quick_a()

subroutine r8row_part_quick_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  l,
integer ( kind = 4 )  r 
)

Definition at line 24274 of file R8LIB.f90.

24275
24276!*****************************************************************************80
24277!
24278!! R8ROW_PART_QUICK_A reorders the rows of an R8ROW.
24279!
24280! Discussion:
24281!
24282! An R8ROW is an M by N array of R8's, regarded as an array of M rows,
24283! each of length N.
24284!
24285! The routine reorders the rows of A. Using A(1,1:N) as a
24286! key, all entries of A that are less than or equal to the key will
24287! precede the key, which precedes all entries that are greater than the key.
24288!
24289! Example:
24290!
24291! Input:
24292!
24293! M = 8, N = 2
24294! A = ( 2 4
24295! 8 8
24296! 6 2
24297! 0 2
24298! 10 6
24299! 10 0
24300! 0 6
24301! 5 8 )
24302!
24303! Output:
24304!
24305! L = 2, R = 4
24306!
24307! A = ( 0 2 LEFT
24308! 0 6
24309! ----
24310! 2 4 KEY
24311! ----
24312! 8 8 RIGHT
24313! 6 2
24314! 10 6
24315! 10 0
24316! 5 8 )
24317!
24318! Licensing:
24319!
24320! This code is distributed under the GNU LGPL license.
24321!
24322! Modified:
24323!
24324! 21 May 2012
24325!
24326! Author:
24327!
24328! John Burkardt
24329!
24330! Parameters:
24331!
24332! Input, integer ( kind = 4 ) M, the row dimension of A.
24333!
24334! Input, integer ( kind = 4 ) N, the column dimension of A, and the
24335! length of a row.
24336!
24337! Input/output, real ( kind = 8 ) A(M,N). On input, the array to be checked.
24338! On output, A has been reordered as described above.
24339!
24340! Output, integer ( kind = 4 ) L, R, the indices of A that define the three
24341! segments. Let KEY = the input value of A(1,1:N). Then
24342! I <= L A(I,1:N) < KEY;
24343! L < I < R A(I,1:N) = KEY;
24344! R <= I KEY < A(I,1:N).
24345!
24346 implicit none
24347
24348 integer ( kind = 4 ) m
24349 integer ( kind = 4 ) n
24350
24351 real ( kind = 8 ) a(m,n)
24352 integer ( kind = 4 ) j
24353 integer ( kind = 4 ) k
24354 real ( kind = 8 ) key(n)
24355 integer ( kind = 4 ) l
24356 integer ( kind = 4 ) r
24357 logical ( kind = 4 ) r8vec_eq
24358 logical ( kind = 4 ) r8vec_gt
24359 logical ( kind = 4 ) r8vec_lt
24360
24361 if ( m < 1 ) then
24362 write ( *, '(a)' ) ' '
24363 write ( *, '(a)' ) 'R8ROW_PART_QUICK_A - Fatal error!'
24364 write ( *, '(a)' ) ' M < 1.'
24365 return
24366 end if
24367
24368 if ( m == 1 ) then
24369 l = 0
24370 r = 2
24371 return
24372 end if
24373
24374 key(1:n) = a(1,1:n)
24375 k = 1
24376!
24377! The elements of unknown size have indices between L+1 and R-1.
24378!
24379 l = 1
24380 r = m + 1
24381
24382 do j = 2, m
24383
24384 if ( r8vec_gt( n, a(l+1,1:n), key(1:n) ) ) then
24385 r = r - 1
24386 call r8vec_swap ( n, a(r,1:n), a(l+1,1:n) )
24387 else if ( r8vec_eq( n, a(l+1,1:n), key(1:n) ) ) then
24388 k = k + 1
24389 call r8vec_swap ( n, a(k,1:n), a(l+1,1:n) )
24390 l = l + 1
24391 else if ( r8vec_lt( n, a(l+1,1:n), key(1:n) ) ) then
24392 l = l + 1
24393 end if
24394
24395 end do
24396!
24397! Shift small elements to the left.
24398!
24399 do j = 1, l - k
24400 a(j,1:n) = a(j+k,1:n)
24401 end do
24402!
24403! Shift KEY elements to center.
24404!
24405 do j = l - k + 1, l
24406 a(j,1:n) = key(1:n)
24407 end do
24408!
24409! Update L.
24410!
24411 l = l - k
24412
24413 return

References r8vec_swap().

Referenced by r8row_sort_quick_a().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8row_reverse()

subroutine r8row_reverse ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 24415 of file R8LIB.f90.

24416
24417!****************************************************************************80
24418!
24419!! R8ROW_REVERSE reverses the order of the rows of an R8ROW.
24420!
24421! Discussion:
24422!
24423! To reverse the rows is to start with something like
24424!
24425! 11 12 13 14 15
24426! 21 22 23 24 25
24427! 31 32 33 34 35
24428! 41 42 43 44 45
24429! 51 52 53 54 55
24430!
24431! and return
24432!
24433! 51 52 53 54 55
24434! 41 42 43 44 45
24435! 31 32 33 34 35
24436! 21 22 23 24 25
24437! 11 12 13 14 15
24438!
24439! Licensing:
24440!
24441! This code is distributed under the GNU LGPL license.
24442!
24443! Modified:
24444!
24445! 06 May 2013
24446!
24447! Author:
24448!
24449! John Burkardt
24450!
24451! Parameters:
24452!
24453! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24454!
24455! Input/output, real ( kind = 8 ) A(M,N), the matrix.
24456!
24457 implicit none
24458
24459 integer ( kind = 4 ) m
24460 integer ( kind = 4 ) n
24461
24462 real ( kind = 8 ) a(m,n)
24463 integer ( kind = 4 ) i
24464 integer ( kind = 4 ) ihi
24465 integer ( kind = 4 ) j
24466 real ( kind = 8 ) t(n)
24467
24468 ihi = m / 2
24469
24470 do i = 1, ihi
24471 t(1:n) = a(i,1:n)
24472 a(i,1:n) = a(m+1-i,1:n)
24473 a(m+1-i,1:n) = t(1:n)
24474 end do
24475
24476 return

◆ r8row_sort_heap_a()

subroutine r8row_sort_heap_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 24478 of file R8LIB.f90.

24479
24480!*****************************************************************************80
24481!
24482!! R8ROW_SORT_HEAP_A ascending heapsorts an R8ROW.
24483!
24484! Discussion:
24485!
24486! An R8ROW is an M by N array of R8's, regarded as an array of M rows,
24487! each of length N.
24488!
24489! In lexicographic order, the statement "X < Y", applied to two real
24490! vectors X and Y of length M, means that there is some index I, with
24491! 1 <= I <= M, with the property that
24492!
24493! X(J) = Y(J) for J < I,
24494! and
24495! X(I) < Y(I).
24496!
24497! In other words, the first time they differ, X is smaller.
24498!
24499! Licensing:
24500!
24501! This code is distributed under the GNU LGPL license.
24502!
24503! Modified:
24504!
24505! 21 May 2012
24506!
24507! Author:
24508!
24509! John Burkardt
24510!
24511! Parameters:
24512!
24513! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24514!
24515! Input/output, real ( kind = 8 ) A(M,N).
24516! On input, the array of M rows of N-vectors.
24517! On output, the rows of A have been sorted in lexicographic order.
24518!
24519 implicit none
24520
24521 integer ( kind = 4 ) m
24522 integer ( kind = 4 ) n
24523
24524 real ( kind = 8 ) a(m,n)
24525 integer ( kind = 4 ) i
24526 integer ( kind = 4 ) indx
24527 integer ( kind = 4 ) isgn
24528 integer ( kind = 4 ) j
24529
24530 if ( m <= 0 ) then
24531 return
24532 end if
24533
24534 if ( m <= 1 ) then
24535 return
24536 end if
24537!
24538! Initialize.
24539!
24540 i = 0
24541 indx = 0
24542 isgn = 0
24543 j = 0
24544!
24545! Call the external heap sorter.
24546!
24547 do
24548
24549 call sort_heap_external ( m, indx, i, j, isgn )
24550!
24551! Interchange the I and J objects.
24552!
24553 if ( 0 < indx ) then
24554
24555 call r8row_swap ( m, n, a, i, j )
24556!
24557! Compare the I and J objects.
24558!
24559 else if ( indx < 0 ) then
24560
24561 call r8row_compare ( m, n, a, i, j, isgn )
24562
24563 else if ( indx == 0 ) then
24564
24565 exit
24566
24567 end if
24568
24569 end do
24570
24571 return
r8row_compare
subroutine r8row_compare(m, n, a, i, j, value)
Definition R8LIB.f90:23983

References r8row_compare(), r8row_swap(), and sort_heap_external().

Here is the call graph for this function:

◆ r8row_sort_heap_index_a()

subroutine r8row_sort_heap_index_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 ), dimension(m)  indx 
)

Definition at line 24573 of file R8LIB.f90.

24574
24575!*****************************************************************************80
24576!
24577!! R8ROW_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8ROW.
24578!
24579! Discussion:
24580!
24581! An R8ROW is an M by N array of R8's, regarded as an array of M rows,
24582! each of length N.
24583!
24584! The sorting is not actually carried out. Rather an index array is
24585! created which defines the sorting. This array may be used to sort
24586! or index the array, or to sort or index related arrays keyed on the
24587! original array.
24588!
24589! A(I1,*) < A(I1,*) if the first nonzero entry of A(I1,*)-A(I2,*)
24590! is negative.
24591!
24592! Once the index array is computed, the sorting can be carried out
24593! "implicitly:
24594!
24595! A(INDX(1:M),1:N) is sorted.
24596!
24597! Licensing:
24598!
24599! This code is distributed under the GNU LGPL license.
24600!
24601! Modified:
24602!
24603! 21 May 2012
24604!
24605! Author:
24606!
24607! John Burkardt
24608!
24609! Parameters:
24610!
24611! Input, integer ( kind = 4 ) M, the number of rows in each column of A.
24612!
24613! Input, integer ( kind = 4 ) N, the number of columns in A.
24614!
24615! Input, real ( kind = 8 ) A(M,N), the array.
24616!
24617! Output, integer ( kind = 4 ) INDX(M), the sort index. The I-th element
24618! of the sorted array is row INDX(I).
24619!
24620 implicit none
24621
24622 integer ( kind = 4 ) m
24623 integer ( kind = 4 ) n
24624
24625 real ( kind = 8 ) a(m,n)
24626 integer ( kind = 4 ) i
24627 integer ( kind = 4 ) indx(m)
24628 integer ( kind = 4 ) indxt
24629 integer ( kind = 4 ) ir
24630 integer ( kind = 4 ) isgn
24631 integer ( kind = 4 ) j
24632 integer ( kind = 4 ) l
24633 real ( kind = 8 ) row(n)
24634
24635 if ( n < 1 ) then
24636 return
24637 end if
24638
24639 do i = 1, m
24640 indx(i) = i
24641 end do
24642
24643 if ( m == 1 ) then
24644 return
24645 end if
24646
24647 l = ( m / 2 ) + 1
24648 ir = m
24649
24650 do
24651
24652 if ( 1 < l ) then
24653
24654 l = l - 1
24655 indxt = indx(l)
24656 row(1:n) = a(indxt,1:n)
24657
24658 else
24659
24660 indxt = indx(ir)
24661 row(1:n) = a(indxt,1:n)
24662 indx(ir) = indx(1)
24663 ir = ir - 1
24664
24665 if ( ir == 1 ) then
24666 indx(1) = indxt
24667 exit
24668 end if
24669
24670 end if
24671
24672 i = l
24673 j = l + l
24674
24675 do while ( j <= ir )
24676
24677 if ( j < ir ) then
24678
24679 call r8row_compare ( m, n, a, indx(j), indx(j+1), isgn )
24680
24681 if ( isgn < 0 ) then
24682 j = j + 1
24683 end if
24684
24685 end if
24686
24687 call r8vec_compare ( n, row, a(indx(j),1:n), isgn )
24688
24689 if ( isgn < 0 ) then
24690 indx(i) = indx(j)
24691 i = j
24692 j = j + j
24693 else
24694 j = ir + 1
24695 end if
24696
24697 end do
24698
24699 indx(i) = indxt
24700
24701 end do
24702
24703 return

References r8row_compare(), and r8vec_compare().

Here is the call graph for this function:

◆ r8row_sort_quick_a()

subroutine r8row_sort_quick_a ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a 
)

Definition at line 24705 of file R8LIB.f90.

24706
24707!*****************************************************************************80
24708!
24709!! R8ROW_SORT_QUICK_A ascending quick sorts an R8ROW.
24710!
24711! Discussion:
24712!
24713! An R8ROW is an M by N array of R8's, regarded as an array of M rows,
24714! each of length N.
24715!
24716! Licensing:
24717!
24718! This code is distributed under the GNU LGPL license.
24719!
24720! Modified:
24721!
24722! 21 May 2012
24723!
24724! Author:
24725!
24726! John Burkardt
24727!
24728! Parameters:
24729!
24730! Input, integer ( kind = 4 ) M, the number of rows of A.
24731!
24732! Input, integer ( kind = 4 ) N, the number of columns of A,
24733! and the length of a row.
24734!
24735! Input/output, real ( kind = 8 ) A(M,N).
24736! On input, the array to be sorted.
24737! On output, the array has been sorted.
24738!
24739 implicit none
24740
24741 integer ( kind = 4 ), parameter :: level_max = 30
24742 integer ( kind = 4 ) m
24743 integer ( kind = 4 ) n
24744
24745 real ( kind = 8 ) a(m,n)
24746 integer ( kind = 4 ) base
24747 integer ( kind = 4 ) l_segment
24748 integer ( kind = 4 ) level
24749 integer ( kind = 4 ) m_segment
24750 integer ( kind = 4 ) rsave(level_max)
24751 integer ( kind = 4 ) r_segment
24752
24753 if ( n <= 0 ) then
24754 return
24755 end if
24756
24757 if ( m < 1 ) then
24758 write ( *, '(a)' ) ' '
24759 write ( *, '(a)' ) 'R8ROW_SORT_QUICK_A - Fatal error!'
24760 write ( *, '(a)' ) ' M < 1.'
24761 write ( *, '(a,i8)' ) ' M = ', m
24762 stop 1
24763 end if
24764
24765 if ( m == 1 ) then
24766 return
24767 end if
24768
24769 level = 1
24770 rsave(level) = m + 1
24771 base = 1
24772 m_segment = m
24773
24774 do
24775!
24776! Partition the segment.
24777!
24778 call r8row_part_quick_a ( m_segment, n, a(base:base+m_segment-1,1:n), &
24779 l_segment, r_segment )
24780!
24781! If the left segment has more than one element, we need to partition it.
24782!
24783 if ( 1 < l_segment ) then
24784
24785 if ( level_max < level ) then
24786 write ( *, '(a)' ) ' '
24787 write ( *, '(a)' ) 'R8ROW_SORT_QUICK_A - Fatal error!'
24788 write ( *, '(a,i8)' ) ' Exceeding recursion maximum of ', level_max
24789 stop 1
24790 end if
24791
24792 level = level + 1
24793 m_segment = l_segment
24794 rsave(level) = r_segment + base - 1
24795!
24796! The left segment and the middle segment are sorted.
24797! Must the right segment be partitioned?
24798!
24799 else if ( r_segment < m_segment ) then
24800
24801 m_segment = m_segment + 1 - r_segment
24802 base = base + r_segment - 1
24803!
24804! Otherwise, we back up a level if there is an earlier one.
24805!
24806 else
24807
24808 do
24809
24810 if ( level <= 1 ) then
24811 return
24812 end if
24813
24814 base = rsave(level)
24815 m_segment = rsave(level-1) - rsave(level)
24816 level = level - 1
24817
24818 if ( 0 < m_segment ) then
24819 exit
24820 end if
24821
24822 end do
24823
24824 end if
24825
24826 end do
24827
24828 return
r8row_part_quick_a
subroutine r8row_part_quick_a(m, n, a, l, r)
Definition R8LIB.f90:24275

References r8row_part_quick_a().

Here is the call graph for this function:

◆ r8row_sorted_unique_count()

subroutine r8row_sorted_unique_count ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  unique_num 
)

Definition at line 24830 of file R8LIB.f90.

24831
24832!*****************************************************************************80
24833!
24834!! R8ROW_SORTED_UNIQUE_COUNT counts unique elements in an R8ROW.
24835!
24836! Discussion:
24837!
24838! An R8ROW is an M by N array of R8 values, regarded
24839! as an array of M rows of length N.
24840!
24841! The rows of the array may be ascending or descending sorted.
24842!
24843! Licensing:
24844!
24845! This code is distributed under the GNU LGPL license.
24846!
24847! Modified:
24848!
24849! 17 February 2005
24850!
24851! Author:
24852!
24853! John Burkardt
24854!
24855! Parameters:
24856!
24857! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24858!
24859! Input, real ( kind = 8 ) A(M,N), a sorted array, containing
24860! M rows of data.
24861!
24862! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique rows.
24863!
24864 implicit none
24865
24866 integer ( kind = 4 ) m
24867 integer ( kind = 4 ) n
24868
24869 real ( kind = 8 ) a(m,n)
24870 integer ( kind = 4 ) i1
24871 integer ( kind = 4 ) i2
24872 integer ( kind = 4 ) unique_num
24873
24874 if ( n <= 0 ) then
24875 unique_num = 0
24876 return
24877 end if
24878
24879 unique_num = 1
24880 i1 = 1
24881
24882 do i2 = 2, m
24883
24884 if ( any( a(i1,1:n) /= a(i2,1:n) ) ) then
24885 unique_num = unique_num + 1
24886 i1 = i2
24887 end if
24888
24889 end do
24890
24891 return

◆ r8row_sum()

subroutine r8row_sum ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  rowsum 
)

Definition at line 24893 of file R8LIB.f90.

24894
24895!*****************************************************************************80
24896!
24897!! R8ROW_SUM returns the sums of the rows of an R8ROW.
24898!
24899! Discussion:
24900!
24901! An R8ROW is an M by N array of R8 values, regarded
24902! as an array of M rows of length N.
24903!
24904! Licensing:
24905!
24906! This code is distributed under the GNU LGPL license.
24907!
24908! Modified:
24909!
24910! 06 December 2004
24911!
24912! Author:
24913!
24914! John Burkardt
24915!
24916! Parameters:
24917!
24918! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24919!
24920! Input, real ( kind = 8 ) A(M,N), the M by N array.
24921!
24922! Output, real ( kind = 8 ) ROWSUM(M), the sum of the entries of
24923! each row.
24924!
24925 implicit none
24926
24927 integer ( kind = 4 ) m
24928 integer ( kind = 4 ) n
24929
24930 real ( kind = 8 ) a(m,n)
24931 integer ( kind = 4 ) i
24932 real ( kind = 8 ) rowsum(m)
24933
24934 do i = 1, m
24935 rowsum(i) = sum( a(i,1:n) )
24936 end do
24937
24938 return

◆ r8row_swap()

subroutine r8row_swap ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
integer ( kind = 4 )  i1,
integer ( kind = 4 )  i2 
)

Definition at line 24940 of file R8LIB.f90.

24941
24942!*****************************************************************************80
24943!
24944!! R8ROW_SWAP swaps two rows of an R8ROW.
24945!
24946! Discussion:
24947!
24948! An R8ROW is an M by N array of R8 values, regarded
24949! as an array of M rows of length N.
24950!
24951! Licensing:
24952!
24953! This code is distributed under the GNU LGPL license.
24954!
24955! Modified:
24956!
24957! 05 December 2004
24958!
24959! Author:
24960!
24961! John Burkardt
24962!
24963! Parameters:
24964!
24965! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
24966!
24967! Input/output, real ( kind = 8 ) A(M,N), the M by N array.
24968!
24969! Input, integer ( kind = 4 ) I1, I2, the two rows to swap.
24970!
24971 implicit none
24972
24973 integer ( kind = 4 ) m
24974 integer ( kind = 4 ) n
24975
24976 real ( kind = 8 ) a(m,n)
24977 integer ( kind = 4 ) i1
24978 integer ( kind = 4 ) i2
24979 real ( kind = 8 ) row(n)
24980
24981 if ( i1 < 1 .or. m < i1 ) then
24982 write ( *, '(a)' ) ' '
24983 write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!'
24984 write ( *, '(a)' ) ' I1 is out of range.'
24985 write ( *, '(a,i8)' ) ' I1 = ', i1
24986 stop 1
24987 end if
24988
24989 if ( i2 < 1 .or. m < i2 ) then
24990 write ( *, '(a)' ) ' '
24991 write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!'
24992 write ( *, '(a)' ) ' I2 is out of range.'
24993 write ( *, '(a,i8)' ) ' I2 = ', i2
24994 stop 1
24995 end if
24996
24997 if ( i1 == i2 ) then
24998 return
24999 end if
25000
25001 row(1:n) = a(i1,1:n)
25002 a(i1,1:n) = a(i2,1:n)
25003 a(i2,1:n) = row(1:n)
25004
25005 return

Referenced by r8col_sortr_a(), r8mat_lu(), and r8row_sort_heap_a().

Here is the caller graph for this function:

◆ r8row_to_r8vec()

subroutine r8row_to_r8vec ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m*n)  x 
)

Definition at line 25007 of file R8LIB.f90.

25008
25009!*****************************************************************************80
25010!
25011!! R8ROW_TO_R8VEC converts an R8ROW into an R8VEC.
25012!
25013! Discussion:
25014!
25015! An R8ROW is an M by N array of R8 values, regarded
25016! as an array of M rows of length N.
25017!
25018! Example:
25019!
25020! M = 3, N = 4
25021!
25022! A =
25023! 11 12 13 14
25024! 21 22 23 24
25025! 31 32 33 34
25026!
25027! X = ( 11, 12, 13, 14, 21, 22, 23, 24, 31, 32, 33, 34 )
25028!
25029! Licensing:
25030!
25031! This code is distributed under the GNU LGPL license.
25032!
25033! Modified:
25034!
25035! 13 July 2000
25036!
25037! Author:
25038!
25039! John Burkardt
25040!
25041! Parameters:
25042!
25043! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
25044!
25045! Input, real ( kind = 8 ) A(M,N), the M by N array.
25046!
25047! Output, real ( kind = 8 ) X(M*N), a vector containing the M rows of A.
25048!
25049 implicit none
25050
25051 integer ( kind = 4 ) m
25052 integer ( kind = 4 ) n
25053
25054 real ( kind = 8 ) a(m,n)
25055 integer ( kind = 4 ) i
25056 integer ( kind = 4 ) j
25057 real ( kind = 8 ) x(m*n)
25058
25059 j = 1
25060 do i = 1, m
25061 x(j:j+n-1) = a(i,1:n)
25062 j = j + n
25063 end do
25064
25065 return

◆ r8row_variance()

subroutine r8row_variance ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(m,n)  a,
real ( kind = 8 ), dimension(m)  variance 
)

Definition at line 25067 of file R8LIB.f90.

25068
25069!*****************************************************************************80
25070!
25071!! R8ROW_VARIANCE returns the variances of an R8ROW.
25072!
25073! Discussion:
25074!
25075! An R8ROW is an M by N array of R8 values, regarded
25076! as an array of M rows of length N.
25077!
25078! Licensing:
25079!
25080! This code is distributed under the GNU LGPL license.
25081!
25082! Modified:
25083!
25084! 10 October 2004
25085!
25086! Author:
25087!
25088! John Burkardt
25089!
25090! Parameters:
25091!
25092! Input, integer ( kind = 4 ) M, N, the number of rows and columns
25093! in the array.
25094!
25095! Input, real ( kind = 8 ) A(M,N), the array whose variances are desired.
25096!
25097! Output, real ( kind = 8 ) VARIANCE(M), the variances of the rows.
25098!
25099 implicit none
25100
25101 integer ( kind = 4 ) m
25102 integer ( kind = 4 ) n
25103
25104 real ( kind = 8 ) a(m,n)
25105 integer ( kind = 4 ) i
25106 integer ( kind = 4 ) j
25107 real ( kind = 8 ) mean
25108 real ( kind = 8 ) variance(m)
25109
25110 do i = 1, m
25111
25112 mean = sum( a(i,1:n) ) / real( n, kind = 8 )
25113
25114 variance(i) = 0.0d+00
25115 do j = 1, n
25116 variance(i) = variance(i) + ( a(i,j) - mean )**2
25117 end do
25118
25119 if ( 1 < n ) then
25120 variance(i) = variance(i) / real( n - 1, kind = 8 )
25121 else
25122 variance(i) = 0.0d+00
25123 end if
25124
25125 end do
25126
25127 return

◆ r8slmat_print()

subroutine r8slmat_print ( integer ( kind = 4 )  m,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
character ( len = * )  title 
)

Definition at line 25129 of file R8LIB.f90.

25130
25131!*****************************************************************************80
25132!
25133!! R8SLMAT_PRINT prints a strict lower triangular R8MAT.
25134!
25135! Example:
25136!
25137! M = 5, N = 5
25138! A = (/ 21, 31, 41, 51, 32, 42, 52, 43, 53, 54 /)
25139!
25140! 21
25141! 31 32
25142! 41 42 43
25143! 51 52 53 54
25144!
25145! Licensing:
25146!
25147! This code is distributed under the GNU LGPL license.
25148!
25149! Modified:
25150!
25151! 30 June 2003
25152!
25153! Author:
25154!
25155! John Burkardt
25156!
25157! Parameters:
25158!
25159! Input, integer ( kind = 4 ) M, the number of rows in A.
25160!
25161! Input, integer ( kind = 4 ) N, the number of columns in A.
25162!
25163! Input, real ( kind = 8 ) A(*), the M by N matrix. Only the strict
25164! lower triangular elements are stored, in column major order.
25165!
25166! Input, character ( len = * ) TITLE, a title.
25167!
25168 implicit none
25169
25170 integer ( kind = 4 ) m
25171 integer ( kind = 4 ) n
25172
25173 real ( kind = 8 ) a(*)
25174 integer ( kind = 4 ) i
25175 integer ( kind = 4 ) indx(10)
25176 integer ( kind = 4 ) j
25177 integer ( kind = 4 ) jhi
25178 integer ( kind = 4 ) jlo
25179 integer ( kind = 4 ) jmax
25180 integer ( kind = 4 ) nn
25181 integer ( kind = 4 ) size
25182 character ( len = * ) title
25183
25184 write ( *, '(a)' ) ' '
25185 write ( *, '(a)' ) trim( title )
25186
25187 jmax = min( n, m - 1 )
25188
25189 if ( m-1 <= n ) then
25190 size = ( m * ( m - 1 ) ) / 2
25191 else if ( n < m-1 ) then
25192 size = ( n * ( n - 1 ) ) / 2 + ( m - n - 1 ) * n
25193 end if
25194
25195 if ( all( a(1:size) == aint( a(1:size) ) ) ) then
25196
25197 nn = 10
25198
25199 do jlo = 1, jmax, nn
25200 jhi = min( jlo + nn - 1, m - 1, jmax )
25201 write ( *, '(a)' ) ' '
25202 write ( *, '(a8,10i8)' ) ' Col', ( j, j = jlo, jhi )
25203 write ( *, '(a8)' ) ' Row'
25204 do i = jlo + 1, m
25205 jhi = min( jlo + nn - 1, i - 1, jmax )
25206 do j = jlo, jhi
25207 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j + 1 ) ) / 2
25208 end do
25209 write ( *, '(2x,i8,10i8)' ) i, int( a(indx(1:jhi+1-jlo)) )
25210 end do
25211 end do
25212
25213 else if ( maxval( abs( a(1:size) ) ) < 1000000.0d+00 ) then
25214
25215 nn = 5
25216
25217 do jlo = 1, jmax, nn
25218 jhi = min( jlo + nn - 1, m - 1, jmax )
25219 write ( *, '(a)' ) ' '
25220 write ( *, '(a10,5(i8,6x))' ) ' Col', ( j, j = jlo, jhi )
25221 write ( *, '(a10)' ) ' Row'
25222 do i = jlo + 1, m
25223 jhi = min( jlo + nn - 1, i - 1, jmax )
25224 do j = jlo, jhi
25225 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j + 1 ) ) / 2
25226 end do
25227 write ( *, '(2x,i8,5f14.6)' ) i, a(indx(1:jhi+1-jlo))
25228 end do
25229 end do
25230
25231 else
25232
25233 nn = 5
25234
25235 do jlo = 1, jmax, nn
25236 jhi = min( jlo + nn - 1, m - 1, jmax )
25237 write ( *, '(a)' ) ' '
25238 write ( *, '(a10,5(i8,6x))' ) ' Col', ( j, j = jlo, jhi )
25239 write ( *, '(a10)' ) ' Row'
25240 do i = jlo + 1, m
25241 jhi = min( jlo + nn - 1, i - 1, jmax )
25242 do j = jlo, jhi
25243 indx(j+1-jlo) = ( j - 1 ) * m + i - ( j * ( j + 1 ) ) / 2
25244 end do
25245 write ( *, '(2x,i8,5g14.6)' ) i, a(indx(1:jhi+1-jlo))
25246 end do
25247 end do
25248
25249 end if
25250
25251 return

◆ r8vec2_compare()

subroutine r8vec2_compare ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j,
integer ( kind = 4 )  isgn 
)

Definition at line 38838 of file R8LIB.f90.

38839
38840!*****************************************************************************80
38841!
38842!! R8VEC2_COMPARE compares two entries in an R8VEC2.
38843!
38844! Discussion:
38845!
38846! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
38847! as two separate vectors A1 and A2.
38848!
38849! The lexicographic ordering is used.
38850!
38851! Example:
38852!
38853! A1(I) A2(I) A1(J) A2(J) ISGN
38854! ----------- ----------- ----
38855! 1.0 5.0 < 1.0 6.0 -1
38856! 1.0 5.0 < 2.0 8.0 -1
38857! 1.0 5.0 < 9.0 1.0 -1
38858! 1.0 5.0 = 1.0 5.0 0
38859! 1.0 5.0 > 0.0 2.0 +1
38860! 1.0 5.0 > 0.0 5.0 +1
38861! 1.0 5.0 > 1.0 3.0 +1
38862!
38863! Licensing:
38864!
38865! This code is distributed under the GNU LGPL license.
38866!
38867! Modified:
38868!
38869! 13 December 2004
38870!
38871! Author:
38872!
38873! John Burkardt
38874!
38875! Parameters:
38876!
38877! Input, integer ( kind = 4 ) N, the number of data items.
38878!
38879! Input, real ( kind = 8 ) A1(N), A2(N), the two components of each item.
38880!
38881! Input, integer ( kind = 4 ) I, J, the items to be compared.
38882!
38883! Output, integer ( kind = 4 ) ISGN, the results of the comparison:
38884! -1, item I < item J,
38885! 0, item I = item J,
38886! +1, item I > item J.
38887!
38888 implicit none
38889
38890 integer ( kind = 4 ) n
38891
38892 real ( kind = 8 ) a1(n)
38893 real ( kind = 8 ) a2(n)
38894 integer ( kind = 4 ) i
38895 integer ( kind = 4 ) isgn
38896 integer ( kind = 4 ) j
38897
38898 isgn = 0
38899
38900 if ( a1(i) < a1(j) ) then
38901
38902 isgn = -1
38903
38904 else if ( a1(i) == a1(j) ) then
38905
38906 if ( a2(i) < a2(j) ) then
38907 isgn = -1
38908 else if ( a2(i) < a2(j) ) then
38909 isgn = 0
38910 else if ( a2(j) < a2(i) ) then
38911 isgn = +1
38912 end if
38913
38914 else if ( a1(j) < a1(i) ) then
38915
38916 isgn = +1
38917
38918 end if
38919
38920 return

Referenced by r8vec2_sort_a(), and r8vec2_sort_d().

Here is the caller graph for this function:

◆ r8vec2_print()

subroutine r8vec2_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
character ( len = * )  title 
)

Definition at line 38922 of file R8LIB.f90.

38923
38924!*****************************************************************************80
38925!
38926!! R8VEC2_PRINT prints an R8VEC2.
38927!
38928! Discussion:
38929!
38930! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
38931! as two separate vectors A1 and A2.
38932!
38933! Licensing:
38934!
38935! This code is distributed under the GNU LGPL license.
38936!
38937! Modified:
38938!
38939! 13 December 2004
38940!
38941! Author:
38942!
38943! John Burkardt
38944!
38945! Parameters:
38946!
38947! Input, integer ( kind = 4 ) N, the number of components of the vector.
38948!
38949! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be printed.
38950!
38951! Input, character ( len = * ) TITLE, a title.
38952!
38953 implicit none
38954
38955 integer ( kind = 4 ) n
38956
38957 real ( kind = 8 ) a1(n)
38958 real ( kind = 8 ) a2(n)
38959 integer ( kind = 4 ) i
38960 character ( len = * ) title
38961
38962 write ( *, '(a)' ) ' '
38963 write ( *, '(a)' ) trim( title )
38964 write ( *, '(a)' ) ' '
38965
38966 do i = 1, n
38967 write ( *, '(2x,i4,2x,g14.6,2x,g14.6)' ) i, a1(i), a2(i)
38968 end do
38969
38970 return

◆ r8vec2_print_some()

subroutine r8vec2_print_some ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x1,
real ( kind = 8 ), dimension(n)  x2,
integer ( kind = 4 )  max_print,
character ( len = * )  title 
)

Definition at line 38972 of file R8LIB.f90.

38973
38974!*****************************************************************************80
38975!
38976!! R8VEC2_PRINT_SOME prints "some" of an R8VEC2.
38977!
38978! Discussion:
38979!
38980! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
38981! as two separate vectors A1 and A2.
38982!
38983! The user specifies MAX_PRINT, the maximum number of lines to print.
38984!
38985! If N, the size of the vectors, is no more than MAX_PRINT, then
38986! the entire vectors are printed, one entry of each per line.
38987!
38988! Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
38989! followed by a line of periods suggesting an omission,
38990! and the last entry.
38991!
38992! Licensing:
38993!
38994! This code is distributed under the GNU LGPL license.
38995!
38996! Modified:
38997!
38998! 10 September 2009
38999!
39000! Author:
39001!
39002! John Burkardt
39003!
39004! Parameters:
39005!
39006! Input, integer ( kind = 4 ) N, the number of entries of the vectors.
39007!
39008! Input, real ( kind = 8 ) X1(N), X2(N), the vector to be printed.
39009!
39010! Input, integer ( kind = 4 ) MAX_PRINT, the maximum number of lines
39011! to print.
39012!
39013! Input, character ( len = * ) TITLE, a title.
39014!
39015 implicit none
39016
39017 integer ( kind = 4 ) n
39018
39019 integer ( kind = 4 ) i
39020 integer ( kind = 4 ) max_print
39021 character ( len = * ) title
39022 real ( kind = 8 ) x1(n)
39023 real ( kind = 8 ) x2(n)
39024
39025 if ( max_print <= 0 ) then
39026 return
39027 end if
39028
39029 if ( n <= 0 ) then
39030 return
39031 end if
39032
39033 write ( *, '(a)' ) ' '
39034 write ( *, '(a)' ) trim( title )
39035 write ( *, '(a)' ) ' '
39036
39037 if ( n <= max_print ) then
39038
39039 do i = 1, n
39040 write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
39041 end do
39042
39043 else if ( 3 <= max_print ) then
39044
39045 do i = 1, max_print - 2
39046 write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
39047 end do
39048 write ( *, '(a)' ) ' ...... .............. ..............'
39049 i = n
39050 write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
39051
39052 else
39053
39054 do i = 1, max_print - 1
39055 write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
39056 end do
39057 i = max_print
39058 write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,a)' ) i, x1(i), x2(i), &
39059 '...more entries...'
39060
39061 end if
39062
39063 return

◆ r8vec2_sort_a()

subroutine r8vec2_sort_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 39065 of file R8LIB.f90.

39066
39067!*****************************************************************************80
39068!
39069!! R8VEC2_SORT_A ascending sorts an R8VEC2.
39070!
39071! Discussion:
39072!
39073! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39074! as two separate vectors A1 and A2.
39075!
39076! Each item to be sorted is a pair (I,J), with the I
39077! and J values stored in separate vectors A1 and A2.
39078!
39079! Licensing:
39080!
39081! This code is distributed under the GNU LGPL license.
39082!
39083! Modified:
39084!
39085! 13 December 2004
39086!
39087! Author:
39088!
39089! John Burkardt
39090!
39091! Parameters:
39092!
39093! Input, integer ( kind = 4 ) N, the number of items of data.
39094!
39095! Input/output, real ( kind = 8 ) A1(N), A2(N), the data to be sorted.
39096!
39097 implicit none
39098
39099 integer ( kind = 4 ) n
39100
39101 real ( kind = 8 ) a1(n)
39102 real ( kind = 8 ) a2(n)
39103 integer ( kind = 4 ) i
39104 integer ( kind = 4 ) indx
39105 integer ( kind = 4 ) isgn
39106 integer ( kind = 4 ) j
39107
39108 if ( n <= 1 ) then
39109 return
39110 end if
39111!
39112! Initialize.
39113!
39114 i = 0
39115 indx = 0
39116 isgn = 0
39117 j = 0
39118!
39119! Call the external heap sorter.
39120!
39121 do
39122
39123 call sort_heap_external ( n, indx, i, j, isgn )
39124!
39125! Interchange the I and J objects.
39126!
39127 if ( 0 < indx ) then
39128
39129 call r8_swap ( a1(i), a1(j) )
39130 call r8_swap ( a2(i), a2(j) )
39131!
39132! Compare the I and J objects.
39133!
39134 else if ( indx < 0 ) then
39135
39136 call r8vec2_compare ( n, a1, a2, i, j, isgn )
39137
39138 else if ( indx == 0 ) then
39139
39140 exit
39141
39142 end if
39143
39144 end do
39145
39146 return
r8vec2_compare
subroutine r8vec2_compare(n, a1, a2, i, j, isgn)
Definition R8LIB.f90:38839

References r8_swap(), r8vec2_compare(), and sort_heap_external().

Here is the call graph for this function:

◆ r8vec2_sort_d()

subroutine r8vec2_sort_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 39148 of file R8LIB.f90.

39149
39150!*****************************************************************************80
39151!
39152!! R8VEC2_SORT_D descending sorts an R8VEC2.
39153!
39154! Discussion:
39155!
39156! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39157! as two separate vectors A1 and A2.
39158!
39159! Each item to be sorted is a pair (I,J), with the I
39160! and J values stored in separate vectors A1 and A2.
39161!
39162! Licensing:
39163!
39164! This code is distributed under the GNU LGPL license.
39165!
39166! Modified:
39167!
39168! 13 December 2004
39169!
39170! Author:
39171!
39172! John Burkardt
39173!
39174! Parameters:
39175!
39176! Input, integer ( kind = 4 ) N, the number of items of data.
39177!
39178! Input/output, real ( kind = 8 ) A1(N), A2(N), the data to be sorted.
39179!
39180 implicit none
39181
39182 integer ( kind = 4 ) n
39183
39184 real ( kind = 8 ) a1(n)
39185 real ( kind = 8 ) a2(n)
39186 integer ( kind = 4 ) i
39187 integer ( kind = 4 ) indx
39188 integer ( kind = 4 ) isgn
39189 integer ( kind = 4 ) j
39190
39191 if ( n <= 1 ) then
39192 return
39193 end if
39194!
39195! Initialize.
39196!
39197 i = 0
39198 indx = 0
39199 isgn = 0
39200 j = 0
39201!
39202! Call the external heap sorter.
39203!
39204 do
39205
39206 call sort_heap_external ( n, indx, i, j, isgn )
39207!
39208! Interchange the I and J objects.
39209!
39210 if ( 0 < indx ) then
39211
39212 call r8_swap ( a1(i), a1(j) )
39213 call r8_swap ( a2(i), a2(j) )
39214!
39215! Compare the I and J objects.
39216! Reverse the value of ISGN to effect a descending sort.
39217!
39218 else if ( indx < 0 ) then
39219
39220 call r8vec2_compare ( n, a1, a2, i, j, isgn )
39221
39222 isgn = -isgn
39223
39224 else if ( indx == 0 ) then
39225
39226 exit
39227
39228 end if
39229
39230 end do
39231
39232 return

References r8_swap(), r8vec2_compare(), and sort_heap_external().

Here is the call graph for this function:

◆ r8vec2_sort_heap_index_a()

subroutine r8vec2_sort_heap_index_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 39234 of file R8LIB.f90.

39235
39236!*****************************************************************************80
39237!
39238!! R8VEC2_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8VEC2.
39239!
39240! Discussion:
39241!
39242! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39243! as two separate vectors A1 and A2.
39244!
39245! The sorting is not actually carried out. Rather an index array is
39246! created which defines the sorting. This array may be used to sort
39247! or index the array, or to sort or index related arrays keyed on the
39248! original array.
39249!
39250! ( X(I), Y(I) ) < ( X(J), Y(J) ) if:
39251!
39252! * X(I) < X(J), or
39253!
39254! * X(I) = X(J), and Y(I) < Y(J).
39255!
39256! Once the index array is computed, the sorting can be carried out
39257! "implicitly:
39258!
39259! ( X(INDX(1:N)), Y(INDX(1:N) ), is sorted,
39260!
39261! or explicitly, by the call
39262!
39263! call r8vec_permute ( n, indx, x )
39264! call r8vec_permute ( n, indx, y )
39265!
39266! after which ( X(1:N), Y(1:N) ), is sorted.
39267!
39268! Licensing:
39269!
39270! This code is distributed under the GNU LGPL license.
39271!
39272! Modified:
39273!
39274! 13 December 2004
39275!
39276! Author:
39277!
39278! John Burkardt
39279!
39280! Parameters:
39281!
39282! Input, integer ( kind = 4 ) N, the number of entries in the array.
39283!
39284! Input, real ( kind = 8 ) X(N),Y(N), pairs of X, Y coordinates of points.
39285!
39286! Output, integer ( kind = 4 ) INDX(N), the sort index. The
39287! I-th element of the sorted array has coordinates ( X(INDX(I)), Y(INDX(I) ).
39288!
39289 implicit none
39290
39291 integer ( kind = 4 ) n
39292
39293 integer ( kind = 4 ) i
39294 integer ( kind = 4 ) indx(n)
39295 integer ( kind = 4 ) indxt
39296 integer ( kind = 4 ) ir
39297 integer ( kind = 4 ) j
39298 integer ( kind = 4 ) l
39299 real ( kind = 8 ) x(n)
39300 real ( kind = 8 ) xval
39301 real ( kind = 8 ) y(n)
39302 real ( kind = 8 ) yval
39303
39304 if ( n < 1 ) then
39305 return
39306 end if
39307
39308 call i4vec_indicator1 ( n, indx )
39309
39310 if ( n == 1 ) then
39311 return
39312 end if
39313
39314 l = n / 2 + 1
39315 ir = n
39316
39317 do
39318
39319 if ( 1 < l ) then
39320
39321 l = l - 1
39322 indxt = indx(l)
39323 xval = x(indxt)
39324 yval = y(indxt)
39325
39326 else
39327
39328 indxt = indx(ir)
39329 xval = x(indxt)
39330 yval = y(indxt)
39331 indx(ir) = indx(1)
39332 ir = ir - 1
39333
39334 if ( ir == 1 ) then
39335 indx(1) = indxt
39336 exit
39337 end if
39338
39339 end if
39340
39341 i = l
39342 j = l + l
39343
39344 do while ( j <= ir )
39345
39346 if ( j < ir ) then
39347
39348 if ( x(indx(j)) < x(indx(j+1)) .or. &
39349 ( x(indx(j)) == x(indx(j+1)) .and. y(indx(j)) < y(indx(j+1)) ) ) then
39350 j = j + 1
39351 end if
39352
39353 end if
39354
39355 if ( xval < x(indx(j)) .or. &
39356 ( xval == x(indx(j)) .and. yval < y(indx(j)) ) ) then
39357 indx(i) = indx(j)
39358 i = j
39359 j = j + j
39360 else
39361 j = ir + 1
39362 end if
39363
39364 end do
39365
39366 indx(i) = indxt
39367
39368 end do
39369
39370 return
i4vec_indicator1
subroutine i4vec_indicator1(n, a)
Definition R8LIB.f90:779

References i4vec_indicator1().

Here is the call graph for this function:

◆ r8vec2_sorted_unique()

subroutine r8vec2_sorted_unique ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
integer ( kind = 4 )  unique_num 
)

Definition at line 39372 of file R8LIB.f90.

39373
39374!*****************************************************************************80
39375!
39376!! R8VEC2_SORTED_UNIQUE keeps unique elements in a sorted R8VEC2.
39377!
39378! Discussion:
39379!
39380! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39381! as two separate vectors A1 and A2.
39382!
39383! Item I is stored as the pair A1(I), A2(I).
39384!
39385! The items must have been sorted, or at least it must be the
39386! case that equal items are stored in adjacent vector locations.
39387!
39388! If the items were not sorted, then this routine will only
39389! replace a string of equal values by a single representative.
39390!
39391! Licensing:
39392!
39393! This code is distributed under the GNU LGPL license.
39394!
39395! Modified:
39396!
39397! 13 December 2004
39398!
39399! Author:
39400!
39401! John Burkardt
39402!
39403! Parameters:
39404!
39405! Input, integer ( kind = 4 ) N, the number of items.
39406!
39407! Input/output, real ( kind = 8 ) A1(N), A2(N).
39408! On input, the array of N items.
39409! On output, an array of unique items.
39410!
39411! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique items.
39412!
39413 implicit none
39414
39415 integer ( kind = 4 ) n
39416
39417 real ( kind = 8 ) a1(n)
39418 real ( kind = 8 ) a2(n)
39419 integer ( kind = 4 ) itest
39420 integer ( kind = 4 ) unique_num
39421
39422 if ( n <= 0 ) then
39423 unique_num = 0
39424 return
39425 end if
39426
39427 unique_num = 1
39428
39429 do itest = 2, n
39430
39431 if ( a1(itest) /= a1(unique_num) .or. a2(itest) /= a2(unique_num) ) then
39432
39433 unique_num = unique_num + 1
39434
39435 a1(unique_num) = a1(itest)
39436 a2(unique_num) = a2(itest)
39437
39438 end if
39439
39440 end do
39441
39442 return

◆ r8vec2_sorted_unique_index()

subroutine r8vec2_sorted_unique_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
integer ( kind = 4 )  unique_num,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 39444 of file R8LIB.f90.

39445
39446!*****************************************************************************80
39447!
39448!! R8VEC2_SORTED_UNIQUE_INDEX indexes unique elements in a sorted R8VEC2.
39449!
39450! Discussion:
39451!
39452! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39453! as two separate vectors A1 and A2.
39454!
39455! Item I is stored as the pair A1(I), A2(I).
39456!
39457! The items must have been sorted, or at least it should be the
39458! case that equal items are stored in adjacent vector locations.
39459!
39460! Licensing:
39461!
39462! This code is distributed under the GNU LGPL license.
39463!
39464! Modified:
39465!
39466! 02 November 2005
39467!
39468! Author:
39469!
39470! John Burkardt
39471!
39472! Parameters:
39473!
39474! Input, integer ( kind = 4 ) N, the number of items.
39475!
39476! Input, real ( kind = 8 ) A1(N), A2(N), the array of N items.
39477!
39478! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique items.
39479!
39480! Output, integer ( kind = 4 ) INDX(N), contains in entries 1 through
39481! UNIQUE_NUM an index array of the unique items. To build new arrays
39482! with no repeated elements:
39483! B1(1:UNIQUE_NUM) = A1(INDX(1:UNIQUE_NUM))
39484!
39485 implicit none
39486
39487 integer ( kind = 4 ) n
39488
39489 real ( kind = 8 ) a1(n)
39490 real ( kind = 8 ) a2(n)
39491 integer ( kind = 4 ) indx(n)
39492 integer ( kind = 4 ) itest
39493 integer ( kind = 4 ) unique_num
39494
39495 if ( n <= 0 ) then
39496 unique_num = 0
39497 return
39498 end if
39499
39500 unique_num = 1
39501 indx(1) = 1
39502
39503 do itest = 2, n
39504
39505 if ( a1(itest-1) /= a1(itest) .or. a2(itest-1) /= a2(itest) ) then
39506
39507 unique_num = unique_num + 1
39508
39509 indx(unique_num) = itest
39510
39511 end if
39512
39513 end do
39514
39515 indx(unique_num+1:n) = 0
39516
39517 return

◆ r8vec2_sum_max_index()

subroutine r8vec2_sum_max_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b,
integer ( kind = 4 )  sum_max_index 
)

Definition at line 39519 of file R8LIB.f90.

39520
39521!*****************************************************************************80
39522!
39523!! R8VEC2_SUM_MAX_INDEX returns the index of the maximum sum of two R8VEC's.
39524!
39525! Discussion:
39526!
39527! An R8VEC2 is a dataset consisting of N pairs of R8's, stored
39528! as two separate vectors A1 and A2.
39529!
39530! Licensing:
39531!
39532! This code is distributed under the GNU LGPL license.
39533!
39534! Modified:
39535!
39536! 13 December 2004
39537!
39538! Author:
39539!
39540! John Burkardt
39541!
39542! Parameters:
39543!
39544! Input, integer ( kind = 4 ) N, the number of entries in the array.
39545!
39546! Input, real ( kind = 8 ) A(N), B(N), two arrays whose sum
39547! is to be examined.
39548!
39549! Output, integer ( kind = 4 ) SUM_MAX_INDEX, the index of the largest
39550! entry in A+B.
39551!
39552 implicit none
39553
39554 integer ( kind = 4 ) n
39555
39556 real ( kind = 8 ) a(n)
39557 real ( kind = 8 ) b(n)
39558 integer ( kind = 4 ) i
39559 real ( kind = 8 ) sum_max
39560 integer ( kind = 4 ) sum_max_index
39561
39562 if ( n <= 0 ) then
39563
39564 sum_max_index = -1
39565
39566 else
39567
39568 sum_max_index = 1
39569 sum_max = a(1) + b(1)
39570
39571 do i = 2, n
39572 if ( sum_max < a(i) + b(i) ) then
39573 sum_max = a(i) + b(i)
39574 sum_max_index = i
39575 end if
39576 end do
39577
39578 end if
39579
39580 return

◆ r8vec3_print()

subroutine r8vec3_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
real ( kind = 8 ), dimension(n)  a3,
character ( len = * )  title 
)

Definition at line 39582 of file R8LIB.f90.

39583
39584!*****************************************************************************80
39585!
39586!! R8VEC3_PRINT prints an R8VEC3.
39587!
39588! Discussion:
39589!
39590! An R8VEC3 is a dataset consisting of N triples of R8's, stored
39591! as three separate vectors A1, A2, A3.
39592!
39593! Licensing:
39594!
39595! This code is distributed under the GNU LGPL license.
39596!
39597! Modified:
39598!
39599! 22 September 2012
39600!
39601! Author:
39602!
39603! John Burkardt
39604!
39605! Parameters:
39606!
39607! Input, integer ( kind = 4 ) N, the number of components of the vector.
39608!
39609! Input, real ( kind = 8 ) A1(N), A2(N), A3(N), the vectors to be printed.
39610!
39611! Input, character ( len = * ) TITLE, a title.
39612!
39613 implicit none
39614
39615 integer ( kind = 4 ) n
39616
39617 real ( kind = 8 ) a1(n)
39618 real ( kind = 8 ) a2(n)
39619 real ( kind = 8 ) a3(n)
39620 integer ( kind = 4 ) i
39621 character ( len = * ) title
39622
39623 write ( *, '(a)' ) ' '
39624 write ( *, '(a)' ) trim( title )
39625 write ( *, '(a)' ) ' '
39626
39627 do i = 1, n
39628 write ( *, '(i8,3g14.6)' ) i, a1(i), a2(i), a3(i)
39629 end do
39630
39631 return

◆ r8vec_01_to_ab()

subroutine r8vec_01_to_ab ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  amax,
real ( kind = 8 )  amin 
)

Definition at line 25253 of file R8LIB.f90.

25254
25255!*****************************************************************************80
25256!
25257!! R8VEC_01_TO_AB shifts and rescales an R8VEC to lie within given bounds.
25258!
25259! Discussion:
25260!
25261! An R8VEC is a vector of R8's.
25262!
25263! On input, A contains the original data, which is presumed to lie
25264! between 0 and 1. However, it is not necessary that this be so.
25265!
25266! On output, A has been shifted and rescaled so that all entries which
25267! on input lay in [0,1] now lie between AMIN and AMAX. Other entries will
25268! be mapped in a corresponding way.
25269!
25270! Licensing:
25271!
25272! This code is distributed under the GNU LGPL license.
25273!
25274! Modified:
25275!
25276! 30 April 1999
25277!
25278! Author:
25279!
25280! John Burkardt
25281!
25282! Parameters:
25283!
25284! Input, integer ( kind = 4 ) N, the number of data values.
25285!
25286! Input/output, real ( kind = 8 ) A(N), the vector to be rescaled.
25287!
25288! Input, real ( kind = 8 ) AMAX, AMIN, the maximum and minimum values
25289! allowed for A.
25290!
25291 implicit none
25292
25293 integer ( kind = 4 ) n
25294
25295 real ( kind = 8 ) a(n)
25296 real ( kind = 8 ) amax
25297 real ( kind = 8 ) amax2
25298 real ( kind = 8 ) amax3
25299 real ( kind = 8 ) amin
25300 real ( kind = 8 ) amin2
25301 real ( kind = 8 ) amin3
25302
25303 if ( amax == amin ) then
25304 a(1:n) = amin
25305 return
25306 end if
25307
25308 amax2 = max( amax, amin )
25309 amin2 = min( amax, amin )
25310
25311 amin3 = minval( a(1:n) )
25312 amax3 = maxval( a(1:n) )
25313
25314 if ( amax3 /= amin3 ) then
25315
25316 a(1:n) = ( ( amax3 - a(1:n) ) * amin2 &
25317 + ( a(1:n) - amin3 ) * amax2 ) &
25318 / ( amax3 - amin3 )
25319
25320 else
25321
25322 a(1:n) = 0.5d+00 * ( amax2 + amin2 )
25323
25324 end if
25325
25326 return

◆ r8vec_ab_to_01()

subroutine r8vec_ab_to_01 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 25328 of file R8LIB.f90.

25329
25330!*****************************************************************************80
25331!
25332!! R8VEC_AB_TO_01 shifts and rescales an R8VEC to lie within [0,1].
25333!
25334! Discussion:
25335!
25336! An R8VEC is a vector of R8's.
25337!
25338! On input, A contains the original data. On output, A has been shifted
25339! and scaled so that all entries lie between 0 and 1.
25340!
25341! Formula:
25342!
25343! A(I) := ( A(I) - AMIN ) / ( AMAX - AMIN )
25344!
25345! Licensing:
25346!
25347! This code is distributed under the GNU LGPL license.
25348!
25349! Modified:
25350!
25351! 12 December 2004
25352!
25353! Author:
25354!
25355! John Burkardt
25356!
25357! Parameters:
25358!
25359! Input, integer ( kind = 4 ) N, the number of data values.
25360!
25361! Input/output, real ( kind = 8 ) A(N), the data to be rescaled.
25362!
25363 implicit none
25364
25365 integer ( kind = 4 ) n
25366
25367 real ( kind = 8 ) a(n)
25368 real ( kind = 8 ) amax
25369 real ( kind = 8 ) amin
25370
25371 amax = maxval( a(1:n) )
25372 amin = minval( a(1:n) )
25373
25374 if ( amin == amax ) then
25375 a(1:n) = 0.5d+00
25376 else
25377 a(1:n) = ( a(1:n) - amin ) / ( amax - amin )
25378 end if
25379
25380 return

◆ r8vec_ab_to_cd()

subroutine r8vec_ab_to_cd ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  bmin,
real ( kind = 8 )  bmax,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 25382 of file R8LIB.f90.

25383
25384!*****************************************************************************80
25385!
25386!! R8VEC_AB_TO_CD shifts and rescales an R8VEC from one interval to another.
25387!
25388! Discussion:
25389!
25390! An R8VEC is a vector of R8's.
25391!
25392! The mininum entry of A is mapped to BMIN, the maximum entry
25393! to BMAX, and values in between are mapped linearly.
25394!
25395! Licensing:
25396!
25397! This code is distributed under the GNU LGPL license.
25398!
25399! Modified:
25400!
25401! 13 December 2004
25402!
25403! Author:
25404!
25405! John Burkardt
25406!
25407! Parameters:
25408!
25409! Input, integer ( kind = 4 ) N, the number of data values.
25410!
25411! Input, real ( kind = 8 ) A(N), the data to be remapped.
25412!
25413! Input, real ( kind = 8 ) BMIN, BMAX, the values to which min(A) and max(A)
25414! are to be assigned.
25415!
25416! Output, real ( kind = 8 ) B(N), the remapped data.
25417!
25418 implicit none
25419
25420 integer ( kind = 4 ) n
25421
25422 real ( kind = 8 ) a(n)
25423 real ( kind = 8 ) amax
25424 real ( kind = 8 ) amin
25425 real ( kind = 8 ) b(n)
25426 real ( kind = 8 ) bmax
25427 real ( kind = 8 ) bmin
25428
25429 if ( bmax == bmin ) then
25430 b(1:n) = bmin
25431 return
25432 end if
25433
25434 amin = minval( a(1:n) )
25435 amax = maxval( a(1:n) )
25436
25437 if ( amax == amin ) then
25438 b(1:n) = 0.5d+00 * ( bmax + bmin )
25439 return
25440 end if
25441
25442 b(1:n) = ( ( amax - a(1:n) ) * bmin &
25443 + ( a(1:n) - amin ) * bmax ) &
25444 / ( amax - amin )
25445
25446 return

◆ r8vec_all_nonpositive()

logical ( kind = 4 ) function r8vec_all_nonpositive ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 25448 of file R8LIB.f90.

25449
25450!*****************************************************************************80
25451!
25452!! R8VEC_ALL_NONPOSITIVE: ( all ( A <= 0 ) ) for R8VEC's.
25453!
25454! Discussion:
25455!
25456! An R8VEC is a vector of R8's.
25457!
25458! Licensing:
25459!
25460! This code is distributed under the GNU LGPL license.
25461!
25462! Modified:
25463!
25464! 08 October 2011
25465!
25466! Author:
25467!
25468! John Burkardt
25469!
25470! Parameters:
25471!
25472! Input, integer ( kind = 4 ) N, the number of entries.
25473!
25474! Input, double ( kind = 8 ) A(N), the vector.
25475!
25476! Output, logical ( kind = 4 ) R8VEC_ALL_NONPOSITIVE is TRUE if all entries
25477! of A are less than or equal to zero.
25478!
25479 implicit none
25480
25481 integer ( kind = 4 ) n
25482
25483 real ( kind = 8 ) a(n)
25484 logical ( kind = 4 ) r8vec_all_nonpositive
25485
25486 r8vec_all_nonpositive = all( a(1:n) <= 0.0d+00 )
25487
25488 return
r8vec_all_nonpositive
logical(kind=4) function r8vec_all_nonpositive(n, a)
Definition R8LIB.f90:25449

References r8vec_all_nonpositive().

Referenced by r8vec_all_nonpositive().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_amax()

subroutine r8vec_amax ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  amax 
)

Definition at line 25490 of file R8LIB.f90.

25491
25492!*****************************************************************************80
25493!
25494!! R8VEC_AMAX returns the maximum absolute value in an R8VEC.
25495!
25496! Discussion:
25497!
25498! An R8VEC is a vector of R8's.
25499!
25500! Licensing:
25501!
25502! This code is distributed under the GNU LGPL license.
25503!
25504! Modified:
25505!
25506! 08 November 2000
25507!
25508! Author:
25509!
25510! John Burkardt
25511!
25512! Parameters:
25513!
25514! Input, integer ( kind = 4 ) N, the number of entries in the array.
25515!
25516! Input, real ( kind = 8 ) A(N), the array.
25517!
25518! Output, real ( kind = 8 ) AMAX, the value of the entry
25519! of largest magnitude.
25520!
25521 implicit none
25522
25523 integer ( kind = 4 ) n
25524
25525 real ( kind = 8 ) a(n)
25526 real ( kind = 8 ) amax
25527
25528 amax = maxval( abs( a(1:n) ) )
25529
25530 return

◆ r8vec_amax_index()

subroutine r8vec_amax_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  amax_index 
)

Definition at line 25532 of file R8LIB.f90.

25533
25534!*****************************************************************************80
25535!
25536!! R8VEC_AMAX_INDEX returns the index of the maximum absolute value in an R8VEC.
25537!
25538! Discussion:
25539!
25540! An R8VEC is a vector of R8's.
25541!
25542! Licensing:
25543!
25544! This code is distributed under the GNU LGPL license.
25545!
25546! Modified:
25547!
25548! 30 January 1999
25549!
25550! Author:
25551!
25552! John Burkardt
25553!
25554! Parameters:
25555!
25556! Input, integer ( kind = 4 ) N, the number of entries in the array.
25557!
25558! Input, real ( kind = 8 ) A(N), the array.
25559!
25560! Output, integer ( kind = 4 ) AMAX_INDEX, the index of the entry of
25561! largest magnitude.
25562!
25563 implicit none
25564
25565 integer ( kind = 4 ) n
25566
25567 real ( kind = 8 ) a(n)
25568 real ( kind = 8 ) amax
25569 integer ( kind = 4 ) amax_index
25570 integer ( kind = 4 ) i
25571
25572 if ( n <= 0 ) then
25573
25574 amax_index = -1
25575
25576 else
25577
25578 amax_index = 1
25579 amax = abs( a(1) )
25580
25581 do i = 2, n
25582 if ( amax < abs( a(i) ) ) then
25583 amax_index = i
25584 amax = abs( a(i) )
25585 end if
25586 end do
25587
25588 end if
25589
25590 return

◆ r8vec_amin()

subroutine r8vec_amin ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  amin 
)

Definition at line 25592 of file R8LIB.f90.

25593
25594!*****************************************************************************80
25595!
25596!! R8VEC_AMIN returns the minimum absolute value in an R8VEC.
25597!
25598! Discussion:
25599!
25600! An R8VEC is a vector of R8's.
25601!
25602! Licensing:
25603!
25604! This code is distributed under the GNU LGPL license.
25605!
25606! Modified:
25607!
25608! 13 December 2004
25609!
25610! Author:
25611!
25612! John Burkardt
25613!
25614! Parameters:
25615!
25616! Input, integer ( kind = 4 ) N, the number of entries in the array.
25617!
25618! Input, real ( kind = 8 )A(N), the array.
25619!
25620! Output, real ( kind = 8 ) AMIN, the value of the entry
25621! of smallest magnitude.
25622!
25623 implicit none
25624
25625 integer ( kind = 4 ) n
25626
25627 real ( kind = 8 ) a(n)
25628 real ( kind = 8 ) amin
25629
25630 amin = minval( abs( a(1:n) ) )
25631
25632 return

◆ r8vec_amin_index()

subroutine r8vec_amin_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  amin_index 
)

Definition at line 25634 of file R8LIB.f90.

25635
25636!*****************************************************************************80
25637!
25638!! R8VEC_AMIN_INDEX returns the index of the minimum absolute value in an R8VEC.
25639!
25640! Discussion:
25641!
25642! An R8VEC is a vector of R8's.
25643!
25644! Licensing:
25645!
25646! This code is distributed under the GNU LGPL license.
25647!
25648! Modified:
25649!
25650! 30 January 1999
25651!
25652! Author:
25653!
25654! John Burkardt
25655!
25656! Parameters:
25657!
25658! Input, integer ( kind = 4 ) N, the number of entries in the array.
25659!
25660! Input, real ( kind = 8 ) A(N), the array.
25661!
25662! Output, integer ( kind = 4 ) AMIN_INDEX, the index of the entry of
25663! smallest magnitude.
25664!
25665 implicit none
25666
25667 integer ( kind = 4 ) n
25668
25669 real ( kind = 8 ) a(n)
25670 real ( kind = 8 ) amin
25671 integer ( kind = 4 ) amin_index
25672 integer ( kind = 4 ) i
25673
25674 if ( n <= 0 ) then
25675
25676 amin_index = 0
25677
25678 else
25679
25680 amin_index = 1
25681 amin = abs( a(1) )
25682
25683 do i = 2, n
25684 if ( abs( a(i) ) < amin ) then
25685 amin_index = i
25686 amin = abs( a(i) )
25687 end if
25688 end do
25689
25690 end if
25691
25692 return

◆ r8vec_any_negative()

logical ( kind = 4 ) function r8vec_any_negative ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 25694 of file R8LIB.f90.

25695
25696!*****************************************************************************80
25697!
25698!! R8VEC_ANY_NEGATIVE: ( any A < 0 ) for R8VEC's.
25699!
25700! Discussion:
25701!
25702! An R8VEC is a vector of R8's.
25703!
25704! Licensing:
25705!
25706! This code is distributed under the GNU LGPL license.
25707!
25708! Modified:
25709!
25710! 08 October 2011
25711!
25712! Author:
25713!
25714! John Burkardt
25715!
25716! Parameters:
25717!
25718! Input, integer ( kind = 4 ) N, the number of entries.
25719!
25720! Input, real ( kind = 8 ) A(N), the vector.
25721!
25722! Output, logical ( kind = 4 ) R8VEC_ANY_NEGATIVE is TRUE if any entry
25723! is negative.
25724!
25725 implicit none
25726
25727 integer ( kind = 4 ) n
25728
25729 real ( kind = 8 ) a(n)
25730 logical ( kind = 4 ) r8vec_any_negative
25731
25732 r8vec_any_negative = any( a(1:n) < 0.0d+00 )
25733
25734 return
r8vec_any_negative
logical(kind=4) function r8vec_any_negative(n, a)
Definition R8LIB.f90:25695

References r8vec_any_negative().

Referenced by r8vec_any_negative().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_any_nonzero()

logical ( kind = 4 ) function r8vec_any_nonzero ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 25736 of file R8LIB.f90.

25737
25738!*****************************************************************************80
25739!
25740!! R8VEC_ANY_NONZERO: ( any A nonzero ) for R8VEC's.
25741!
25742! Discussion:
25743!
25744! An R8VEC is a vector of R8's.
25745!
25746! Licensing:
25747!
25748! This code is distributed under the GNU LGPL license.
25749!
25750! Modified:
25751!
25752! 25 December 2011
25753!
25754! Author:
25755!
25756! John Burkardt
25757!
25758! Parameters:
25759!
25760! Input, integer ( kind = 4 ) N, the number of entries.
25761!
25762! Input, real ( kind = 8 ) A(N), the vector.
25763!
25764! Output, logical ( kind = 4 ) R8VEC_ANY_NONZERO is TRUE if any entry
25765! is nonzero.
25766!
25767 implicit none
25768
25769 integer ( kind = 4 ) n
25770
25771 real ( kind = 8 ) a(n)
25772 logical ( kind = 4 ) r8vec_any_nonzero
25773
25774 r8vec_any_nonzero = any( a(1:n) /= 0.0d+00 )
25775
25776 return
r8vec_any_nonzero
logical(kind=4) function r8vec_any_nonzero(n, a)
Definition R8LIB.f90:25737

References r8vec_any_nonzero().

Referenced by r8vec_any_nonzero().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_any_normal()

subroutine r8vec_any_normal ( integer ( kind = 4 )  dim_num,
real ( kind = 8 ), dimension(dim_num)  v1,
real ( kind = 8 ), dimension(dim_num)  v2 
)

Definition at line 25778 of file R8LIB.f90.

25779
25780!*****************************************************************************80
25781!
25782!! R8VEC_ANY_NORMAL returns some normal vector to V1.
25783!
25784! Discussion:
25785!
25786! If DIM_NUM < 2, then no normal vector can be returned.
25787!
25788! If V1 is the zero vector, then any unit vector will do.
25789!
25790! No doubt, there are better, more robust algorithms. But I will take
25791! just about ANY reasonable unit vector that is normal to V1.
25792!
25793! Licensing:
25794!
25795! This code is distributed under the GNU LGPL license.
25796!
25797! Modified:
25798!
25799! 23 August 2005
25800!
25801! Author:
25802!
25803! John Burkardt
25804!
25805! Parameters:
25806!
25807! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension.
25808!
25809! Input, real ( kind = 8 ) V1(DIM_NUM), the vector.
25810!
25811! Output, real ( kind = 8 ) V2(DIM_NUM), a vector that is
25812! normal to V2, and has unit Euclidean length.
25813!
25814 implicit none
25815
25816 integer ( kind = 4 ) dim_num
25817
25818 integer ( kind = 4 ) i
25819 integer ( kind = 4 ) j
25820 integer ( kind = 4 ) k
25821 real ( kind = 8 ) r8vec_norm
25822 real ( kind = 8 ) v1(dim_num)
25823 real ( kind = 8 ) v2(dim_num)
25824 real ( kind = 8 ) vj
25825 real ( kind = 8 ) vk
25826
25827 if ( dim_num < 2 ) then
25828 write ( *, '(a)' ) ' '
25829 write ( *, '(a)' ) 'R8VEC_ANY_NORMAL - Fatal error!'
25830 write ( *, '(a)' ) ' Called with DIM_NUM < 2.'
25831 stop 1
25832 end if
25833
25834 if ( r8vec_norm( dim_num, v1 ) == 0.0d+00 ) then
25835 v2(1) = 1.0d+00
25836 v2(2:dim_num) = 0.0d+00
25837 return
25838 end if
25839!
25840! Seek the largest entry in V1, VJ = V1(J), and the
25841! second largest, VK = V1(K).
25842!
25843! Since V1 does not have zero norm, we are guaranteed that
25844! VJ, at least, is not zero.
25845!
25846 j = - 1
25847 vj = 0.0d+00
25848
25849 k = - 1
25850 vk = 0.0d+00
25851
25852 do i = 1, dim_num
25853
25854 if ( abs( vk ) < abs( v1(i) ) .or. k < 1 ) then
25855
25856 if ( abs( vj ) < abs( v1(i) ) .or. j < 1 ) then
25857 k = j
25858 vk = vj
25859 j = i
25860 vj = v1(i)
25861 else
25862 k = i
25863 vk = v1(i)
25864 end if
25865
25866 end if
25867
25868 end do
25869!
25870! Setting V2 to zero, except that V2(J) = -VK, and V2(K) = VJ,
25871! will just about do the trick.
25872!
25873 v2(1:dim_num) = 0.0d+00
25874
25875 v2(j) = - vk / sqrt( vk * vk + vj * vj )
25876 v2(k) = vj / sqrt( vk * vk + vj * vj )
25877
25878 return
r8vec_norm
real(kind=8) function r8vec_norm(n, a)
Definition R8LIB.f90:33258

References r8vec_norm().

Here is the call graph for this function:

◆ r8vec_ascends()

logical ( kind = 4 ) function r8vec_ascends ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 25880 of file R8LIB.f90.

25881
25882!*****************************************************************************80
25883!
25884!! R8VEC_ASCENDS determines if an R8VEC is (weakly) ascending.
25885!
25886! Discussion:
25887!
25888! An R8VEC is a vector of R8's.
25889!
25890! For example, if:
25891!
25892! X = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.5, 9.8 )
25893!
25894! then
25895!
25896! R8VEC_ASCENDS = TRUE
25897!
25898! The sequence is not required to be strictly ascending.
25899!
25900! Licensing:
25901!
25902! This code is distributed under the GNU LGPL license.
25903!
25904! Modified:
25905!
25906! 26 April 2005
25907!
25908! Author:
25909!
25910! John Burkardt
25911!
25912! Parameters:
25913!
25914! Input, integer ( kind = 4 ) N, the size of the array.
25915!
25916! Input, real ( kind = 8 ) X(N), the array to be examined.
25917!
25918! Output, logical ( kind = 4 ) R8VEC_ASCENDS, is TRUE if the
25919! entries of X ascend.
25920!
25921 implicit none
25922
25923 integer ( kind = 4 ) n
25924
25925 integer ( kind = 4 ) i
25926 logical ( kind = 4 ) r8vec_ascends
25927 real ( kind = 8 ) x(n)
25928
25929 do i = 1, n - 1
25930 if ( x(i+1) < x(i) ) then
25931 r8vec_ascends = .false.
25932 return
25933 end if
25934 end do
25935
25936 r8vec_ascends = .true.
25937
25938 return
r8vec_ascends
logical(kind=4) function r8vec_ascends(n, x)
Definition R8LIB.f90:25881

References r8vec_ascends().

Referenced by r8vec_ascends().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_ascends_strictly()

logical ( kind = 4 ) function r8vec_ascends_strictly ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 25940 of file R8LIB.f90.

25941
25942!*****************************************************************************80
25943!
25944!! R8VEC_ASCENDS_STRICTLY determines if an R8VEC is strictly ascending.
25945!
25946! Discussion:
25947!
25948! An R8VEC is a vector of R8's.
25949!
25950! Notice the effect of entry number 6 in the following results:
25951!
25952! X = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.4, 9.8 )
25953! Y = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.5, 9.8 )
25954! Z = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.6, 9.8 )
25955!
25956! R8VEC_ASCENDS_STRICTLY ( X ) = FALSE
25957! R8VEC_ASCENDS_STRICTLY ( Y ) = FALSE
25958! R8VEC_ASCENDS_STRICTLY ( Z ) = TRUE
25959!
25960! Licensing:
25961!
25962! This code is distributed under the GNU LGPL license.
25963!
25964! Modified:
25965!
25966! 03 December 2007
25967!
25968! Author:
25969!
25970! John Burkardt
25971!
25972! Parameters:
25973!
25974! Input, integer ( kind = 4 ) N, the size of the array.
25975!
25976! Input, real ( kind = 8 ) X(N), the array to be examined.
25977!
25978! Output, logical ( kind = 4 ) R8VEC_ASCENDS_STRICTLY, is TRUE if the
25979! entries of X strictly ascend.
25980!
25981 implicit none
25982
25983 integer ( kind = 4 ) n
25984
25985 integer ( kind = 4 ) i
25986 logical ( kind = 4 ) r8vec_ascends_strictly
25987 real ( kind = 8 ) x(n)
25988
25989 do i = 1, n - 1
25990 if ( x(i+1) <= x(i) ) then
25991 r8vec_ascends_strictly = .false.
25992 return
25993 end if
25994 end do
25995
25996 r8vec_ascends_strictly = .true.
25997
25998 return
r8vec_ascends_strictly
logical(kind=4) function r8vec_ascends_strictly(n, x)
Definition R8LIB.f90:25941

References r8vec_ascends_strictly().

Referenced by r8vec_ascends_strictly().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_bin()

subroutine r8vec_bin ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 )  bin_num,
real ( kind = 8 )  bin_min,
real ( kind = 8 )  bin_max,
integer ( kind = 4 ), dimension(0:bin_num+1)  bin,
real ( kind = 8 ), dimension(0:bin_num)  bin_limit 
)

Definition at line 26000 of file R8LIB.f90.

26001
26002!*****************************************************************************80
26003!
26004!! R8VEC_BIN computes bins based on a given R8VEC.
26005!
26006! Discussion:
26007!
26008! The user specifies minimum and maximum bin values, BIN_MIN and
26009! BIN_MAX, and the number of bins, BIN_NUM. This determines a
26010! "bin width":
26011!
26012! H = ( BIN_MAX - BIN_MIN ) / BIN_NUM
26013!
26014! so that bin I will count all entries X(J) such that
26015!
26016! BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
26017!
26018! The array X does NOT have to be sorted.
26019!
26020! Licensing:
26021!
26022! This code is distributed under the GNU LGPL license.
26023!
26024! Modified:
26025!
26026! 29 July 1999
26027!
26028! Author:
26029!
26030! John Burkardt
26031!
26032! Parameters:
26033!
26034! Input, integer ( kind = 4 ) N, the number of entries of X.
26035!
26036! Input, real ( kind = 8 ) X(N), an (unsorted) array to be binned.
26037!
26038! Input, integer ( kind = 4 ) BIN_NUM, the number of bins. Two extra bins,
26039! #0 and #BIN_NUM+1, count extreme values.
26040!
26041! Input, real ( kind = 8 ) BIN_MIN, BIN_MAX, define the range and size
26042! of the bins. BIN_MIN and BIN_MAX must be distinct.
26043! Normally, BIN_MIN < BIN_MAX, and the documentation will assume
26044! this, but proper results will be computed if BIN_MIN > BIN_MAX.
26045!
26046! Output, integer ( kind = 4 ) BIN(0:BIN_NUM+1).
26047! BIN(0) counts entries of X less than BIN_MIN.
26048! BIN(BIN_NUM+1) counts entries greater than or equal to BIN_MAX.
26049! For 1 <= I <= BIN_NUM, BIN(I) counts the entries X(J) such that
26050! BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
26051! where H is the bin spacing.
26052!
26053! Output, real ( kind = 8 ) BIN_LIMIT(0:BIN_NUM), the "limits" of the bins.
26054! BIN(I) counts the number of entries X(J) such that
26055! BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
26056!
26057 implicit none
26058
26059 integer ( kind = 4 ) n
26060 integer ( kind = 4 ) bin_num
26061
26062 integer ( kind = 4 ) bin(0:bin_num+1)
26063 real ( kind = 8 ) bin_limit(0:bin_num)
26064 real ( kind = 8 ) bin_max
26065 real ( kind = 8 ) bin_min
26066 integer ( kind = 4 ) i
26067 integer ( kind = 4 ) j
26068 real ( kind = 8 ) t
26069 real ( kind = 8 ) x(n)
26070
26071 if ( bin_max == bin_min ) then
26072 write ( *, '(a)' ) ' '
26073 write ( *, '(a)' ) 'R8VEC_BIN - Fatal error!'
26074 write ( *, '(a)' ) ' BIN_MIN = BIN_MAX.'
26075 stop 1
26076 end if
26077
26078 bin(0:bin_num+1) = 0
26079
26080 do i = 1, n
26081
26082 t = ( x(i) - bin_min ) / ( bin_max - bin_min )
26083
26084 if ( t < 0.0d+00 ) then
26085 j = 0
26086 else if ( 1.0d+00 <= t ) then
26087 j = bin_num + 1
26088 else
26089 j = 1 + int( real( bin_num, kind = 8 ) * t )
26090 end if
26091
26092 bin(j) = bin(j) + 1
26093
26094 end do
26095!
26096! Compute the bin limits.
26097!
26098 do i = 0, bin_num
26099 bin_limit(i) = ( real( bin_num - i, kind = 8 ) * bin_min &
26100 + real( i, kind = 8 ) * bin_max ) &
26101 / real( bin_num, kind = 8 )
26102 end do
26103
26104 return

◆ r8vec_blend()

subroutine r8vec_blend ( integer ( kind = 4 )  n,
real ( kind = 8 )  t1,
real ( kind = 8 ), dimension(n)  x1,
real ( kind = 8 )  t2,
real ( kind = 8 ), dimension(n)  x2,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 26106 of file R8LIB.f90.

26107
26108!*****************************************************************************80
26109!
26110!! R8VEC_BLEND performs weighted interpolation of two R8VEC's.
26111!
26112! Discussion:
26113!
26114! An R8VEC is a vector of R8's.
26115!
26116! The formula used is:
26117!
26118! x(i) = t * x1(i) + (1-t) * x2(i)
26119!
26120! Licensing:
26121!
26122! This code is distributed under the GNU LGPL license.
26123!
26124! Modified:
26125!
26126! 01 March 1999
26127!
26128! Author:
26129!
26130! John Burkardt
26131!
26132! Parameters:
26133!
26134! Input, integer ( kind = 4 ) N, the number of entries in each vector.
26135!
26136! Input, real ( kind = 8 ) T1, the weight factor for vector 1.
26137!
26138! Input, real ( kind = 8 ) X1(N), the first vector.
26139!
26140! Input, real ( kind = 8 ) T2, the weight factor for vector 2.
26141!
26142! Input, real ( kind = 8 ) X2(N), the second vector.
26143!
26144! Output, real ( kind = 8 ) X(N), the interpolated or extrapolated value.
26145!
26146 implicit none
26147
26148 integer ( kind = 4 ) n
26149
26150 real ( kind = 8 ) t1
26151 real ( kind = 8 ) t2
26152 real ( kind = 8 ) x(n)
26153 real ( kind = 8 ) x1(n)
26154 real ( kind = 8 ) x2(n)
26155
26156 x(1:n) = t1 * x1(1:n) + t2 * x2(1:n)
26157
26158 return

◆ r8vec_bracket()

subroutine r8vec_bracket ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 )  xval,
integer ( kind = 4 )  left,
integer ( kind = 4 )  right 
)

Definition at line 26160 of file R8LIB.f90.

26161
26162!*****************************************************************************80
26163!
26164!! R8VEC_BRACKET searches a sorted R8VEC for successive brackets of a value.
26165!
26166! Discussion:
26167!
26168! This is an inefficient implementation that uses linear search.
26169!
26170! An R8VEC is a vector of R8's.
26171!
26172! If the values in the vector are thought of as defining intervals
26173! on the real line, then this routine searches for the interval
26174! nearest to or containing the given value.
26175!
26176! It is always true that RIGHT = LEFT+1.
26177!
26178! If XVAL < X(1), then LEFT = 1, RIGHT = 2, and
26179! XVAL < X(1) < X(2);
26180! If X(1) <= XVAL < X(N), then
26181! X(LEFT) <= XVAL < X(RIGHT);
26182! If X(N) <= XVAL, then LEFT = N-1, RIGHT = N, and
26183! X(LEFT) <= X(RIGHT) <= XVAL.
26184!
26185! Licensing:
26186!
26187! This code is distributed under the GNU LGPL license.
26188!
26189! Modified:
26190!
26191! 06 April 1999
26192!
26193! Author:
26194!
26195! John Burkardt
26196!
26197! Parameters:
26198!
26199! Input, integer ( kind = 4 ) N, length of input array.
26200!
26201! Input, real ( kind = 8 ) X(N), an array that has been sorted into
26202! ascending order.
26203!
26204! Input, real ( kind = 8 ) XVAL, a value to be bracketed.
26205!
26206! Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search.
26207!
26208 implicit none
26209
26210 integer ( kind = 4 ) n
26211
26212 integer ( kind = 4 ) i
26213 integer ( kind = 4 ) left
26214 integer ( kind = 4 ) right
26215 real ( kind = 8 ) x(n)
26216 real ( kind = 8 ) xval
26217
26218 do i = 2, n - 1
26219
26220 if ( xval < x(i) ) then
26221 left = i - 1
26222 right = i
26223 return
26224 end if
26225
26226 end do
26227
26228 left = n - 1
26229 right = n
26230
26231 return

Referenced by r8vec_bracket2().

Here is the caller graph for this function:

◆ r8vec_bracket2()

subroutine r8vec_bracket2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 )  xval,
integer ( kind = 4 )  start,
integer ( kind = 4 )  left,
integer ( kind = 4 )  right 
)

Definition at line 26233 of file R8LIB.f90.

26234
26235!*****************************************************************************80
26236!
26237!! R8VEC_BRACKET2 searches a sorted R8VEC for successive brackets of a value.
26238!
26239! Discussion:
26240!
26241! An R8VEC is a vector of R8's.
26242!
26243! If the values in the vector are thought of as defining intervals
26244! on the real line, then this routine searches for the interval
26245! containing the given value.
26246!
26247! R8VEC_BRACKET2 is a variation on R8VEC_BRACKET. It seeks to reduce
26248! the search time by allowing the user to suggest an interval that
26249! probably contains the value. The routine will look in that interval
26250! and the intervals to the immediate left and right. If this does
26251! not locate the point, a binary search will be carried out on
26252! appropriate subportion of the sorted array.
26253!
26254! In the most common case, 1 <= LEFT < LEFT + 1 = RIGHT <= N,
26255! and X(LEFT) <= XVAL <= X(RIGHT).
26256!
26257! Special cases:
26258! Value is less than all data values:
26259! LEFT = -1, RIGHT = 1, and XVAL < X(RIGHT).
26260! Value is greater than all data values:
26261! LEFT = N, RIGHT = -1, and X(LEFT) < XVAL.
26262! Value is equal to a data value:
26263! LEFT = RIGHT, and X(LEFT) = X(RIGHT) = XVAL.
26264!
26265! Licensing:
26266!
26267! This code is distributed under the GNU LGPL license.
26268!
26269! Modified:
26270!
26271! 26 February 1999
26272!
26273! Author:
26274!
26275! John Burkardt
26276!
26277! Parameters:
26278!
26279! Input, integer ( kind = 4 ) N, length of the input array.
26280!
26281! Input, real ( kind = 8 ) X(N), an array that has been sorted into
26282! ascending order.
26283!
26284! Input, real ( kind = 8 ) XVAL, a value to be bracketed by entries of X.
26285!
26286! Input, integer ( kind = 4 ) START, between 1 and N, specifies that XVAL
26287! is likely to be in the interval:
26288! [ X(START), X(START+1) ]
26289! or, if not in that interval, then either
26290! [ X(START+1), X(START+2) ]
26291! or
26292! [ X(START-1), X(START) ].
26293!
26294! Output, integer ( kind = 4 ) LEFT, RIGHT, the results of the search.
26295!
26296 implicit none
26297
26298 integer ( kind = 4 ) n
26299
26300 integer ( kind = 4 ) high
26301 integer ( kind = 4 ) left
26302 integer ( kind = 4 ) low
26303 integer ( kind = 4 ) right
26304 integer ( kind = 4 ) start
26305 real ( kind = 8 ) x(n)
26306 real ( kind = 8 ) xval
26307!
26308! Check.
26309!
26310 if ( n < 1 ) then
26311 write ( *, '(a)' ) ' '
26312 write ( *, '(a)' ) 'R8VEC_BRACKET2 - Fatal error!'
26313 write ( *, '(a)' ) ' N < 1.'
26314 stop 1
26315 end if
26316
26317 if ( start < 1 .or. n < start ) then
26318 start = ( n + 1 ) / 2
26319 end if
26320!
26321! XVAL = X(START)?
26322!
26323 if ( x(start) == xval ) then
26324
26325 left = start
26326 right = start
26327 return
26328!
26329! X(START) < XVAL?
26330!
26331 else if ( x(start) < xval ) then
26332!
26333! X(START) = X(N) < XVAL < oo?
26334!
26335 if ( n < start + 1 ) then
26336
26337 left = start
26338 right = -1
26339 return
26340!
26341! XVAL = X(START+1)?
26342!
26343 else if ( xval == x(start+1) ) then
26344
26345 left = start + 1
26346 right = start + 1
26347 return
26348!
26349! X(START) < XVAL < X(START+1)?
26350!
26351 else if ( xval < x(start+1) ) then
26352
26353 left = start
26354 right = start + 1
26355 return
26356!
26357! X(START+1) = X(N) < XVAL < oo?
26358!
26359 else if ( n < start + 2 ) then
26360
26361 left = start + 1
26362 right = -1
26363 return
26364!
26365! XVAL = X(START+2)?
26366!
26367 else if ( xval == x(start+2) ) then
26368
26369 left = start + 2
26370 right = start + 2
26371 return
26372!
26373! X(START+1) < XVAL < X(START+2)?
26374!
26375 else if ( xval < x(start+2) ) then
26376
26377 left = start + 1
26378 right = start + 2
26379 return
26380!
26381! Binary search for XVAL in [ X(START+2), X(N) ],
26382! where XVAL is guaranteed to be greater than X(START+2).
26383!
26384 else
26385
26386 low = start + 2
26387 high = n
26388 call r8vec_bracket ( high + 1 - low, x(low), xval, left, right )
26389 left = left + low - 1
26390 right = right + low - 1
26391
26392 end if
26393!
26394! -oo < XVAL < X(START) = X(1).
26395!
26396 else if ( start == 1 ) then
26397
26398 left = -1
26399 right = start
26400 return
26401!
26402! XVAL = X(START-1)?
26403!
26404 else if ( xval == x(start-1) ) then
26405
26406 left = start - 1
26407 right = start - 1
26408 return
26409!
26410! X(START-1) < XVAL < X(START)?
26411!
26412 else if ( x(start-1) <= xval ) then
26413
26414 left = start - 1
26415 right = start
26416 return
26417!
26418! Binary search for XVAL in [ X(1), X(START-1) ],
26419! where XVAL is guaranteed to be less than X(START-1).
26420!
26421 else
26422
26423 low = 1
26424 high = start - 1
26425 call r8vec_bracket ( high + 1 - low, x(1), xval, left, right )
26426
26427 end if
26428
26429 return
r8vec_bracket
subroutine r8vec_bracket(n, x, xval, left, right)
Definition R8LIB.f90:26161

References r8vec_bracket().

Here is the call graph for this function:

◆ r8vec_bracket3()

subroutine r8vec_bracket3 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  t,
real ( kind = 8 )  tval,
integer ( kind = 4 )  left 
)

Definition at line 26431 of file R8LIB.f90.

26432
26433!*****************************************************************************80
26434!
26435!! R8VEC_BRACKET3 finds the interval containing or nearest a given value.
26436!
26437! Discussion:
26438!
26439! An R8VEC is a vector of R8's.
26440!
26441! The routine always returns the index LEFT of the sorted array
26442! T with the property that either
26443! * T is contained in the interval [ T(LEFT), T(LEFT+1) ], or
26444! * T < T(LEFT) = T(1), or
26445! * T > T(LEFT+1) = T(N).
26446!
26447! The routine is useful for interpolation problems, where
26448! the abscissa must be located within an interval of data
26449! abscissas for interpolation, or the "nearest" interval
26450! to the (extreme) abscissa must be found so that extrapolation
26451! can be carried out.
26452!
26453! Licensing:
26454!
26455! This code is distributed under the GNU LGPL license.
26456!
26457! Modified:
26458!
26459! 05 April 1999
26460!
26461! Author:
26462!
26463! John Burkardt
26464!
26465! Parameters:
26466!
26467! Input, integer ( kind = 4 ) N, length of the input array.
26468!
26469! Input, real ( kind = 8 ) T(N), an array that has been sorted
26470! into ascending order.
26471!
26472! Input, real ( kind = 8 ) TVAL, a value to be bracketed by entries of T.
26473!
26474! Input/output, integer ( kind = 4 ) LEFT.
26475! On input, if 1 <= LEFT <= N-1, LEFT is taken as a suggestion for the
26476! interval [ T(LEFT), T(LEFT+1) ] in which TVAL lies. This interval
26477! is searched first, followed by the appropriate interval to the left
26478! or right. After that, a binary search is used.
26479! On output, LEFT is set so that the interval [ T(LEFT), T(LEFT+1) ]
26480! is the closest to TVAL; it either contains TVAL, or else TVAL
26481! lies outside the interval [ T(1), T(N) ].
26482!
26483 implicit none
26484
26485 integer ( kind = 4 ) n
26486
26487 integer ( kind = 4 ) high
26488 integer ( kind = 4 ) left
26489 integer ( kind = 4 ) low
26490 integer ( kind = 4 ) mid
26491 real ( kind = 8 ) t(n)
26492 real ( kind = 8 ) tval
26493!
26494! Check the input data.
26495!
26496 if ( n < 2 ) then
26497 write ( *, '(a)' ) ' '
26498 write ( *, '(a)' ) 'R8VEC_BRACKET3 - Fatal error!'
26499 write ( *, '(a)' ) ' N must be at least 2.'
26500 stop 1
26501 end if
26502!
26503! If LEFT is not between 1 and N-1, set it to the middle value.
26504!
26505 if ( left < 1 .or. n - 1 < left ) then
26506 left = ( n + 1 ) / 2
26507 end if
26508!
26509! CASE 1: TVAL < T(LEFT):
26510! Search for TVAL in [T(I), T(I+1)] for intervals I = 1 to LEFT-1.
26511!
26512 if ( tval < t(left) ) then
26513
26514 if ( left == 1 ) then
26515 return
26516 else if ( left == 2 ) then
26517 left = 1
26518 return
26519 else if ( t(left-1) <= tval ) then
26520 left = left - 1
26521 return
26522 else if ( tval <= t(2) ) then
26523 left = 1
26524 return
26525 end if
26526!
26527! ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = 2 to LEFT-2.
26528!
26529 low = 2
26530 high = left - 2
26531
26532 do
26533
26534 if ( low == high ) then
26535 left = low
26536 return
26537 end if
26538
26539 mid = ( low + high + 1 ) / 2
26540
26541 if ( t(mid) <= tval ) then
26542 low = mid
26543 else
26544 high = mid - 1
26545 end if
26546
26547 end do
26548!
26549! CASE2: T(LEFT+1) < TVAL:
26550! Search for TVAL in [T(I),T(I+1)] for intervals I = LEFT+1 to N-1.
26551!
26552 else if ( t(left+1) < tval ) then
26553
26554 if ( left == n - 1 ) then
26555 return
26556 else if ( left == n - 2 ) then
26557 left = left + 1
26558 return
26559 else if ( tval <= t(left+2) ) then
26560 left = left + 1
26561 return
26562 else if ( t(n-1) <= tval ) then
26563 left = n - 1
26564 return
26565 end if
26566!
26567! ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = LEFT+2 to N-2.
26568!
26569 low = left + 2
26570 high = n - 2
26571
26572 do
26573
26574 if ( low == high ) then
26575 left = low
26576 return
26577 end if
26578
26579 mid = ( low + high + 1 ) / 2
26580
26581 if ( t(mid) <= tval ) then
26582 low = mid
26583 else
26584 high = mid - 1
26585 end if
26586
26587 end do
26588!
26589! CASE3: T(LEFT) <= TVAL <= T(LEFT+1):
26590! T is in [T(LEFT), T(LEFT+1)], as the user said it might be.
26591!
26592 else
26593
26594 end if
26595
26596 return

◆ r8vec_bracket4()

subroutine r8vec_bracket4 ( integer ( kind = 4 )  nt,
real ( kind = 8 ), dimension(nt)  t,
integer ( kind = 4 )  ns,
real ( kind = 8 ), dimension(ns)  s,
integer ( kind = 4 ), dimension(ns)  left 
)

Definition at line 26598 of file R8LIB.f90.

26599
26600!*****************************************************************************80
26601!
26602!! R8VEC_BRACKET4 finds the nearest interval to each of a vector of values.
26603!
26604! Discussion:
26605!
26606! An R8VEC is a vector of R8's.
26607!
26608! The routine always returns the index LEFT of the sorted array
26609! T with the property that either
26610! * T is contained in the interval [ T(LEFT), T(LEFT+1) ], or
26611! * T < T(LEFT) = T(1), or
26612! * T > T(LEFT+1) = T(NT).
26613!
26614! The routine is useful for interpolation problems, where
26615! the abscissa must be located within an interval of data
26616! abscissas for interpolation, or the "nearest" interval
26617! to the (extreme) abscissa must be found so that extrapolation
26618! can be carried out.
26619!
26620! Licensing:
26621!
26622! This code is distributed under the GNU LGPL license.
26623!
26624! Modified:
26625!
26626! 25 April 2009
26627!
26628! Author:
26629!
26630! John Burkardt
26631!
26632! Parameters:
26633!
26634! Input, integer ( kind = 4 ) NT, length of the input array.
26635!
26636! Input, real ( kind = 8 ) T(NT), an array that has been sorted
26637! into ascending order.
26638!
26639! Input, integer ( kind = 4 ) NS, the number of points to be bracketed.
26640!
26641! Input, real ( kind = 8 ) S(NS), values to be bracketed by entries of T.
26642!
26643! Output, integer ( kind = 4 ) LEFT(NS).
26644! LEFT(I) is set so that the interval [ T(LEFT(I)), T(LEFT(I)+1) ]
26645! is the closest to S(I); it either contains S(I), or else S(I)
26646! lies outside the interval [ T(1), T(NT) ].
26647!
26648 implicit none
26649
26650 integer ( kind = 4 ) ns
26651 integer ( kind = 4 ) nt
26652
26653 integer ( kind = 4 ) high
26654 integer ( kind = 4 ) i
26655 integer ( kind = 4 ) left(ns)
26656 integer ( kind = 4 ) low
26657 integer ( kind = 4 ) mid
26658 real ( kind = 8 ) s(ns)
26659 real ( kind = 8 ) t(nt)
26660!
26661! Check the input data.
26662!
26663 if ( nt < 2 ) then
26664 write ( *, '(a)' ) ' '
26665 write ( *, '(a)' ) 'R8VEC_BRACKET4 - Fatal error!'
26666 write ( *, '(a)' ) ' NT must be at least 2.'
26667 stop 1
26668 end if
26669
26670 do i = 1, ns
26671
26672 left(i) = ( nt + 1 ) / 2
26673!
26674! CASE 1: S < T(LEFT):
26675! Search for S in [T(I), T(I+1)] for intervals I = 1 to LEFT-1.
26676!
26677 if ( s(i) < t(left(i)) ) then
26678
26679 if ( left(i) == 1 ) then
26680 cycle
26681 else if ( left(i) == 2 ) then
26682 left(i) = 1
26683 cycle
26684 else if ( t(left(i)-1) <= s(i) ) then
26685 left(i) = left(i) - 1
26686 cycle
26687 else if ( s(i) <= t(2) ) then
26688 left(i) = 1
26689 cycle
26690 end if
26691!
26692! ...Binary search for S in [T(I), T(I+1)] for intervals I = 2 to LEFT-2.
26693!
26694 low = 2
26695 high = left(i) - 2
26696
26697 do
26698
26699 if ( low == high ) then
26700 left(i) = low
26701 exit
26702 end if
26703
26704 mid = ( low + high + 1 ) / 2
26705
26706 if ( t(mid) <= s(i) ) then
26707 low = mid
26708 else
26709 high = mid - 1
26710 end if
26711
26712 end do
26713!
26714! CASE2: T(LEFT+1) < S:
26715! Search for S in [T(I),T(I+1)] for intervals I = LEFT+1 to N-1.
26716!
26717 else if ( t(left(i)+1) < s(i) ) then
26718
26719 if ( left(i) == nt - 1 ) then
26720 cycle
26721 else if ( left(i) == nt - 2 ) then
26722 left(i) = left(i) + 1
26723 cycle
26724 else if ( s(i) <= t(left(i)+2) ) then
26725 left(i) = left(i) + 1
26726 cycle
26727 else if ( t(nt-1) <= s(i) ) then
26728 left(i) = nt - 1
26729 cycle
26730 end if
26731!
26732! ...Binary search for S in [T(I), T(I+1)] for intervals I = LEFT+2 to NT-2.
26733!
26734 low = left(i) + 2
26735 high = nt - 2
26736
26737 do
26738
26739 if ( low == high ) then
26740 left(i) = low
26741 exit
26742 end if
26743
26744 mid = ( low + high + 1 ) / 2
26745
26746 if ( t(mid) <= s(i) ) then
26747 low = mid
26748 else
26749 high = mid - 1
26750 end if
26751
26752 end do
26753!
26754! CASE3: T(LEFT) <= S <= T(LEFT+1):
26755! S is in [T(LEFT), T(LEFT+1)].
26756!
26757 else
26758
26759 end if
26760
26761 end do
26762
26763 return

◆ r8vec_bracket5()

integer ( kind = 4 ) function r8vec_bracket5 ( integer ( kind = 4 )  nd,
real ( kind = 8 ), dimension(nd)  xd,
real ( kind = 8 )  xi 
)

Definition at line 26765 of file R8LIB.f90.

26766
26767!*****************************************************************************80
26768!
26769!! R8VEC_BRACKET5 brackets data between successive entries of a sorted R8VEC.
26770!
26771! Discussion:
26772!
26773! We assume XD is sorted.
26774!
26775! If XI is contained in the interval [XD(1),XD(N)], then the returned
26776! value B indicates that XI is contained in [ XD(B), XD(B+1) ].
26777!
26778! If XI is not contained in the interval [XD(1),XD(N)], then B = -1.
26779!
26780! This code implements a version of binary search which is perhaps more
26781! understandable than the usual ones.
26782!
26783! Licensing:
26784!
26785! This code is distributed under the GNU LGPL license.
26786!
26787! Modified:
26788!
26789! 14 October 2012
26790!
26791! Author:
26792!
26793! John Burkardt
26794!
26795! Parameters:
26796!
26797! Input, integer ( kind = 4 ) ND, the number of data values.
26798!
26799! Input, real ( kind = 8 ) XD(N), the sorted data.
26800!
26801! Input, real ( kind = 8 ) XD, the query value.
26802!
26803! Output, integer ( kind = 4 ) R8VEC_BRACKET5, the bracket information.
26804!
26805 implicit none
26806
26807 integer ( kind = 4 ) nd
26808
26809 integer ( kind = 4 ) b
26810 integer ( kind = 4 ) l
26811 integer ( kind = 4 ) m
26812 integer ( kind = 4 ) r
26813 integer ( kind = 4 ) r8vec_bracket5
26814 real ( kind = 8 ) xd(nd)
26815 real ( kind = 8 ) xi
26816
26817 if ( xi < xd(1) .or. xd(nd) < xi ) then
26818
26819 b = -1
26820
26821 else
26822
26823 l = 1
26824 r = nd
26825
26826 do while ( l + 1 < r )
26827 m = ( l + r ) / 2
26828 if ( xi < xd(m) ) then
26829 r = m
26830 else
26831 l = m
26832 end if
26833 end do
26834
26835 b = l
26836
26837 end if
26838
26839 r8vec_bracket5 = b
26840
26841 return
r8vec_bracket5
integer(kind=4) function r8vec_bracket5(nd, xd, xi)
Definition R8LIB.f90:26766

References r8vec_bracket5().

Referenced by r8vec_bracket5().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_bracket6()

subroutine r8vec_bracket6 ( integer ( kind = 4 )  nd,
real ( kind = 8 ), dimension(nd)  xd,
integer ( kind = 4 )  ni,
real ( kind = 8 ), dimension(ni)  xi,
integer ( kind = 4 ), dimension(ni)  b 
)

Definition at line 26843 of file R8LIB.f90.

26844
26845!*****************************************************************************80
26846!
26847!! R8VEC_BRACKET6 brackets data between successive entries of a sorted R8VEC.
26848!
26849! Discussion:
26850!
26851! We assume XD is sorted.
26852!
26853! If XI(I) is contained in the interval [XD(1),XD(N)], then the value of
26854! B(I) indicates that XI(I) is contained in [ XD(B(I)), XD(B(I)+1) ].
26855!
26856! If XI(I) is not contained in the interval [XD(1),XD(N)], then B(I) = -1.
26857!
26858! This code implements a version of binary search which is perhaps more
26859! understandable than the usual ones.
26860!
26861! Licensing:
26862!
26863! This code is distributed under the GNU LGPL license.
26864!
26865! Modified:
26866!
26867! 14 October 2012
26868!
26869! Author:
26870!
26871! John Burkardt
26872!
26873! Parameters:
26874!
26875! Input, integer ( kind = 4 ) ND, the number of data values.
26876!
26877! Input, real ( kind = 8 ) XD(N), the sorted data.
26878!
26879! Input, integer ( kind = 4 ) NI, the number of inquiry values.
26880!
26881! Input, real ( kind = 8 ) XD(NI), the query values.
26882!
26883! Output, integer ( kind = 4 ) B(NI), the bracket information.
26884!
26885 implicit none
26886
26887 integer ( kind = 4 ) nd
26888 integer ( kind = 4 ) ni
26889
26890 integer ( kind = 4 ) b(ni)
26891 integer ( kind = 4 ) i
26892 integer ( kind = 4 ) l
26893 integer ( kind = 4 ) m
26894 integer ( kind = 4 ) r
26895 real ( kind = 8 ) xd(nd)
26896 real ( kind = 8 ) xi(ni)
26897
26898 do i = 1, ni
26899
26900 if ( xi(i) < xd(1) .or. xd(nd) < xi(i) ) then
26901
26902 b(i) = -1
26903
26904 else
26905
26906 l = 1
26907 r = nd
26908
26909 do while ( l + 1 < r )
26910 m = ( l + r ) / 2
26911 if ( xi(i) < xd(m) ) then
26912 r = m
26913 else
26914 l = m
26915 end if
26916 end do
26917
26918 b(i) = l
26919
26920 end if
26921
26922 end do
26923
26924 return

◆ r8vec_ceiling()

subroutine r8vec_ceiling ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r8vec,
real ( kind = 8 ), dimension(n)  ceilingvec 
)

Definition at line 26926 of file R8LIB.f90.

26927
26928!*****************************************************************************80
26929!
26930!! R8VEC_CEILING rounds "up" (towards +oo) entries of an R8VEC.
26931!
26932! Example:
26933!
26934! R8 Value
26935!
26936! -1.1 -1.0
26937! -1.0 -1.0
26938! -0.9 0.0
26939! 0.0 0.0
26940! 5.0 5.0
26941! 5.1 6.0
26942! 5.9 6.0
26943! 6.0 6.0
26944!
26945! Licensing:
26946!
26947! This code is distributed under the GNU LGPL license.
26948!
26949! Modified:
26950!
26951! 10 November 2011
26952!
26953! Author:
26954!
26955! John Burkardt
26956!
26957! Parameters:
26958!
26959! Input, integer ( kind = 4 ) N, the number of entries.
26960!
26961! Input, real ( kind = 8 ) R8VEC(N), the vector.
26962!
26963! Output, real ( kind = 8 ) CEILINGVEC(N), the rounded values.
26964!
26965 implicit none
26966
26967 integer ( kind = 4 ) n
26968
26969 real ( kind = 8 ) ceilingvec(n)
26970 integer ( kind = 4 ) i
26971 real ( kind = 8 ) r8vec(n)
26972 real ( kind = 8 ) value
26973
26974 do i = 1, n
26975
26976 value = real( int( r8vec(i) ), kind = 8 )
26977
26978 if ( value < r8vec(i) ) then
26979 value = value + 1.0d+00
26980 end if
26981
26982 ceilingvec(i) = value
26983
26984 end do
26985
26986 return

◆ r8vec_cheby1space()

subroutine r8vec_cheby1space ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 27059 of file R8LIB.f90.

27060
27061!*****************************************************************************80
27062!
27063!! R8VEC_CHEBY1SPACE creates Type 1 Chebyshev spaced values in [A,B].
27064!
27065! Discussion:
27066!
27067! An R8VEC is a vector of R8's.
27068!
27069! Licensing:
27070!
27071! This code is distributed under the GNU LGPL license.
27072!
27073! Modified:
27074!
27075! 17 September 2012
27076!
27077! Author:
27078!
27079! John Burkardt
27080!
27081! Parameters:
27082!
27083! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27084!
27085! Input, real ( kind = 8 ) A, B, the first and last entries.
27086!
27087! Output, real ( kind = 8 ) X(N), a vector of Chebyshev spaced data.
27088!
27089 implicit none
27090
27091 integer ( kind = 4 ) n
27092
27093 real ( kind = 8 ) a
27094 real ( kind = 8 ) b
27095 real ( kind = 8 ) c
27096 integer ( kind = 4 ) i
27097 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
27098 real ( kind = 8 ) theta
27099 real ( kind = 8 ) x(n)
27100
27101 if ( n == 1 ) then
27102
27103 x(1) = ( a + b ) / 2.0d+00
27104
27105 else
27106
27107 do i = 1, n
27108
27109 theta = real( 2 * ( n - i ) + 1, kind = 8 ) * r8_pi &
27110 / real( 2 * n, kind = 8 )
27111
27112 c = cos( theta )
27113
27114 if ( mod( n, 2 ) == 1 ) then
27115 if ( 2 * i - 1 == n ) then
27116 c = 0.0d+00
27117 end if
27118 end if
27119
27120 x(i) = ( ( 1.0d+00 - c ) * a &
27121 + ( 1.0d+00 + c ) * b ) &
27122 / 2.0d+00
27123
27124 end do
27125
27126 end if
27127
27128 return

References r8_pi().

Here is the call graph for this function:

◆ r8vec_cheby2space()

subroutine r8vec_cheby2space ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 27130 of file R8LIB.f90.

27131
27132!*****************************************************************************80
27133!
27134!! R8VEC_CHEBY2SPACE creates Type 2 Chebyshev spaced values in [A,B].
27135!
27136! Discussion:
27137!
27138! An R8VEC is a vector of R8's.
27139!
27140! Licensing:
27141!
27142! This code is distributed under the GNU LGPL license.
27143!
27144! Modified:
27145!
27146! 17 September 2012
27147!
27148! Author:
27149!
27150! John Burkardt
27151!
27152! Parameters:
27153!
27154! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27155!
27156! Input, real ( kind = 8 ) A, B, the first and last entries.
27157!
27158! Output, real ( kind = 8 ) X(N), a vector of Chebyshev spaced data.
27159!
27160 implicit none
27161
27162 integer ( kind = 4 ) n
27163
27164 real ( kind = 8 ) a
27165 real ( kind = 8 ) b
27166 real ( kind = 8 ) c
27167 integer ( kind = 4 ) i
27168 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
27169 real ( kind = 8 ) theta
27170 real ( kind = 8 ) x(n)
27171
27172 if ( n == 1 ) then
27173
27174 x(1) = ( a + b ) / 2.0d+00
27175
27176 else
27177
27178 do i = 1, n
27179
27180 theta = real( n - i, kind = 8 ) * r8_pi / real( n - 1, kind = 8 )
27181
27182 c = cos( theta )
27183
27184 if ( mod( n, 2 ) == 1 ) then
27185 if ( 2 * i - 1 == n ) then
27186 c = 0.0d+00
27187 end if
27188 end if
27189
27190 x(i) = ( ( 1.0d+00 - c ) * a &
27191 + ( 1.0d+00 + c ) * b ) &
27192 / 2.0d+00
27193
27194 end do
27195
27196 end if
27197
27198 return

References r8_pi().

Here is the call graph for this function:

◆ r8vec_chebyspace()

subroutine r8vec_chebyspace ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 26988 of file R8LIB.f90.

26989
26990!*****************************************************************************80
26991!
26992!! R8VEC_CHEBYSPACE creates a vector of Chebyshev spaced values in [A,B].
26993!
26994! Discussion:
26995!
26996! An R8VEC is a vector of R8's.
26997!
26998! Licensing:
26999!
27000! This code is distributed under the GNU LGPL license.
27001!
27002! Modified:
27003!
27004! 08 June 2011
27005!
27006! Author:
27007!
27008! John Burkardt
27009!
27010! Parameters:
27011!
27012! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27013!
27014! Input, real ( kind = 8 ) A, B, the interval.
27015!
27016! Output, real ( kind = 8 ) X(N), a vector of Chebyshev spaced data.
27017!
27018 implicit none
27019
27020 integer ( kind = 4 ) n
27021
27022 real ( kind = 8 ) a
27023 real ( kind = 8 ) b
27024 real ( kind = 8 ) c
27025 integer ( kind = 4 ) i
27026 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
27027 real ( kind = 8 ) theta
27028 real ( kind = 8 ) x(n)
27029
27030 if ( n == 1 ) then
27031
27032 x(1) = ( a + b ) / 2.0d+00
27033
27034 else
27035
27036 do i = 1, n
27037
27038 theta = real( n - i, kind = 8 ) * r8_pi &
27039 / real( n - 1, kind = 8 )
27040
27041 c = cos( theta )
27042
27043 if ( mod( n, 2 ) == 1 ) then
27044 if ( 2 * i - 1 == n ) then
27045 c = 0.0d+00
27046 end if
27047 end if
27048
27049 x(i) = ( ( 1.0d+00 - c ) * a &
27050 + ( 1.0d+00 + c ) * b ) &
27051 / 2.0d+00
27052
27053 end do
27054
27055 end if
27056
27057 return

References r8_pi().

Here is the call graph for this function:

◆ r8vec_circular_variance()

subroutine r8vec_circular_variance ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 )  circular_variance 
)

Definition at line 27200 of file R8LIB.f90.

27201
27202!*****************************************************************************80
27203!
27204!! R8VEC_CIRCULAR_VARIANCE returns the circular variance of an R8VEC.
27205!
27206! Discussion:
27207!
27208! An R8VEC is a vector of R8's.
27209!
27210! Licensing:
27211!
27212! This code is distributed under the GNU LGPL license.
27213!
27214! Modified:
27215!
27216! 02 December 2004
27217!
27218! Author:
27219!
27220! John Burkardt
27221!
27222! Parameters:
27223!
27224! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27225!
27226! Input, real ( kind = 8 ) X(N), the vector whose variance is desired.
27227!
27228! Output, real ( kind = 8 ) CIRCULAR VARIANCE, the circular variance
27229! of the vector entries.
27230!
27231 implicit none
27232
27233 integer ( kind = 4 ) n
27234
27235 real ( kind = 8 ) circular_variance
27236 real ( kind = 8 ) mean
27237 real ( kind = 8 ) x(n)
27238
27239 call r8vec_mean ( n, x, mean )
27240
27241 circular_variance = &
27242 ( sum( cos( x(1:n) - mean ) ) )**2 &
27243 + ( sum( sin( x(1:n) - mean ) ) )**2
27244
27245 circular_variance = sqrt( circular_variance ) / real( n, kind = 8 )
27246
27247 circular_variance = 1.0d+00 - circular_variance
27248
27249 return
r8vec_mean
subroutine r8vec_mean(n, a, mean)
Definition R8LIB.f90:32664

References r8vec_mean().

Here is the call graph for this function:

◆ r8vec_compare()

subroutine r8vec_compare ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2,
integer ( kind = 4 )  isgn 
)

Definition at line 27251 of file R8LIB.f90.

27252
27253!*****************************************************************************80
27254!
27255!! R8VEC_COMPARE compares two R8VEC's.
27256!
27257! Discussion:
27258!
27259! An R8VEC is a vector of R8's.
27260!
27261! The lexicographic ordering is used.
27262!
27263! Example:
27264!
27265! Input:
27266!
27267! A1 = ( 2.0, 6.0, 2.0 )
27268! A2 = ( 2.0, 8.0, 12.0 )
27269!
27270! Output:
27271!
27272! ISGN = -1
27273!
27274! Licensing:
27275!
27276! This code is distributed under the GNU LGPL license.
27277!
27278! Modified:
27279!
27280! 23 February 1999
27281!
27282! Author:
27283!
27284! John Burkardt
27285!
27286! Parameters:
27287!
27288! Input, integer ( kind = 4 ) N, the number of entries in the vectors.
27289!
27290! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared.
27291!
27292! Output, integer ( kind = 4 ) ISGN, the results of the comparison:
27293! -1, A1 < A2,
27294! 0, A1 = A2,
27295! +1, A1 > A2.
27296!
27297 implicit none
27298
27299 integer ( kind = 4 ) n
27300
27301 real ( kind = 8 ) a1(n)
27302 real ( kind = 8 ) a2(n)
27303 integer ( kind = 4 ) isgn
27304 integer ( kind = 4 ) k
27305
27306 isgn = 0
27307
27308 k = 1
27309
27310 do while ( k <= n )
27311
27312 if ( a1(k) < a2(k) ) then
27313 isgn = -1
27314 return
27315 else if ( a2(k) < a1(k) ) then
27316 isgn = + 1
27317 return
27318 end if
27319
27320 k = k + 1
27321
27322 end do
27323
27324 return

Referenced by r8col_sort_heap_index_a(), and r8row_sort_heap_index_a().

Here is the caller graph for this function:

◆ r8vec_concatenate()

subroutine r8vec_concatenate ( integer ( kind = 4 )  n1,
real ( kind = 8 ), dimension(n1)  a,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(n2)  b,
real ( kind = 8 ), dimension(n1+n2)  c 
)

Definition at line 27326 of file R8LIB.f90.

27327
27328!*****************************************************************************80
27329!
27330!! R8VEC_CONCATENATE concatenates two R8VEC's.
27331!
27332! Discussion:
27333!
27334! An R8VEC is a vector of R8 values.
27335!
27336! Licensing:
27337!
27338! This code is distributed under the GNU LGPL license.
27339!
27340! Modified:
27341!
27342! 22 November 2013
27343!
27344! Author:
27345!
27346! John Burkardt
27347!
27348! Parameters:
27349!
27350! Input, integer ( kind = 4 ) N1, the number of entries in the first vector.
27351!
27352! Input, real ( kind = 8 ) A(N1), the first vector.
27353!
27354! Input, integer ( kind = 4 ) N2, the number of entries in the second vector.
27355!
27356! Input, real ( kind = 8 ) B(N2), the second vector.
27357!
27358! Output, real ( kind = 8 ) C(N1+N2), the concatenation of A and B.
27359!
27360 implicit none
27361
27362 integer ( kind = 4 ) n1
27363 integer ( kind = 4 ) n2
27364
27365 real ( kind = 8 ) a(n1)
27366 real ( kind = 8 ) b(n2)
27367 real ( kind = 8 ) c(n1+n2)
27368
27369 c( 1:n1) = a(1:n1)
27370 c(n1+1:n1+n2) = b(1:n2)
27371
27372 return

◆ r8vec_convolution()

subroutine r8vec_convolution ( integer ( kind = 4 )  m,
real ( kind = 8 ), dimension(m)  x,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 ), dimension(m+n-1)  z 
)

Definition at line 27374 of file R8LIB.f90.

27375
27376!*****************************************************************************80
27377!
27378!! R8VEC_CONVOLUTION returns the convolution of two R8VEC's.
27379!
27380! Discussion:
27381!
27382! An R8VEC is a vector of R8's.
27383!
27384! The I-th entry of the convolution can be formed by summing the products
27385! that lie along the I-th diagonal of the following table:
27386!
27387! Y3 | 3 4 5 6 7
27388! Y2 | 2 3 4 5 6
27389! Y1 | 1 2 3 4 5
27390! +------------------
27391! X1 X2 X3 X4 X5
27392!
27393! which will result in:
27394!
27395! Z = ( X1 * Y1,
27396! X1 * Y2 + X2 * Y1,
27397! X1 * Y3 + X2 * Y2 + X3 * Y1,
27398! X2 * Y3 + X3 * Y2 + X4 * Y1,
27399! X3 * Y3 + X4 * Y2 + X5 * Y1,
27400! X4 * Y3 + X5 * Y2,
27401! X5 * Y3 )
27402!
27403! Example:
27404!
27405! Input:
27406!
27407! X = (/ 1, 2, 3, 4 /)
27408! Y = (/ -1, 5, 3 /)
27409!
27410! Output:
27411!
27412! Z = (/ -1, 3, 10, 17, 29, 12 /)
27413!
27414! Licensing:
27415!
27416! This code is distributed under the GNU LGPL license.
27417!
27418! Modified:
27419!
27420! 05 May 2012
27421!
27422! Author:
27423!
27424! John Burkardt
27425!
27426! Parameters:
27427!
27428! Input, integer ( kind = 4 ) M, the dimension of X.
27429!
27430! Input, real ( kind = 8 ) X(M), the first vector to be convolved.
27431!
27432! Input, integer ( kind = 4 ) N, the dimension of Y.
27433!
27434! Input, real ( kind = 8 ) Y(N), the second vector to be convolved.
27435!
27436! Output, real ( kind = 8 ) Z(M+N-1), the convolution of X and Y.
27437!
27438 implicit none
27439
27440 integer ( kind = 4 ) m
27441 integer ( kind = 4 ) n
27442
27443 integer ( kind = 4 ) j
27444 real ( kind = 8 ) x(m)
27445 real ( kind = 8 ) y(n)
27446 real ( kind = 8 ) z(m+n-1)
27447
27448 z(1:m+n-1) = 0.0d+00
27449
27450 do j = 1, n
27451 z(j:j+m-1) = z(j:j+m-1) + x(1:m) * y(j)
27452 end do
27453
27454 return

◆ r8vec_convolution_circ()

subroutine r8vec_convolution_circ ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 ), dimension(n)  z 
)

Definition at line 27456 of file R8LIB.f90.

27457
27458!*****************************************************************************80
27459!
27460!! R8VEC_CONVOLUTION_CIRC: discrete circular convolution of two R8VEC's.
27461!
27462! Discussion:
27463!
27464! An R8VEC is a vector of R8's.
27465!
27466! The formula used is:
27467!
27468! z(1+m) = xCCy(m) = sum ( 0 <= k <= n-1 ) x(1+k) * y(1+m-k)
27469!
27470! Here, if the index of Y becomes nonpositive, it is "wrapped around"
27471! by having N added to it.
27472!
27473! The circular convolution is equivalent to multiplication of Y by a
27474! circulant matrix formed from the vector X.
27475!
27476! Example:
27477!
27478! Input:
27479!
27480! X = (/ 1, 2, 3, 4 /)
27481! Y = (/ 1, 2, 4, 8 /)
27482!
27483! Output:
27484!
27485! Circulant form:
27486!
27487! Z = ( 1 4 3 2 ) ( 1 )
27488! ( 2 1 4 3 ) ( 2 )
27489! ( 3 2 1 4 ) * ( 4 )
27490! ( 4 3 2 1 ) ( 8 )
27491!
27492! The formula:
27493!
27494! Z = (/ 1*1 + 2*8 + 3*4 + 4*2,
27495! 1*2 + 2*1 + 3*8 + 4*4,
27496! 1*4 + 2*2 + 3*1 + 4*8,
27497! 1*8 + 2*4 + 3*2 + 4*1 /)
27498!
27499! Result:
27500!
27501! Z = (/ 37, 44, 43, 26 /)
27502!
27503! Licensing:
27504!
27505! This code is distributed under the GNU LGPL license.
27506!
27507! Modified:
27508!
27509! 23 September 2000
27510!
27511! Author:
27512!
27513! John Burkardt
27514!
27515! Parameters:
27516!
27517! Input, integer ( kind = 4 ) N, the dimension of the vectors.
27518!
27519! Input, real ( kind = 8 ) X(N), Y(N), the vectors to be convolved.
27520!
27521! Output, real ( kind = 8 ) Z(N), the circular convolution of X and Y.
27522!
27523 implicit none
27524
27525 integer ( kind = 4 ) n
27526
27527 integer ( kind = 4 ) m
27528 real ( kind = 8 ) x(n)
27529 real ( kind = 8 ) y(n)
27530 real ( kind = 8 ) z(n)
27531
27532 do m = 1, n
27533 z(m) = dot_product( x(1:m), y(m:1:-1) ) &
27534 + dot_product( x(m+1:n), y(n:m+1:-1) )
27535 end do
27536
27537 return

◆ r8vec_copy()

subroutine r8vec_copy ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 27539 of file R8LIB.f90.

27540
27541!*****************************************************************************80
27542!
27543!! R8VEC_COPY copies an R8VEC.
27544!
27545! Discussion:
27546!
27547! An R8VEC is a vector of R8's.
27548!
27549! Licensing:
27550!
27551! This code is distributed under the GNU LGPL license.
27552!
27553! Modified:
27554!
27555! 17 September 2005
27556!
27557! Author:
27558!
27559! John Burkardt
27560!
27561! Parameters:
27562!
27563! Input, integer ( kind = 4 ) N, the length of the vectors.
27564!
27565! Input, real ( kind = 8 ) A1(N), the vector to be copied.
27566!
27567! Output, real ( kind = 8 ) A2(N), a copy of A1.
27568!
27569 implicit none
27570
27571 integer ( kind = 4 ) n
27572
27573 real ( kind = 8 ) a1(n)
27574 real ( kind = 8 ) a2(n)
27575
27576 a2(1:n) = a1(1:n)
27577
27578 return

◆ r8vec_correlation()

subroutine r8vec_correlation ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 )  correlation 
)

Definition at line 27580 of file R8LIB.f90.

27581
27582!*****************************************************************************80
27583!
27584!! R8VEC_CORRELATION returns the correlation of two R8VEC's.
27585!
27586! Discussion:
27587!
27588! An R8VEC is a vector of R8's.
27589!
27590! If X and Y are two nonzero vectors of length N, then
27591!
27592! correlation = (x/||x||)' (y/||y||)
27593!
27594! It is the cosine of the angle between the two vectors.
27595!
27596! Licensing:
27597!
27598! This code is distributed under the GNU LGPL license.
27599!
27600! Modified:
27601!
27602! 21 August 2010
27603!
27604! Author:
27605!
27606! John Burkardt
27607!
27608! Parameters:
27609!
27610! Input, integer ( kind = 4 ) N, the dimension of the vectors.
27611!
27612! Input, real ( kind = 8 ) X(N), Y(N), the vectors to be convolved.
27613!
27614! Output, real ( kind = 8 ) CORRELATION, the correlation of X and Y.
27615!
27616 implicit none
27617
27618 integer ( kind = 4 ) n
27619
27620 real ( kind = 8 ) correlation
27621 real ( kind = 8 ) r8vec_norm
27622 real ( kind = 8 ) x(n)
27623 real ( kind = 8 ) x_norm
27624 real ( kind = 8 ) xy_dot
27625 real ( kind = 8 ) y(n)
27626 real ( kind = 8 ) y_norm
27627
27628 x_norm = r8vec_norm( n, x )
27629 y_norm = r8vec_norm( n, y )
27630 xy_dot = dot_product( x(1:n), y(1:n) )
27631
27632 if ( x_norm == 0.0d+00 .or. y_norm == 0.0d+00 ) then
27633 correlation = 0.0d+00
27634 else
27635 correlation = xy_dot / x_norm / y_norm
27636 end if
27637
27638 return

References r8vec_norm().

Here is the call graph for this function:

◆ r8vec_covar()

real ( kind = 8 ) function r8vec_covar ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y 
)

Definition at line 27640 of file R8LIB.f90.

27641
27642!*****************************************************************************80
27643!
27644!! R8VEC_COVAR computes the covariance of two vectors.
27645!
27646! Licensing:
27647!
27648! This code is distributed under the GNU LGPL license.
27649!
27650! Modified:
27651!
27652! 20 April 2013
27653!
27654! Author:
27655!
27656! John Burkardt.
27657!
27658! Parameters:
27659!
27660! Input, real ( kind = 8 ) X(N), Y(N), the two vectors.
27661!
27662! Input, integer ( kind = 4 ) N, the dimension of the two vectors.
27663!
27664! Output, real ( kind = 8 ) R4VEC_COVAR, the covariance of the vectors.
27665!
27666 implicit none
27667
27668 integer ( kind = 4 ) n
27669
27670 integer ( kind = 4 ) i
27671 real ( kind = 8 ) r8vec_covar
27672 real ( kind = 8 ) value
27673 real ( kind = 8 ) x(n)
27674 real ( kind = 8 ) x_average
27675 real ( kind = 8 ) y(n)
27676 real ( kind = 8 ) y_average
27677
27678 x_average = sum( x(1:n) ) / real( n, kind = 8 )
27679 y_average = sum( y(1:n) ) / real( n, kind = 8 )
27680
27681 value = 0.0d+00
27682 do i = 1, n
27683 value = value + ( x(i) - x_average ) * ( y(i) - y_average )
27684 end do
27685
27686 r8vec_covar = value / real( n - 1, kind = 8 )
27687
27688 return
r8vec_covar
real(kind=8) function r8vec_covar(n, x, y)
Definition R8LIB.f90:27641

References r8vec_covar().

Referenced by r8vec_covar().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_cross_product_2d()

real ( kind = 8 ) function r8vec_cross_product_2d ( real ( kind = 8 ), dimension(2)  v1,
real ( kind = 8 ), dimension(2)  v2 
)

Definition at line 27690 of file R8LIB.f90.

27691
27692!*****************************************************************************80
27693!
27694!! R8VEC_CROSS_PRODUCT_2D finds the cross product of a pair of vectors in 2D.
27695!
27696! Discussion:
27697!
27698! Strictly speaking, the vectors V1 and V2 should be considered
27699! to lie in a 3D space, both having Z coordinate zero. The cross
27700! product value V3 then represents the standard cross product vector
27701! (0,0,V3).
27702!
27703! Licensing:
27704!
27705! This code is distributed under the GNU LGPL license.
27706!
27707! Modified:
27708!
27709! 07 August 2005
27710!
27711! Author:
27712!
27713! John Burkardt
27714!
27715! Parameters:
27716!
27717! Input, real ( kind = 8 ) V1(2), V2(2), the vectors.
27718!
27719! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_2D, the cross product.
27720!
27721 implicit none
27722
27723 real ( kind = 8 ) r8vec_cross_product_2d
27724 real ( kind = 8 ) v1(2)
27725 real ( kind = 8 ) v2(2)
27726
27727 r8vec_cross_product_2d = v1(1) * v2(2) - v1(2) * v2(1)
27728
27729 return
r8vec_cross_product_2d
real(kind=8) function r8vec_cross_product_2d(v1, v2)
Definition R8LIB.f90:27691

References r8vec_cross_product_2d().

Referenced by r8vec_cross_product_2d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_cross_product_3d()

subroutine r8vec_cross_product_3d ( real ( kind = 8 ), dimension(3)  v1,
real ( kind = 8 ), dimension(3)  v2,
real ( kind = 8 ), dimension(3)  v3 
)

Definition at line 27778 of file R8LIB.f90.

27779
27780!*****************************************************************************80
27781!
27782!! R8VEC_CROSS_PRODUCT_3D computes the cross product of two R8VEC's in 3D.
27783!
27784! Discussion:
27785!
27786! An R8VEC is a vector of R8's.
27787!
27788! The cross product in 3D can be regarded as the determinant of the
27789! symbolic matrix:
27790!
27791! | i j k |
27792! det | x1 y1 z1 |
27793! | x2 y2 z2 |
27794!
27795! = ( y1 * z2 - z1 * y2 ) * i
27796! + ( z1 * x2 - x1 * z2 ) * j
27797! + ( x1 * y2 - y1 * x2 ) * k
27798!
27799! Licensing:
27800!
27801! This code is distributed under the GNU LGPL license.
27802!
27803! Modified:
27804!
27805! 07 August 2005
27806!
27807! Author:
27808!
27809! John Burkardt
27810!
27811! Parameters:
27812!
27813! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors.
27814!
27815! Output, real ( kind = 8 ) V3(3), the cross product vector.
27816!
27817 implicit none
27818
27819 real ( kind = 8 ) v1(3)
27820 real ( kind = 8 ) v2(3)
27821 real ( kind = 8 ) v3(3)
27822
27823 v3(1) = v1(2) * v2(3) - v1(3) * v2(2)
27824 v3(2) = v1(3) * v2(1) - v1(1) * v2(3)
27825 v3(3) = v1(1) * v2(2) - v1(2) * v2(1)
27826
27827 return

Referenced by r8vec_vector_triple_product().

Here is the caller graph for this function:

◆ r8vec_cross_product_affine_2d()

real ( kind = 8 ) function r8vec_cross_product_affine_2d ( real ( kind = 8 ), dimension(2)  v0,
real ( kind = 8 ), dimension(2)  v1,
real ( kind = 8 ), dimension(2)  v2 
)

Definition at line 27731 of file R8LIB.f90.

27732
27733!*****************************************************************************80
27734!
27735!! R8VEC_CROSS_PRODUCT_AFFINE_2D finds the affine cross product in 2D.
27736!
27737! Discussion:
27738!
27739! Strictly speaking, the vectors V1 and V2 should be considered
27740! to lie in a 3D space, both having Z coordinate zero. The cross
27741! product value V3 then represents the standard cross product vector
27742! (0,0,V3).
27743!
27744! Licensing:
27745!
27746! This code is distributed under the GNU LGPL license.
27747!
27748! Modified:
27749!
27750! 27 October 2010
27751!
27752! Author:
27753!
27754! John Burkardt
27755!
27756! Parameters:
27757!
27758! Input, real ( kind = 8 ) V0(2), the base vector.
27759!
27760! Input, real ( kind = 8 ) V1(2), V2(2), the vectors.
27761!
27762! Output, real ( kind = 8 ) R8VEC_CROSS_PRODUCT_AFFINE_2D,
27763! the cross product (V1-V0) x (V2-V0).
27764!
27765 implicit none
27766
27767 real ( kind = 8 ) r8vec_cross_product_affine_2d
27768 real ( kind = 8 ) v0(2)
27769 real ( kind = 8 ) v1(2)
27770 real ( kind = 8 ) v2(2)
27771
27772 r8vec_cross_product_affine_2d = &
27773 ( v1(1) - v0(1) ) * ( v2(2) - v0(2) ) &
27774 - ( v2(1) - v0(1) ) * ( v1(2) - v0(2) )
27775
27776 return
r8vec_cross_product_affine_2d
real(kind=8) function r8vec_cross_product_affine_2d(v0, v1, v2)
Definition R8LIB.f90:27732

References r8vec_cross_product_affine_2d().

Referenced by r8vec_cross_product_affine_2d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_cross_product_affine_3d()

subroutine r8vec_cross_product_affine_3d ( real ( kind = 8 ), dimension(3)  v0,
real ( kind = 8 ), dimension(3)  v1,
real ( kind = 8 ), dimension(3)  v2,
real ( kind = 8 ), dimension(3)  v3 
)

Definition at line 27829 of file R8LIB.f90.

27830
27831!*****************************************************************************80
27832!
27833!! R8VEC_CROSS_PRODUCT_AFFINE_3D computes the affine cross product in 3D.
27834!
27835! Discussion:
27836!
27837! The cross product in 3D can be regarded as the determinant of the
27838! symbolic matrix:
27839!
27840! | i j k |
27841! det | x1 y1 z1 |
27842! | x2 y2 z2 |
27843!
27844! = ( y1 * z2 - z1 * y2 ) * i
27845! + ( z1 * x2 - x1 * z2 ) * j
27846! + ( x1 * y2 - y1 * x2 ) * k
27847!
27848! Here, we use V0 as the base of an affine system so we compute
27849! the cross product of (V1-V0) and (V2-V0).
27850!
27851! Licensing:
27852!
27853! This code is distributed under the GNU LGPL license.
27854!
27855! Modified:
27856!
27857! 27 October 2010
27858!
27859! Author:
27860!
27861! John Burkardt
27862!
27863! Parameters:
27864!
27865! Input, real ( kind = 8 ) V0(3), the base vector.
27866!
27867! Input, real ( kind = 8 ) V1(3), V2(3), the two vectors.
27868!
27869! Output, real ( kind = 8 ) V3(3), the cross product vector
27870! ( V1-V0) x (V2-V0).
27871!
27872 implicit none
27873
27874 real ( kind = 8 ) v0(3)
27875 real ( kind = 8 ) v1(3)
27876 real ( kind = 8 ) v2(3)
27877 real ( kind = 8 ) v3(3)
27878
27879 v3(1) = ( v1(2) - v0(2) ) * ( v2(3) - v0(3) ) &
27880 - ( v2(2) - v0(2) ) * ( v1(3) - v0(3) )
27881
27882 v3(2) = ( v1(3) - v0(3) ) * ( v2(1) - v0(1) ) &
27883 - ( v2(3) - v0(3) ) * ( v1(1) - v0(1) )
27884
27885 v3(3) = ( v1(1) - v0(1) ) * ( v2(2) - v0(2) ) &
27886 - ( v2(1) - v0(1) ) * ( v1(2) - v0(2) )
27887
27888 return

◆ r8vec_cum()

subroutine r8vec_cum ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  a_cum 
)

Definition at line 27890 of file R8LIB.f90.

27891
27892!*****************************************************************************80
27893!
27894!! R8VEC_CUM computes the cumulutive sums of an R8VEC.
27895!
27896! Discussion:
27897!
27898! An R8VEC is a vector of R8's.
27899!
27900! Input:
27901!
27902! A = (/ 1.0, 2.0, 3.0, 4.0 /)
27903!
27904! Output:
27905!
27906! A_CUM = (/ 1.0, 3.0, 6.0, 10.0 /)
27907!
27908! Licensing:
27909!
27910! This code is distributed under the GNU LGPL license.
27911!
27912! Modified:
27913!
27914! 07 May 2012
27915!
27916! Author:
27917!
27918! John Burkardt
27919!
27920! Parameters:
27921!
27922! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27923!
27924! Input, real ( kind = 8 ) A(N), the vector to be summed.
27925!
27926! Output, real ( kind = 8 ) A_CUM(1:N), the cumulative sums.
27927!
27928 implicit none
27929
27930 integer ( kind = 4 ) n
27931
27932 real ( kind = 8 ) a(n)
27933 real ( kind = 8 ) a_cum(n)
27934 integer ( kind = 4 ) i
27935
27936 a_cum(1) = a(1)
27937
27938 do i = 2, n
27939 a_cum(i) = a_cum(i-1) + a(i)
27940 end do
27941
27942 return

◆ r8vec_cum0()

subroutine r8vec_cum0 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(0:n)  a_cum 
)

Definition at line 27944 of file R8LIB.f90.

27945
27946!*****************************************************************************80
27947!
27948!! R8VEC_CUM0 computes the cumulutive sums of an R8VEC.
27949!
27950! Discussion:
27951!
27952! An R8VEC is a vector of R8's.
27953!
27954! Input:
27955!
27956! A = (/ 1.0, 2.0, 3.0, 4.0 /)
27957!
27958! Output:
27959!
27960! A_CUM = (/ 0.0, 1.0, 3.0, 6.0, 10.0 /)
27961!
27962! Licensing:
27963!
27964! This code is distributed under the GNU LGPL license.
27965!
27966! Modified:
27967!
27968! 07 May 2012
27969!
27970! Author:
27971!
27972! John Burkardt
27973!
27974! Parameters:
27975!
27976! Input, integer ( kind = 4 ) N, the number of entries in the vector.
27977!
27978! Input, real ( kind = 8 ) A(N), the vector to be summed.
27979!
27980! Output, real ( kind = 8 ) A_CUM(0:N), the cumulative sums.
27981!
27982 implicit none
27983
27984 integer ( kind = 4 ) n
27985
27986 real ( kind = 8 ) a(n)
27987 real ( kind = 8 ) a_cum(0:n)
27988 integer ( kind = 4 ) i
27989
27990 a_cum(0) = 0.0d+00
27991
27992 do i = 1, n
27993 a_cum(i) = a_cum(i-1) + a(i)
27994 end do
27995
27996 return

◆ r8vec_dif()

subroutine r8vec_dif ( integer ( kind = 4 )  n,
real ( kind = 8 )  h,
real ( kind = 8 ), dimension(0:n)  cof 
)

Definition at line 27998 of file R8LIB.f90.

27999
28000!*****************************************************************************80
28001!
28002!! R8VEC_DIF computes coefficients for estimating the N-th derivative.
28003!
28004! Discussion:
28005!
28006! An R8VEC is a vector of R8's.
28007!
28008! The routine computes the N+1 coefficients for a centered finite difference
28009! estimate of the N-th derivative of a function.
28010!
28011! The estimate has the form
28012!
28013! FDIF(N,X) = Sum (I = 0 to N) COF(I) * F ( X(I) )
28014!
28015! To understand the computation of the coefficients, it is enough
28016! to realize that the first difference approximation is
28017!
28018! FDIF(1,X) = F(X+DX) - F(X-DX) ) / (2*DX)
28019!
28020! and that the second difference approximation can be regarded as
28021! the first difference approximation repeated:
28022!
28023! FDIF(2,X) = FDIF(1,X+DX) - FDIF(1,X-DX) / (2*DX)
28024! = F(X+2*DX) - 2 F(X) + F(X-2*DX) / (4*DX)
28025!
28026! and so on for higher order differences.
28027!
28028! Thus, the next thing to consider is the integer coefficients of
28029! the sampled values of F, which are clearly the Pascal coefficients,
28030! but with an alternating negative sign. In particular, if we
28031! consider row I of Pascal's triangle to have entries j = 0 through I,
28032! then P(I,J) = P(I-1,J-1) - P(I-1,J), where P(*,-1) is taken to be 0,
28033! and P(0,0) = 1.
28034!
28035! 1
28036! -1 1
28037! 1 -2 1
28038! -1 3 -3 1
28039! 1 -4 6 -4 1
28040! -1 5 -10 10 -5 1
28041! 1 -6 15 -20 15 -6 1
28042!
28043! Next, note that the denominator of the approximation for the
28044! N-th derivative will be (2*DX)^N.
28045!
28046! And finally, consider the location of the N+1 sampling
28047! points for F:
28048!
28049! X-N*DX, X-(N-2)*DX, X-(N-4)*DX, ..., X+(N-4)*DX, X+(N-2*DX), X+N*DX.
28050!
28051! Thus, a formula for evaluating FDIF(N,X) is
28052!
28053! fdif = 0.0
28054! do i = 0, n
28055! xi = x + (2*i-n) * h
28056! fdif = fdif + cof(i) * f(xi)
28057! end do
28058!
28059! Licensing:
28060!
28061! This code is distributed under the GNU LGPL license.
28062!
28063! Modified:
28064!
28065! 17 February 2004
28066!
28067! Author:
28068!
28069! John Burkardt
28070!
28071! Parameters:
28072!
28073! Input, integer ( kind = 4 ) N, the order of the derivative to be
28074! approximated. N must be 0 or greater.
28075!
28076! Input, real ( kind = 8 ) H, the half spacing between points.
28077! H must be positive.
28078!
28079! Output, real ( kind = 8 ) COF(0:N), the coefficients needed to approximate
28080! the N-th derivative of a function F.
28081!
28082 implicit none
28083
28084 integer ( kind = 4 ) n
28085
28086 real ( kind = 8 ) cof(0:n)
28087 real ( kind = 8 ) h
28088 integer ( kind = 4 ) i
28089 integer ( kind = 4 ) j
28090
28091 if ( n < 0 ) then
28092 write ( *, '(a)' ) ' '
28093 write ( *, '(a)' ) 'R8VEC_DIF - Fatal error!'
28094 write ( *, '(a,i8)' ) ' Derivative order N = ', n
28095 write ( *, '(a)' ) ' but N must be at least 0.'
28096 stop 1
28097 end if
28098
28099 if ( h <= 0.0d+00 ) then
28100 write ( *, '(a)' ) ' '
28101 write ( *, '(a)' ) 'R8VEC_DIF - Fatal error!'
28102 write ( *, '(a,g14.6)' ) ' The half sampling spacing is H = ', h
28103 write ( *, '(a)' ) ' but H must be positive.'
28104 stop 1
28105 end if
28106
28107 do i = 0, n
28108
28109 cof(i) = 1.0d+00
28110
28111 do j = i - 1, 1, -1
28112 cof(j) = -cof(j) + cof(j-1)
28113 end do
28114
28115 if ( 0 < i ) then
28116 cof(0) = -cof(0)
28117 end if
28118
28119 end do
28120
28121 cof(0:n) = cof(0:n) / ( 2.0d+00 * h )**n
28122
28123 return

◆ r8vec_diff_dot_product()

real ( kind = 8 ) function r8vec_diff_dot_product ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  u1,
real ( kind = 8 ), dimension(n)  v1,
real ( kind = 8 ), dimension(n)  u2,
real ( kind = 8 ), dimension(n)  v2 
)

Definition at line 28125 of file R8LIB.f90.

28126
28127!*****************************************************************************80
28128!
28129!! R8VEC_DIFF_DOT_PRODUCT: dot product of a pair of R8VEC differences.
28130!
28131! Discussion:
28132!
28133! An R8VEC is a vector of R8 values.
28134!
28135! Licensing:
28136!
28137! This code is distributed under the GNU LGPL license.
28138!
28139! Modified:
28140!
28141! 31 March 2011
28142!
28143! Author:
28144!
28145! John Burkardt
28146!
28147! Parameters:
28148!
28149! Input, integer ( kind = 4 ) N, the dimension of the vectors.
28150!
28151! Input, real ( kind = 8 ) U1(N), V1(N), defines the vector U1-V1.
28152!
28153! Input, real ( kind = 8 ) U2(N), V2(N), defines the vector U2-V2.
28154!
28155! Output, real ( kind = 8 ) R8VEC_DIFF_DOT_PRODUCT, the dot product
28156! of (U1-V1)*(U2-V2).
28157!
28158 implicit none
28159
28160 integer ( kind = 4 ) n
28161
28162 integer ( kind = 4 ) i
28163 real ( kind = 8 ) r8vec_diff_dot_product
28164 real ( kind = 8 ) u1(n)
28165 real ( kind = 8 ) u2(n)
28166 real ( kind = 8 ) v1(n)
28167 real ( kind = 8 ) v2(n)
28168 real ( kind = 8 ) value
28169
28170 value = 0.0d+00
28171 do i = 1, n
28172 value = value + ( u1(i) - v1(i) ) * ( u2(i) - v2(i) )
28173 end do
28174
28175 r8vec_diff_dot_product = value
28176
28177 return
r8vec_diff_dot_product
real(kind=8) function r8vec_diff_dot_product(n, u1, v1, u2, v2)
Definition R8LIB.f90:28126

References r8vec_diff_dot_product().

Referenced by r8vec_diff_dot_product().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_diff_norm()

real ( kind = 8 ) function r8vec_diff_norm ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 28179 of file R8LIB.f90.

28180
28181!*****************************************************************************80
28182!
28183!! R8VEC_DIFF_NORM returns the L2 norm of the difference of R8VEC's.
28184!
28185! Discussion:
28186!
28187! An R8VEC is a vector of R8's.
28188!
28189! The vector L2 norm is defined as:
28190!
28191! R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
28192!
28193! Licensing:
28194!
28195! This code is distributed under the GNU LGPL license.
28196!
28197! Modified:
28198!
28199! 02 April 2010
28200!
28201! Author:
28202!
28203! John Burkardt
28204!
28205! Parameters:
28206!
28207! Input, integer ( kind = 4 ) N, the number of entries in A.
28208!
28209! Input, real ( kind = 8 ) A(N), B(N), the vectors
28210!
28211! Output, real ( kind = 8 ) R8VEC_DIFF_NORM, the L2 norm of A - B.
28212!
28213 implicit none
28214
28215 integer ( kind = 4 ) n
28216
28217 real ( kind = 8 ) a(n)
28218 real ( kind = 8 ) b(n)
28219 real ( kind = 8 ) r8vec_diff_norm
28220
28221 r8vec_diff_norm = sqrt( sum( ( a(1:n) - b(1:n) )**2 ) )
28222
28223 return
r8vec_diff_norm
real(kind=8) function r8vec_diff_norm(n, a, b)
Definition R8LIB.f90:28180

References r8vec_diff_norm().

Referenced by r8vec_diff_norm().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_diff_norm_l1()

real ( kind = 8 ) function r8vec_diff_norm_l1 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 28225 of file R8LIB.f90.

28226
28227!*****************************************************************************80
28228!
28229!! R8VEC_DIFF_NORM_L1 returns the L1 norm of the difference of R8VEC's.
28230!
28231! Discussion:
28232!
28233! An R8VEC is a vector of R8's.
28234!
28235! The vector L1 norm is defined as:
28236!
28237! R8VEC_NORM_L1 = sum ( 1 <= I <= N ) abs ( A(I) ).
28238!
28239! Licensing:
28240!
28241! This code is distributed under the GNU LGPL license.
28242!
28243! Modified:
28244!
28245! 02 April 2010
28246!
28247! Author:
28248!
28249! John Burkardt
28250!
28251! Parameters:
28252!
28253! Input, integer ( kind = 4 ) N, the number of entries in A.
28254!
28255! Input, real ( kind = 8 ) A(N), B(N), the vectors.
28256!
28257! Output, real ( kind = 8 ) R8VEC_DIFF_NORM_L1, the L1 norm of A - B.
28258!
28259 implicit none
28260
28261 integer ( kind = 4 ) n
28262
28263 real ( kind = 8 ) a(n)
28264 real ( kind = 8 ) b(n)
28265 real ( kind = 8 ) r8vec_diff_norm_l1
28266
28267 r8vec_diff_norm_l1 = sum( abs( a(1:n) - b(1:n) ) )
28268
28269 return
r8vec_diff_norm_l1
real(kind=8) function r8vec_diff_norm_l1(n, a, b)
Definition R8LIB.f90:28226

References r8vec_diff_norm_l1().

Referenced by r8vec_diff_norm_l1().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_diff_norm_l2()

real ( kind = 8 ) function r8vec_diff_norm_l2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 28271 of file R8LIB.f90.

28272
28273!*****************************************************************************80
28274!
28275!! R8VEC_DIFF_NORM_L2 returns the L2 norm of the difference of R8VEC's.
28276!
28277! Discussion:
28278!
28279! An R8VEC is a vector of R8's.
28280!
28281! The vector L2 norm is defined as:
28282!
28283! R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
28284!
28285! Licensing:
28286!
28287! This code is distributed under the GNU LGPL license.
28288!
28289! Modified:
28290!
28291! 02 April 2010
28292!
28293! Author:
28294!
28295! John Burkardt
28296!
28297! Parameters:
28298!
28299! Input, integer ( kind = 4 ) N, the number of entries in A.
28300!
28301! Input, real ( kind = 8 ) A(N), B(N), the vectors
28302!
28303! Output, real ( kind = 8 ) R8VEC_DIFF_NORM_L2, the L2 norm of A - B.
28304!
28305 implicit none
28306
28307 integer ( kind = 4 ) n
28308
28309 real ( kind = 8 ) a(n)
28310 real ( kind = 8 ) b(n)
28311 real ( kind = 8 ) r8vec_diff_norm_l2
28312
28313 r8vec_diff_norm_l2 = sqrt( sum( ( a(1:n) - b(1:n) )**2 ) )
28314
28315 return
r8vec_diff_norm_l2
real(kind=8) function r8vec_diff_norm_l2(n, a, b)
Definition R8LIB.f90:28272

References r8vec_diff_norm_l2().

Referenced by r8vec_diff_norm_l2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_diff_norm_li()

real ( kind = 8 ) function r8vec_diff_norm_li ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 28317 of file R8LIB.f90.

28318
28319!*****************************************************************************80
28320!
28321!! R8VEC_DIFF_NORM_LI returns the L-oo norm of the difference of R8VEC's.
28322!
28323! Discussion:
28324!
28325! An R8VEC is a vector of R8's.
28326!
28327! The vector L-oo norm is defined as:
28328!
28329! R8VEC_NORM_LI = max ( 1 <= I <= N ) abs ( A(I) ).
28330!
28331! Licensing:
28332!
28333! This code is distributed under the GNU LGPL license.
28334!
28335! Modified:
28336!
28337! 02 April 2010
28338!
28339! Author:
28340!
28341! John Burkardt
28342!
28343! Parameters:
28344!
28345! Input, integer ( kind = 4 ) N, the number of entries in A.
28346!
28347! Input, real ( kind = 8 ) A(N), B(N), the vectors
28348!
28349! Output, real ( kind = 8 ) R8VEC_DIFF_NORM_LI, the L-oo norm of A - B.
28350!
28351 implicit none
28352
28353 integer ( kind = 4 ) n
28354
28355 real ( kind = 8 ) a(n)
28356 real ( kind = 8 ) b(n)
28357 real ( kind = 8 ) r8vec_diff_norm_li
28358
28359 r8vec_diff_norm_li = maxval( abs( a(1:n) - b(1:n) ) )
28360
28361 return
r8vec_diff_norm_li
real(kind=8) function r8vec_diff_norm_li(n, a, b)
Definition R8LIB.f90:28318

References r8vec_diff_norm_li().

Referenced by r8vec_diff_norm_li().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_diff_norm_squared()

real ( kind = 8 ) function r8vec_diff_norm_squared ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b 
)

Definition at line 28363 of file R8LIB.f90.

28364
28365!*****************************************************************************80
28366!
28367!! R8VEC_DIFF_NORM_SQUARED: square of the L2 norm of the difference of R8VEC's.
28368!
28369! Discussion:
28370!
28371! An R8VEC is a vector of R8's.
28372!
28373! R8VEC_DIFF_NORM_SQUARED = sum ( 1 <= I <= N ) ( A(I) - B(I) )^2
28374!
28375! Licensing:
28376!
28377! This code is distributed under the GNU LGPL license.
28378!
28379! Modified:
28380!
28381! 30 March 2011
28382!
28383! Author:
28384!
28385! John Burkardt
28386!
28387! Parameters:
28388!
28389! Input, integer ( kind = 4 ) N, the number of entries in A.
28390!
28391! Input, real ( kind = 8 ) A(N), B(N), the vectors
28392!
28393! Output, real ( kind = 8 ) R8VEC_DIFF_NORM_SQUARED, the square of
28394! the L2 norm of A - B.
28395!
28396 implicit none
28397
28398 integer ( kind = 4 ) n
28399
28400 real ( kind = 8 ) a(n)
28401 real ( kind = 8 ) b(n)
28402 real ( kind = 8 ) r8vec_diff_norm_squared
28403
28404 r8vec_diff_norm_squared = sum( ( a(1:n) - b(1:n) )**2 )
28405
28406 return
r8vec_diff_norm_squared
real(kind=8) function r8vec_diff_norm_squared(n, a, b)
Definition R8LIB.f90:28364

References r8vec_diff_norm_squared().

Referenced by r8vec_diff_norm_squared().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_direct_product()

subroutine r8vec_direct_product ( integer ( kind = 4 )  factor_index,
integer ( kind = 4 )  factor_order,
real ( kind = 8 ), dimension(factor_order)  factor_value,
integer ( kind = 4 )  factor_num,
integer ( kind = 4 )  point_num,
real ( kind = 8 ), dimension(factor_num,point_num)  x 
)

Definition at line 28408 of file R8LIB.f90.

28410
28411!*****************************************************************************80
28412!
28413!! R8VEC_DIRECT_PRODUCT creates a direct product of R8VEC's.
28414!
28415! Discussion:
28416!
28417! An R8VEC is a vector of R8's.
28418!
28419! To explain what is going on here, suppose we had to construct
28420! a multidimensional quadrature rule as the product of K rules
28421! for 1D quadrature.
28422!
28423! The product rule will be represented as a list of points and weights.
28424!
28425! The J-th item in the product rule will be associated with
28426! item J1 of 1D rule 1,
28427! item J2 of 1D rule 2,
28428! ...,
28429! item JK of 1D rule K.
28430!
28431! In particular,
28432! X(J) = ( X(1,J1), X(2,J2), ..., X(K,JK))
28433! and
28434! W(J) = W(1,J1) * W(2,J2) * ... * W(K,JK)
28435!
28436! So we can construct the quadrature rule if we can properly
28437! distribute the information in the 1D quadrature rules.
28438!
28439! This routine carries out that task for the abscissas X.
28440!
28441! Another way to do this would be to compute, one by one, the
28442! set of all possible indices (J1,J2,...,JK), and then index
28443! the appropriate information. An advantage of the method shown
28444! here is that you can process the K-th set of information and
28445! then discard it.
28446!
28447! Example:
28448!
28449! Rule 1:
28450! Order = 4
28451! X(1:4) = ( 1, 2, 3, 4 )
28452!
28453! Rule 2:
28454! Order = 3
28455! X(1:3) = ( 10, 20, 30 )
28456!
28457! Rule 3:
28458! Order = 2
28459! X(1:2) = ( 100, 200 )
28460!
28461! Product Rule:
28462! Order = 24
28463! X(1:24) =
28464! ( 1, 10, 100 )
28465! ( 2, 10, 100 )
28466! ( 3, 10, 100 )
28467! ( 4, 10, 100 )
28468! ( 1, 20, 100 )
28469! ( 2, 20, 100 )
28470! ( 3, 20, 100 )
28471! ( 4, 20, 100 )
28472! ( 1, 30, 100 )
28473! ( 2, 30, 100 )
28474! ( 3, 30, 100 )
28475! ( 4, 30, 100 )
28476! ( 1, 10, 200 )
28477! ( 2, 10, 200 )
28478! ( 3, 10, 200 )
28479! ( 4, 10, 200 )
28480! ( 1, 20, 200 )
28481! ( 2, 20, 200 )
28482! ( 3, 20, 200 )
28483! ( 4, 20, 200 )
28484! ( 1, 30, 200 )
28485! ( 2, 30, 200 )
28486! ( 3, 30, 200 )
28487! ( 4, 30, 200 )
28488!
28489! Licensing:
28490!
28491! This code is distributed under the GNU LGPL license.
28492!
28493! Modified:
28494!
28495! 18 April 2009
28496!
28497! Author:
28498!
28499! John Burkardt
28500!
28501! Parameters:
28502!
28503! Input, integer ( kind = 4 ) FACTOR_INDEX, the index of the factor being
28504! processed. The first factor processed must be factor 1!
28505!
28506! Input, integer ( kind = 4 ) FACTOR_ORDER, the order of the factor.
28507!
28508! Input, real ( kind = 8 ) FACTOR_VALUE(FACTOR_ORDER), the factor values
28509! for factor FACTOR_INDEX.
28510!
28511! Input, integer ( kind = 4 ) FACTOR_NUM, the number of factors.
28512!
28513! Input, integer ( kind = 4 ) POINT_NUM, the number of elements in the
28514! direct product.
28515!
28516! Input/output, real ( kind = 8 ) X(FACTOR_NUM,POINT_NUM), the elements of
28517! the direct product, which are built up gradually.
28518!
28519! Local Parameters:
28520!
28521! Local, integer ( kind = 4 ) START, the first location of a block of
28522! values to set.
28523!
28524! Local, integer ( kind = 4 ) CONTIG, the number of consecutive values
28525! to set.
28526!
28527! Local, integer ( kind = 4 ) SKIP, the distance from the current value
28528! of START to the next location of a block of values to set.
28529!
28530! Local, integer ( kind = 4 ) REP, the number of blocks of values to set.
28531!
28532 implicit none
28533
28534 integer ( kind = 4 ) factor_num
28535 integer ( kind = 4 ) factor_order
28536 integer ( kind = 4 ) point_num
28537
28538 integer ( kind = 4 ), save :: contig
28539 integer ( kind = 4 ) factor_index
28540 real ( kind = 8 ) factor_value(factor_order)
28541 integer ( kind = 4 ) j
28542 integer ( kind = 4 ) k
28543 integer ( kind = 4 ), save :: rep
28544 integer ( kind = 4 ), save :: skip
28545 integer ( kind = 4 ) start
28546 real ( kind = 8 ) x(factor_num,point_num)
28547
28548 if ( factor_index == 1 ) then
28549 contig = 1
28550 skip = 1
28551 rep = point_num
28552 x(1:factor_num,1:point_num) = 0.0d+00
28553 end if
28554
28555 rep = rep / factor_order
28556 skip = skip * factor_order
28557
28558 do j = 1, factor_order
28559
28560 start = 1 + ( j - 1 ) * contig
28561
28562 do k = 1, rep
28563 x(factor_index,start:start+contig-1) = factor_value(j)
28564 start = start + skip
28565 end do
28566
28567 end do
28568
28569 contig = contig * factor_order
28570
28571 return

◆ r8vec_direct_product2()

subroutine r8vec_direct_product2 ( integer ( kind = 4 )  factor_index,
integer ( kind = 4 )  factor_order,
real ( kind = 8 ), dimension(factor_order)  factor_value,
integer ( kind = 4 )  factor_num,
integer ( kind = 4 )  point_num,
real ( kind = 8 ), dimension(point_num)  w 
)

Definition at line 28573 of file R8LIB.f90.

28575
28576!*****************************************************************************80
28577!
28578!! R8VEC_DIRECT_PRODUCT2 creates a direct product of R8VEC's.
28579!
28580! Discussion:
28581!
28582! An R8VEC is a vector of R8's.
28583!
28584! To explain what is going on here, suppose we had to construct
28585! a multidimensional quadrature rule as the product of K rules
28586! for 1D quadrature.
28587!
28588! The product rule will be represented as a list of points and weights.
28589!
28590! The J-th item in the product rule will be associated with
28591! item J1 of 1D rule 1,
28592! item J2 of 1D rule 2,
28593! ...,
28594! item JK of 1D rule K.
28595!
28596! In particular,
28597! X(J) = ( X(1,J1), X(2,J2), ..., X(K,JK))
28598! and
28599! W(J) = W(1,J1) * W(2,J2) * ... * W(K,JK)
28600!
28601! So we can construct the quadrature rule if we can properly
28602! distribute the information in the 1D quadrature rules.
28603!
28604! This routine carries out the task involving the weights W.
28605!
28606! Another way to do this would be to compute, one by one, the
28607! set of all possible indices (J1,J2,...,JK), and then index
28608! the appropriate information. An advantage of the method shown
28609! here is that you can process the K-th set of information and
28610! then discard it.
28611!
28612! Example:
28613!
28614! Rule 1:
28615! Order = 4
28616! W(1:4) = ( 2, 3, 5, 7 )
28617!
28618! Rule 2:
28619! Order = 3
28620! W(1:3) = ( 11, 13, 17 )
28621!
28622! Rule 3:
28623! Order = 2
28624! W(1:2) = ( 19, 23 )
28625!
28626! Product Rule:
28627! Order = 24
28628! W(1:24) =
28629! ( 2 * 11 * 19 )
28630! ( 3 * 11 * 19 )
28631! ( 4 * 11 * 19 )
28632! ( 7 * 11 * 19 )
28633! ( 2 * 13 * 19 )
28634! ( 3 * 13 * 19 )
28635! ( 5 * 13 * 19 )
28636! ( 7 * 13 * 19 )
28637! ( 2 * 17 * 19 )
28638! ( 3 * 17 * 19 )
28639! ( 5 * 17 * 19 )
28640! ( 7 * 17 * 19 )
28641! ( 2 * 11 * 23 )
28642! ( 3 * 11 * 23 )
28643! ( 5 * 11 * 23 )
28644! ( 7 * 11 * 23 )
28645! ( 2 * 13 * 23 )
28646! ( 3 * 13 * 23 )
28647! ( 5 * 13 * 23 )
28648! ( 7 * 13 * 23 )
28649! ( 2 * 17 * 23 )
28650! ( 3 * 17 * 23 )
28651! ( 5 * 17 * 23 )
28652! ( 7 * 17 * 23 )
28653!
28654! Licensing:
28655!
28656! This code is distributed under the GNU LGPL license.
28657!
28658! Modified:
28659!
28660! 18 April 2009
28661!
28662! Author:
28663!
28664! John Burkardt
28665!
28666! Parameters:
28667!
28668! Input, integer ( kind = 4 ) FACTOR_INDEX, the index of the factor being
28669! processed. The first factor processed must be factor 1!
28670!
28671! Input, integer ( kind = 4 ) FACTOR_ORDER, the order of the factor.
28672!
28673! Input, real ( kind = 8 ) FACTOR_VALUE(FACTOR_ORDER), the factor values
28674! for factor FACTOR_INDEX.
28675!
28676! Input, integer ( kind = 4 ) FACTOR_NUM, the number of factors.
28677!
28678! Input, integer ( kind = 4 ) POINT_NUM, the number of elements in the
28679! direct product.
28680!
28681! Input/output, real ( kind = 8 ) W(POINT_NUM), the elements of the
28682! direct product, which are built up gradually.
28683!
28684! Local Parameters:
28685!
28686! Local, integer ( kind = 4 ) START, the first location of a block of values
28687! to set.
28688!
28689! Local, integer ( kind = 4 ) CONTIG, the number of consecutive values
28690! to set.
28691!
28692! Local, integer ( kind = 4 ) SKIP, the distance from the current value
28693! of START to the next location of a block of values to set.
28694!
28695! Local, integer ( kind = 4 ) REP, the number of blocks of values to set.
28696!
28697 implicit none
28698
28699 integer ( kind = 4 ) factor_num
28700 integer ( kind = 4 ) factor_order
28701 integer ( kind = 4 ) point_num
28702
28703 integer ( kind = 4 ), save :: contig
28704 integer ( kind = 4 ) factor_index
28705 real ( kind = 8 ) factor_value(factor_order)
28706 integer ( kind = 4 ) j
28707 integer ( kind = 4 ) k
28708 integer ( kind = 4 ), save :: rep
28709 integer ( kind = 4 ), save :: skip
28710 integer ( kind = 4 ) start
28711 real ( kind = 8 ) w(point_num)
28712
28713 if ( factor_index == 1 ) then
28714 contig = 1
28715 skip = 1
28716 rep = point_num
28717 w(1:point_num) = 1.0d+00
28718 end if
28719
28720 rep = rep / factor_order
28721 skip = skip * factor_order
28722
28723 do j = 1, factor_order
28724
28725 start = 1 + ( j - 1 ) * contig
28726
28727 do k = 1, rep
28728 w(start:start+contig-1) = w(start:start+contig-1) * factor_value(j)
28729 start = start + skip
28730 end do
28731
28732 end do
28733
28734 contig = contig * factor_order
28735
28736 return

◆ r8vec_distance()

real ( kind = 8 ) function r8vec_distance ( integer ( kind = 4 )  dim_num,
real ( kind = 8 ), dimension(dim_num)  v1,
real ( kind = 8 ), dimension(dim_num)  v2 
)

Definition at line 28738 of file R8LIB.f90.

28739
28740!*****************************************************************************80
28741!
28742!! R8VEC_DISTANCE returns the Euclidean distance between two R8VEC's.
28743!
28744! Discussion:
28745!
28746! An R8VEC is a vector of R8's.
28747!
28748! Licensing:
28749!
28750! This code is distributed under the GNU LGPL license.
28751!
28752! Modified:
28753!
28754! 11 August 2005
28755!
28756! Author:
28757!
28758! John Burkardt
28759!
28760! Parameters:
28761!
28762! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension.
28763!
28764! Input, real ( kind = 8 ) V1(DIM_NUM), V2(DIM_NUM), the vectors.
28765!
28766! Output, real ( kind = 8 ) R8VEC_DISTANCE, the Euclidean distance
28767! between the vectors.
28768!
28769 implicit none
28770
28771 integer ( kind = 4 ) dim_num
28772
28773 real ( kind = 8 ) r8vec_distance
28774 real ( kind = 8 ) v1(dim_num)
28775 real ( kind = 8 ) v2(dim_num)
28776
28777 r8vec_distance = sqrt( sum( ( v1(1:dim_num) - v2(1:dim_num) )**2 ) )
28778
28779 return
r8vec_distance
real(kind=8) function r8vec_distance(dim_num, v1, v2)
Definition R8LIB.f90:28739

References r8vec_distance().

Referenced by r8vec_distance().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_distinct()

logical ( kind = 4 ) function r8vec_distinct ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 28781 of file R8LIB.f90.

28782
28783!*****************************************************************************80
28784!
28785!! R8VEC_DISTINCT is true if the entries in an R8VEC are distinct.
28786!
28787! Discussion:
28788!
28789! An R8VEC is a vector of R8's.
28790!
28791! Licensing:
28792!
28793! This code is distributed under the GNU LGPL license.
28794!
28795! Modified:
28796!
28797! 16 September 1999
28798!
28799! Author:
28800!
28801! John Burkardt
28802!
28803! Parameters:
28804!
28805! Input, integer ( kind = 4 ) N, the number of entries in the vector.
28806!
28807! Input, real ( kind = 8 ) A(N), the vector to be checked.
28808!
28809! Output, logical ( kind = 4 ) R8VEC_DISTINCT is TRUE if the elements of
28810! the vector are distinct.
28811!
28812 implicit none
28813
28814 integer ( kind = 4 ) n
28815
28816 real ( kind = 8 ) a(n)
28817 integer ( kind = 4 ) i
28818 integer ( kind = 4 ) j
28819 logical ( kind = 4 ) r8vec_distinct
28820
28821 r8vec_distinct = .false.
28822
28823 do i = 2, n
28824 do j = 1, i - 1
28825 if ( a(i) == a(j) ) then
28826 return
28827 end if
28828 end do
28829 end do
28830
28831 r8vec_distinct = .true.
28832
28833 return

References r8vec_distinct().

Referenced by r8vec_distinct().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_dot_product()

real ( kind = 8 ) function r8vec_dot_product ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v1,
real ( kind = 8 ), dimension(n)  v2 
)

Definition at line 28835 of file R8LIB.f90.

28836
28837!*****************************************************************************80
28838!
28839!! R8VEC_DOT_PRODUCT finds the dot product of a pair of R8VEC's.
28840!
28841! Discussion:
28842!
28843! An R8VEC is a vector of R8's.
28844!
28845! In FORTRAN90, the system routine DOT_PRODUCT should be called
28846! directly.
28847!
28848! Licensing:
28849!
28850! This code is distributed under the GNU LGPL license.
28851!
28852! Modified:
28853!
28854! 27 May 2008
28855!
28856! Author:
28857!
28858! John Burkardt
28859!
28860! Parameters:
28861!
28862! Input, integer ( kind = 4 ) N, the dimension of the vectors.
28863!
28864! Input, real ( kind = 8 ) V1(N), V2(N), the vectors.
28865!
28866! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT, the dot product.
28867!
28868 implicit none
28869
28870 integer ( kind = 4 ) n
28871
28872 real ( kind = 8 ) r8vec_dot_product
28873 real ( kind = 8 ) v1(n)
28874 real ( kind = 8 ) v2(n)
28875
28876 r8vec_dot_product = dot_product( v1(1:n), v2(1:n) )
28877
28878 return
r8vec_dot_product
real(kind=8) function r8vec_dot_product(n, v1, v2)
Definition R8LIB.f90:28836

References r8vec_dot_product().

Referenced by r8vec_dot_product().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_dot_product_affine()

real ( kind = 8 ) function r8vec_dot_product_affine ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v0,
real ( kind = 8 ), dimension(n)  v1,
real ( kind = 8 ), dimension(n)  v2 
)

Definition at line 28880 of file R8LIB.f90.

28881
28882!*****************************************************************************80
28883!
28884!! R8VEC_DOT_PRODUCT_AFFINE computes the affine dot product V1-V0 * V2-V0.
28885!
28886! Licensing:
28887!
28888! This code is distributed under the GNU LGPL license.
28889!
28890! Modified:
28891!
28892! 27 October 2010
28893!
28894! Author:
28895!
28896! John Burkardt
28897!
28898! Parameters:
28899!
28900! Input, integer ( kind = 4 ) N, the spatial dimension.
28901!
28902! Input, real ( kind = 8 ) V0(N), the base vector.
28903!
28904! Input, real ( kind = 8 ) V1(N), V2(N), the vectors.
28905!
28906! Output, real ( kind = 8 ) R8VEC_DOT_PRODUCT_AFFINE, the dot product.
28907!
28908 implicit none
28909
28910 integer ( kind = 4 ) n
28911
28912 real ( kind = 8 ) r8vec_dot_product_affine
28913 real ( kind = 8 ) v0(n)
28914 real ( kind = 8 ) v1(n)
28915 real ( kind = 8 ) v2(n)
28916
28917 r8vec_dot_product_affine = dot_product( &
28918 v1(1:n) - v0(1:n), &
28919 v2(1:n) - v0(1:n) )
28920
28921 return
r8vec_dot_product_affine
real(kind=8) function r8vec_dot_product_affine(n, v0, v1, v2)
Definition R8LIB.f90:28881

References r8vec_dot_product_affine().

Referenced by r8vec_dot_product_affine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_entropy()

real ( kind = 8 ) function r8vec_entropy ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 28923 of file R8LIB.f90.

28924
28925!*****************************************************************************80
28926!
28927!! R8VEC_ENTROPY computes the entropy of an R8VEC.
28928!
28929! Discussion:
28930!
28931! Typically, the entries represent probabilities, and must sum to 1.
28932! For this function, the only requirement is that the entries be nonnegative.
28933!
28934! An R8VEC is a vector of R8's.
28935!
28936! Licensing:
28937!
28938! This code is distributed under the GNU LGPL license.
28939!
28940! Modified:
28941!
28942! 30 August 2013
28943!
28944! Author:
28945!
28946! John Burkardt
28947!
28948! Parameters:
28949!
28950! Input, integer ( kind = 4 ) N, the number of entries.
28951!
28952! Input, real ( kind = 8 ) X(N), the vector.
28953! Each entry must be nonnegative.
28954!
28955! Output, real ( kind = 8 ) R8VEC_ENTROPY, the entropy of the
28956! normalized vector.
28957!
28958 implicit none
28959
28960 integer ( kind = 4 ) n
28961
28962 integer ( kind = 4 ) i
28963 real ( kind = 8 ) r8_log_2
28964 real ( kind = 8 ) r8vec_entropy
28965 real ( kind = 8 ) value
28966 real ( kind = 8 ) x(n)
28967 real ( kind = 8 ) x_sum
28968 real ( kind = 8 ) xi
28969
28970 if ( any( x(1:n) < 0.0d+00 ) ) then
28971 write ( *, '(a)' ) ' '
28972 write ( *, '(a)' ) 'R8VEC_ENTROPY - Fatal error!'
28973 write ( *, '(a)' ) ' Some entries are negative.'
28974 stop 1
28975 end if
28976
28977 x_sum = sum( x(1:n) )
28978
28979 if ( x_sum == 0.0d+00 ) then
28980 write ( *, '(a)' ) ' '
28981 write ( *, '(a)' ) 'R8VEC_ENTROPY - Fatal error!'
28982 write ( *, '(a)' ) ' Entries sum to 0.'
28983 stop 1
28984 end if
28985
28986 value = 0.0d+00
28987 do i = 1, n
28988 if ( 0.0d+00 < x(i) ) then
28989 xi = x(i) / x_sum
28990 value = value - r8_log_2( xi ) * xi
28991 end if
28992 end do
28993
28994 r8vec_entropy = value
28995
28996 return
r8vec_entropy
real(kind=8) function r8vec_entropy(n, x)
Definition R8LIB.f90:28924

References r8_log_2(), and r8vec_entropy().

Referenced by r8vec_entropy().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_eq()

logical ( kind = 4 ) function r8vec_eq ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 28998 of file R8LIB.f90.

28999
29000!*****************************************************************************80
29001!
29002!! R8VEC_EQ is true if two R8VECs are equal.
29003!
29004! Discussion:
29005!
29006! An R8VEC is a vector of R8's.
29007!
29008! Licensing:
29009!
29010! This code is distributed under the GNU LGPL license.
29011!
29012! Modified:
29013!
29014! 05 December 2004
29015!
29016! Author:
29017!
29018! John Burkardt
29019!
29020! Parameters:
29021!
29022! Input, integer ( kind = 4 ) N, the number of entries in the vectors.
29023!
29024! Input, real ( kind = 8 ) A1(N), A2(N), two vectors to compare.
29025!
29026! Output, logical ( kind = 4 ) R8VEC_EQ, is TRUE if every pair of elements
29027! A1(I) and A2(I) are equal, and FALSE otherwise.
29028!
29029 implicit none
29030
29031 integer ( kind = 4 ) n
29032
29033 real ( kind = 8 ) a1(n)
29034 real ( kind = 8 ) a2(n)
29035 logical ( kind = 4 ) r8vec_eq
29036
29037 r8vec_eq = ( all( a1(1:n) == a2(1:n) ) )
29038
29039 return

References r8vec_eq().

Referenced by r8vec_eq().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_even()

subroutine r8vec_even ( integer ( kind = 4 )  n,
real ( kind = 8 )  alo,
real ( kind = 8 )  ahi,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 29041 of file R8LIB.f90.

29042
29043!*****************************************************************************80
29044!
29045!! R8VEC_EVEN returns an R8VEC of evenly spaced values.
29046!
29047! Discussion:
29048!
29049! An R8VEC is a vector of R8's.
29050!
29051! If N is 1, then the midpoint is returned.
29052!
29053! Otherwise, the two endpoints are returned, and N-2 evenly
29054! spaced points between them.
29055!
29056! Licensing:
29057!
29058! This code is distributed under the GNU LGPL license.
29059!
29060! Modified:
29061!
29062! 09 December 2004
29063!
29064! Author:
29065!
29066! John Burkardt
29067!
29068! Parameters:
29069!
29070! Input, integer ( kind = 4 ) N, the number of values.
29071!
29072! Input, real ( kind = 8 ) ALO, AHI, the low and high values.
29073!
29074! Output, real ( kind = 8 ) A(N), N evenly spaced values.
29075! Normally, A(1) = ALO and A(N) = AHI.
29076! However, if N = 1, then A(1) = 0.5*(ALO+AHI).
29077!
29078 implicit none
29079
29080 integer ( kind = 4 ) n
29081
29082 real ( kind = 8 ) a(n)
29083 real ( kind = 8 ) ahi
29084 real ( kind = 8 ) alo
29085 integer ( kind = 4 ) i
29086
29087 if ( n == 1 ) then
29088
29089 a(1) = 0.5d+00 * ( alo + ahi )
29090
29091 else
29092
29093 do i = 1, n
29094 a(i) = ( real( n - i, kind = 8 ) * alo &
29095 + real( i - 1, kind = 8 ) * ahi ) &
29096 / real( n - 1, kind = 8 )
29097 end do
29098
29099 end if
29100
29101 return

◆ r8vec_even2()

subroutine r8vec_even2 ( integer ( kind = 4 )  maxval,
integer ( kind = 4 ), dimension(nold-1)  nfill,
integer ( kind = 4 )  nold,
real ( kind = 8 ), dimension(nold)  xold,
integer ( kind = 4 )  nval,
real ( kind = 8 ), dimension(maxval)  xval 
)

Definition at line 29166 of file R8LIB.f90.

29167
29168!*****************************************************************************80
29169!
29170!! R8VEC_EVEN2 linearly interpolates new numbers into an R8VEC.
29171!
29172! Discussion:
29173!
29174! An R8VEC is a vector of R8's.
29175!
29176! The number of values created between two old values can vary from
29177! one pair of values to the next.
29178!
29179! The interpolated values are evenly spaced.
29180!
29181! This routine is a generalization of R8VEC_EVEN.
29182!
29183! Licensing:
29184!
29185! This code is distributed under the GNU LGPL license.
29186!
29187! Modified:
29188!
29189! 30 October 2005
29190!
29191! Author:
29192!
29193! John Burkardt
29194!
29195! Parameters:
29196!
29197! Input, integer ( kind = 4 ) MAXVAL, the size of the XVAL array, as declared
29198! by the user. MAXVAL must be large enough to hold the NVAL values computed
29199! by this routine. In other words, MAXVAL must be at least equal to
29200! NOLD + SUM (1 <= I <= NOLD-1) NFILL(I).
29201!
29202! Input, integer ( kind = 4 ) NFILL(NOLD-1), the number of values
29203! to be interpolated between XOLD(I) and XOLD(I+1).
29204! NFILL(I) does not count the endpoints. Thus, if
29205! NFILL(I) is 1, there will be one new point generated
29206! between XOLD(I) and XOLD(I+1).
29207! NFILL(I) must be nonnegative.
29208!
29209! Input, integer ( kind = 4 ) NOLD, the number of values XOLD,
29210! between which extra values are to be interpolated.
29211!
29212! Input, real ( kind = 8 ) XOLD(NOLD), the original vector of numbers
29213! between which new values are to be interpolated.
29214!
29215! Output, integer ( kind = 4 ) NVAL, the number of values computed
29216! in the XVAL array.
29217! NVAL = NOLD + SUM ( 1 <= I <= NOLD-1 ) NFILL(I)
29218!
29219! Output, real ( kind = 8 ) XVAL(MAXVAL). On output, XVAL contains the
29220! NOLD values of XOLD, as well as the interpolated
29221! values, making a total of NVAL values.
29222!
29223 implicit none
29224
29225 integer ( kind = 4 ) maxval
29226 integer ( kind = 4 ) nold
29227
29228 integer ( kind = 4 ) i
29229 integer ( kind = 4 ) j
29230 integer ( kind = 4 ) nadd
29231 integer ( kind = 4 ) nfill(nold-1)
29232 integer ( kind = 4 ) nval
29233 real ( kind = 8 ) xold(nold)
29234 real ( kind = 8 ) xval(maxval)
29235
29236 nval = 1
29237
29238 do i = 1, nold - 1
29239
29240 if ( nfill(i) < 0 ) then
29241 write ( *, '(a)' ) ' '
29242 write ( *, '(a)' ) 'R8VEC_EVEN2 - Fatal error!'
29243 write ( *, '(a,i8)' ) ' NFILL(I) is negative for I = ', i
29244 write ( *, '(a,i8)' ) ' NFILL(I) = ', nfill(i)
29245 stop 1
29246 end if
29247
29248 if ( maxval < nval + nfill(i) + 1 ) then
29249 write ( *, '(a)' ) ' '
29250 write ( *, '(a)' ) 'R8VEC_EVEN2 - Fatal error!'
29251 write ( *, '(a)' ) ' MAXVAL is not large enough. '
29252 write ( *, '(a,i8)' ) ' MAXVAL = ', maxval
29253 write ( *, '(a)' ) ' which is exceeded by storage requirements'
29254 write ( *, '(a,i8)' ) ' for interpolating in interval ', i
29255 stop 1
29256 end if
29257
29258 nadd = nfill(i) + 2
29259
29260 do j = 1, nadd
29261 xval(nval+j-1) = ( real( nadd - j, kind = 8 ) * xold(i) &
29262 + real( j - 1, kind = 8 ) * xold(i+1) ) &
29263 / real( nadd - 1, kind = 8 )
29264 end do
29265
29266 nval = nval + nfill(i) + 1
29267
29268 end do
29269
29270 return

◆ r8vec_even2_select()

subroutine r8vec_even2_select ( integer ( kind = 4 )  n,
real ( kind = 8 )  xlo,
real ( kind = 8 )  xhi,
integer ( kind = 4 )  ival,
real ( kind = 8 )  xval 
)

Definition at line 29272 of file R8LIB.f90.

29273
29274!*****************************************************************************80
29275!
29276!! R8VEC_EVEN2_SELECT returns the I-th of N evenly spaced midpoint values.
29277!
29278! Discussion:
29279!
29280! An R8VEC is a vector of R8's.
29281!
29282! This function returns the I-th of N evenly spaced midpoints of N
29283! equal subintervals of [XLO,XHI].
29284!
29285! XVAL = ( ( 2 * N - 2 * IVAL + 1 ) * XLO
29286! + ( 2 * IVAL - 1 ) * XHI )
29287! / ( 2 * N )
29288!
29289! Licensing:
29290!
29291! This code is distributed under the GNU LGPL license.
29292!
29293! Modified:
29294!
29295! 25 July 2012
29296!
29297! Author:
29298!
29299! John Burkardt
29300!
29301! Parameters:
29302!
29303! Input, integer ( kind = 4 ) N, the number of values.
29304!
29305! Input, real ( kind = 8 ) XLO, XHI, the low and high values.
29306!
29307! Input, integer ( kind = 4 ) IVAL, the index of the desired point.
29308! IVAL is normally between 1 and N, but may be any integer value.
29309!
29310! Output, real ( kind = 8 ) XVAL, the IVAL-th of N evenly spaced midpoints
29311! between XLO and XHI.
29312!
29313 implicit none
29314
29315 integer ( kind = 4 ) n
29316
29317 integer ( kind = 4 ) ival
29318 real ( kind = 8 ) xhi
29319 real ( kind = 8 ) xlo
29320 real ( kind = 8 ) xval
29321
29322 xval = ( real( 2 * n - 2 * ival + 1, kind = 8 ) * xlo &
29323 + real( 2 * ival - 1, kind = 8 ) * xhi ) &
29324 / real( 2 * n, kind = 8 )
29325
29326 return

◆ r8vec_even3()

subroutine r8vec_even3 ( integer ( kind = 4 )  nold,
integer ( kind = 4 )  nval,
real ( kind = 8 ), dimension(nold)  xold,
real ( kind = 8 ), dimension(nval)  xval 
)

Definition at line 29328 of file R8LIB.f90.

29329
29330!*****************************************************************************80
29331!
29332!! R8VEC_EVEN3 evenly interpolates new data into an R8VEC.
29333!
29334! Discussion:
29335!
29336! An R8VEC is a vector of R8's.
29337!
29338! This routine accepts a short vector of numbers, and returns a longer
29339! vector of numbers, created by interpolating new values between
29340! the given values.
29341!
29342! Between any two original values, new values are evenly interpolated.
29343!
29344! Over the whole vector, the new numbers are interpolated in
29345! such a way as to try to minimize the largest distance interval size.
29346!
29347! The algorithm employed is not "perfect".
29348!
29349! Licensing:
29350!
29351! This code is distributed under the GNU LGPL license.
29352!
29353! Modified:
29354!
29355! 29 October 2005
29356!
29357! Author:
29358!
29359! John Burkardt
29360!
29361! Parameters:
29362!
29363! Input, integer ( kind = 4 ) NOLD, the number of values XOLD, between
29364! which extra values are to be interpolated.
29365!
29366! Input, integer ( kind = 4 ) NVAL, the number of values to be computed
29367! in the XVAL array. NVAL should be at least NOLD.
29368!
29369! Input, real ( kind = 8 ) XOLD(NOLD), the original vector of numbers
29370! between which new values are to be interpolated.
29371!
29372! Output, real ( kind = 8 ) XVAL(NVAL). On output, XVAL contains the
29373! NOLD values of XOLD, as well as interpolated
29374! values, making a total of NVAL values.
29375!
29376 implicit none
29377
29378 integer ( kind = 4 ) nval
29379 integer ( kind = 4 ) nold
29380
29381 real ( kind = 8 ) density
29382 integer ( kind = 4 ) i
29383 integer ( kind = 4 ) ival
29384 integer ( kind = 4 ) j
29385 integer ( kind = 4 ) nmaybe
29386 integer ( kind = 4 ) npts
29387 integer ( kind = 4 ) ntemp
29388 integer ( kind = 4 ) ntot
29389 real ( kind = 8 ) xlen
29390 real ( kind = 8 ) xleni
29391 real ( kind = 8 ) xlentot
29392 real ( kind = 8 ) xold(nold)
29393 real ( kind = 8 ) xval(nval)
29394
29395 xlen = 0.0d+00
29396 do i = 1, nold - 1
29397 xlen = xlen + abs( xold(i+1) - xold(i) )
29398 end do
29399
29400 ntemp = nval - nold
29401
29402 density = real( ntemp, kind = 8 ) / xlen
29403
29404 ival = 1
29405 ntot = 0
29406 xlentot = 0.0d+00
29407
29408 do i = 1, nold - 1
29409
29410 xleni = abs( xold(i+1) - xold(i) )
29411 npts = int( density * xleni )
29412 ntot = ntot + npts
29413!
29414! Determine if we have enough left-over density that it should
29415! be changed into a point. A better algorithm would agonize
29416! more over where that point should go.
29417!
29418 xlentot = xlentot + xleni
29419 nmaybe = nint( xlentot * density )
29420
29421 if ( ntot < nmaybe ) then
29422 npts = npts + nmaybe - ntot
29423 ntot = nmaybe
29424 end if
29425
29426 do j = 1, npts + 2
29427 xval(ival+j-1) = ( real( npts+2 - j, kind = 8 ) * xold(i) &
29428 + real( j - 1, kind = 8 ) * xold(i+1) ) &
29429 / real( npts+2 - 1, kind = 8 )
29430 end do
29431
29432 ival = ival + npts + 1
29433
29434 end do
29435
29436 return

◆ r8vec_even_select()

subroutine r8vec_even_select ( integer ( kind = 4 )  n,
real ( kind = 8 )  xlo,
real ( kind = 8 )  xhi,
integer ( kind = 4 )  ival,
real ( kind = 8 )  xval 
)

Definition at line 29103 of file R8LIB.f90.

29104
29105!*****************************************************************************80
29106!
29107!! R8VEC_EVEN_SELECT returns the I-th of N evenly spaced values in [ XLO, XHI ].
29108!
29109! Discussion:
29110!
29111! An R8VEC is a vector of R8's.
29112!
29113! XVAL = ( (N-IVAL) * XLO + (IVAL-1) * XHI ) / real ( N - 1 )
29114!
29115! Unless N = 1, X(1) = XLO and X(N) = XHI.
29116!
29117! If N = 1, then X(1) = 0.5*(XLO+XHI).
29118!
29119! Licensing:
29120!
29121! This code is distributed under the GNU LGPL license.
29122!
29123! Modified:
29124!
29125! 09 December 2004
29126!
29127! Author:
29128!
29129! John Burkardt
29130!
29131! Parameters:
29132!
29133! Input, integer ( kind = 4 ) N, the number of values.
29134!
29135! Input, real ( kind = 8 ) XLO, XHI, the low and high values.
29136!
29137! Input, integer ( kind = 4 ) IVAL, the index of the desired point.
29138! IVAL is normally between 1 and N, but may be any integer value.
29139!
29140! Output, real ( kind = 8 ) XVAL, the IVAL-th of N evenly spaced values
29141! between XLO and XHI.
29142!
29143 implicit none
29144
29145 integer ( kind = 4 ) n
29146
29147 integer ( kind = 4 ) ival
29148 real ( kind = 8 ) xhi
29149 real ( kind = 8 ) xlo
29150 real ( kind = 8 ) xval
29151
29152 if ( n == 1 ) then
29153
29154 xval = 0.5d+00 * ( xlo + xhi )
29155
29156 else
29157
29158 xval = ( real( n - ival, kind = 8 ) * xlo &
29159 + real( ival - 1, kind = 8 ) * xhi ) &
29160 / real( n - 1, kind = 8 )
29161
29162 end if
29163
29164 return

◆ r8vec_expand_linear()

subroutine r8vec_expand_linear ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 )  fat,
real ( kind = 8 ), dimension((n-1)*(fat+1)+1)  xfat 
)

Definition at line 29438 of file R8LIB.f90.

29439
29440!*****************************************************************************80
29441!
29442!! R8VEC_EXPAND_LINEAR linearly interpolates new data into an R8VEC.
29443!
29444! Discussion:
29445!
29446! An R8VEC is a vector of R8's.
29447!
29448! This routine copies the old data, and inserts NFAT new values
29449! between each pair of old data values. This would be one way to
29450! determine places to evenly sample a curve, given the (unevenly
29451! spaced) points at which it was interpolated.
29452!
29453! Example:
29454!
29455! N = 3
29456! NFAT = 2
29457!
29458! X(1:N) = (/ 0.0, 6.0, 7.0 /)
29459! XFAT(1:2*3+1) = (/ 0.0, 2.0, 4.0, 6.0, 6.33, 6.66, 7.0 /)
29460!
29461! Licensing:
29462!
29463! This code is distributed under the GNU LGPL license.
29464!
29465! Modified:
29466!
29467! 10 October 2001
29468!
29469! Author:
29470!
29471! John Burkardt
29472!
29473! Parameters:
29474!
29475! Input, integer ( kind = 4 ) N, the number of input data values.
29476!
29477! Input, real ( kind = 8 ) X(N), the original data.
29478!
29479! Input, integer ( kind = 4 ) FAT, the number of data values to interpolate
29480! between each pair of original data values.
29481!
29482! Output, real ( kind = 8 ) XFAT((N-1)*(FAT+1)+1), the "fattened" data.
29483!
29484 implicit none
29485
29486 integer ( kind = 4 ) fat
29487 integer ( kind = 4 ) n
29488
29489 integer ( kind = 4 ) i
29490 integer ( kind = 4 ) j
29491 integer ( kind = 4 ) k
29492 real ( kind = 8 ) x(n)
29493 real ( kind = 8 ) xfat((n-1)*(fat+1)+1)
29494
29495 k = 0
29496
29497 do i = 1, n - 1
29498
29499 k = k + 1
29500 xfat(k) = x(i)
29501
29502 do j = 1, fat
29503 k = k + 1
29504 xfat(k) = ( real( fat - j + 1, kind = 8 ) * x(i) &
29505 + real( j, kind = 8 ) * x(i+1) ) &
29506 / real( fat + 1, kind = 8 )
29507 end do
29508
29509 end do
29510
29511 k = k + 1
29512 xfat(k) = x(n)
29513
29514 return

◆ r8vec_expand_linear2()

subroutine r8vec_expand_linear2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 )  before,
integer ( kind = 4 )  fat,
integer ( kind = 4 )  after,
real ( kind = 8 ), dimension(before+(n-1)*(fat+1)+1+after)  xfat 
)

Definition at line 29516 of file R8LIB.f90.

29517
29518!*****************************************************************************80
29519!
29520!! R8VEC_EXPAND_LINEAR2 linearly interpolates new data into an R8VEC.
29521!
29522! Discussion:
29523!
29524! An R8VEC is a vector of R8's.
29525!
29526! This routine starts with a vector of data.
29527!
29528! The intent is to "fatten" the data, that is, to insert more points
29529! between successive values of the original data.
29530!
29531! There will also be extra points placed BEFORE the first original
29532! value and AFTER that last original value.
29533!
29534! The "fattened" data is equally spaced between the original points.
29535!
29536! The BEFORE data uses the spacing of the first original interval,
29537! and the AFTER data uses the spacing of the last original interval.
29538!
29539! Example:
29540!
29541! N = 3
29542! BEFORE = 3
29543! FAT = 2
29544! AFTER = 1
29545!
29546! X = (/ 0.0, 6.0, 7.0 /)
29547! XFAT = (/ -6.0, -4.0, -2.0, 0.0, 2.0, 4.0, 6.0, 6.33, 6.66, 7.0, 7.66 /)
29548! 3 "BEFORE's" Old 2 "FATS" Old 2 "FATS" Old 1 "AFTER"
29549!
29550! Licensing:
29551!
29552! This code is distributed under the GNU LGPL license.
29553!
29554! Modified:
29555!
29556! 03 December 2007
29557!
29558! Author:
29559!
29560! John Burkardt
29561!
29562! Parameters:
29563!
29564! Input, integer ( kind = 4 ) N, the number of input data values.
29565! N must be at least 2.
29566!
29567! Input, real ( kind = 8 ) X(N), the original data.
29568!
29569! Input, integer ( kind = 4 ) BEFORE, the number of "before" values.
29570!
29571! Input, integer ( kind = 4 ) FAT, the number of data values to interpolate
29572! between each pair of original data values.
29573!
29574! Input, integer ( kind = 4 ) AFTER, the number of "after" values.
29575!
29576! Output, real ( kind = 8 ) XFAT(BEFORE+(N-1)*(FAT+1)+1+AFTER), the
29577! "fattened" data.
29578!
29579 implicit none
29580
29581 integer ( kind = 4 ) after
29582 integer ( kind = 4 ) before
29583 integer ( kind = 4 ) fat
29584 integer ( kind = 4 ) n
29585
29586 integer ( kind = 4 ) i
29587 integer ( kind = 4 ) j
29588 integer ( kind = 4 ) k
29589 real ( kind = 8 ) x(n)
29590 real ( kind = 8 ) xfat(before+(n-1)*(fat+1)+1+after)
29591
29592 k = 0
29593!
29594! Points BEFORE.
29595!
29596 do j = 1 - before + fat, fat
29597 k = k + 1
29598 xfat(k) = ( real( fat - j + 1, kind = 8 ) * ( x(1) - ( x(2) - x(1) ) ) &
29599 + real( j, kind = 8 ) * x(1) ) &
29600 / real( fat + 1, kind = 8 )
29601 end do
29602!
29603! Original points and FAT points.
29604!
29605 do i = 1, n - 1
29606
29607 k = k + 1
29608 xfat(k) = x(i)
29609
29610 do j = 1, fat
29611 k = k + 1
29612 xfat(k) = ( real( fat - j + 1, kind = 8 ) * x(i) &
29613 + real( j, kind = 8 ) * x(i+1) ) &
29614 / real( fat + 1, kind = 8 )
29615 end do
29616
29617 end do
29618
29619 k = k + 1
29620 xfat(k) = x(n)
29621!
29622! Points AFTER.
29623!
29624 do j = 1, after
29625 k = k + 1
29626 xfat(k) = ( real( fat - j + 1, kind = 8 ) * x(n) &
29627 + real( j, kind = 8 ) &
29628 * ( x(n) + ( x(n) - x(n-1) ) ) ) &
29629 / real( fat + 1, kind = 8 )
29630 end do
29631
29632 return

◆ r8vec_first_index()

subroutine r8vec_first_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(n)  first_index 
)

Definition at line 29634 of file R8LIB.f90.

29635
29636!*****************************************************************************80
29637!
29638!! R8VEC_FIRST_INDEX indexes the first occurrence of values in an R8VEC.
29639!
29640! Discussion:
29641!
29642! An R8VEC is a vector of R8's.
29643!
29644! For element A(I) of the vector, FIRST_INDEX(I) is the index in A of
29645! the first occurrence of the value A(I).
29646!
29647! Licensing:
29648!
29649! This code is distributed under the GNU LGPL license.
29650!
29651! Modified:
29652!
29653! 24 August 2008
29654!
29655! Author:
29656!
29657! John Burkardt
29658!
29659! Parameters:
29660!
29661! Input, integer ( kind = 4 ) N, the number of elements of A.
29662!
29663! Input, real ( kind = 8 ) A(N), the array.
29664!
29665! Input, real ( kind = 8 ) TOL, a tolerance for equality.
29666!
29667! Output, integer ( kind = 4 ) FIRST_INDEX(N), the first occurrence index.
29668!
29669 implicit none
29670
29671 integer ( kind = 4 ) n
29672
29673 real ( kind = 8 ) a(n)
29674 integer ( kind = 4 ) first_index(n)
29675 integer ( kind = 4 ) i
29676 integer ( kind = 4 ) j
29677 real ( kind = 8 ) tol
29678
29679 first_index(1:n) = -1
29680
29681 do i = 1, n
29682
29683 if ( first_index(i) == -1 ) then
29684
29685 first_index(i) = i
29686
29687 do j = i + 1, n
29688 if ( abs( a(i) - a(j) ) <= tol ) then
29689 first_index(j) = i
29690 end if
29691 end do
29692
29693 end if
29694
29695 end do
29696
29697 return

◆ r8vec_floor()

subroutine r8vec_floor ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r8vec,
integer ( kind = 4 ), dimension(n)  floorvec 
)

Definition at line 29699 of file R8LIB.f90.

29700
29701!*****************************************************************************80
29702!
29703!! R8VEC_FLOOR rounds "down" (towards -oo) entries of an R8VEC.
29704!
29705! Discussion:
29706!
29707! An R8VEC is a vector of R8's.
29708!
29709! Example:
29710!
29711! R8 Value
29712!
29713! -1.1 -2
29714! -1.0 -1
29715! -0.9 -1
29716! 0.0 0
29717! 5.0 5
29718! 5.1 5
29719! 5.9 5
29720! 6.0 6
29721!
29722! Licensing:
29723!
29724! This code is distributed under the GNU LGPL license.
29725!
29726! Modified:
29727!
29728! 20 April 2007
29729!
29730! Author:
29731!
29732! John Burkardt
29733!
29734! Parameters:
29735!
29736! Input, integer ( kind = 4 ) N, the number of entries.
29737!
29738! Input, real ( kind = 8 ) R8VEC(N), the values to be rounded down.
29739!
29740! Output, integer ( kind = 4 ) FLOORVEC(N), the rounded value.
29741!
29742 implicit none
29743
29744 integer ( kind = 4 ) n
29745
29746 integer ( kind = 4 ) floorvec(n)
29747 integer ( kind = 4 ) i
29748 real ( kind = 8 ) r8vec(n)
29749 integer ( kind = 4 ) value
29750
29751 do i = 1, n
29752
29753 value = int( r8vec(i) )
29754
29755 if ( r8vec(i) < real( value, kind = 8 ) ) then
29756 value = value - 1
29757 end if
29758
29759 floorvec(i) = value
29760
29761 end do
29762
29763 return

◆ r8vec_frac()

subroutine r8vec_frac ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  k,
real ( kind = 8 )  frac 
)

Definition at line 29765 of file R8LIB.f90.

29766
29767!*****************************************************************************80
29768!
29769!! R8VEC_FRAC searches for the K-th smallest entry in an R8VEC.
29770!
29771! Discussion:
29772!
29773! An R8VEC is a vector of R8's.
29774!
29775! Hoare's algorithm is used.
29776!
29777! Licensing:
29778!
29779! This code is distributed under the GNU LGPL license.
29780!
29781! Modified:
29782!
29783! 17 July 2000
29784!
29785! Author:
29786!
29787! John Burkardt
29788!
29789! Parameters:
29790!
29791! Input, integer ( kind = 4 ) N, the number of elements of A.
29792!
29793! Input/output, real ( kind = 8 ) A(N).
29794! On input, A is the array to search.
29795! On output, the elements of A have been somewhat rearranged.
29796!
29797! Input, integer ( kind = 4 ) K, the fractile to be sought. If K = 1, the
29798! minimum entry is sought. If K = N, the maximum is sought. Other values
29799! of K search for the entry which is K-th in size. K must be at
29800! least 1, and no greater than N.
29801!
29802! Output, real ( kind = 8 ) FRAC, the value of the K-th fractile of A.
29803!
29804 implicit none
29805
29806 integer ( kind = 4 ) n
29807
29808 real ( kind = 8 ) a(n)
29809 real ( kind = 8 ) frac
29810 integer ( kind = 4 ) i
29811 integer ( kind = 4 ) iryt
29812 integer ( kind = 4 ) j
29813 integer ( kind = 4 ) k
29814 integer ( kind = 4 ) left
29815 real ( kind = 8 ) temp
29816 real ( kind = 8 ) x
29817
29818 if ( n <= 0 ) then
29819 write ( *, '(a)' ) ' '
29820 write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
29821 write ( *, '(a,i8)' ) ' Illegal nonpositive value of N = ', n
29822 stop 1
29823 end if
29824
29825 if ( k <= 0 ) then
29826 write ( *, '(a)' ) ' '
29827 write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
29828 write ( *, '(a,i8)' ) ' Illegal nonpositive value of K = ', k
29829 stop 1
29830 end if
29831
29832 if ( n < k ) then
29833 write ( *, '(a)' ) ' '
29834 write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
29835 write ( *, '(a,i8)' ) ' Illegal N < K, K = ', k
29836 stop 1
29837 end if
29838
29839 left = 1
29840 iryt = n
29841
29842 do
29843
29844 if ( iryt <= left ) then
29845 frac = a(k)
29846 exit
29847 end if
29848
29849 x = a(k)
29850 i = left
29851 j = iryt
29852
29853 do
29854
29855 if ( j < i ) then
29856 if ( j < k ) then
29857 left = i
29858 end if
29859 if ( k < i ) then
29860 iryt = j
29861 end if
29862 exit
29863 end if
29864!
29865! Find I so that X <= A(I).
29866!
29867 do while ( a(i) < x )
29868 i = i + 1
29869 end do
29870!
29871! Find J so that A(J) <= X.
29872!
29873 do while ( x < a(j) )
29874 j = j - 1
29875 end do
29876
29877 if ( i <= j ) then
29878
29879 temp = a(i)
29880 a(i) = a(j)
29881 a(j) = temp
29882
29883 i = i + 1
29884 j = j - 1
29885 end if
29886
29887 end do
29888
29889 end do
29890
29891 return

Referenced by r8vec_median().

Here is the caller graph for this function:

◆ r8vec_fraction()

subroutine r8vec_fraction ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  fraction 
)

Definition at line 29893 of file R8LIB.f90.

29894
29895!*****************************************************************************80
29896!
29897!! R8VEC_FRACTION returns the fraction parts of an R8VEC.
29898!
29899! Discussion:
29900!
29901! An R8VEC is a vector of R8's.
29902!
29903! If we regard a real number as
29904!
29905! R8 = SIGN * ( WHOLE + FRACTION )
29906!
29907! where
29908!
29909! SIGN is +1 or -1,
29910! WHOLE is a nonnegative integer
29911! FRACTION is a nonnegative real number strictly less than 1,
29912!
29913! then this routine returns the value of FRACTION.
29914!
29915! Example:
29916!
29917! R8 R8_FRACTION
29918!
29919! 0.00 0.00
29920! 1.01 0.01
29921! 2.02 0.02
29922! 19.73 0.73
29923! -4.34 0.34
29924!
29925! Licensing:
29926!
29927! This code is distributed under the GNU LGPL license.
29928!
29929! Modified:
29930!
29931! 18 April 2007
29932!
29933! Author:
29934!
29935! John Burkardt
29936!
29937! Parameters:
29938!
29939! Input, integer ( kind = 4 ) N, the number of arguments.
29940!
29941! Input, real ( kind = 8 ) X(N), the arguments.
29942!
29943! Output, real ( kind = 8 ) FRACTION(N), the fraction parts.
29944!
29945 implicit none
29946
29947 integer ( kind = 4 ) n
29948
29949 real ( kind = 8 ) fraction(n)
29950 real ( kind = 8 ) x(n)
29951
29952 fraction(1:n) = abs( x(1:n) ) - real( int( abs( x(1:n) ) ), kind = 8 )
29953
29954 return

◆ r8vec_gt()

logical ( kind = 4 ) function r8vec_gt ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 29956 of file R8LIB.f90.

29957
29958!*****************************************************************************80
29959!
29960!! R8VEC_GT == ( A1 > A2 ) for R8VEC's.
29961!
29962! Discussion:
29963!
29964! An R8VEC is a vector of R8's.
29965!
29966! The comparison is lexicographic.
29967!
29968! A1 > A2 <=> A1(1) > A2(1) or
29969! ( A1(1) == A2(1) and A1(2) > A2(2) ) or
29970! ...
29971! ( A1(1:N-1) == A2(1:N-1) and A1(N) > A2(N)
29972!
29973! Licensing:
29974!
29975! This code is distributed under the GNU LGPL license.
29976!
29977! Modified:
29978!
29979! 05 December 2004
29980!
29981! Author:
29982!
29983! John Burkardt
29984!
29985! Parameters:
29986!
29987! Input, integer ( kind = 4 ) N, the dimension of the vectors.
29988!
29989! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared.
29990!
29991! Output, logical ( kind = 4 ) R8VEC_GT, is TRUE if and only if A1 > A2.
29992!
29993 implicit none
29994
29995 integer ( kind = 4 ) n
29996
29997 real ( kind = 8 ) a1(n)
29998 real ( kind = 8 ) a2(n)
29999 integer ( kind = 4 ) i
30000 logical ( kind = 4 ) r8vec_gt
30001
30002 r8vec_gt = .false.
30003
30004 do i = 1, n
30005
30006 if ( a2(i) < a1(i) ) then
30007 r8vec_gt = .true.
30008 exit
30009 else if ( a1(i) < a2(i) ) then
30010 r8vec_gt = .false.
30011 exit
30012 end if
30013
30014 end do
30015
30016 return

References r8vec_gt().

Referenced by r8vec_gt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_heap_a()

subroutine r8vec_heap_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 30018 of file R8LIB.f90.

30019
30020!*****************************************************************************80
30021!
30022!! R8VEC_HEAP_A reorders an R8VEC into an ascending heap.
30023!
30024! Discussion:
30025!
30026! An R8VEC is a vector of R8's.
30027!
30028! An ascending heap is an array A with the property that, for every index J,
30029! A(J) <= A(2*J) and A(J) <= A(2*J+1), (as long as the indices
30030! 2*J and 2*J+1 are legal).
30031!
30032! A(1)
30033! / \
30034! A(2) A(3)
30035! / \ / \
30036! A(4) A(5) A(6) A(7)
30037! / \ / \
30038! A(8) A(9) A(10) A(11)
30039!
30040! Licensing:
30041!
30042! This code is distributed under the GNU LGPL license.
30043!
30044! Modified:
30045!
30046! 07 July 2003
30047!
30048! Author:
30049!
30050! John Burkardt
30051!
30052! Reference:
30053!
30054! Albert Nijenhuis, Herbert Wilf,
30055! Combinatorial Algorithms for Computers and Calculators,
30056! Academic Press, 1978,
30057! ISBN: 0-12-519260-6,
30058! LC: QA164.N54.
30059!
30060! Parameters:
30061!
30062! Input, integer ( kind = 4 ) N, the size of the input array.
30063!
30064! Input/output, real ( kind = 8 ) A(N).
30065! On input, an unsorted array.
30066! On output, the array has been reordered into a heap.
30067!
30068 implicit none
30069
30070 integer ( kind = 4 ) n
30071
30072 real ( kind = 8 ) a(n)
30073 integer ( kind = 4 ) i
30074 integer ( kind = 4 ) ifree
30075 real ( kind = 8 ) key
30076 integer ( kind = 4 ) m
30077!
30078! Only nodes N/2 down to 1 can be "parent" nodes.
30079!
30080 do i = n / 2, 1, -1
30081!
30082! Copy the value out of the parent node.
30083! Position IFREE is now "open".
30084!
30085 key = a(i)
30086 ifree = i
30087
30088 do
30089!
30090! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
30091! IFREE. (One or both may not exist because they exceed N.)
30092!
30093 m = 2 * ifree
30094!
30095! Does the first position exist?
30096!
30097 if ( n < m ) then
30098 exit
30099 end if
30100!
30101! Does the second position exist?
30102!
30103 if ( m + 1 <= n ) then
30104!
30105! If both positions exist, take the smaller of the two values,
30106! and update M if necessary.
30107!
30108 if ( a(m+1) < a(m) ) then
30109 m = m + 1
30110 end if
30111
30112 end if
30113!
30114! If the small descendant is smaller than KEY, move it up,
30115! and update IFREE, the location of the free position, and
30116! consider the descendants of THIS position.
30117!
30118 if ( key <= a(m) ) then
30119 exit
30120 end if
30121
30122 a(ifree) = a(m)
30123 ifree = m
30124
30125 end do
30126!
30127! Once there is no more shifting to do, KEY moves into the free spot.
30128!
30129 a(ifree) = key
30130
30131 end do
30132
30133 return

Referenced by r8vec_sort_heap_d().

Here is the caller graph for this function:

◆ r8vec_heap_d()

subroutine r8vec_heap_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 30135 of file R8LIB.f90.

30136
30137!*****************************************************************************80
30138!
30139!! R8VEC_HEAP_D reorders an R8VEC into an descending heap.
30140!
30141! Discussion:
30142!
30143! An R8VEC is a vector of R8's.
30144!
30145! A descending heap is an array A with the property that, for every index J,
30146! A(J) >= A(2*J) and A(J) >= A(2*J+1), (as long as the indices
30147! 2*J and 2*J+1 are legal).
30148!
30149! A(1)
30150! / \
30151! A(2) A(3)
30152! / \ / \
30153! A(4) A(5) A(6) A(7)
30154! / \ / \
30155! A(8) A(9) A(10) A(11)
30156!
30157! Licensing:
30158!
30159! This code is distributed under the GNU LGPL license.
30160!
30161! Modified:
30162!
30163! 07 July 2003
30164!
30165! Author:
30166!
30167! John Burkardt
30168!
30169! Reference:
30170!
30171! Albert Nijenhuis, Herbert Wilf,
30172! Combinatorial Algorithms for Computers and Calculators,
30173! Academic Press, 1978,
30174! ISBN: 0-12-519260-6,
30175! LC: QA164.N54.
30176!
30177! Parameters:
30178!
30179! Input, integer ( kind = 4 ) N, the size of the input array.
30180!
30181! Input/output, real ( kind = 8 ) A(N).
30182! On input, an unsorted array.
30183! On output, the array has been reordered into a heap.
30184!
30185 implicit none
30186
30187 integer ( kind = 4 ) n
30188
30189 real ( kind = 8 ) a(n)
30190 integer ( kind = 4 ) i
30191 integer ( kind = 4 ) ifree
30192 real ( kind = 8 ) key
30193 integer ( kind = 4 ) m
30194!
30195! Only nodes N/2 down to 1 can be "parent" nodes.
30196!
30197 do i = n / 2, 1, -1
30198!
30199! Copy the value out of the parent node.
30200! Position IFREE is now "open".
30201!
30202 key = a(i)
30203 ifree = i
30204
30205 do
30206!
30207! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
30208! IFREE. (One or both may not exist because they exceed N.)
30209!
30210 m = 2 * ifree
30211!
30212! Does the first position exist?
30213!
30214 if ( n < m ) then
30215 exit
30216 end if
30217!
30218! Does the second position exist?
30219!
30220 if ( m + 1 <= n ) then
30221!
30222! If both positions exist, take the larger of the two values,
30223! and update M if necessary.
30224!
30225 if ( a(m) < a(m+1) ) then
30226 m = m + 1
30227 end if
30228
30229 end if
30230!
30231! If the large descendant is larger than KEY, move it up,
30232! and update IFREE, the location of the free position, and
30233! consider the descendants of THIS position.
30234!
30235 if ( a(m) <= key ) then
30236 exit
30237 end if
30238
30239 a(ifree) = a(m)
30240 ifree = m
30241
30242 end do
30243!
30244! Once there is no more shifting to do, KEY moves into the free spot IFREE.
30245!
30246 a(ifree) = key
30247
30248 end do
30249
30250 return

Referenced by r8vec_sort_heap_a().

Here is the caller graph for this function:

◆ r8vec_heap_d_extract()

subroutine r8vec_heap_d_extract ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
real ( kind = 8 )  value 
)

Definition at line 30252 of file R8LIB.f90.

30253
30254!*****************************************************************************80
30255!
30256!! R8VEC_HEAP_D_EXTRACT: extract maximum from a heap descending sorted R8VEC.
30257!
30258! Discussion:
30259!
30260! An R8VEC is a vector of R8's.
30261!
30262! In other words, the routine finds the maximum value in the
30263! heap, returns that value to the user, deletes that value from
30264! the heap, and restores the heap to its proper form.
30265!
30266! This is one of three functions needed to model a priority queue.
30267!
30268! Licensing:
30269!
30270! This code is distributed under the GNU LGPL license.
30271!
30272! Modified:
30273!
30274! 16 August 2010
30275!
30276! Author:
30277!
30278! John Burkardt
30279!
30280! Reference:
30281!
30282! Thomas Cormen, Charles Leiserson, Ronald Rivest,
30283! Introduction to Algorithms,
30284! MIT Press, 2001,
30285! ISBN: 0262032937,
30286! LC: QA76.C662.
30287!
30288! Parameters:
30289!
30290! Input/output, integer ( kind = 4 ) N, the number of items in the heap.
30291!
30292! Input/output, real ( kind = 8 ) A(N), the heap.
30293!
30294! Output, real ( kind = 8 ) VALUE, the item of maximum value, which has
30295! been removed from the heap.
30296!
30297 implicit none
30298
30299 real ( kind = 8 ) a(*)
30300 integer ( kind = 4 ) n
30301 real ( kind = 8 ) value
30302
30303 if ( n < 1 ) then
30304 write ( *, '(a)' ) ' '
30305 write ( *, '(a)' ) 'R8VEC_HEAP_D_EXTRACT - Fatal error!'
30306 write ( *, '(a)' ) ' The heap is empty.'
30307 stop 1
30308 end if
30309!
30310! Get the maximum value.
30311!
30312 value = a(1)
30313
30314 if ( n == 1 ) then
30315 n = 0
30316 return
30317 end if
30318!
30319! Shift the last value down.
30320!
30321 a(1) = a(n)
30322!
30323! Restore the heap structure.
30324!
30325 n = n - 1
30326 call r8vec_sort_heap_d ( n, a )
30327
30328 return
r8vec_sort_heap_d
subroutine r8vec_sort_heap_d(n, a)
Definition R8LIB.f90:35710

References r8vec_sort_heap_d().

Here is the call graph for this function:

◆ r8vec_heap_d_insert()

subroutine r8vec_heap_d_insert ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
real ( kind = 8 )  value 
)

Definition at line 30330 of file R8LIB.f90.

30331
30332!*****************************************************************************80
30333!
30334!! R8VEC_HEAP_D_INSERT inserts a value into a heap descending sorted R8VEC.
30335!
30336! Discussion:
30337!
30338! An R8VEC is a vector of R8's.
30339!
30340! This is one of three functions needed to model a priority queue.
30341!
30342! Licensing:
30343!
30344! This code is distributed under the GNU LGPL license.
30345!
30346! Modified:
30347!
30348! 16 August 2010
30349!
30350! Author:
30351!
30352! John Burkardt
30353!
30354! Reference:
30355!
30356! Thomas Cormen, Charles Leiserson, Ronald Rivest,
30357! Introduction to Algorithms,
30358! MIT Press, 2001,
30359! ISBN: 0262032937,
30360! LC: QA76.C662.
30361!
30362! Parameters:
30363!
30364! Input/output, integer ( kind = 4 ) N, the number of items in the heap.
30365!
30366! Input/output, real ( kind = 8 ) A(N), the heap.
30367!
30368! Input, real ( kind = 8 ) VALUE, the value to be inserted.
30369!
30370 implicit none
30371
30372 real ( kind = 8 ) a(*)
30373 integer ( kind = 4 ) i
30374 integer ( kind = 4 ) n
30375 integer ( kind = 4 ) parent
30376 real ( kind = 8 ) value
30377
30378 n = n + 1
30379 i = n
30380
30381 do while ( 1 < i )
30382
30383 parent = i / 2
30384
30385 if ( value <= a(parent) ) then
30386 exit
30387 end if
30388
30389 a(i) = a(parent)
30390 i = parent
30391
30392 end do
30393
30394 a(i) = value
30395
30396 return

◆ r8vec_heap_d_max()

subroutine r8vec_heap_d_max ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  value 
)

Definition at line 30398 of file R8LIB.f90.

30399
30400!*****************************************************************************80
30401!
30402!! R8VEC_HEAP_D_MAX returns the maximum value in a heap descending sorted R8VEC.
30403!
30404! Discussion:
30405!
30406! An R8VEC is a vector of R8's.
30407!
30408! This is one of three functions needed to model a priority queue.
30409!
30410! Licensing:
30411!
30412! This code is distributed under the GNU LGPL license.
30413!
30414! Modified:
30415!
30416! 16 August 2010
30417!
30418! Author:
30419!
30420! John Burkardt
30421!
30422! Reference:
30423!
30424! Thomas Cormen, Charles Leiserson, Ronald Rivest,
30425! Introduction to Algorithms,
30426! MIT Press, 2001,
30427! ISBN: 0262032937,
30428! LC: QA76.C662.
30429!
30430! Parameters:
30431!
30432! Input, integer ( kind = 4 ) N, the number of items in the heap.
30433!
30434! Input, real ( kind = 8 ) A(N), the heap.
30435!
30436! Output, real ( kind = 8 ) VALUE, the maximum value in the heap.
30437!
30438 implicit none
30439
30440 integer ( kind = 4 ) n
30441
30442 real ( kind = 8 ) a(n)
30443 real ( kind = 8 ) value
30444
30445 value = a(1)
30446
30447 return

◆ r8vec_histogram()

subroutine r8vec_histogram ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  a_lo,
real ( kind = 8 )  a_hi,
integer ( kind = 4 )  histo_num,
integer ( kind = 4 ), dimension(0:histo_num+1)  histo_gram 
)

Definition at line 30449 of file R8LIB.f90.

30450
30451!*****************************************************************************80
30452!
30453!! R8VEC_HISTOGRAM histograms an R8VEC.
30454!
30455! Discussion:
30456!
30457! An R8VEC is a vector of R8's.
30458!
30459! Values between A_LO and A_HI will be histogrammed into the bins
30460! 1 through HISTO_NUM. Values below A_LO are counted in bin 0,
30461! and values greater than A_HI are counted in bin HISTO_NUM+1.
30462!
30463! Licensing:
30464!
30465! This code is distributed under the GNU LGPL license.
30466!
30467! Modified:
30468!
30469! 09 September 2005
30470!
30471! Author:
30472!
30473! John Burkardt
30474!
30475! Parameters:
30476!
30477! Input, integer ( kind = 4 ) N, the number of elements of A.
30478!
30479! Input, real ( kind = 8 ) A(N), the array to examine.
30480!
30481! Input, real ( kind = 8 ) A_LO, A_HI, the lowest and highest
30482! values to be histogrammed. These values will also define the bins.
30483!
30484! Input, integer ( kind = 4 ) HISTO_NUM, the number of bins to use.
30485!
30486! Output, integer ( kind = 4 ) HISTO_GRAM(0:HISTO_NUM+1), contains the
30487! number of entries of A in each bin.
30488!
30489 implicit none
30490
30491 integer ( kind = 4 ) histo_num
30492 integer ( kind = 4 ) n
30493
30494 real ( kind = 8 ) a(n)
30495 real ( kind = 8 ) a_hi
30496 real ( kind = 8 ) a_lo
30497 real ( kind = 8 ) delta
30498 integer ( kind = 4 ) histo_gram(0:histo_num+1)
30499 integer ( kind = 4 ) i
30500 integer ( kind = 4 ) j
30501
30502 histo_gram(0:histo_num+1) = 0
30503
30504 delta = ( a_hi - a_lo ) / real( 2 * histo_num, kind = 8 )
30505
30506 do i = 1, n
30507
30508 if ( a(i) < a_lo ) then
30509
30510 histo_gram(0) = histo_gram(0) + 1
30511
30512 else if ( a(i) <= a_hi ) then
30513
30514 j = nint( &
30515 ( ( a_hi - delta - a(i) ) &
30516 * real( 1, kind = 8 ) &
30517 + ( - delta + a(i) - a_lo ) &
30518 * real( histo_num, kind = 8 ) ) &
30519 / ( a_hi - 2.0d+00 * delta - a_lo ) )
30520
30521 histo_gram(j) = histo_gram(j) + 1
30522
30523 else if ( a_hi < a(i) ) then
30524
30525 histo_gram(histo_num+1) = histo_gram(histo_num+1) + 1
30526
30527 end if
30528
30529 end do
30530
30531 return

◆ r8vec_house_column()

subroutine r8vec_house_column ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  k,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 30533 of file R8LIB.f90.

30534
30535!*****************************************************************************80
30536!
30537!! R8VEC_HOUSE_COLUMN defines a Householder premultiplier that "packs" a column.
30538!
30539! Discussion:
30540!
30541! An R8VEC is a vector of R8's.
30542!
30543! The routine returns a vector V that defines a Householder
30544! premultiplier matrix H(V) that zeros out the subdiagonal entries of
30545! column K of the matrix A.
30546!
30547! H(V) = I - 2 * v * v'
30548!
30549! Licensing:
30550!
30551! This code is distributed under the GNU LGPL license.
30552!
30553! Modified:
30554!
30555! 01 June 2002
30556!
30557! Author:
30558!
30559! John Burkardt
30560!
30561! Parameters:
30562!
30563! Input, integer ( kind = 4 ) N, the order of the matrix A.
30564!
30565! Input, real ( kind = 8 ) A(N), column K of the matrix A.
30566!
30567! Input, integer ( kind = 4 ) K, the column of the matrix to be modified.
30568!
30569! Output, real ( kind = 8 ) V(N), a vector of unit L2 norm which defines an
30570! orthogonal Householder premultiplier matrix H with the property
30571! that the K-th column of H*A is zero below the diagonal.
30572!
30573 implicit none
30574
30575 integer ( kind = 4 ) n
30576
30577 real ( kind = 8 ) a(n)
30578 integer ( kind = 4 ) k
30579 real ( kind = 8 ) s
30580 real ( kind = 8 ) v(n)
30581
30582 v(1:n) = 0.0d+00
30583
30584 if ( k < 1 .or. n <= k ) then
30585 return
30586 end if
30587
30588 s = sqrt( dot_product( a(k:n), a(k:n) ) )
30589
30590 if ( s == 0.0d+00 ) then
30591 return
30592 end if
30593
30594 v(k) = a(k) + sign( s, a(k) )
30595 v(k+1:n) = a(k+1:n)
30596
30597 v(k:n) = v(k:n) / sqrt( dot_product( v(k:n), v(k:n) ) )
30598
30599 return

Referenced by r8mat_house_post(), r8mat_house_pre(), and r8mat_orth_uniform().

Here is the caller graph for this function:

◆ r8vec_i4vec_dot_product()

real ( kind = 8 ) function r8vec_i4vec_dot_product ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r8vec,
integer ( kind = 4 ), dimension(n)  i4vec 
)

Definition at line 30601 of file R8LIB.f90.

30602
30603!*****************************************************************************80
30604!
30605!! R8VEC_I4VEC_DOT_PRODUCT finds the dot product of an R8VEC and an I4VEC.
30606!
30607! Discussion:
30608!
30609! An R8VEC is a vector of R8's.
30610!
30611! An I4VEC is a vector of I4's.
30612!
30613! Licensing:
30614!
30615! This code is distributed under the GNU LGPL license.
30616!
30617! Modified:
30618!
30619! 30 June 2009
30620!
30621! Author:
30622!
30623! John Burkardt
30624!
30625! Parameters:
30626!
30627! Input, integer ( kind = 4 ) N, the dimension of the vectors.
30628!
30629! Input, real ( kind = 8 ) R8VEC(N), the first vector.
30630!
30631! Input, integer ( kind = 4 ) I4VEC(N), the second vector.
30632!
30633! Output, real ( kind = 8 ) R8VEC_I4VEC_DOT_PRODUCT, the dot product.
30634!
30635 implicit none
30636
30637 integer ( kind = 4 ) n
30638
30639 integer ( kind = 4 ) i4vec(n)
30640 real ( kind = 8 ) r8vec(n)
30641 real ( kind = 8 ) r8vec_i4vec_dot_product
30642
30643 r8vec_i4vec_dot_product = dot_product( r8vec(1:n), &
30644 real ( i4vec(1:n), kind = 8 ) )
30645
30646 return
r8vec_i4vec_dot_product
real(kind=8) function r8vec_i4vec_dot_product(n, r8vec, i4vec)
Definition R8LIB.f90:30602

References r8vec_i4vec_dot_product().

Referenced by r8vec_i4vec_dot_product().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_in_01()

logical ( kind = 4 ) function r8vec_in_01 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 30648 of file R8LIB.f90.

30649
30650!*****************************************************************************80
30651!
30652!! R8VEC_IN_01 is TRUE if the entries of an R8VEC are in the range [0,1].
30653!
30654! Discussion:
30655!
30656! An R8VEC is a vector of R8's.
30657!
30658! Licensing:
30659!
30660! This code is distributed under the GNU LGPL license.
30661!
30662! Modified:
30663!
30664! 06 October 2004
30665!
30666! Author:
30667!
30668! John Burkardt
30669!
30670! Parameters:
30671!
30672! Input, integer ( kind = 4 ) N, the number of entries in A.
30673!
30674! Input, real ( kind = 8 ) A(N), the vector.
30675!
30676! Output, logical ( kind = 4 ) R8VEC_IN_01, is TRUE if every entry of A is
30677! between 0 and 1.
30678!
30679 implicit none
30680
30681 integer ( kind = 4 ) n
30682
30683 real ( kind = 8 ) a(n)
30684 logical ( kind = 4 ) r8vec_in_01
30685
30686 if ( any( a(1:n) < 0.0d+00 .or. 1.0d+00 < a(1:n) ) ) then
30687 r8vec_in_01 = .false.
30688 else
30689 r8vec_in_01 = .true.
30690 end if
30691
30692 return
r8vec_in_01
logical(kind=4) function r8vec_in_01(n, a)
Definition R8LIB.f90:30649

References r8vec_in_01().

Referenced by r8vec_in_01().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_in_ab()

logical ( kind = 4 ) function r8vec_in_ab ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 )  a,
real ( kind = 8 )  b 
)

Definition at line 30694 of file R8LIB.f90.

30695
30696!*****************************************************************************80
30697!
30698!! R8VEC_IN_AB is TRUE if the entries of an R8VEC are in the range [A,B].
30699!
30700! Discussion:
30701!
30702! An R8VEC is a vector of R8's.
30703!
30704! Licensing:
30705!
30706! This code is distributed under the GNU LGPL license.
30707!
30708! Modified:
30709!
30710! 15 April 2012
30711!
30712! Author:
30713!
30714! John Burkardt
30715!
30716! Parameters:
30717!
30718! Input, integer ( kind = 4 ) N, the number of entries in X.
30719!
30720! Input, real ( kind = 8 ) X(N), the vector.
30721!
30722! Input, real ( kind = 8 ) A, B, the limits of the range.
30723!
30724! Output, logical ( kind = 4 ) R8VEC_IN_AB, is TRUE if every entry of A is
30725! between A and B.
30726!
30727 implicit none
30728
30729 integer ( kind = 4 ) n
30730
30731 real ( kind = 8 ) a
30732 real ( kind = 8 ) b
30733 logical ( kind = 4 ) r8vec_in_ab
30734 real ( kind = 8 ) x(n)
30735
30736 if ( any( x(1:n) < a .or. b < x(1:n) ) ) then
30737 r8vec_in_ab = .false.
30738 else
30739 r8vec_in_ab = .true.
30740 end if
30741
30742 return
r8vec_in_ab
logical(kind=4) function r8vec_in_ab(n, x, a, b)
Definition R8LIB.f90:30695

References r8vec_in_ab().

Referenced by r8vec_in_ab().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_index_delete_all()

subroutine r8vec_index_delete_all ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  x,
integer ( kind = 4 ), dimension(*)  indx,
real ( kind = 8 )  xval 
)

Definition at line 30744 of file R8LIB.f90.

30745
30746!*****************************************************************************80
30747!
30748!! R8VEC_INDEX_DELETE_ALL deletes a value from an indexed sorted R8VEC.
30749!
30750! Discussion:
30751!
30752! An R8VEC is a vector of R8's.
30753!
30754! Note that the value of N is adjusted because of the deletions!
30755!
30756! Licensing:
30757!
30758! This code is distributed under the GNU LGPL license.
30759!
30760! Modified:
30761!
30762! 11 October 2000
30763!
30764! Author:
30765!
30766! John Burkardt
30767!
30768! Parameters:
30769!
30770! Input/output, integer ( kind = 4 ) N, the size of the current list.
30771!
30772! Input/output, real ( kind = 8 ) X(N), the list.
30773!
30774! Input/output, integer ( kind = 4 ) INDX(N), the sort index of the list.
30775!
30776! Input, real ( kind = 8 ) XVAL, the value to be sought.
30777!
30778 implicit none
30779
30780 integer ( kind = 4 ) n
30781
30782 integer ( kind = 4 ) equal
30783 integer ( kind = 4 ) equal1
30784 integer ( kind = 4 ) equal2
30785 integer ( kind = 4 ) get
30786 integer ( kind = 4 ) i
30787 integer ( kind = 4 ) indx(*)
30788 integer ( kind = 4 ) less
30789 integer ( kind = 4 ) more
30790 integer ( kind = 4 ) put
30791 real ( kind = 8 ) x(*)
30792 real ( kind = 8 ) xval
30793
30794 if ( n < 1 ) then
30795 n = 0
30796 return
30797 end if
30798
30799 call r8vec_index_search ( n, x, indx, xval, less, equal, more )
30800
30801 if ( equal == 0 ) then
30802 return
30803 end if
30804
30805 equal1 = equal
30806
30807 do
30808
30809 if ( equal1 <= 1 ) then
30810 exit
30811 end if
30812
30813 if ( x(indx(equal1-1)) /= xval ) then
30814 exit
30815 end if
30816
30817 equal1 = equal1 - 1
30818
30819 end do
30820
30821 equal2 = equal
30822
30823 do
30824
30825 if ( n <= equal2 ) then
30826 exit
30827 end if
30828
30829 if ( x(indx(equal2+1)) /= xval ) then
30830 exit
30831 end if
30832
30833 equal2 = equal2 + 1
30834
30835 end do
30836!
30837! Discard certain X values.
30838!
30839 put = 0
30840
30841 do get = 1, n
30842
30843 if ( x(get) /= xval ) then
30844 put = put + 1
30845 x(put) = x(get)
30846 end if
30847
30848 end do
30849
30850 x(put+1:n) = 0.0d+00
30851!
30852! Adjust the INDX values.
30853!
30854 do equal = equal1, equal2
30855 do i = 1, n
30856 if ( indx(equal) < indx(i) ) then
30857 indx(i) = indx(i) - 1
30858 end if
30859 end do
30860 end do
30861!
30862! Discard certain INDX values.
30863!
30864 indx(equal1:n+equal1-equal2-1) = indx(equal2+1:n)
30865 indx(n+equal1-equal2:n) = 0
30866!
30867! Adjust N.
30868!
30869 n = put
30870
30871 return
r8vec_index_search
subroutine r8vec_index_search(n, x, indx, xval, less, equal, more)
Definition R8LIB.f90:31218

References r8vec_index_search().

Here is the call graph for this function:

◆ r8vec_index_delete_dupes()

subroutine r8vec_index_delete_dupes ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 ), dimension(n)  indx,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(n)  x2,
integer ( kind = 4 ), dimension(n)  indx2 
)

Definition at line 30873 of file R8LIB.f90.

30874
30875!*****************************************************************************80
30876!
30877!! R8VEC_INDEX_DELETE_DUPES deletes duplicates from an indexed sorted R8VEC.
30878!
30879! Discussion:
30880!
30881! An R8VEC is a vector of R8's.
30882!
30883! The output quantities N2, X2, and INDX2 are computed from the
30884! input quantities by sorting, and eliminating duplicates.
30885!
30886! The output arrays should be dimensioned of size N, unless the user
30887! knows in advance what the value of N2 will be.
30888!
30889! The output arrays may be identified with the input arrays.
30890!
30891! Licensing:
30892!
30893! This code is distributed under the GNU LGPL license.
30894!
30895! Modified:
30896!
30897! 15 October 2005
30898!
30899! Author:
30900!
30901! John Burkardt
30902!
30903! Parameters:
30904!
30905! Input, integer ( kind = 4 ) N, the size of the input list.
30906!
30907! Input, real ( kind = 8 ) X(N), the list.
30908!
30909! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
30910!
30911! Output, integer ( kind = 4 ) N2, the number of unique entries in X.
30912!
30913! Output, real ( kind = 8 ) X2(N2), a copy of the list which has
30914! been sorted, and made unique.
30915!
30916! Output, integer ( kind = 4 ) INDX2(N2), the sort index of the new list.
30917!
30918 implicit none
30919
30920 integer ( kind = 4 ) n
30921
30922 integer ( kind = 4 ) i
30923 integer ( kind = 4 ) indx(n)
30924 integer ( kind = 4 ) indx2(n)
30925 integer ( kind = 4 ) n2
30926 integer ( kind = 4 ) n3
30927 real ( kind = 8 ) x(n)
30928 real ( kind = 8 ) x2(n)
30929 real ( kind = 8 ) x3(n)
30930
30931 i = 0
30932 n3 = 0
30933
30934 do
30935
30936 i = i + 1
30937
30938 if ( n < i ) then
30939 exit
30940 end if
30941
30942 if ( 1 < i ) then
30943 if ( x(indx(i)) == x3(n3) ) then
30944 cycle
30945 end if
30946 end if
30947
30948 n3 = n3 + 1
30949 x3(n3) = x(indx(i))
30950
30951 end do
30952!
30953! Copy data into output arrays.
30954!
30955 n2 = n3
30956 x2(1:n2) = x3(1:n3)
30957 call i4vec_indicator1 ( n2, indx2 )
30958
30959 return

References i4vec_indicator1().

Here is the call graph for this function:

◆ r8vec_index_delete_one()

subroutine r8vec_index_delete_one ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 ), dimension(n)  indx,
real ( kind = 8 )  xval,
integer ( kind = 4 )  n2,
real ( kind = 8 ), dimension(n)  x2,
integer ( kind = 4 ), dimension(n)  indx2 
)

Definition at line 30961 of file R8LIB.f90.

30962
30963!*****************************************************************************80
30964!
30965!! R8VEC_INDEX_DELETE_ONE deletes one copy of a value from indexed sorted R8VEC.
30966!
30967! Discussion:
30968!
30969! An R8VEC is a vector of R8's.
30970!
30971! If the value occurs in the list more than once, only one copy is deleted.
30972!
30973! Note that the value of N is adjusted because of the deletions.
30974!
30975! Licensing:
30976!
30977! This code is distributed under the GNU LGPL license.
30978!
30979! Modified:
30980!
30981! 24 October 2000
30982!
30983! Author:
30984!
30985! John Burkardt
30986!
30987! Parameters:
30988!
30989! Input, integer ( kind = 4 ) N, the size of the current list.
30990!
30991! Input, real ( kind = 8 ) X(N), the list.
30992!
30993! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
30994!
30995! Input, real ( kind = 8 ) XVAL, the value to be sought.
30996!
30997! Output, integer ( kind = 4 ) N2, the size of the current list.
30998!
30999! Output, real ( kind = 8 ) X2(N2), the list.
31000!
31001! Output, integer ( kind = 4 ) INDX2(N2), the sort index of the list.
31002!
31003 implicit none
31004
31005 integer ( kind = 4 ) n
31006
31007 integer ( kind = 4 ) equal
31008 integer ( kind = 4 ) i
31009 integer ( kind = 4 ) indx(n)
31010 integer ( kind = 4 ) indx2(n)
31011 integer ( kind = 4 ) j
31012 integer ( kind = 4 ) less
31013 integer ( kind = 4 ) more
31014 integer ( kind = 4 ) n2
31015 real ( kind = 8 ) x(n)
31016 real ( kind = 8 ) x2(n)
31017 real ( kind = 8 ) xval
31018
31019 if ( n < 1 ) then
31020 n2 = 0
31021 return
31022 end if
31023
31024 n2 = n
31025 indx2(1:n2) = indx(1:n2)
31026 x2(1:n2) = x(1:n2)
31027
31028 call r8vec_index_search ( n2, x2, indx2, xval, less, equal, more )
31029
31030 if ( equal /= 0 ) then
31031 j = indx2(equal)
31032 x2(j:n2-1) = x2(j+1:n2)
31033 indx2(equal:n2-1) = indx2(equal+1:n2)
31034 do i = 1, n2-1
31035 if ( j < indx2(i) ) then
31036 indx2(i) = indx2(i) - 1
31037 end if
31038 end do
31039 n2 = n2 - 1
31040 end if
31041
31042 return

References r8vec_index_search().

Here is the call graph for this function:

◆ r8vec_index_insert()

subroutine r8vec_index_insert ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  x,
integer ( kind = 4 ), dimension(*)  indx,
real ( kind = 8 )  xval 
)

Definition at line 31044 of file R8LIB.f90.

31045
31046!*****************************************************************************80
31047!
31048!! R8VEC_INDEX_INSERT inserts a value in an indexed sorted R8VEC.
31049!
31050! Discussion:
31051!
31052! An R8VEC is a vector of R8's.
31053!
31054! Licensing:
31055!
31056! This code is distributed under the GNU LGPL license.
31057!
31058! Modified:
31059!
31060! 11 October 2000
31061!
31062! Author:
31063!
31064! John Burkardt
31065!
31066! Parameters:
31067!
31068! Input/output, integer ( kind = 4 ) N, the size of the current list.
31069!
31070! Input/output, real ( kind = 8 ) X(N), the list.
31071!
31072! Input/output, integer ( kind = 4 ) INDX(N), the sort index of the list.
31073!
31074! Input, real ( kind = 8 ) XVAL, the value to be sought.
31075!
31076 implicit none
31077
31078 integer ( kind = 4 ) n
31079
31080 integer ( kind = 4 ) equal
31081 integer ( kind = 4 ) indx(*)
31082 integer ( kind = 4 ) less
31083 integer ( kind = 4 ) more
31084 real ( kind = 8 ) x(*)
31085 real ( kind = 8 ) xval
31086
31087 if ( n <= 0 ) then
31088 n = 1
31089 x(1) = xval
31090 indx(1) = 1
31091 return
31092 end if
31093
31094 call r8vec_index_search ( n, x, indx, xval, less, equal, more )
31095
31096 x(n+1) = xval
31097 indx(n+1:more+1:-1) = indx(n:more:-1)
31098 indx(more) = n + 1
31099 n = n + 1
31100
31101 return

References r8vec_index_search().

Here is the call graph for this function:

◆ r8vec_index_insert_unique()

subroutine r8vec_index_insert_unique ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  x,
integer ( kind = 4 ), dimension(*)  indx,
real ( kind = 8 )  xval 
)

Definition at line 31103 of file R8LIB.f90.

31104
31105!*****************************************************************************80
31106!
31107!! R8VEC_INDEX_INSERT_UNIQUE inserts a unique value in an indexed sorted R8VEC.
31108!
31109! Discussion:
31110!
31111! An R8VEC is a vector of R8's.
31112!
31113! If the value does not occur in the list, it is included in the list,
31114! and N, X and INDX are updated.
31115!
31116! Licensing:
31117!
31118! This code is distributed under the GNU LGPL license.
31119!
31120! Modified:
31121!
31122! 11 October 2000
31123!
31124! Author:
31125!
31126! John Burkardt
31127!
31128! Parameters:
31129!
31130! Input/output, integer ( kind = 4 ) N, the size of the current list.
31131!
31132! Input/output, real ( kind = 8 ) X(N), the list.
31133!
31134! Input/output, integer ( kind = 4 ) INDX(N), the sort index of the list.
31135!
31136! Input, real ( kind = 8 ) XVAL, the value to be sought.
31137!
31138 implicit none
31139
31140 integer ( kind = 4 ) n
31141
31142 integer ( kind = 4 ) equal
31143 integer ( kind = 4 ) indx(*)
31144 integer ( kind = 4 ) less
31145 integer ( kind = 4 ) more
31146 real ( kind = 8 ) x(*)
31147 real ( kind = 8 ) xval
31148
31149 if ( n <= 0 ) then
31150 n = 1
31151 x(1) = xval
31152 indx(1) = 1
31153 return
31154 end if
31155!
31156! Does XVAL already occur in X?
31157!
31158 call r8vec_index_search ( n, x, indx, xval, less, equal, more )
31159
31160 if ( equal == 0 ) then
31161 x(n+1) = xval
31162 indx(n+1:more+1:-1) = indx(n:more:-1)
31163 indx(more) = n + 1
31164 n = n + 1
31165 end if
31166
31167 return

References r8vec_index_search().

Referenced by r8vec_index_sort_unique().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_index_order()

subroutine r8vec_index_order ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 31169 of file R8LIB.f90.

31170
31171!*****************************************************************************80
31172!
31173!! R8VEC_INDEX_ORDER sorts an R8VEC using an index vector.
31174!
31175! Discussion:
31176!
31177! An R8VEC is a vector of R8's.
31178!
31179! The index vector itself is not modified. Therefore, the pair
31180! (X,INDX) no longer represents an index sorted vector. If this
31181! relationship is to be preserved, then simply set INDX(1:N)=(1:N).
31182!
31183! Licensing:
31184!
31185! This code is distributed under the GNU LGPL license.
31186!
31187! Modified:
31188!
31189! 11 October 2000
31190!
31191! Author:
31192!
31193! John Burkardt
31194!
31195! Parameters:
31196!
31197! Input, integer ( kind = 4 ) N, the size of the current list.
31198!
31199! Input/output, real ( kind = 8 ) X(N), the list. On output, the list
31200! has been sorted.
31201!
31202! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
31203!
31204 implicit none
31205
31206 integer ( kind = 4 ) n
31207
31208 integer ( kind = 4 ) indx(n)
31209 real ( kind = 8 ) x(n)
31210 real ( kind = 8 ) y(n)
31211
31212 y(1:n) = x(indx(1:n))
31213 x(1:n) = y(1:n)
31214
31215 return

◆ r8vec_index_search()

subroutine r8vec_index_search ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 ), dimension(n)  indx,
real ( kind = 8 )  xval,
integer ( kind = 4 )  less,
integer ( kind = 4 )  equal,
integer ( kind = 4 )  more 
)

Definition at line 31217 of file R8LIB.f90.

31218
31219!*****************************************************************************80
31220!
31221!! R8VEC_INDEX_SEARCH searches for a value in an indexed sorted R8VEC.
31222!
31223! Discussion:
31224!
31225! An R8VEC is a vector of R8's.
31226!
31227! Licensing:
31228!
31229! This code is distributed under the GNU LGPL license.
31230!
31231! Modified:
31232!
31233! 11 October 2000
31234!
31235! Author:
31236!
31237! John Burkardt
31238!
31239! Parameters:
31240!
31241! Input, integer ( kind = 4 ) N, the size of the current list.
31242!
31243! Input, real ( kind = 8 ) X(N), the list.
31244!
31245! Input, integer ( kind = 4 ) INDX(N), the sort index of the list.
31246!
31247! Input, real ( kind = 8 ) XVAL, the value to be sought.
31248!
31249! Output, integer ( kind = 4 ) LESS, EQUAL, MORE, the indexes in INDX of the
31250! entries of X that are just less than, equal to, and just greater
31251! than XVAL. If XVAL does not occur in X, then EQUAL is zero.
31252! If XVAL is the minimum entry of X, then LESS is 0. If XVAL
31253! is the greatest entry of X, then MORE is N+1.
31254!
31255 implicit none
31256
31257 integer ( kind = 4 ) n
31258
31259 integer ( kind = 4 ) equal
31260 integer ( kind = 4 ) hi
31261 integer ( kind = 4 ) indx(n)
31262 integer ( kind = 4 ) less
31263 integer ( kind = 4 ) lo
31264 integer ( kind = 4 ) mid
31265 integer ( kind = 4 ) more
31266 real ( kind = 8 ) x(n)
31267 real ( kind = 8 ) xhi
31268 real ( kind = 8 ) xlo
31269 real ( kind = 8 ) xmid
31270 real ( kind = 8 ) xval
31271
31272 if ( n <= 0 ) then
31273 less = 0
31274 equal = 0
31275 more = 0
31276 return
31277 end if
31278
31279 lo = 1
31280 hi = n
31281 xlo = x(indx(lo))
31282 xhi = x(indx(hi))
31283
31284 if ( xval < xlo ) then
31285 less = 0
31286 equal = 0
31287 more = 1
31288 return
31289 else if ( xval == xlo ) then
31290 less = 0
31291 equal = 1
31292 more = 2
31293 return
31294 end if
31295
31296 if ( xhi < xval ) then
31297 less = n
31298 equal = 0
31299 more = n + 1
31300 return
31301 else if ( xval == xhi ) then
31302 less = n - 1
31303 equal = n
31304 more = n + 1
31305 return
31306 end if
31307
31308 do
31309
31310 if ( lo + 1 == hi ) then
31311 less = lo
31312 equal = 0
31313 more = hi
31314 return
31315 end if
31316
31317 mid = ( lo + hi ) / 2
31318 xmid = x(indx(mid))
31319
31320 if ( xval == xmid ) then
31321 equal = mid
31322 less = equal - 1
31323 more = equal + 1
31324 return
31325 else if ( xval < xmid ) then
31326 hi = mid
31327 else if ( xmid < xval ) then
31328 lo = mid
31329 end if
31330
31331 end do
31332
31333 return

Referenced by r8vec_index_delete_all(), r8vec_index_delete_one(), r8vec_index_insert(), and r8vec_index_insert_unique().

Here is the caller graph for this function:

◆ r8vec_index_sort_unique()

subroutine r8vec_index_sort_unique ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
integer ( kind = 4 ), dimension(n)  indx,
integer ( kind = 4 )  n2 
)

Definition at line 31335 of file R8LIB.f90.

31336
31337!*****************************************************************************80
31338!
31339!! R8VEC_INDEX_SORT_UNIQUE creates a sorted unique index for an R8VEC.
31340!
31341! Discussion:
31342!
31343! An R8VEC is a vector of R8's.
31344!
31345! Licensing:
31346!
31347! This code is distributed under the GNU LGPL license.
31348!
31349! Modified:
31350!
31351! 11 October 2000
31352!
31353! Author:
31354!
31355! John Burkardt
31356!
31357! Parameters:
31358!
31359! Input, integer ( kind = 4 ) N, the size of the current list.
31360!
31361! Input/output, real ( kind = 8 ) X(N), the list. On output, X contains only
31362! unique elements.
31363!
31364! Output, integer ( kind = 4 ) INDX(N), the sort index of the list.
31365!
31366! Output, integer ( kind = 4 ) N2, the number of unique elements in X.
31367!
31368 implicit none
31369
31370 integer ( kind = 4 ) n
31371
31372 integer ( kind = 4 ) i
31373 integer ( kind = 4 ) indx(n)
31374 integer ( kind = 4 ) n2
31375 real ( kind = 8 ) x(n)
31376 real ( kind = 8 ) y(n)
31377
31378 n2 = 0
31379
31380 do i = 1, n
31381 call r8vec_index_insert_unique ( n2, y, indx, x(i) )
31382 end do
31383
31384 x(1:n2) = y(1:n2)
31385
31386 x(n2+1:n) = 0.0d+00
31387 indx(n2+1:n) = 0
31388
31389 return
r8vec_index_insert_unique
subroutine r8vec_index_insert_unique(n, x, indx, xval)
Definition R8LIB.f90:31104

References r8vec_index_insert_unique().

Here is the call graph for this function:

◆ r8vec_index_sorted_range()

subroutine r8vec_index_sorted_range ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r,
integer ( kind = 4 ), dimension(n)  indx,
real ( kind = 8 )  r_lo,
real ( kind = 8 )  r_hi,
integer ( kind = 4 )  i_lo,
integer ( kind = 4 )  i_hi 
)

Definition at line 31391 of file R8LIB.f90.

31392
31393!*****************************************************************************80
31394!
31395!! R8VEC_INDEX_SORTED_RANGE: search index sorted vector for elements in a range.
31396!
31397! Licensing:
31398!
31399! This code is distributed under the GNU LGPL license.
31400!
31401! Modified:
31402!
31403! 24 September 2010
31404!
31405! Author:
31406!
31407! John Burkardt
31408!
31409! Parameters:
31410!
31411! Input, integer ( kind = 4 ) N, the number of items in the vector.
31412!
31413! Input, real ( kind = 8 ) R(N), the index sorted vector.
31414!
31415! Input, integer ( kind = 4 ) INDX(N), the vector used to sort R.
31416! The vector R(INDX(*)) is sorted.
31417!
31418! Input, real ( kind = 8 ) R_LO, R_HI, the limits of the range.
31419!
31420! Output, integer ( kind = 4 ) I_LO, I_HI, the range of indices
31421! so that I_LO <= I <= I_HI => R_LO <= R(INDX(I)) <= R_HI. If no
31422! values in R lie in the range, then I_HI < I_LO will be returned.
31423!
31424 implicit none
31425
31426 integer ( kind = 4 ) n
31427
31428 integer ( kind = 4 ) i_hi
31429 integer ( kind = 4 ) i_lo
31430 integer ( kind = 4 ) i1
31431 integer ( kind = 4 ) i2
31432 integer ( kind = 4 ) indx(n)
31433 integer ( kind = 4 ) j1
31434 integer ( kind = 4 ) j2
31435 real ( kind = 8 ) r(n)
31436 real ( kind = 8 ) r_hi
31437 real ( kind = 8 ) r_lo
31438!
31439! Cases we can handle immediately.
31440!
31441 if ( r(indx(n)) < r_lo ) then
31442 i_lo = n + 1
31443 i_hi = n
31444 return
31445 end if
31446
31447 if ( r_hi < r(indx(1)) ) then
31448 i_lo = 1
31449 i_hi = 0
31450 return
31451 end if
31452!
31453! Are there are least two intervals?
31454!
31455 if ( n == 1 ) then
31456 if ( r_lo <= r(indx(1)) .and. r(indx(1)) <= r_hi ) then
31457 i_lo = 1
31458 i_hi = 1
31459 else
31460 i_lo = 0
31461 i_hi = -1
31462 end if
31463 return
31464 end if
31465!
31466! Bracket R_LO.
31467!
31468 if ( r_lo <= r(indx(1)) ) then
31469
31470 i_lo = 1
31471
31472 else
31473!
31474! R_LO is in one of the intervals spanned by R(INDX(J1)) to R(INDX(J2)).
31475! Examine the intermediate interval [R(INDX(I1)), R(INDX(I1+1))].
31476! Does R_LO lie here, or below or above?
31477!
31478 j1 = 1
31479 j2 = n
31480 i1 = ( j1 + j2 - 1 ) / 2
31481 i2 = i1 + 1
31482
31483 do
31484
31485 if ( r_lo < r(indx(i1)) ) then
31486 j2 = i1
31487 i1 = ( j1 + j2 - 1 ) / 2
31488 i2 = i1 + 1
31489 else if ( r(indx(i2)) < r_lo ) then
31490 j1 = i2
31491 i1 = ( j1 + j2 - 1 ) / 2
31492 i2 = i1 + 1
31493 else
31494 i_lo = i1
31495 exit
31496 end if
31497
31498 end do
31499
31500 end if
31501!
31502! Bracket R_HI.
31503!
31504 if ( r(indx(n)) <= r_hi ) then
31505
31506 i_hi = n
31507
31508 else
31509
31510 j1 = i_lo
31511 j2 = n
31512 i1 = ( j1 + j2 - 1 ) / 2
31513 i2 = i1 + 1
31514
31515 do
31516
31517 if ( r_hi < r(indx(i1)) ) then
31518 j2 = i1
31519 i1 = ( j1 + j2 - 1 ) / 2
31520 i2 = i1 + 1
31521 else if ( r(indx(i2)) < r_hi ) then
31522 j1 = i2
31523 i1 = ( j1 + j2 - 1 ) / 2
31524 i2 = i1 + 1
31525 else
31526 i_hi = i2
31527 exit
31528 end if
31529
31530 end do
31531
31532 end if
31533!
31534! We expect to have computed the largest I_LO and smallest I_HI such that
31535! R(INDX(I_LO)) <= R_LO <= R_HI <= R(INDX(I_HI))
31536! but what we want is actually
31537! R_LO <= R(INDX(I_LO)) <= R(INDX(I_HI)) <= R_HI
31538! which we can usually get simply by incrementing I_LO and decrementing I_HI.
31539!
31540 if ( r(indx(i_lo)) < r_lo ) then
31541 i_lo = i_lo + 1
31542 if ( n < i_lo ) then
31543 i_hi = i_lo - 1
31544 end if
31545 end if
31546
31547 if ( r_hi < r(indx(i_hi)) ) then
31548 i_hi = i_hi - 1
31549 if ( i_hi < 1 ) then
31550 i_lo = i_hi + 1
31551 end if
31552 end if
31553
31554 return

◆ r8vec_indexed_heap_d()

subroutine r8vec_indexed_heap_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 31556 of file R8LIB.f90.

31557
31558!*****************************************************************************80
31559!
31560!! R8VEC_INDEXED_HEAP_D creates a descending heap from an indexed R8VEC.
31561!
31562! Discussion:
31563!
31564! An R8VEC is a vector of R8's.
31565!
31566! An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
31567! each referencing an entry of the data vector.
31568!
31569! The function adjusts the index vector INDX so that, for 1 <= J <= N/2,
31570! we have:
31571! A(INDX(2*J)) <= A(INDX(J))
31572! and
31573! A(INDX(2*J+1)) <= A(INDX(J))
31574!
31575! Licensing:
31576!
31577! This code is distributed under the GNU LGPL license.
31578!
31579! Modified:
31580!
31581! 16 August 2010
31582!
31583! Author:
31584!
31585! John Burkardt
31586!
31587! Reference:
31588!
31589! Albert Nijenhuis, Herbert Wilf,
31590! Combinatorial Algorithms for Computers and Calculators,
31591! Academic Press, 1978,
31592! ISBN: 0-12-519260-6,
31593! LC: QA164.N54.
31594!
31595! Parameters:
31596!
31597! Input, integer ( kind = 4 ) N, the size of the index array.
31598!
31599! Input, real ( kind = 8 ) A(*), the data vector.
31600!
31601! Input/output, integer ( kind = 4 ) INDX(N), the index array.
31602! Each entry of INDX must be a valid index for the array A.
31603! On output, the indices have been reordered into a descending heap.
31604!
31605 implicit none
31606
31607 integer ( kind = 4 ) n
31608
31609 real ( kind = 8 ) a(*)
31610 integer ( kind = 4 ) i
31611 integer ( kind = 4 ) ifree
31612 integer ( kind = 4 ) indx(n)
31613 integer ( kind = 4 ) key
31614 integer ( kind = 4 ) m
31615!
31616! Only nodes N/2 down to 1 can be "parent" nodes.
31617!
31618 do i = n / 2, 1, -1
31619!
31620! Copy the value out of the parent node.
31621! Position IFREE is now "open".
31622!
31623 key = indx(i)
31624 ifree = i
31625
31626 do
31627!
31628! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
31629! IFREE. (One or both may not exist because they exceed N.)
31630!
31631 m = 2 * ifree
31632!
31633! Does the first position exist?
31634!
31635 if ( n < m ) then
31636 exit
31637 end if
31638!
31639! Does the second position exist?
31640!
31641 if ( m + 1 <= n ) then
31642!
31643! If both positions exist, take the larger of the two values,
31644! and update M if necessary.
31645!
31646 if ( a(indx(m)) < a(indx(m+1)) ) then
31647 m = m + 1
31648 end if
31649
31650 end if
31651!
31652! If the large descendant is larger than KEY, move it up,
31653! and update IFREE, the location of the free position, and
31654! consider the descendants of THIS position.
31655!
31656 if ( a(indx(m)) <= a(key) ) then
31657 exit
31658 end if
31659
31660 indx(ifree) = indx(m)
31661 ifree = m
31662
31663 end do
31664!
31665! Once there is no more shifting to do, KEY moves into the free spot IFREE.
31666!
31667 indx(ifree) = key
31668
31669 end do
31670
31671 return

Referenced by r8vec_indexed_heap_d_extract().

Here is the caller graph for this function:

◆ r8vec_indexed_heap_d_extract()

subroutine r8vec_indexed_heap_d_extract ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
integer ( kind = 4 ), dimension(*)  indx,
integer ( kind = 4 )  indx_extract 
)

Definition at line 31673 of file R8LIB.f90.

31674
31675!*****************************************************************************80
31676!
31677!! R8VEC_INDEXED_HEAP_D_EXTRACT: extract from heap descending indexed R8VEC.
31678!
31679! Discussion:
31680!
31681! An R8VEC is a vector of R8's.
31682!
31683! An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
31684! each referencing an entry of the data vector.
31685!
31686! The routine finds the maximum value in the heap, returns that value to the
31687! user, deletes that value from the heap, and restores the heap to its
31688! proper form.
31689!
31690! Note that the argument N must be a variable, which will be decremented
31691! before return, and that INDX will hold one less value on output than it
31692! held on input.
31693!
31694! This is one of three functions needed to model a priority queue.
31695!
31696! Licensing:
31697!
31698! This code is distributed under the GNU LGPL license.
31699!
31700! Modified:
31701!
31702! 16 August 2010
31703!
31704! Author:
31705!
31706! John Burkardt
31707!
31708! Reference:
31709!
31710! Thomas Cormen, Charles Leiserson, Ronald Rivest,
31711! Introduction to Algorithms,
31712! MIT Press, 2001,
31713! ISBN: 0262032937,
31714! LC: QA76.C662.
31715!
31716! Parameters:
31717!
31718! Input/output, integer ( kind = 4 ) N, the number of items in the
31719! index vector.
31720!
31721! Input, real ( kind = 8 ) A(*), the data vector.
31722!
31723! Input/output, integer ( kind = 4 ) INDX(N), the index vector.
31724!
31725! Output, integer ( kind = 4 ) INDX_EXTRACT, the index in A of the item of
31726! maximum value, which has now been removed from the heap.
31727!
31728 implicit none
31729
31730 real ( kind = 8 ) a(*)
31731 integer ( kind = 4 ) indx(*)
31732 integer ( kind = 4 ) indx_extract
31733 integer ( kind = 4 ) n
31734
31735 if ( n < 1 ) then
31736 write ( *, '(a)' ) ' '
31737 write ( *, '(a)' ) 'R8VEC_INDEXED_HEAP_D_EXTRACT - Fatal error!'
31738 write ( *, '(a)' ) ' The heap is empty.'
31739 stop 1
31740 end if
31741!
31742! Get the index of the maximum value.
31743!
31744 indx_extract = indx(1)
31745
31746 if ( n == 1 ) then
31747 n = 0
31748 return
31749 end if
31750!
31751! Shift the last index down.
31752!
31753 indx(1) = indx(n)
31754!
31755! Restore the heap structure.
31756!
31757 n = n - 1
31758 call r8vec_indexed_heap_d ( n, a, indx )
31759
31760 return
r8vec_indexed_heap_d
subroutine r8vec_indexed_heap_d(n, a, indx)
Definition R8LIB.f90:31557

References r8vec_indexed_heap_d().

Here is the call graph for this function:

◆ r8vec_indexed_heap_d_insert()

subroutine r8vec_indexed_heap_d_insert ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
integer ( kind = 4 ), dimension(*)  indx,
integer ( kind = 4 )  indx_insert 
)

Definition at line 31762 of file R8LIB.f90.

31763
31764!*****************************************************************************80
31765!
31766!! R8VEC_INDEXED_HEAP_D_INSERT: insert value into heap descending indexed R8VEC.
31767!
31768! Discussion:
31769!
31770! An R8VEC is a vector of R8's.
31771!
31772! An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
31773! each referencing an entry of the data vector.
31774!
31775! Note that the argument N must be a variable, and will be incremented before
31776! return, and that INDX must be able to hold one more entry on output than
31777! it held on input.
31778!
31779! This is one of three functions needed to model a priority queue.
31780!
31781! Licensing:
31782!
31783! This code is distributed under the GNU LGPL license.
31784!
31785! Modified:
31786!
31787! 16 August 2010
31788!
31789! Author:
31790!
31791! John Burkardt
31792!
31793! Reference:
31794!
31795! Thomas Cormen, Charles Leiserson, Ronald Rivest,
31796! Introduction to Algorithms,
31797! MIT Press, 2001,
31798! ISBN: 0262032937,
31799! LC: QA76.C662.
31800!
31801! Parameters:
31802!
31803! Input/output, integer ( kind = 4 ) N, the number of items in the
31804! index vector.
31805!
31806! Input, real ( kind = 8 ) A(*), the data vector.
31807!
31808! Input/output, integer ( kind = 4 ) INDX(N), the index vector.
31809!
31810! Input, integer ( kind = 4 ) INDX_INSERT, the index in A of the value
31811! to be inserted into the heap.
31812!
31813 implicit none
31814
31815 real ( kind = 8 ) a(*)
31816 integer ( kind = 4 ) i
31817 integer ( kind = 4 ) indx(*)
31818 integer ( kind = 4 ) indx_insert
31819 integer ( kind = 4 ) n
31820 integer ( kind = 4 ) parent
31821
31822 n = n + 1
31823 i = n
31824
31825 do while ( 1 < i )
31826
31827 parent = i / 2
31828
31829 if ( a(indx_insert) <= a(indx(parent)) ) then
31830 exit
31831 end if
31832
31833 indx(i) = indx(parent)
31834 i = parent
31835
31836 end do
31837
31838 indx(i) = indx_insert
31839
31840 return

◆ r8vec_indexed_heap_d_max()

subroutine r8vec_indexed_heap_d_max ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(*)  a,
integer ( kind = 4 ), dimension(n)  indx,
integer ( kind = 4 )  indx_max 
)

Definition at line 31842 of file R8LIB.f90.

31843
31844!*****************************************************************************80
31845!
31846!! R8VEC_INDEXED_HEAP_D_MAX: maximum value in heap descending indexed R8VEC.
31847!
31848! Discussion:
31849!
31850! An R8VEC is a vector of R8's.
31851!
31852! An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
31853! each referencing an entry of the data vector.
31854!
31855! This is one of three functions needed to model a priority queue.
31856!
31857! Licensing:
31858!
31859! This code is distributed under the GNU LGPL license.
31860!
31861! Modified:
31862!
31863! 16 August 2010
31864!
31865! Author:
31866!
31867! John Burkardt
31868!
31869! Reference:
31870!
31871! Thomas Cormen, Charles Leiserson, Ronald Rivest,
31872! Introduction to Algorithms,
31873! MIT Press, 2001,
31874! ISBN: 0262032937,
31875! LC: QA76.C662.
31876!
31877! Parameters:
31878!
31879! Input, integer ( kind = 4 ) N, the number of items in the index vector.
31880!
31881! Input, real ( kind = 8 ) A(*), the data vector.
31882!
31883! Input, integer ( kind = 4 ) INDX(N), the index vector.
31884!
31885! Output, integer ( kind = 4 ) INDX_MAX, the index in A of the maximum value
31886! in the heap.
31887!
31888 implicit none
31889
31890 integer ( kind = 4 ) n
31891
31892 real ( kind = 8 ) a(*)
31893 integer ( kind = 4 ) indx(n)
31894 integer ( kind = 4 ) indx_max
31895
31896 indx_max = indx(1)
31897
31898 return

◆ r8vec_indicator0()

subroutine r8vec_indicator0 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 31900 of file R8LIB.f90.

31901
31902!*****************************************************************************80
31903!
31904!! R8VEC_INDICATOR0 sets an R8VEC to the indicator vector (0,1,2,...).
31905!
31906! Discussion:
31907!
31908! An R8VEC is a vector of R8's.
31909!
31910! Licensing:
31911!
31912! This code is distributed under the GNU LGPL license.
31913!
31914! Modified:
31915!
31916! 27 September 2014
31917!
31918! Author:
31919!
31920! John Burkardt
31921!
31922! Parameters:
31923!
31924! Input, integer ( kind = 4 ) N, the number of elements of A.
31925!
31926! Output, real ( kind = 8 ) A(N), the array.
31927!
31928 implicit none
31929
31930 integer ( kind = 4 ) n
31931
31932 real ( kind = 8 ) a(n)
31933 integer ( kind = 4 ) i
31934
31935 do i = 1, n
31936 a(i) = real( i - 1, kind = 8 )
31937 end do
31938
31939 return

◆ r8vec_indicator1()

subroutine r8vec_indicator1 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 31941 of file R8LIB.f90.

31942
31943!*****************************************************************************80
31944!
31945!! R8VEC_INDICATOR1 sets an R8VEC to the indicator vector (1,2,3,...).
31946!
31947! Discussion:
31948!
31949! An R8VEC is a vector of R8's.
31950!
31951! Licensing:
31952!
31953! This code is distributed under the GNU LGPL license.
31954!
31955! Modified:
31956!
31957! 27 September 2014
31958!
31959! Author:
31960!
31961! John Burkardt
31962!
31963! Parameters:
31964!
31965! Input, integer ( kind = 4 ) N, the number of elements of A.
31966!
31967! Output, real ( kind = 8 ) A(N), the array.
31968!
31969 implicit none
31970
31971 integer ( kind = 4 ) n
31972
31973 real ( kind = 8 ) a(n)
31974 integer ( kind = 4 ) i
31975
31976 do i = 1, n
31977 a(i) = real( i, kind = 8 )
31978 end do
31979
31980 return

◆ r8vec_insert()

subroutine r8vec_insert ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n+1)  a,
integer ( kind = 4 )  pos,
real ( kind = 8 )  value 
)

Definition at line 31982 of file R8LIB.f90.

31983
31984!*****************************************************************************80
31985!
31986!! R8VEC_INSERT inserts a value into an R8VEC.
31987!
31988! Discussion:
31989!
31990! An R8VEC is a vector of R8's.
31991!
31992! Licensing:
31993!
31994! This code is distributed under the GNU LGPL license.
31995!
31996! Modified:
31997!
31998! 17 February 2000
31999!
32000! Author:
32001!
32002! John Burkardt
32003!
32004! Parameters:
32005!
32006! Input, integer ( kind = 4 ) N, the dimension of the array on input.
32007!
32008! Input/output, real ( kind = 8 ) A(N+1), the array. On input, A is
32009! assumed to contain only N entries, while on output, A actually
32010! contains N+1 entries.
32011!
32012! Input, integer ( kind = 4 ) POS, the position to be assigned the new entry.
32013! 1 <= POS <= N+1.
32014!
32015! Input, real ( kind = 8 ) VALUE, the value to be inserted.
32016!
32017 implicit none
32018
32019 integer ( kind = 4 ) n
32020
32021 real ( kind = 8 ) a(n+1)
32022 integer ( kind = 4 ) i
32023 integer ( kind = 4 ) pos
32024 real ( kind = 8 ) value
32025
32026 if ( pos < 1 .or. n + 1 < pos ) then
32027
32028 write ( *, '(a)' ) ' '
32029 write ( *, '(a)' ) 'R8VEC_INSERT - Fatal error!'
32030 write ( *, '(a,i8)' ) ' Illegal insertion position = ', pos
32031 stop 1
32032
32033 else
32034
32035 do i = n + 1, pos + 1, -1
32036 a(i) = a(i-1)
32037 end do
32038
32039 a(pos) = value
32040
32041 end if
32042
32043 return

◆ r8vec_insignificant()

logical ( kind = 4 ) function r8vec_insignificant ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r,
real ( kind = 8 ), dimension(n)  s 
)

Definition at line 32045 of file R8LIB.f90.

32046
32047!*****************************************************************************80
32048!
32049!! R8VEC_INSIGNIFICANT determines if an R8VEC is insignificant.
32050!
32051! Licensing:
32052!
32053! This code is distributed under the GNU LGPL license.
32054!
32055! Modified:
32056!
32057! 26 November 2011
32058!
32059! Author:
32060!
32061! John Burkardt
32062!
32063! Parameters:
32064!
32065! Input, integer ( kind = 4 ) N, the dimension of the vectors.
32066!
32067! Input, real ( kind = 8 ) R(N), the vector to be compared against.
32068!
32069! Input, real ( kind = 8 ) S(N), the vector to be compared.
32070!
32071! Output, logical ( kind = 4 ) R8VEC_INSIGNIFICANT, is TRUE if S is
32072! insignificant compared to R.
32073!
32074 implicit none
32075
32076 integer ( kind = 4 ) n
32077
32078 integer ( kind = 4 ) i
32079 real ( kind = 8 ) r(n)
32080 logical ( kind = 4 ) r8vec_insignificant
32081 real ( kind = 8 ) s(n)
32082 real ( kind = 8 ) t
32083 real ( kind = 8 ) tol
32084 logical ( kind = 4 ) value
32085
32086 value = .true.
32087
32088 do i = 1, n
32089
32090 t = r(i) + s(i)
32091 tol = epsilon( r(i) ) * abs( r(i) )
32092
32093 if ( tol < abs( r(i) - t ) ) then
32094 value = .false.
32095 exit
32096 end if
32097
32098 end do
32099
32100 r8vec_insignificant = value
32101
32102 return
r8vec_insignificant
logical(kind=4) function r8vec_insignificant(n, r, s)
Definition R8LIB.f90:32046

References r8vec_insignificant().

Referenced by r8vec_insignificant().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_is_int()

logical ( kind = 4 ) function r8vec_is_int ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 32104 of file R8LIB.f90.

32105
32106!*****************************************************************************80
32107!
32108!! R8VEC_IS_INT is TRUE if the entries of an R8VEC are integers.
32109!
32110! Discussion:
32111!
32112! An R8VEC is a vector of R8's.
32113!
32114! Licensing:
32115!
32116! This code is distributed under the GNU LGPL license.
32117!
32118! Modified:
32119!
32120! 04 October 2005
32121!
32122! Author:
32123!
32124! John Burkardt
32125!
32126! Parameters:
32127!
32128! Input, integer ( kind = 4 ) N, the number of entries in A.
32129!
32130! Input, real ( kind = 8 ) A(N), the vector.
32131!
32132! Output, logical ( kind = 4 ) R8VEC_IS_INT, is TRUE if every entry of A is
32133! integral.
32134!
32135 implicit none
32136
32137 integer ( kind = 4 ) n
32138
32139 real ( kind = 8 ) a(n)
32140 logical ( kind = 4 ) r8vec_is_int
32141
32142 r8vec_is_int = all( a(1:n) == aint( a(1:n) ) )
32143
32144 return
r8vec_is_int
logical(kind=4) function r8vec_is_int(n, a)
Definition R8LIB.f90:32105

References r8vec_is_int().

Referenced by r8vec_is_int().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_is_nonnegative()

logical ( kind = 4 ) function r8vec_is_nonnegative ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 32146 of file R8LIB.f90.

32147
32148!*****************************************************************************80
32149!
32150!! R8VEC_IS_NONNEGATIVE is TRUE if all the entries of an R8VEC are nonnegative.
32151!
32152! Discussion:
32153!
32154! An R8VEC is a vector of R8's.
32155!
32156! Licensing:
32157!
32158! This code is distributed under the GNU LGPL license.
32159!
32160! Modified:
32161!
32162! 29 March 2011
32163!
32164! Author:
32165!
32166! John Burkardt
32167!
32168! Parameters:
32169!
32170! Input, integer ( kind = 4 ) N, the number of entries in A.
32171!
32172! Input, real ( kind = 8 ) A(N), the vector.
32173!
32174! Output, logical ( kind = 4 ) R8VEC_IS_NONNEGATIVE, the value of
32175! the condition.
32176!
32177 implicit none
32178
32179 integer ( kind = 4 ) n
32180
32181 real ( kind = 8 ) a(n)
32182 logical ( kind = 4 ) r8vec_is_nonnegative
32183
32184 r8vec_is_nonnegative = all( 0.0d+00 <= a(1:n) )
32185
32186 return
r8vec_is_nonnegative
logical(kind=4) function r8vec_is_nonnegative(n, a)
Definition R8LIB.f90:32147

References r8vec_is_nonnegative().

Referenced by r8vec_is_nonnegative().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_is_zero()

logical ( kind = 4 ) function r8vec_is_zero ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 32188 of file R8LIB.f90.

32189
32190!*****************************************************************************80
32191!
32192!! R8VEC_IS_ZERO is TRUE if all the entries of an R8VEC are zero.
32193!
32194! Discussion:
32195!
32196! An R8VEC is a vector of R8's.
32197!
32198! Licensing:
32199!
32200! This code is distributed under the GNU LGPL license.
32201!
32202! Modified:
32203!
32204! 29 March 2011
32205!
32206! Author:
32207!
32208! John Burkardt
32209!
32210! Parameters:
32211!
32212! Input, integer ( kind = 4 ) N, the number of entries in A.
32213!
32214! Input, real ( kind = 8 ) A(N), the vector.
32215!
32216! Output, logical ( kind = 4 ) R8VEC_IS_ZERO, the value of the condition.
32217!
32218 implicit none
32219
32220 integer ( kind = 4 ) n
32221
32222 real ( kind = 8 ) a(n)
32223 logical ( kind = 4 ) r8vec_is_zero
32224
32225 r8vec_is_zero = all( a(1:n) == 0.0d+00 )
32226
32227 return
r8vec_is_zero
logical(kind=4) function r8vec_is_zero(n, a)
Definition R8LIB.f90:32189

References r8vec_is_zero().

Referenced by r8vec_is_zero().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_legendre()

subroutine r8vec_legendre ( integer ( kind = 4 )  n,
real ( kind = 8 )  x_first,
real ( kind = 8 )  x_last,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 32229 of file R8LIB.f90.

32230
32231!*****************************************************************************80
32232!
32233!! R8VEC_LEGENDRE creates a vector of Legendre-spaced values.
32234!
32235! Discussion:
32236!
32237! An R8VEC is a vector of R8's.
32238!
32239! Licensing:
32240!
32241! This code is distributed under the GNU LGPL license.
32242!
32243! Modified:
32244!
32245! 17 June 2011
32246!
32247! Author:
32248!
32249! John Burkardt
32250!
32251! Parameters:
32252!
32253! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32254!
32255! Input, real ( kind = 8 ) X_FIRST, X_LAST, the first and last entries.
32256!
32257! Output, real ( kind = 8 ) X(N), a vector of Legendre-spaced data.
32258!
32259 implicit none
32260
32261 integer ( kind = 4 ) n
32262
32263 integer ( kind = 4 ) i
32264 real ( kind = 8 ) x(n)
32265 real ( kind = 8 ) x_first
32266 real ( kind = 8 ) x_last
32267
32268 call legendre_zeros ( n, x )
32269
32270 x(1:n) = ( ( 1.0d+00 - x(1:n) ) * x_first &
32271 + ( 1.0d+00 + x(1:n) ) * x_last ) &
32272 / 2.0d+00
32273
32274 return
legendre_zeros
subroutine legendre_zeros(n, x)
Definition R8LIB.f90:986

References legendre_zeros().

Here is the call graph for this function:

◆ r8vec_linspace()

subroutine r8vec_linspace ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 32276 of file R8LIB.f90.

32277
32278!*****************************************************************************80
32279!
32280!! R8VEC_LINSPACE creates a vector of linearly spaced values.
32281!
32282! Discussion:
32283!
32284! An R8VEC is a vector of R8's.
32285!
32286! 4 points evenly spaced between 0 and 12 will yield 0, 4, 8, 12.
32287!
32288! In other words, the interval is divided into N-1 even subintervals,
32289! and the endpoints of intervals are used as the points.
32290!
32291! Licensing:
32292!
32293! This code is distributed under the GNU LGPL license.
32294!
32295! Modified:
32296!
32297! 14 March 2011
32298!
32299! Author:
32300!
32301! John Burkardt
32302!
32303! Parameters:
32304!
32305! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32306!
32307! Input, real ( kind = 8 ) A, B, the first and last entries.
32308!
32309! Output, real ( kind = 8 ) X(N), a vector of linearly spaced data.
32310!
32311 implicit none
32312
32313 integer ( kind = 4 ) n
32314
32315 real ( kind = 8 ) a
32316 real ( kind = 8 ) b
32317 integer ( kind = 4 ) i
32318 real ( kind = 8 ) x(n)
32319
32320 if ( n == 1 ) then
32321
32322 x(1) = ( a + b ) / 2.0d+00
32323
32324 else
32325
32326 do i = 1, n
32327 x(i) = ( real( n - i, kind = 8 ) * a &
32328 + real( i - 1, kind = 8 ) * b ) &
32329 / real( n - 1, kind = 8 )
32330 end do
32331
32332 end if
32333
32334 return

◆ r8vec_linspace2()

subroutine r8vec_linspace2 ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 32336 of file R8LIB.f90.

32337
32338!*****************************************************************************80
32339!
32340!! R8VEC_LINSPACE2 creates a vector of linearly spaced values.
32341!
32342! Discussion:
32343!
32344! An R8VEC is a vector of R8's.
32345!
32346! 4 points evenly spaced between 0 and 12 will yield 2, 4, 6, 8, 10.
32347!
32348! In other words, the interval is divided into N+1 even subintervals,
32349! and the endpoints of internal intervals are used as the points.
32350!
32351! Licensing:
32352!
32353! This code is distributed under the GNU LGPL license.
32354!
32355! Modified:
32356!
32357! 17 September 2012
32358!
32359! Author:
32360!
32361! John Burkardt
32362!
32363! Parameters:
32364!
32365! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32366!
32367! Input, real ( kind = 8 ) A, B, the first and last entries.
32368!
32369! Output, real ( kind = 8 ) X(N), a vector of linearly spaced data.
32370!
32371 implicit none
32372
32373 integer ( kind = 4 ) n
32374
32375 real ( kind = 8 ) a
32376 real ( kind = 8 ) b
32377 integer ( kind = 4 ) i
32378 real ( kind = 8 ) x(n)
32379
32380 do i = 1, n
32381 x(i) = ( real( n - i + 1, kind = 8 ) * a &
32382 + real( i, kind = 8 ) * b ) &
32383 / real( n + 1, kind = 8 )
32384 end do
32385
32386 return

◆ r8vec_lt()

logical ( kind = 4 ) function r8vec_lt ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 32388 of file R8LIB.f90.

32389
32390!*****************************************************************************80
32391!
32392!! R8VEC_LT == ( A1 < A2 ) for R8VEC's.
32393!
32394! Discussion:
32395!
32396! An R8VEC is a vector of R8's.
32397!
32398! The comparison is lexicographic.
32399!
32400! A1 < A2 <=> A1(1) < A2(1) or
32401! ( A1(1) == A2(1) and A1(2) < A2(2) ) or
32402! ...
32403! ( A1(1:N-1) == A2(1:N-1) and A1(N) < A2(N)
32404!
32405! Licensing:
32406!
32407! This code is distributed under the GNU LGPL license.
32408!
32409! Modified:
32410!
32411! 05 December 2004
32412!
32413! Author:
32414!
32415! John Burkardt
32416!
32417! Parameters:
32418!
32419! Input, integer ( kind = 4 ) N, the dimension of the vectors.
32420!
32421! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared.
32422!
32423! Output, logical ( kind = 4 ) R8VEC_LT, is TRUE if and only if A1 < A2.
32424!
32425 implicit none
32426
32427 integer ( kind = 4 ) n
32428
32429 real ( kind = 8 ) a1(n)
32430 real ( kind = 8 ) a2(n)
32431 logical ( kind = 4 ) r8vec_lt
32432 integer ( kind = 4 ) i
32433
32434 r8vec_lt = .false.
32435
32436 do i = 1, n
32437
32438 if ( a1(i) < a2(i) ) then
32439 r8vec_lt = .true.
32440 exit
32441 else if ( a2(i) < a1(i) ) then
32442 r8vec_lt = .false.
32443 exit
32444 end if
32445
32446 end do
32447
32448 return

References r8vec_lt().

Referenced by r8vec_lt().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_mask_print()

subroutine r8vec_mask_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  mask_num,
integer ( kind = 4 ), dimension(mask_num)  mask,
character ( len = * )  title 
)

Definition at line 32450 of file R8LIB.f90.

32451
32452!*****************************************************************************80
32453!
32454!! R8VEC_MASK_PRINT prints a masked R8VEC.
32455!
32456! Discussion:
32457!
32458! An R8VEC is a vector of R8's.
32459!
32460! Licensing:
32461!
32462! This code is distributed under the GNU LGPL license.
32463!
32464! Modified:
32465!
32466! 24 September 2001
32467!
32468! Author:
32469!
32470! John Burkardt
32471!
32472! Parameters:
32473!
32474! Input, integer ( kind = 4 ) N, the number of components of the vector.
32475!
32476! Input, real ( kind = 8 ) A(N), the vector to be printed.
32477!
32478! Input, integer ( kind = 4 ) MASK_NUM, the number of masked elements.
32479!
32480! Input, integer ( kind = 4 ) MASK(MASK_NUM), the indices of the vector
32481! to be printed.
32482!
32483! Input, character ( len = * ) TITLE, a title.
32484!
32485 implicit none
32486
32487 integer ( kind = 4 ) mask_num
32488 integer ( kind = 4 ) n
32489
32490 real ( kind = 8 ) a(n)
32491 integer ( kind = 4 ) i
32492 integer ( kind = 4 ) mask(mask_num)
32493 character ( len = * ) title
32494
32495 write ( *, '(a)' ) ' '
32496 write ( *, '(a)' ) ' Masked vector printout:'
32497
32498 write ( *, '(a)' ) ' '
32499 write ( *, '(a)' ) trim( title )
32500 write ( *, '(a)' ) ' '
32501 do i = 1, mask_num
32502 write ( *, '(2x,i8,a,1x,i8,2x,g14.6)' ) i, ':', mask(i), a(mask(i))
32503 end do
32504
32505 return

◆ r8vec_max()

real ( kind = 8 ) function r8vec_max ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 32507 of file R8LIB.f90.

32508
32509!*****************************************************************************80
32510!
32511!! R8VEC_MAX returns the maximum value in an R8VEC.
32512!
32513! Discussion:
32514!
32515! An R8VEC is a vector of R8's.
32516!
32517! Licensing:
32518!
32519! This code is distributed under the GNU LGPL license.
32520!
32521! Modified:
32522!
32523! 30 January 1999
32524!
32525! Author:
32526!
32527! John Burkardt
32528!
32529! Parameters:
32530!
32531! Input, integer ( kind = 4 ) N, the number of entries in the array.
32532!
32533! Input, real ( kind = 8 ) A(N), the array.
32534!
32535! Output, real ( kind = 8 ) R8VEC_MAX, the value of the largest entry.
32536!
32537 implicit none
32538
32539 integer ( kind = 4 ) n
32540
32541 real ( kind = 8 ) a(n)
32542 real ( kind = 8 ) r8vec_max
32543 real ( kind = 8 ) value
32544
32545 value = maxval( a(1:n) )
32546
32547 r8vec_max = value
32548
32549 return
r8vec_max
real(kind=8) function r8vec_max(n, a)
Definition R8LIB.f90:32508

References r8vec_max().

Referenced by r8vec_max().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_max_abs_index()

subroutine r8vec_max_abs_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  max_index 
)

Definition at line 32551 of file R8LIB.f90.

32552
32553!*****************************************************************************80
32554!
32555!! R8VEC_MAX_ABS_INDEX: index of the maximum absolute value in an R8VEC.
32556!
32557! Discussion:
32558!
32559! An R8VEC is a vector of R8's.
32560!
32561! Licensing:
32562!
32563! This code is distributed under the GNU LGPL license.
32564!
32565! Modified:
32566!
32567! 02 August 2005
32568!
32569! Author:
32570!
32571! John Burkardt
32572!
32573! Parameters:
32574!
32575! Input, integer ( kind = 4 ) N, the number of entries in the array.
32576!
32577! Input, real ( kind = 8 ) A(N), the array.
32578!
32579! Output, integer ( kind = 4 ) MAX_INDEX, the index of the largest entry.
32580!
32581 implicit none
32582
32583 integer ( kind = 4 ) n
32584
32585 real ( kind = 8 ) a(n)
32586 integer ( kind = 4 ) i
32587 integer ( kind = 4 ) max_index
32588
32589 if ( n <= 0 ) then
32590
32591 max_index = -1
32592
32593 else
32594
32595 max_index = 1
32596
32597 do i = 2, n
32598 if ( abs( a(max_index) ) < abs( a(i) ) ) then
32599 max_index = i
32600 end if
32601 end do
32602
32603 end if
32604
32605 return

◆ r8vec_max_index()

subroutine r8vec_max_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  max_index 
)

Definition at line 32607 of file R8LIB.f90.

32608
32609!*****************************************************************************80
32610!
32611!! R8VEC_MAX_INDEX returns the index of the maximum value in an R8VEC.
32612!
32613! Discussion:
32614!
32615! An R8VEC is a vector of R8's.
32616!
32617! Licensing:
32618!
32619! This code is distributed under the GNU LGPL license.
32620!
32621! Modified:
32622!
32623! 02 August 2005
32624!
32625! Author:
32626!
32627! John Burkardt
32628!
32629! Parameters:
32630!
32631! Input, integer ( kind = 4 ) N, the number of entries in the array.
32632!
32633! Input, real ( kind = 8 ) A(N), the array.
32634!
32635! Output, integer ( kind = 4 ) MAX_INDEX, the index of the largest entry.
32636!
32637 implicit none
32638
32639 integer ( kind = 4 ) n
32640
32641 real ( kind = 8 ) a(n)
32642 integer ( kind = 4 ) i
32643 integer ( kind = 4 ) max_index
32644
32645 if ( n <= 0 ) then
32646
32647 max_index = -1
32648
32649 else
32650
32651 max_index = 1
32652
32653 do i = 2, n
32654 if ( a(max_index) < a(i) ) then
32655 max_index = i
32656 end if
32657 end do
32658
32659 end if
32660
32661 return

◆ r8vec_mean()

subroutine r8vec_mean ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  mean 
)

Definition at line 32663 of file R8LIB.f90.

32664
32665!*****************************************************************************80
32666!
32667!! R8VEC_MEAN returns the mean of an R8VEC.
32668!
32669! Discussion:
32670!
32671! An R8VEC is a vector of R8's.
32672!
32673! Licensing:
32674!
32675! This code is distributed under the GNU LGPL license.
32676!
32677! Modified:
32678!
32679! 02 February 1999
32680!
32681! Author:
32682!
32683! John Burkardt
32684!
32685! Parameters:
32686!
32687! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32688!
32689! Input, real ( kind = 8 ) A(N), the vector whose mean is desired.
32690!
32691! Output, real ( kind = 8 ) MEAN, the mean of the vector entries.
32692!
32693 implicit none
32694
32695 integer ( kind = 4 ) n
32696
32697 real ( kind = 8 ) a(n)
32698 real ( kind = 8 ) mean
32699
32700 mean = sum( a(1:n) ) / real( n, kind = 8 )
32701
32702 return

Referenced by r8vec_circular_variance().

Here is the caller graph for this function:

◆ r8vec_mean_geometric()

subroutine r8vec_mean_geometric ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  mean 
)

Definition at line 32704 of file R8LIB.f90.

32705
32706!*****************************************************************************80
32707!
32708!! R8VEC_MEAN_GEOMETRIC returns the geometric mean of an R8VEC.
32709!
32710! Discussion:
32711!
32712! An R8VEC is a vector of R8's.
32713!
32714! Licensing:
32715!
32716! This code is distributed under the GNU LGPL license.
32717!
32718! Modified:
32719!
32720! 27 April 2014
32721!
32722! Author:
32723!
32724! John Burkardt
32725!
32726! Parameters:
32727!
32728! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32729!
32730! Input, real ( kind = 8 ) A(N), the vector whose mean is desired.
32731!
32732! Output, real ( kind = 8 ) MEAN, the geometric mean of the vector entries.
32733!
32734 implicit none
32735
32736 integer ( kind = 4 ) n
32737
32738 real ( kind = 8 ) a(n)
32739 real ( kind = 8 ) mean
32740
32741 mean = exp( sum( log( a(1:n) ) ) / real( n, kind = 8 ) )
32742
32743 return

◆ r8vec_median()

subroutine r8vec_median ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  median 
)

Definition at line 32745 of file R8LIB.f90.

32746
32747!*****************************************************************************80
32748!
32749!! R8VEC_MEDIAN returns the median of an unsorted R8VEC.
32750!
32751! Discussion:
32752!
32753! An R8VEC is a vector of R8's.
32754!
32755! Hoare's algorithm is used. The values of the vector are
32756! rearranged by this routine.
32757!
32758! Licensing:
32759!
32760! This code is distributed under the GNU LGPL license.
32761!
32762! Modified:
32763!
32764! 18 September 2000
32765!
32766! Parameters:
32767!
32768! Input, integer ( kind = 4 ) N, the number of elements of A.
32769!
32770! Input/output, real ( kind = 8 ) A(N), the array to search. On output,
32771! the order of the elements of A has been somewhat changed.
32772!
32773! Output, real ( kind = 8 ) MEDIAN, the value of the median of A.
32774!
32775 implicit none
32776
32777 integer ( kind = 4 ) n
32778
32779 real ( kind = 8 ) a(n)
32780 integer ( kind = 4 ) k
32781 real ( kind = 8 ) median
32782
32783 k = ( n + 1 ) / 2
32784
32785 call r8vec_frac ( n, a, k, median )
32786
32787 return
r8vec_frac
subroutine r8vec_frac(n, a, k, frac)
Definition R8LIB.f90:29766

References r8vec_frac().

Here is the call graph for this function:

◆ r8vec_mesh_2d()

subroutine r8vec_mesh_2d ( integer ( kind = 4 )  nx,
integer ( kind = 4 )  ny,
real ( kind = 8 ), dimension(nx)  xvec,
real ( kind = 8 ), dimension(ny)  yvec,
real ( kind = 8 ), dimension(nx,ny)  xmat,
real ( kind = 8 ), dimension(nx,ny)  ymat 
)

Definition at line 32789 of file R8LIB.f90.

32790
32791!*****************************************************************************80
32792!
32793!! R8VEC_MESH_2D creates a 2D mesh from X and Y vectors.
32794!
32795! Discussion:
32796!
32797! An R8VEC is a vector of R8's.
32798!
32799! NX = 2
32800! XVEC = ( 1, 2, 3 )
32801! NY = 3
32802! YVEC = ( 4, 5 )
32803!
32804! XMAT = (
32805! 1, 2, 3
32806! 1, 2, 3 )
32807!
32808! YMAT = (
32809! 4, 4, 4
32810! 5, 5, 5 )
32811!
32812! Licensing:
32813!
32814! This code is distributed under the GNU LGPL license.
32815!
32816! Modified:
32817!
32818! 22 July 2013
32819!
32820! Parameters:
32821!
32822! Input, integer ( kind = 4 ) NX, NY, the number of X and Y values.
32823!
32824! Input, real ( kind = 8 ) XVEC(NX), YVEC(NY), the X and Y coordinate
32825! values.
32826!
32827! Output, real ( kind = 8 ) XMAT(NX,NY), YMAT(NX,NY), the coordinate
32828! values of points on an NX by NY mesh.
32829!
32830 implicit none
32831
32832 integer ( kind = 4 ) nx
32833 integer ( kind = 4 ) ny
32834
32835 integer ( kind = 4 ) j
32836 real ( kind = 8 ) xmat(nx,ny)
32837 real ( kind = 8 ) xvec(nx)
32838 real ( kind = 8 ) ymat(nx,ny)
32839 real ( kind = 8 ) yvec(ny)
32840
32841 do j = 1, ny
32842 xmat(1:nx,j) = xvec(1:nx)
32843 end do
32844
32845 do j = 1, ny
32846 ymat(1:nx,j) = yvec(j)
32847 end do
32848
32849 return

◆ r8vec_midspace()

subroutine r8vec_midspace ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 32851 of file R8LIB.f90.

32852
32853!*****************************************************************************80
32854!
32855!! R8VEC_MIDSPACE creates a vector of linearly spaced values.
32856!
32857! Discussion:
32858!
32859! An R8VEC is a vector of R8's.
32860!
32861! This function divides the interval [a,b] into n subintervals, and then
32862! returns the midpoints of those subintervals.
32863!
32864! Example:
32865!
32866! N = 5, A = 10, B = 20
32867! X = [ 11, 13, 15, 17, 19 ]
32868!
32869! Licensing:
32870!
32871! This code is distributed under the GNU LGPL license.
32872!
32873! Modified:
32874!
32875! 03 June 2012
32876!
32877! Author:
32878!
32879! John Burkardt
32880!
32881! Parameters:
32882!
32883! Input, integer ( kind = 4 ) N, the number of entries in the vector.
32884!
32885! Input, real ( kind = 8 ) A, B, the endpoints of the interval.
32886!
32887! Output, real ( kind = 8 ) X(N), a vector of linearly spaced data.
32888!
32889 implicit none
32890
32891 integer ( kind = 4 ) n
32892
32893 real ( kind = 8 ) a
32894 real ( kind = 8 ) b
32895 integer ( kind = 4 ) i
32896 real ( kind = 8 ) x(n)
32897
32898 do i = 1, n
32899 x(i) = ( real( 2 * n - 2 * i + 1, kind = 8 ) * a &
32900 + real( 2 * i - 1, kind = 8 ) * b ) &
32901 / real( 2 * n, kind = 8 )
32902 end do
32903
32904 return

◆ r8vec_min()

real ( kind = 8 ) function r8vec_min ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 32906 of file R8LIB.f90.

32907
32908!*****************************************************************************80
32909!
32910!! R8VEC_MIN returns the minimum value of an R8VEC.
32911!
32912! Discussion:
32913!
32914! An R8VEC is a vector of R8's.
32915!
32916! Licensing:
32917!
32918! This code is distributed under the GNU LGPL license.
32919!
32920! Modified:
32921!
32922! 17 November 1999
32923!
32924! Author:
32925!
32926! John Burkardt
32927!
32928! Parameters:
32929!
32930! Input, integer ( kind = 4 ) N, the number of entries in the array.
32931!
32932! Input, real ( kind = 8 ) A(N), the array.
32933!
32934! Output, real ( kind = 8 ) R8VEC_MIN, the value of the smallest entry.
32935!
32936 implicit none
32937
32938 integer ( kind = 4 ) n
32939
32940 real ( kind = 8 ) a(n)
32941 real ( kind = 8 ) r8vec_min
32942 real ( kind = 8 ) value
32943
32944 value = minval( a(1:n) )
32945
32946 r8vec_min = value
32947
32948 return
r8vec_min
real(kind=8) function r8vec_min(n, a)
Definition R8LIB.f90:32907

References r8vec_min().

Referenced by r8vec_min().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_min_index()

subroutine r8vec_min_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  min_index 
)

Definition at line 32950 of file R8LIB.f90.

32951
32952!*****************************************************************************80
32953!
32954!! R8VEC_MIN_INDEX returns the index of the minimum value in an R8VEC.
32955!
32956! Discussion:
32957!
32958! An R8VEC is a vector of R8's.
32959!
32960! Licensing:
32961!
32962! This code is distributed under the GNU LGPL license.
32963!
32964! Modified:
32965!
32966! 02 August 2005
32967!
32968! Author:
32969!
32970! John Burkardt
32971!
32972! Parameters:
32973!
32974! Input, integer ( kind = 4 ) N, the number of entries in the array.
32975!
32976! Input, real ( kind = 8 ) A(N), the array.
32977!
32978! Output, integer ( kind = 4 ) MIN_INDEX, the index of the smallest entry.
32979!
32980 implicit none
32981
32982 integer ( kind = 4 ) n
32983
32984 real ( kind = 8 ) a(n)
32985 integer ( kind = 4 ) i
32986 integer ( kind = 4 ) min_index
32987
32988 if ( n <= 0 ) then
32989
32990 min_index = -1
32991
32992 else
32993
32994 min_index = 1
32995
32996 do i = 2, n
32997 if ( a(i) < a(min_index) ) then
32998 min_index = i
32999 end if
33000 end do
33001
33002 end if
33003
33004 return

◆ r8vec_min_pos()

real ( kind = 8 ) function r8vec_min_pos ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33006 of file R8LIB.f90.

33007
33008!*****************************************************************************80
33009!
33010!! R8VEC_MIN_POS returns the minimum positive value of an R8VEC.
33011!
33012! Discussion:
33013!
33014! An R8VEC is a vector of R8's.
33015!
33016! Licensing:
33017!
33018! This code is distributed under the GNU LGPL license.
33019!
33020! Modified:
33021!
33022! 08 November 2009
33023!
33024! Author:
33025!
33026! John Burkardt
33027!
33028! Parameters:
33029!
33030! Input, integer ( kind = 4 ) N, the number of entries.
33031!
33032! Input, real ( kind = 8 ) A(N), the array.
33033!
33034! Output, real ( kind = 8 ) R8VEC_MIN_POS, the smallest positive entry.
33035!
33036 implicit none
33037
33038 integer ( kind = 4 ) n
33039
33040 real ( kind = 8 ) a(n)
33041 integer ( kind = 4 ) i
33042 real ( kind = 8 ) r8vec_min_pos
33043 real ( kind = 8 ) value
33044
33045 value = huge( value )
33046
33047 do i = 1, n
33048 if ( 0.0d+00 < a(i) ) then
33049 value = min( value, a(i) )
33050 end if
33051 end do
33052
33053 r8vec_min_pos = value
33054
33055 return
r8vec_min_pos
real(kind=8) function r8vec_min_pos(n, a)
Definition R8LIB.f90:33007

References r8vec_min_pos().

Referenced by r8vec_min_pos().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_mirror_next()

subroutine r8vec_mirror_next ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
logical ( kind = 4 )  done 
)

Definition at line 33057 of file R8LIB.f90.

33058
33059!*****************************************************************************80
33060!
33061!! R8VEC_MIRROR_NEXT steps through all sign variations of an R8VEC.
33062!
33063! Discussion:
33064!
33065! An R8VEC is a vector of R8's.
33066!
33067! In normal use, the user would set every element of A to be positive.
33068! The routine will take the input value of A, and output a copy in
33069! which the signs of one or more entries have been changed. Repeatedly
33070! calling the routine with the output from the previous call will generate
33071! every distinct "variation" of A; that is, all possible sign variations.
33072!
33073! When the output variable DONE is TRUE (or equal to 1), then the
33074! output value of A_NEW is the last in the series.
33075!
33076! Note that A may have some zero values. The routine will essentially
33077! ignore such entries; more exactly, it will not stupidly assume that -0
33078! is a proper "variation" of 0!
33079!
33080! Also, it is possible to call this routine with the signs of A set
33081! in any way you like. The routine will operate properly, but it
33082! will nonethess terminate when it reaches the value of A in which
33083! every nonzero entry has negative sign.
33084!
33085! More efficient algorithms using the Gray code seem to require internal
33086! memory in the routine, which is not one of MATLAB's strong points,
33087! or the passing back and forth of a "memory array", or the use of
33088! global variables, or unnatural demands on the user. This form of
33089! the routine is about as clean as I can make it.
33090!
33091! Example:
33092!
33093! Input Output
33094! --------- --------------
33095! A A_NEW DONE
33096! --------- -------- ----
33097! 1 2 3 -1 2 3 false
33098! -1 2 3 1 -2 3 false
33099! 1 -2 3 -1 -2 3 false
33100! -1 -2 3 1 2 -3 false
33101! 1 2 -3 -1 2 -3 false
33102! -1 2 -3 1 -2 -3 false
33103! 1 -2 -3 -1 -2 -3 false
33104! -1 -2 -3 1 2 3 true
33105!
33106! 1 0 3 -1 0 3 false
33107! -1 0 3 1 0 -3 false
33108! 1 0 -3 -1 0 -3 false
33109! -1 0 -3 1 0 3 true
33110!
33111! Licensing:
33112!
33113! This code is distributed under the GNU LGPL license.
33114!
33115! Modified:
33116!
33117! 19 April 2005
33118!
33119! Author:
33120!
33121! John Burkardt
33122!
33123! Reference:
33124!
33125! Albert Nijenhuis, Herbert Wilf,
33126! Combinatorial Algorithms for Computers and Calculators,
33127! Academic Press, 1978,
33128! ISBN: 0-12-519260-6,
33129! LC: QA164.N54.
33130!
33131! Parameters:
33132!
33133! Input, integer ( kind = 4 ) N, the number of entries in the vector.
33134!
33135! Input/output, real ( kind = 8 ) A(N), a vector of real numbers.
33136! On output, the signs of some entries have been changed.
33137!
33138! Output, logical ( kind = 4 ) DONE, is TRUE if the input vector A was the
33139! last element in the series (every entry was nonpositive); the output
33140! vector is reset so that all entries are nonnegative, but presumably the
33141! ride is over!
33142!
33143 implicit none
33144
33145 integer ( kind = 4 ) n
33146
33147 real ( kind = 8 ) a(n)
33148 logical ( kind = 4 ) done
33149 integer ( kind = 4 ) i
33150 integer ( kind = 4 ) positive
33151!
33152! Seek the first strictly positive entry of A.
33153!
33154 positive = 0
33155 do i = 1, n
33156 if ( 0.0d+00 < a(i) ) then
33157 positive = i
33158 exit
33159 end if
33160 end do
33161!
33162! If there is no strictly positive entry of A, there is no successor.
33163!
33164 if ( positive == 0 ) then
33165 a(1:n) = - a(1:n)
33166 done = .true.
33167 return
33168 end if
33169!
33170! Otherwise, negate A up to the positive entry.
33171!
33172 a(1:positive) = - a(1:positive)
33173 done = .false.
33174
33175 return

◆ r8vec_negative_strict()

logical ( kind = 4 ) function r8vec_negative_strict ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33177 of file R8LIB.f90.

33178
33179!*****************************************************************************80
33180!
33181!! R8VEC_NEGATIVE_STRICT: every element of an R8VEC is strictly negative.
33182!
33183! Discussion:
33184!
33185! An R8VEC is a vector of R8's.
33186!
33187! Licensing:
33188!
33189! This code is distributed under the GNU LGPL license.
33190!
33191! Modified:
33192!
33193! 24 June 2010
33194!
33195! Author:
33196!
33197! John Burkardt
33198!
33199! Parameters:
33200!
33201! Input, integer ( kind = 4 ) N, the number of entries in the vector.
33202!
33203! Input, real ( kind = 8 ) A(N).
33204!
33205! Output, logical ( kind = 4 ) R8VEC_NEGATIVE_STRICT, is TRUE every entry
33206! of the vector is strictly negative.
33207!
33208 implicit none
33209
33210 integer ( kind = 4 ) n
33211
33212 real ( kind = 8 ) a(n)
33213 logical ( kind = 4 ) r8vec_negative_strict
33214
33215 r8vec_negative_strict = ( all( a(1:n) < 0.0d+00 ) )
33216
33217 return
r8vec_negative_strict
logical(kind=4) function r8vec_negative_strict(n, a)
Definition R8LIB.f90:33178

References r8vec_negative_strict().

Referenced by r8vec_negative_strict().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_nint()

subroutine r8vec_nint ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33219 of file R8LIB.f90.

33220
33221!*****************************************************************************80
33222!
33223!! R8VEC_NINT rounds entries of an R8VEC.
33224!
33225! Discussion:
33226!
33227! An R8VEC is a vector of R8's.
33228!
33229! Licensing:
33230!
33231! This code is distributed under the GNU LGPL license.
33232!
33233! Modified:
33234!
33235! 10 March 2003
33236!
33237! Author:
33238!
33239! John Burkardt
33240!
33241! Parameters:
33242!
33243! Input, integer ( kind = 4 ) N, the number of entries in the vector.
33244!
33245! Input/output, real ( kind = 8 ) A(N), the vector to be NINT'ed.
33246!
33247 implicit none
33248
33249 integer ( kind = 4 ) n
33250
33251 real ( kind = 8 ) a(n)
33252
33253 a(1:n) = nint( real( a(1:n), kind = 8 ) )
33254
33255 return

◆ r8vec_norm()

real ( kind = 8 ) function r8vec_norm ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33257 of file R8LIB.f90.

33258
33259!*****************************************************************************80
33260!
33261!! R8VEC_NORM returns the L2 norm of an R8VEC.
33262!
33263! Discussion:
33264!
33265! An R8VEC is a vector of R8's.
33266!
33267! The vector L2 norm is defined as:
33268!
33269! R8VEC_NORM = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
33270!
33271! Licensing:
33272!
33273! This code is distributed under the GNU LGPL license.
33274!
33275! Modified:
33276!
33277! 21 August 2010
33278!
33279! Author:
33280!
33281! John Burkardt
33282!
33283! Parameters:
33284!
33285! Input, integer ( kind = 4 ) N, the number of entries in A.
33286!
33287! Input, real ( kind = 8 ) A(N), the vector whose L2 norm is desired.
33288!
33289! Output, real ( kind = 8 ) R8VEC_NORM, the L2 norm of A.
33290!
33291 implicit none
33292
33293 integer ( kind = 4 ) n
33294
33295 real ( kind = 8 ) a(n)
33296 real ( kind = 8 ) r8vec_norm
33297
33298 r8vec_norm = sqrt( sum( a(1:n)**2 ) )
33299
33300 return

References r8vec_norm().

Referenced by r8vec_any_normal(), r8vec_correlation(), and r8vec_norm().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_affine()

real ( kind = 8 ) function r8vec_norm_affine ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v0,
real ( kind = 8 ), dimension(n)  v1 
)

Definition at line 33302 of file R8LIB.f90.

33303
33304!*****************************************************************************80
33305!
33306!! R8VEC_NORM_AFFINE returns the affine norm of an R8VEC.
33307!
33308! Discussion:
33309!
33310! An R8VEC is a vector of R8's.
33311!
33312! The affine vector L2 norm is defined as:
33313!
33314! R8VEC_NORM_AFFINE(V0,V1)
33315! = sqrt ( sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2
33316!
33317! Licensing:
33318!
33319! This code is distributed under the GNU LGPL license.
33320!
33321! Modified:
33322!
33323! 27 October 2010
33324!
33325! Author:
33326!
33327! John Burkardt
33328!
33329! Parameters:
33330!
33331! Input, integer ( kind = 4 ) N, the order of the vectors.
33332!
33333! Input, real ( kind = 8 ) V0(N), the base vector.
33334!
33335! Input, real ( kind = 8 ) V1(N), the vector whose affine norm is desired.
33336!
33337! Output, real ( kind = 8 ) R8VEC_NORM_AFFINE, the L2 norm of V1-V0.
33338!
33339 implicit none
33340
33341 integer ( kind = 4 ) n
33342
33343 real ( kind = 8 ) r8vec_norm_affine
33344 real ( kind = 8 ) v0(n)
33345 real ( kind = 8 ) v1(n)
33346
33347 r8vec_norm_affine = sqrt( sum( ( v0(1:n) - v1(1:n) )**2 ) )
33348
33349 return
r8vec_norm_affine
real(kind=8) function r8vec_norm_affine(n, v0, v1)
Definition R8LIB.f90:33303

References r8vec_norm_affine().

Referenced by r8vec_norm_affine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_l0()

integer ( kind = 4 ) function r8vec_norm_l0 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33351 of file R8LIB.f90.

33352
33353!*****************************************************************************80
33354!
33355!! R8VEC_NORM_L0 returns the l0 "norm" of an R8VEC.
33356!
33357! Discussion:
33358!
33359! An R8VEC is a vector of R8's.
33360!
33361! The l0 "norm" simply counts the number of nonzero entries in the vector.
33362! It is not a true norm, but has some similarities to one. It is useful
33363! in the study of compressive sensing.
33364!
33365! Licensing:
33366!
33367! This code is distributed under the GNU LGPL license.
33368!
33369! Modified:
33370!
33371! 01 June 2012
33372!
33373! Author:
33374!
33375! John Burkardt
33376!
33377! Parameters:
33378!
33379! Input, integer ( kind = 4 ) N, the number of entries in the vector.
33380!
33381! Input, real ( kind = 8 ) A(N), the vector.
33382!
33383! Output, integer ( kind = 4 ) R8VEC_NORM_L0, the value of the norm.
33384!
33385 implicit none
33386
33387 integer ( kind = 4 ) n
33388
33389 real ( kind = 8 ) a(n)
33390 integer ( kind = 4 ) i
33391 integer ( kind = 4 ) r8vec_norm_l0
33392 integer ( kind = 4 ) value
33393
33394 value = 0
33395 do i = 1, n
33396 if ( a(i) /= 0.0d+00 ) then
33397 value = value + 1
33398 end if
33399 end do
33400
33401 r8vec_norm_l0 = value
33402
33403 return
r8vec_norm_l0
integer(kind=4) function r8vec_norm_l0(n, a)
Definition R8LIB.f90:33352

References r8vec_norm_l0().

Referenced by r8vec_norm_l0().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_l1()

real ( kind = 8 ) function r8vec_norm_l1 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33405 of file R8LIB.f90.

33406
33407!*****************************************************************************80
33408!
33409!! R8VEC_NORM_L1 returns the L1 norm of an R8VEC.
33410!
33411! Discussion:
33412!
33413! An R8VEC is a vector of R8's.
33414!
33415! The vector L1 norm is defined as:
33416!
33417! R8VEC_NORM_L1 = sum ( 1 <= I <= N ) abs ( A(I) ).
33418!
33419! Licensing:
33420!
33421! This code is distributed under the GNU LGPL license.
33422!
33423! Modified:
33424!
33425! 25 April 2002
33426!
33427! Author:
33428!
33429! John Burkardt
33430!
33431! Parameters:
33432!
33433! Input, integer ( kind = 4 ) N, the number of entries in A.
33434!
33435! Input, real ( kind = 8 ) A(N), the vector whose L1 norm is desired.
33436!
33437! Output, real ( kind = 8 ) R8VEC_NORM_L1, the L1 norm of A.
33438!
33439 implicit none
33440
33441 integer ( kind = 4 ) n
33442
33443 real ( kind = 8 ) a(n)
33444 real ( kind = 8 ) r8vec_norm_l1
33445
33446 r8vec_norm_l1 = sum( abs( a(1:n) ) )
33447
33448 return
r8vec_norm_l1
real(kind=8) function r8vec_norm_l1(n, a)
Definition R8LIB.f90:33406

References r8vec_norm_l1().

Referenced by r8vec_norm_l1().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_l2()

real ( kind = 8 ) function r8vec_norm_l2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33450 of file R8LIB.f90.

33451
33452!*****************************************************************************80
33453!
33454!! R8VEC_NORM_L2 returns the L2 norm of an R8VEC.
33455!
33456! Discussion:
33457!
33458! An R8VEC is a vector of R8's.
33459!
33460! The vector L2 norm is defined as:
33461!
33462! R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
33463!
33464! Licensing:
33465!
33466! This code is distributed under the GNU LGPL license.
33467!
33468! Modified:
33469!
33470! 25 April 2002
33471!
33472! Author:
33473!
33474! John Burkardt
33475!
33476! Parameters:
33477!
33478! Input, integer ( kind = 4 ) N, the number of entries in A.
33479!
33480! Input, real ( kind = 8 ) A(N), the vector whose L2 norm is desired.
33481!
33482! Output, real ( kind = 8 ) R8VEC_NORM_L2, the L2 norm of A.
33483!
33484 implicit none
33485
33486 integer ( kind = 4 ) n
33487
33488 real ( kind = 8 ) a(n)
33489 real ( kind = 8 ) r8vec_norm_l2
33490
33491 r8vec_norm_l2 = sqrt( sum( a(1:n)**2 ) )
33492
33493 return
r8vec_norm_l2
real(kind=8) function r8vec_norm_l2(n, a)
Definition R8LIB.f90:33451

References r8vec_norm_l2().

Referenced by r8vec_norm_l2().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_li()

real ( kind = 8 ) function r8vec_norm_li ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33495 of file R8LIB.f90.

33496
33497!*****************************************************************************80
33498!
33499!! R8VEC_NORM_LI returns the L-oo norm of an R8VEC.
33500!
33501! Discussion:
33502!
33503! An R8VEC is a vector of R8's.
33504!
33505! The vector L-oo norm is defined as:
33506!
33507! R8VEC_NORM_LI = max ( 1 <= I <= N ) abs ( A(I) ).
33508!
33509! Licensing:
33510!
33511! This code is distributed under the GNU LGPL license.
33512!
33513! Modified:
33514!
33515! 25 April 2002
33516!
33517! Author:
33518!
33519! John Burkardt
33520!
33521! Parameters:
33522!
33523! Input, integer ( kind = 4 ) N, the number of entries in A.
33524!
33525! Input, real ( kind = 8 ) A(N), the vector whose L-oo norm is desired.
33526!
33527! Output, real ( kind = 8 ) R8VEC_NORM_LI, the L-oo norm of A.
33528!
33529 implicit none
33530
33531 integer ( kind = 4 ) n
33532
33533 real ( kind = 8 ) a(n)
33534 real ( kind = 8 ) r8vec_norm_li
33535
33536 r8vec_norm_li = maxval( abs( a(1:n) ) )
33537
33538 return
r8vec_norm_li
real(kind=8) function r8vec_norm_li(n, a)
Definition R8LIB.f90:33496

References r8vec_norm_li().

Referenced by r8vec_norm_li().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_lp()

real ( kind = 8 ) function r8vec_norm_lp ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  p 
)

Definition at line 33540 of file R8LIB.f90.

33541
33542!*****************************************************************************80
33543!
33544!! R8VEC_NORM_LP returns the LP norm of an R8VEC.
33545!
33546! Discussion:
33547!
33548! An R8VEC is a vector of R8's.
33549!
33550! The vector LP norm is defined as:
33551!
33552! R8VEC_NORM_LP = ( sum ( 1 <= I <= N ) ( abs ( A(I) ) )^P )^(1/P).
33553!
33554! Usually, the LP norms with
33555! 1 <= P <= oo
33556! are of interest. This routine allows
33557! 0 < P <= Huge ( P ).
33558! If P = Huge ( P ), then the L-oo norm is returned, which is
33559! simply the maximum of the absolute values of the vector components.
33560!
33561! Licensing:
33562!
33563! This code is distributed under the GNU LGPL license.
33564!
33565! Modified:
33566!
33567! 25 April 2002
33568!
33569! Author:
33570!
33571! John Burkardt
33572!
33573! Parameters:
33574!
33575! Input, integer ( kind = 4 ) N, the number of entries in A.
33576!
33577! Input, real ( kind = 8 ) A(N), the vector whose LP norm is desired.
33578!
33579! Input, real ( kind = 8 ) P, the index of the norm.
33580!
33581! Output, real ( kind = 8 ) R8VEC_NORM_LP, the LP norm of A.
33582!
33583 implicit none
33584
33585 integer ( kind = 4 ) n
33586
33587 real ( kind = 8 ) a(n)
33588 real ( kind = 8 ) p
33589 real ( kind = 8 ) r8vec_norm_lp
33590
33591 if ( p <= 0.0d+00 ) then
33592 r8vec_norm_lp = -1.0d+00
33593 else if ( p == huge( p ) ) then
33594 r8vec_norm_lp = maxval( abs( a(1:n) ) )
33595 else if ( p == 1.0d+00 ) then
33596 r8vec_norm_lp = sum( abs( a(1:n) ) )
33597 else if ( p == 2.0d+00 ) then
33598 r8vec_norm_lp = sqrt( sum( a(1:n)**2 ) )
33599 else
33600 r8vec_norm_lp = ( sum( ( abs( a(1:n) ) )**p ) )**( 1.0d+00 / p )
33601 end if
33602
33603 return
r8vec_norm_lp
real(kind=8) function r8vec_norm_lp(n, a, p)
Definition R8LIB.f90:33541

References r8vec_norm_lp().

Referenced by r8vec_norm_lp().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_norm_squared()

real ( kind = 8 ) function r8vec_norm_squared ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33605 of file R8LIB.f90.

33606
33607!*****************************************************************************80
33608!
33609!! R8VEC_NORM_SQUARED returns the square of the L2 norm of an R8VEC.
33610!
33611! Discussion:
33612!
33613! An R8VEC is a vector of R8's.
33614!
33615! R8VEC_NORM_SQUARED = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
33616!
33617! Licensing:
33618!
33619! This code is distributed under the GNU LGPL license.
33620!
33621! Modified:
33622!
33623! 30 March 2011
33624!
33625! Author:
33626!
33627! John Burkardt
33628!
33629! Parameters:
33630!
33631! Input, integer ( kind = 4 ) N, the number of entries in A.
33632!
33633! Input, real ( kind = 8 ) A(N), the vector.
33634!
33635! Output, real ( kind = 8 ) R8VEC_NORM_SQUARED, the squared L2 norm of A.
33636!
33637 implicit none
33638
33639 integer ( kind = 4 ) n
33640
33641 real ( kind = 8 ) a(n)
33642 real ( kind = 8 ) r8vec_norm_squared
33643
33644 r8vec_norm_squared = sum( a(1:n)**2 )
33645
33646 return
r8vec_norm_squared
real(kind=8) function r8vec_norm_squared(n, a)
Definition R8LIB.f90:33606

References r8vec_norm_squared().

Referenced by r8vec_norm_squared().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_normal_01()

subroutine r8vec_normal_01 ( integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 33648 of file R8LIB.f90.

33649
33650!*****************************************************************************80
33651!
33652!! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
33653!
33654! Discussion:
33655!
33656! An R8VEC is a vector of R8's.
33657!
33658! The standard normal probability distribution function (PDF) has
33659! mean 0 and standard deviation 1.
33660!
33661! This routine can generate a vector of values on one call. It
33662! has the feature that it should provide the same results
33663! in the same order no matter how we break up the task.
33664!
33665! Before calling this routine, the user may call RANDOM_SEED
33666! in order to set the seed of the random number generator.
33667!
33668! Licensing:
33669!
33670! This code is distributed under the GNU LGPL license.
33671!
33672! Modified:
33673!
33674! 06 August 2013
33675!
33676! Author:
33677!
33678! John Burkardt
33679!
33680! Parameters:
33681!
33682! Input, integer ( kind = 4 ) N, the number of values desired.
33683!
33684! Input/output, integer ( kind = 4 ) SEED, a seed for the random
33685! number generator.
33686!
33687! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
33688!
33689! Local parameters:
33690!
33691! Local, real ( kind = 8 ) R(N+1), is used to store some uniform
33692! random values. Its dimension is N+1, but really it is only needed
33693! to be the smallest even number greater than or equal to N.
33694!
33695! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of
33696! X that we need to compute.
33697!
33698 implicit none
33699
33700 integer ( kind = 4 ) n
33701
33702 integer ( kind = 4 ) m
33703 real ( kind = 8 ) r(n+1)
33704 real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793d+00
33705 real ( kind = 8 ) r8_uniform_01
33706 integer ( kind = 4 ) seed
33707 real ( kind = 8 ) x(n)
33708 integer ( kind = 4 ) x_hi_index
33709 integer ( kind = 4 ) x_lo_index
33710!
33711! Record the range of X we need to fill in.
33712!
33713 x_lo_index = 1
33714 x_hi_index = n
33715!
33716! Maybe we don't need any more values.
33717!
33718 if ( x_hi_index - x_lo_index + 1 == 1 ) then
33719
33720 r(1) = r8_uniform_01( seed )
33721
33722 if ( r(1) == 0.0d+00 ) then
33723 write ( *, '(a)' ) ' '
33724 write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!'
33725 write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.'
33726 stop 1
33727 end if
33728
33729 r(2) = r8_uniform_01( seed )
33730
33731 x(x_hi_index) = &
33732 sqrt( -2.0d+00 * log( r(1) ) ) * cos( 2.0d+00 * r8_pi * r(2) )
33733!
33734! If we require an even number of values, that's easy.
33735!
33736 else if ( mod( x_hi_index - x_lo_index + 1, 2 ) == 0 ) then
33737
33738 m = ( x_hi_index - x_lo_index + 1 ) / 2
33739
33740 call r8vec_uniform_01 ( 2*m, seed, r )
33741
33742 x(x_lo_index:x_hi_index-1:2) = &
33743 sqrt( -2.0d+00 * log( r(1:2*m-1:2) ) ) &
33744 * cos( 2.0d+00 * r8_pi * r(2:2*m:2) )
33745
33746 x(x_lo_index+1:x_hi_index:2) = &
33747 sqrt( -2.0d+00 * log( r(1:2*m-1:2) ) ) &
33748 * sin( 2.0d+00 * r8_pi * r(2:2*m:2) )
33749!
33750! If we require an odd number of values, we generate an even number,
33751! and handle the last pair specially, storing one in X(N), and
33752! saving the other for later.
33753!
33754 else
33755
33756 x_hi_index = x_hi_index - 1
33757
33758 m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1
33759
33760 call r8vec_uniform_01 ( 2 * m, seed, r )
33761
33762 x(x_lo_index:x_hi_index-1:2) = &
33763 sqrt( -2.0d+00 * log( r(1:2*m-3:2) ) ) &
33764 * cos( 2.0d+00 * r8_pi * r(2:2*m-2:2) )
33765
33766 x(x_lo_index+1:x_hi_index:2) = &
33767 sqrt( -2.0d+00 * log( r(1:2*m-3:2) ) ) &
33768 * sin( 2.0d+00 * r8_pi * r(2:2*m-2:2) )
33769
33770 x(n) = sqrt( -2.0d+00 * log( r(2*m-1) ) ) &
33771 * cos( 2.0d+00 * r8_pi * r(2*m) )
33772
33773 end if
33774
33775 return
r8vec_uniform_01
subroutine r8vec_uniform_01(n, seed, r)
Definition R8LIB.f90:38171

References r8_pi(), r8_uniform_01(), and r8vec_uniform_01().

Referenced by r8mat_normal_01(), and r8vec_uniform_unit().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_normalize()

subroutine r8vec_normalize ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33777 of file R8LIB.f90.

33778
33779!*****************************************************************************80
33780!
33781!! R8VEC_NORMALIZE normalizes an R8VEC in the Euclidean norm.
33782!
33783! Discussion:
33784!
33785! An R8VEC is a vector of R8's.
33786!
33787! The euclidean norm is also sometimes called the l2 or
33788! least squares norm.
33789!
33790! Licensing:
33791!
33792! This code is distributed under the GNU LGPL license.
33793!
33794! Modified:
33795!
33796! 11 October 2010
33797!
33798! Author:
33799!
33800! John Burkardt
33801!
33802! Parameters:
33803!
33804! Input, integer ( kind = 4 ) N, the dimension of the vector.
33805!
33806! Input/output, real ( kind = 8 ) A(N), the vector to be normalized.
33807!
33808 implicit none
33809
33810 integer ( kind = 4 ) n
33811
33812 real ( kind = 8 ) a(n)
33813 real ( kind = 8 ) norm
33814
33815 norm = sqrt( sum( a(1:n)**2 ) )
33816
33817 if ( norm /= 0.0d+00 ) then
33818 a(1:n) = a(1:n) / norm
33819 end if
33820
33821 return

◆ r8vec_normalize_l1()

subroutine r8vec_normalize_l1 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 33823 of file R8LIB.f90.

33824
33825!*****************************************************************************80
33826!
33827!! R8VEC_NORMALIZE_L1 normalizes an R8VEC to have unit sum.
33828!
33829! Discussion:
33830!
33831! An R8VEC is a vector of R8's.
33832!
33833! Licensing:
33834!
33835! This code is distributed under the GNU LGPL license.
33836!
33837! Modified:
33838!
33839! 10 July 2000
33840!
33841! Author:
33842!
33843! John Burkardt
33844!
33845! Parameters:
33846!
33847! Input, integer ( kind = 4 ) N, the number of entries in the vector.
33848!
33849! Input/output, real ( kind = 8 ) A(N), the vector to be normalized.
33850! On output, the entries of A should have unit sum. However, if
33851! the input vector has zero sum, the routine halts.
33852!
33853 implicit none
33854
33855 integer ( kind = 4 ) n
33856
33857 real ( kind = 8 ) a(n)
33858 real ( kind = 8 ) a_sum
33859
33860 a_sum = sum( a(1:n) )
33861
33862 if ( a_sum == 0.0d+00 ) then
33863 write ( *, '(a)' ) ' '
33864 write ( *, '(a)' ) 'R8VEC_NORMALIZE_L1 - Fatal error!'
33865 write ( *, '(a)' ) ' The vector entries sum to 0.'
33866 stop 1
33867 end if
33868
33869 a(1:n) = a(1:n) / a_sum
33870
33871 return

◆ r8vec_normsq()

real ( kind = 8 ) function r8vec_normsq ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v 
)

Definition at line 33873 of file R8LIB.f90.

33874
33875!*****************************************************************************80
33876!
33877!! R8VEC_NORMSQ returns the square of the L2 norm of an R8VEC.
33878!
33879! Discussion:
33880!
33881! An R8VEC is a vector of R8's.
33882!
33883! The square of the vector L2 norm is defined as:
33884!
33885! R8VEC_NORMSQ = sum ( 1 <= I <= N ) V(I)^2.
33886!
33887! Licensing:
33888!
33889! This code is distributed under the GNU LGPL license.
33890!
33891! Modified:
33892!
33893! 28 October 2010
33894!
33895! Author:
33896!
33897! John Burkardt
33898!
33899! Parameters:
33900!
33901! Input, integer ( kind = 4 ) N, the vector dimension.
33902!
33903! Input, real ( kind = 8 ) V(N), the vector.
33904!
33905! Output, real ( kind = 8 ) R8VEC_NORMSQ, the squared L2 norm.
33906!
33907 implicit none
33908
33909 integer ( kind = 4 ) n
33910
33911 real ( kind = 8 ) r8vec_normsq
33912 real ( kind = 8 ) v(n)
33913
33914 r8vec_normsq = sum( v(1:n)**2 )
33915
33916 return
r8vec_normsq
real(kind=8) function r8vec_normsq(n, v)
Definition R8LIB.f90:33874

References r8vec_normsq().

Referenced by r8vec_normsq().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_normsq_affine()

real ( kind = 8 ) function r8vec_normsq_affine ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  v0,
real ( kind = 8 ), dimension(n)  v1 
)

Definition at line 33918 of file R8LIB.f90.

33919
33920!*****************************************************************************80
33921!
33922!! R8VEC_NORMSQ_AFFINE returns the affine squared norm of an R8VEC.
33923!
33924! Discussion:
33925!
33926! An R8VEC is a vector of R8's.
33927!
33928! The affine squared vector L2 norm is defined as:
33929!
33930! R8VEC_NORMSQ_AFFINE(V0,V1)
33931! = sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2
33932!
33933! Licensing:
33934!
33935! This code is distributed under the GNU LGPL license.
33936!
33937! Modified:
33938!
33939! 28 October 2010
33940!
33941! Author:
33942!
33943! John Burkardt
33944!
33945! Parameters:
33946!
33947! Input, integer ( kind = 4 ) N, the vector dimension.
33948!
33949! Input, real ( kind = 8 ) V0(N), the base vector.
33950!
33951! Input, real ( kind = 8 ) V1(N), the vector.
33952!
33953! Output, real ( kind = 8 ) R8VEC_NORMSQ_AFFINE, the squared affine L2 norm.
33954!
33955 implicit none
33956
33957 integer ( kind = 4 ) n
33958
33959 real ( kind = 8 ) r8vec_normsq_affine
33960 real ( kind = 8 ) v0(n)
33961 real ( kind = 8 ) v1(n)
33962
33963 r8vec_normsq_affine = sum( ( v0(1:n) - v1(1:n) )**2 )
33964
33965 return
r8vec_normsq_affine
real(kind=8) function r8vec_normsq_affine(n, v0, v1)
Definition R8LIB.f90:33919

References r8vec_normsq_affine().

Referenced by r8vec_normsq_affine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_order_type()

subroutine r8vec_order_type ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  order 
)

Definition at line 33967 of file R8LIB.f90.

33968
33969!*****************************************************************************80
33970!
33971!! R8VEC_ORDER_TYPE determines if R8VEC is (non)strictly ascending/descending.
33972!
33973! Discussion:
33974!
33975! An R8VEC is a vector of R8's.
33976!
33977! Licensing:
33978!
33979! This code is distributed under the GNU LGPL license.
33980!
33981! Modified:
33982!
33983! 15 December 2004
33984!
33985! Author:
33986!
33987! John Burkardt
33988!
33989! Parameters:
33990!
33991! Input, integer ( kind = 4 ) N, the number of entries of the array.
33992!
33993! Input, real ( kind = 8 ) A(N), the array to be checked.
33994!
33995! Output, integer ( kind = 4 ) ORDER, order indicator:
33996! -1, no discernable order;
33997! 0, all entries are equal;
33998! 1, ascending order;
33999! 2, strictly ascending order;
34000! 3, descending order;
34001! 4, strictly descending order.
34002!
34003 implicit none
34004
34005 integer ( kind = 4 ) n
34006
34007 real ( kind = 8 ) a(n)
34008 integer ( kind = 4 ) i
34009 integer ( kind = 4 ) order
34010!
34011! Search for the first value not equal to A(1).
34012!
34013 i = 1
34014
34015 do
34016
34017 i = i + 1
34018
34019 if ( n < i ) then
34020 order = 0
34021 return
34022 end if
34023
34024 if ( a(1) < a(i) ) then
34025
34026 if ( i == 2 ) then
34027 order = 2
34028 else
34029 order = 1
34030 end if
34031
34032 exit
34033
34034 else if ( a(i) < a(1) ) then
34035
34036 if ( i == 2 ) then
34037 order = 4
34038 else
34039 order = 3
34040 end if
34041
34042 exit
34043
34044 end if
34045
34046 end do
34047!
34048! Now we have a "direction". Examine subsequent entries.
34049!
34050 do while ( i < n )
34051
34052 i = i + 1
34053
34054 if ( order == 1 ) then
34055
34056 if ( a(i) < a(i-1) ) then
34057 order = -1
34058 exit
34059 end if
34060
34061 else if ( order == 2 ) then
34062
34063 if ( a(i) < a(i-1) ) then
34064 order = -1
34065 exit
34066 else if ( a(i) == a(i-1) ) then
34067 order = 1
34068 end if
34069
34070 else if ( order == 3 ) then
34071
34072 if ( a(i-1) < a(i) ) then
34073 order = -1
34074 exit
34075 end if
34076
34077 else if ( order == 4 ) then
34078
34079 if ( a(i-1) < a(i) ) then
34080 order = -1
34081 exit
34082 else if ( a(i) == a(i-1) ) then
34083 order = 3
34084 end if
34085
34086 end if
34087
34088 end do
34089
34090 return

Referenced by r8vec_sorted_merge_a().

Here is the caller graph for this function:

◆ r8vec_part_quick_a()

subroutine r8vec_part_quick_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  l,
integer ( kind = 4 )  r 
)

Definition at line 34092 of file R8LIB.f90.

34093
34094!*****************************************************************************80
34095!
34096!! R8VEC_PART_QUICK_A reorders an R8VEC as part of a quick sort.
34097!
34098! Discussion:
34099!
34100! An R8VEC is a vector of R8's.
34101!
34102! The routine reorders the entries of A. Using A(1) as the key,
34103! all entries of A that are less than or equal to the key will
34104! precede the key which precedes all entries that are greater than the key.
34105!
34106! Example:
34107!
34108! Input:
34109!
34110! N = 8
34111!
34112! A = ( 6, 7, 3, 1, 6, 8, 2, 9 )
34113!
34114! Output:
34115!
34116! L = 3, R = 6
34117!
34118! A = ( 3, 1, 2, 6, 6, 8, 9, 7 )
34119! ------- -------
34120!
34121! Licensing:
34122!
34123! This code is distributed under the GNU LGPL license.
34124!
34125! Modified:
34126!
34127! 08 December 2004
34128!
34129! Author:
34130!
34131! John Burkardt
34132!
34133! Parameters:
34134!
34135! Input, integer ( kind = 4 ) N, the number of entries of A.
34136!
34137! Input/output, real ( kind = 8 ) A(N). On input, the array to be checked.
34138! On output, A has been reordered as described above.
34139!
34140! Output, integer ( kind = 4 ) L, R, the indices of A that define
34141! the three segments. Let KEY = the input value of A(1). Then
34142! I <= L A(I) < KEY;
34143! L < I < R A(I) = KEY;
34144! R <= I KEY < A(I).
34145!
34146 implicit none
34147
34148 integer ( kind = 4 ) n
34149
34150 real ( kind = 8 ) a(n)
34151 integer ( kind = 4 ) i
34152 real ( kind = 8 ) key
34153 integer ( kind = 4 ) l
34154 integer ( kind = 4 ) m
34155 integer ( kind = 4 ) r
34156 real ( kind = 8 ) temp
34157
34158 if ( n < 1 ) then
34159 write ( *, '(a)' ) ' '
34160 write ( *, '(a)' ) 'R8VEC_PART_QUICK_A - Fatal error!'
34161 write ( *, '(a)' ) ' N < 1.'
34162 stop 1
34163 else if ( n == 1 ) then
34164 l = 0
34165 r = 2
34166 return
34167 end if
34168
34169 key = a(1)
34170 m = 1
34171!
34172! The elements of unknown size have indices between L+1 and R-1.
34173!
34174 l = 1
34175 r = n + 1
34176
34177 do i = 2, n
34178
34179 if ( key < a(l+1) ) then
34180 r = r - 1
34181 temp = a(r)
34182 a(r) = a(l+1)
34183 a(l+1) = temp
34184 else if ( a(l+1) == key ) then
34185 m = m + 1
34186 temp = a(m)
34187 a(m) = a(l+1)
34188 a(l+1) = temp
34189 l = l + 1
34190 else if ( a(l+1) < key ) then
34191 l = l + 1
34192 end if
34193
34194 end do
34195!
34196! Now shift small elements to the left, and KEY elements to center.
34197!
34198 do i = 1, l - m
34199 a(i) = a(i+m)
34200 end do
34201!
34202! Out of bounds here, occasionally
34203!
34204 l = l - m
34205
34206 a(l+1:l+m) = key
34207
34208 return

Referenced by r8vec_sort_quick_a().

Here is the caller graph for this function:

◆ r8vec_permute()

subroutine r8vec_permute ( integer ( kind = 4 )  n,
integer ( kind = 4 ), dimension(n)  p,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 34210 of file R8LIB.f90.

34211
34212!*****************************************************************************80
34213!
34214!! R8VEC_PERMUTE permutes an R8VEC in place.
34215!
34216! Discussion:
34217!
34218! An R8VEC is a vector of R8's.
34219!
34220! This routine permutes an array of real "objects", but the same
34221! logic can be used to permute an array of objects of any arithmetic
34222! type, or an array of objects of any complexity. The only temporary
34223! storage required is enough to store a single object. The number
34224! of data movements made is N + the number of cycles of order 2 or more,
34225! which is never more than N + N/2.
34226!
34227! P(I) = J means that the I-th element of the output array should be
34228! the J-th element of the input array. P must be a legal permutation
34229! of the integers from 1 to N, otherwise the algorithm will
34230! fail catastrophically.
34231!
34232! Example:
34233!
34234! Input:
34235!
34236! N = 5
34237! P = ( 2, 4, 5, 1, 3 )
34238! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
34239!
34240! Output:
34241!
34242! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 ).
34243!
34244! Licensing:
34245!
34246! This code is distributed under the GNU LGPL license.
34247!
34248! Modified:
34249!
34250! 20 July 2000
34251!
34252! Author:
34253!
34254! John Burkardt
34255!
34256! Parameters:
34257!
34258! Input, integer ( kind = 4 ) N, the number of objects.
34259!
34260! Input, integer ( kind = 4 ) P(N), the permutation.
34261!
34262! Input/output, real ( kind = 8 ) A(N), the array to be permuted.
34263!
34264 implicit none
34265
34266 integer ( kind = 4 ) n
34267
34268 real ( kind = 8 ) a(n)
34269 real ( kind = 8 ) a_temp
34270 integer ( kind = 4 ) ierror
34271 integer ( kind = 4 ) iget
34272 integer ( kind = 4 ) iput
34273 integer ( kind = 4 ) istart
34274 integer ( kind = 4 ) p(n)
34275
34276 call perm_check1 ( n, p )
34277!
34278! Search for the next element of the permutation that has not been used.
34279!
34280 do istart = 1, n
34281
34282 if ( p(istart) < 0 ) then
34283
34284 cycle
34285
34286 else if ( p(istart) == istart ) then
34287
34288 p(istart) = - p(istart)
34289 cycle
34290
34291 else
34292
34293 a_temp = a(istart)
34294 iget = istart
34295!
34296! Copy the new value into the vacated entry.
34297!
34298 do
34299
34300 iput = iget
34301 iget = p(iget)
34302
34303 p(iput) = - p(iput)
34304
34305 if ( iget < 1 .or. n < iget ) then
34306 write ( *, '(a)' ) ' '
34307 write ( *, '(a)' ) 'R8VEC_PERMUTE - Fatal error!'
34308 write ( *, '(a)' ) ' A permutation index is out of range.'
34309 write ( *, '(a,i8,a,i8)' ) ' P(', iput, ') = ', iget
34310 stop 1
34311 end if
34312
34313 if ( iget == istart ) then
34314 a(iput) = a_temp
34315 exit
34316 end if
34317
34318 a(iput) = a(iget)
34319
34320 end do
34321
34322 end if
34323
34324 end do
34325!
34326! Restore the signs of the entries.
34327!
34328 p(1:n) = - p(1:n)
34329
34330 return

References perm_check1().

Referenced by r8vec_permute_uniform().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_permute_cyclic()

subroutine r8vec_permute_cyclic ( integer ( kind = 4 )  n,
integer ( kind = 4 )  k,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 34332 of file R8LIB.f90.

34333
34334!*****************************************************************************80
34335!
34336!! R8VEC_PERMUTE_CYCLIC performs a cyclic permutation of an R8VEC.
34337!
34338! Discussion:
34339!
34340! An R8VEC is a vector of R8's.
34341!
34342! For 0 <= K < N, this function cyclically permutes the input vector
34343! to have the form
34344!
34345! ( A(K+1), A(K+2), ..., A(N), A(1), ..., A(K) )
34346!
34347! Licensing:
34348!
34349! This code is distributed under the GNU LGPL license.
34350!
34351! Modified:
34352!
34353! 22 August 2010
34354!
34355! Author:
34356!
34357! John Burkardt
34358!
34359! Parameters:
34360!
34361! Input, integer ( kind = 4 ) N, the number of objects.
34362!
34363! Input, integer ( kind = 4 ) K, the increment used.
34364!
34365! Input/output, real ( kind = 8 ) A(N), the array to be permuted.
34366!
34367 implicit none
34368
34369 integer ( kind = 4 ) n
34370
34371 real ( kind = 8 ) a(n)
34372 real ( kind = 8 ) b(n)
34373 integer ( kind = 4 ) i
34374 integer ( kind = 4 ) i4_wrap
34375 integer ( kind = 4 ) ipk
34376 integer ( kind = 4 ) k
34377
34378 do i = 1, n
34379 ipk = i4_wrap( i + k, 1, n )
34380 b(i) = a(ipk)
34381 end do
34382
34383 a(1:n) = b(1:n)
34384
34385 return

◆ r8vec_permute_uniform()

subroutine r8vec_permute_uniform ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  seed 
)

Definition at line 34387 of file R8LIB.f90.

34388
34389!*****************************************************************************80
34390!
34391!! R8VEC_PERMUTE_UNIFORM randomly permutes an R8VEC.
34392!
34393! Discussion:
34394!
34395! An R8VEC is a vector of R8's.
34396!
34397! Licensing:
34398!
34399! This code is distributed under the GNU LGPL license.
34400!
34401! Modified:
34402!
34403! 01 April 2003
34404!
34405! Author:
34406!
34407! John Burkardt
34408!
34409! Parameters:
34410!
34411! Input, integer ( kind = 4 ) N, the number of objects.
34412!
34413! Input/output, real ( kind = 8 ) A(N), the array to be permuted.
34414!
34415! Input/output, integer ( kind = 4 ) SEED, a seed for the random
34416! number generator.
34417!
34418 implicit none
34419
34420 integer ( kind = 4 ) n
34421
34422 real ( kind = 8 ) a(n)
34423 integer ( kind = 4 ) p(n)
34424 integer ( kind = 4 ) seed
34425
34426 call perm_uniform ( n, seed, p )
34427
34428 call r8vec_permute ( n, p, a )
34429
34430 return
perm_uniform
subroutine perm_uniform(n, seed, p)
Definition R8LIB.f90:1259
r8vec_permute
subroutine r8vec_permute(n, p, a)
Definition R8LIB.f90:34211

References perm_uniform(), and r8vec_permute().

Here is the call graph for this function:

◆ r8vec_polarize()

subroutine r8vec_polarize ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  p,
real ( kind = 8 ), dimension(n)  a_normal,
real ( kind = 8 ), dimension(n)  a_parallel 
)

Definition at line 34432 of file R8LIB.f90.

34433
34434!*****************************************************************************80
34435!
34436!! R8VEC_POLARIZE decomposes an R8VEC into normal and parallel components.
34437!
34438! Discussion:
34439!
34440! An R8VEC is a vector of R8's.
34441!
34442! The (nonzero) vector P defines a direction.
34443!
34444! The vector A can be written as the sum
34445!
34446! A = A_normal + A_parallel
34447!
34448! where A_parallel is a linear multiple of P, and A_normal
34449! is perpendicular to P.
34450!
34451! Licensing:
34452!
34453! This code is distributed under the GNU LGPL license.
34454!
34455! Modified:
34456!
34457! 08 November 2000
34458!
34459! Author:
34460!
34461! John Burkardt
34462!
34463! Parameters:
34464!
34465! Input, integer ( kind = 4 ) N, the number of entries in the array.
34466!
34467! Input, real ( kind = 8 ) A(N), the vector to be polarized.
34468!
34469! Input, real ( kind = 8 ) P(N), the polarizing direction.
34470!
34471! Output, real ( kind = 8 ) A_NORMAL(N), A_PARALLEL(N), the normal
34472! and parallel components of A.
34473!
34474 implicit none
34475
34476 integer ( kind = 4 ) n
34477
34478 real ( kind = 8 ) a(n)
34479 real ( kind = 8 ) a_dot_p
34480 real ( kind = 8 ) a_normal(n)
34481 real ( kind = 8 ) a_parallel(n)
34482 real ( kind = 8 ) p(n)
34483 real ( kind = 8 ) p_norm
34484
34485 p_norm = sqrt( sum( p(1:n)**2 ) )
34486
34487 if ( p_norm == 0.0d+00 ) then
34488 a_normal(1:n) = a(1:n)
34489 a_parallel(1:n) = 0.0d+00
34490 return
34491 end if
34492
34493 a_dot_p = dot_product( a(1:n), p(1:n) ) / p_norm
34494
34495 a_parallel(1:n) = a_dot_p * p(1:n) / p_norm
34496
34497 a_normal(1:n) = a(1:n) - a_parallel(1:n)
34498
34499 return

◆ r8vec_positive_strict()

logical ( kind = 4 ) function r8vec_positive_strict ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 34501 of file R8LIB.f90.

34502
34503!*****************************************************************************80
34504!
34505!! R8VEC_POSITIVE_STRICT: every element of an R8VEC is strictly positive.
34506!
34507! Discussion:
34508!
34509! An R8VEC is a vector of R8's.
34510!
34511! Licensing:
34512!
34513! This code is distributed under the GNU LGPL license.
34514!
34515! Modified:
34516!
34517! 24 June 2010
34518!
34519! Author:
34520!
34521! John Burkardt
34522!
34523! Parameters:
34524!
34525! Input, integer ( kind = 4 ) N, the number of entries in the vector.
34526!
34527! Input, real ( kind = 8 ) A(N).
34528!
34529! Output, logical ( kind = 4 ) R8VEC_POSITIVE_STRICT, is TRUE every entry
34530! of the vector is strictly positive.
34531!
34532 implicit none
34533
34534 integer ( kind = 4 ) n
34535
34536 real ( kind = 8 ) a(n)
34537 logical ( kind = 4 ) r8vec_positive_strict
34538
34539 r8vec_positive_strict = ( all( 0.0d+00 < a(1:n) ) )
34540
34541 return
r8vec_positive_strict
logical(kind=4) function r8vec_positive_strict(n, a)
Definition R8LIB.f90:34502

References r8vec_positive_strict().

Referenced by r8vec_positive_strict().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_print()

subroutine r8vec_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
character ( len = * )  title 
)

Definition at line 34543 of file R8LIB.f90.

34544
34545!*****************************************************************************80
34546!
34547!! R8VEC_PRINT prints an R8VEC.
34548!
34549! Discussion:
34550!
34551! An R8VEC is a vector of R8's.
34552!
34553! Licensing:
34554!
34555! This code is distributed under the GNU LGPL license.
34556!
34557! Modified:
34558!
34559! 22 August 2000
34560!
34561! Author:
34562!
34563! John Burkardt
34564!
34565! Parameters:
34566!
34567! Input, integer ( kind = 4 ) N, the number of components of the vector.
34568!
34569! Input, real ( kind = 8 ) A(N), the vector to be printed.
34570!
34571! Input, character ( len = * ) TITLE, a title.
34572!
34573 implicit none
34574
34575 integer ( kind = 4 ) n
34576
34577 real ( kind = 8 ) a(n)
34578 integer ( kind = 4 ) i
34579 character ( len = * ) title
34580
34581 write ( *, '(a)' ) ' '
34582 write ( *, '(a)' ) trim( title )
34583 write ( *, '(a)' ) ' '
34584
34585 do i = 1, n
34586 write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
34587 end do
34588
34589 return

◆ r8vec_print2()

subroutine r8vec_print2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 34780 of file R8LIB.f90.

34781
34782!*****************************************************************************80
34783!
34784!! R8VEC_PRINT2 prints out an R8VEC.
34785!
34786! Discussion:
34787!
34788! An R8VEC is a vector of R8's.
34789!
34790! Licensing:
34791!
34792! This code is distributed under the GNU LGPL license.
34793!
34794! Modified:
34795!
34796! 26 March 2006
34797!
34798! Author:
34799!
34800! John Burkardt
34801!
34802! Parameters:
34803!
34804! Input, integer ( kind = 4 ) N, the number of entries of A.
34805!
34806! Input, real ( kind = 8 ) A(N), the vector to be printed.
34807!
34808 implicit none
34809
34810 integer ( kind = 4 ) n
34811
34812 real ( kind = 8 ) a(n)
34813 real ( kind = 8 ) amax
34814 real ( kind = 8 ) amin
34815 integer ( kind = 4 ) i
34816 character ( len = 11 ) iform
34817 logical ( kind = 4 ) integ
34818 integer ( kind = 4 ) lmax
34819 real ( kind = 8 ) r8_log_10
34820!
34821! Check if all entries are integral.
34822!
34823 integ = .true.
34824
34825 do i = 1, n
34826
34827 if ( a(i) /= real( int( a(i) ), kind = 8 ) ) then
34828 integ = .false.
34829 exit
34830 end if
34831
34832 end do
34833!
34834! Find the range of the array.
34835!
34836 amax = maxval( abs( a(1:n) ) )
34837 amin = minval( abs( a(1:n) ) )
34838!
34839! Use the information about the maximum size of an entry to
34840! compute an intelligent format for use with integer entries.
34841!
34842! Later, we might also do this for real vectors.
34843!
34844 lmax = int( r8_log_10( amax ) )
34845
34846 if ( integ ) then
34847 write ( iform, '( ''(2x,i'', i2, '')'' )' ) lmax + 3
34848 else
34849 iform = ' '
34850 end if
34851
34852 do i = 1, n
34853
34854 if ( integ ) then
34855 write ( *, iform ) int( a(i) )
34856 else
34857 write ( *, '(2x,g14.6)' ) a(i)
34858 end if
34859
34860 end do
34861
34862 return

References r8_log_10().

Here is the call graph for this function:

◆ r8vec_print_16()

subroutine r8vec_print_16 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
character ( len = * )  title 
)

Definition at line 34591 of file R8LIB.f90.

34592
34593!*****************************************************************************80
34594!
34595!! R8VEC_PRINT_16 prints an R8VEC to 16 decimal places.
34596!
34597! Discussion:
34598!
34599! An R8VEC is a vector of R8's.
34600!
34601! Licensing:
34602!
34603! This code is distributed under the GNU LGPL license.
34604!
34605! Modified:
34606!
34607! 29 May 2014
34608!
34609! Author:
34610!
34611! John Burkardt
34612!
34613! Parameters:
34614!
34615! Input, integer ( kind = 4 ) N, the number of components of the vector.
34616!
34617! Input, real ( kind = 8 ) A(N), the vector to be printed.
34618!
34619! Input, character ( len = * ) TITLE, a title.
34620!
34621 implicit none
34622
34623 integer ( kind = 4 ) n
34624
34625 real ( kind = 8 ) a(n)
34626 integer ( kind = 4 ) i
34627 character ( len = * ) title
34628
34629 write ( *, '(a)' ) ' '
34630 write ( *, '(a)' ) trim( title )
34631 write ( *, '(a)' ) ' '
34632
34633 do i = 1, n
34634 write ( *, '(2x,i8,a,1x,g24.16)' ) i, ':', a(i)
34635 end do
34636
34637 return

◆ r8vec_print_part()

subroutine r8vec_print_part ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  max_print,
character ( len = * )  title 
)

Definition at line 34639 of file R8LIB.f90.

34640
34641!*****************************************************************************80
34642!
34643!! R8VEC_PRINT_PART prints "part" of an R8VEC.
34644!
34645! Discussion:
34646!
34647! The user specifies MAX_PRINT, the maximum number of lines to print.
34648!
34649! If N, the size of the vector, is no more than MAX_PRINT, then
34650! the entire vector is printed, one entry per line.
34651!
34652! Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
34653! followed by a line of periods suggesting an omission,
34654! and the last entry.
34655!
34656! Licensing:
34657!
34658! This code is distributed under the GNU LGPL license.
34659!
34660! Modified:
34661!
34662! 19 December 2001
34663!
34664! Author:
34665!
34666! John Burkardt
34667!
34668! Parameters:
34669!
34670! Input, integer ( kind = 4 ) N, the number of entries of the vector.
34671!
34672! Input, real ( kind = 8 ) A(N), the vector to be printed.
34673!
34674! Input, integer ( kind = 4 ) MAX_PRINT, the maximum number of lines
34675! to print.
34676!
34677! Input, character ( len = * ) TITLE, a title.
34678!
34679 implicit none
34680
34681 integer ( kind = 4 ) n
34682
34683 real ( kind = 8 ) a(n)
34684 integer ( kind = 4 ) i
34685 integer ( kind = 4 ) max_print
34686 character ( len = * ) title
34687
34688 if ( max_print <= 0 ) then
34689 return
34690 end if
34691
34692 if ( n <= 0 ) then
34693 return
34694 end if
34695
34696 write ( *, '(a)' ) ' '
34697 write ( *, '(a)' ) trim( title )
34698 write ( *, '(a)' ) ' '
34699
34700 if ( n <= max_print ) then
34701
34702 do i = 1, n
34703 write ( *, '(2x,i8,a,1x,g14.6)' ) i, ':', a(i)
34704 end do
34705
34706 else if ( 3 <= max_print ) then
34707
34708 do i = 1, max_print - 2
34709 write ( *, '(2x,i8,a,1x,g14.6)' ) i, ':', a(i)
34710 end do
34711 write ( *, '(a)' ) ' ........ ..............'
34712 i = n
34713 write ( *, '(2x,i8,a,1x,g14.6)' ) i, ':', a(i)
34714
34715 else
34716
34717 do i = 1, max_print - 1
34718 write ( *, '(2x,i8,a,1x,g14.6)' ) i, ':', a(i)
34719 end do
34720 i = max_print
34721 write ( *, '(2x,i8,a,1x,g14.6,2x,a)' ) i, ':', a(i), '...more entries...'
34722
34723 end if
34724
34725 return

◆ r8vec_print_some()

subroutine r8vec_print_some ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  i_lo,
integer ( kind = 4 )  i_hi,
character ( len = * )  title 
)

Definition at line 34727 of file R8LIB.f90.

34728
34729!*****************************************************************************80
34730!
34731!! R8VEC_PRINT_SOME prints "some" of an R8VEC.
34732!
34733! Discussion:
34734!
34735! An R8VEC is a vector of R8's.
34736!
34737! Licensing:
34738!
34739! This code is distributed under the GNU LGPL license.
34740!
34741! Modified:
34742!
34743! 10 September 2009
34744!
34745! Author:
34746!
34747! John Burkardt
34748!
34749! Parameters:
34750!
34751! Input, integer ( kind = 4 ) N, the number of entries of the vector.
34752!
34753! Input, real ( kind = 8 ) A(N), the vector to be printed.
34754!
34755! Input, integer ( kind = 4 ) I_LO, I_HI, the first and last indices
34756! to print. The routine expects 1 <= I_LO <= I_HI <= N.
34757!
34758! Input, character ( len = * ) TITLE, a title.
34759!
34760 implicit none
34761
34762 integer ( kind = 4 ) n
34763
34764 real ( kind = 8 ) a(n)
34765 integer ( kind = 4 ) i
34766 integer ( kind = 4 ) i_hi
34767 integer ( kind = 4 ) i_lo
34768 character ( len = * ) title
34769
34770 write ( *, '(a)' ) ' '
34771 write ( *, '(a)' ) trim( title )
34772
34773 write ( *, '(a)' ) ' '
34774 do i = max( i_lo, 1 ), min( i_hi, n )
34775 write ( *, '(2x,i8,a,1x,g14.8)' ) i, ':', a(i)
34776 end do
34777
34778 return

◆ r8vec_product()

real ( kind = 8 ) function r8vec_product ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 34864 of file R8LIB.f90.

34865
34866!*****************************************************************************80
34867!
34868!! R8VEC_PRODUCT returns the product of the entries of an R8VEC.
34869!
34870! Discussion:
34871!
34872! An R8VEC is a vector of R8's.
34873!
34874! In FORTRAN90, this facility is offered by the built in
34875! PRODUCT function:
34876!
34877! R8VEC_PRODUCT ( N, A ) = PRODUCT ( A(1:N) )
34878!
34879! In MATLAB, this facility is offered by the built in
34880! PROD function:
34881!
34882! R8VEC_PRODUCT ( N, A ) = PROD ( A(1:N) )
34883!
34884! Licensing:
34885!
34886! This code is distributed under the GNU LGPL license.
34887!
34888! Modified:
34889!
34890! 17 September 2003
34891!
34892! Author:
34893!
34894! John Burkardt
34895!
34896! Parameters:
34897!
34898! Input, integer ( kind = 4 ) N, the number of entries in the array.
34899!
34900! Input, real ( kind = 8 ) A(N), the array.
34901!
34902! Output, real ( kind = 8 ) R8VEC_PRODUCT, the product of the entries.
34903!
34904 implicit none
34905
34906 integer ( kind = 4 ) n
34907
34908 real ( kind = 8 ) a(n)
34909 real ( kind = 8 ) r8vec_product
34910
34911 r8vec_product = product( a(1:n) )
34912
34913 return
r8vec_product
real(kind=8) function r8vec_product(n, a)
Definition R8LIB.f90:34865

References r8vec_product().

Referenced by r8vec_product().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_range()

subroutine r8vec_range ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 )  xmin,
real ( kind = 8 )  xmax,
real ( kind = 8 ), dimension(n)  y,
real ( kind = 8 )  ymin,
real ( kind = 8 )  ymax 
)

Definition at line 34915 of file R8LIB.f90.

34916
34917!*****************************************************************************80
34918!
34919!! R8VEC_RANGE finds the range of Y's within a restricted X range.
34920!
34921! Discussion:
34922!
34923! An R8VEC is a vector of R8's.
34924!
34925! The routine is given a set of pairs of points (X,Y), and a range
34926! XMIN to XMAX of valid X values. Over this range, it seeks
34927! YMIN and YMAX, the minimum and maximum values of Y for
34928! valid X's.
34929!
34930! Licensing:
34931!
34932! This code is distributed under the GNU LGPL license.
34933!
34934! Modified:
34935!
34936! 14 May 2005
34937!
34938! Author:
34939!
34940! John Burkardt
34941!
34942! Parameters:
34943!
34944! Input, integer ( kind = 4 ) N, the number of entries in the array.
34945!
34946! Input, real ( kind = 8 ) X(N), the X array.
34947!
34948! Input, real ( kind = 8 ) XMIN, XMAX, the range of X values to check.
34949!
34950! Input, real ( kind = 8 ) Y(N), the Y array.
34951!
34952! Output, real ( kind = 8 ) YMIN, YMAX, the range of Y values whose
34953! X value is within the X range.
34954!
34955 implicit none
34956
34957 integer ( kind = 4 ) n
34958
34959 integer ( kind = 4 ) i
34960 real ( kind = 8 ) x(n)
34961 real ( kind = 8 ) xmax
34962 real ( kind = 8 ) xmin
34963 real ( kind = 8 ) y(n)
34964 real ( kind = 8 ) ymax
34965 real ( kind = 8 ) ymin
34966
34967 ymin = huge( ymin )
34968 ymax = - huge( ymax )
34969
34970 do i = 1, n
34971
34972 if ( xmin <= x(i) .and. x(i) <= xmax ) then
34973
34974 ymin = min( ymin, y(i) )
34975 ymax = max( ymax, y(i) )
34976
34977 end if
34978
34979 end do
34980
34981 return

◆ r8vec_range_2()

subroutine r8vec_range_2 ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  amin,
real ( kind = 8 )  amax 
)

Definition at line 34983 of file R8LIB.f90.

34984
34985!*****************************************************************************80
34986!
34987!! R8VEC_RANGE_2 updates a range to include a new array.
34988!
34989! Discussion:
34990!
34991! An R8VEC is a vector of R8's.
34992!
34993! Given a range AMIN to AMAX, and an array A, the routine will
34994! decrease AMIN if necessary, or increase AMAX if necessary, so that
34995! every entry of A is between AMIN and AMAX.
34996!
34997! However, AMIN will not be increased, nor AMAX decreased.
34998!
34999! This routine may be used to compute the maximum and minimum of a
35000! collection of arrays one at a time.
35001!
35002! Licensing:
35003!
35004! This code is distributed under the GNU LGPL license.
35005!
35006! Modified:
35007!
35008! 18 November 2000
35009!
35010! Author:
35011!
35012! John Burkardt
35013!
35014! Parameters:
35015!
35016! Input, integer ( kind = 4 ) N, the number of entries in the array.
35017!
35018! Input, real ( kind = 8 ) A(N), the array.
35019!
35020! Input/output, real ( kind = 8 ) AMIN, AMAX. On input, the
35021! current legal range of values for A. On output, AMIN and AMAX
35022! are either unchanged, or else "widened" so that all entries
35023! of A are within the range.
35024!
35025 implicit none
35026
35027 integer ( kind = 4 ) n
35028
35029 real ( kind = 8 ) a(n)
35030 real ( kind = 8 ) amax
35031 real ( kind = 8 ) amin
35032
35033 amax = max( amax, maxval( a(1:n) ) )
35034 amin = min( amin, minval( a(1:n) ) )
35035
35036 return

◆ r8vec_reverse()

subroutine r8vec_reverse ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35038 of file R8LIB.f90.

35039
35040!*****************************************************************************80
35041!
35042!! R8VEC_REVERSE reverses the elements of an R8VEC.
35043!
35044! Discussion:
35045!
35046! An R8VEC is a vector of R8's.
35047!
35048! In FORTRAN90, calling R8VEC_REVERSE is equivalent to
35049!
35050! A(1:N) = A(N:1:-1)
35051!
35052! Example:
35053!
35054! Input:
35055!
35056! N = 5,
35057! A = ( 11.0, 12.0, 13.0, 14.0, 15.0 ).
35058!
35059! Output:
35060!
35061! A = ( 15.0, 14.0, 13.0, 12.0, 11.0 ).
35062!
35063! Licensing:
35064!
35065! This code is distributed under the GNU LGPL license.
35066!
35067! Modified:
35068!
35069! 30 September 2009
35070!
35071! Author:
35072!
35073! John Burkardt
35074!
35075! Parameters:
35076!
35077! Input, integer ( kind = 4 ) N, the number of entries in the array.
35078!
35079! Input/output, real ( kind = 8 ) A(N), the array to be reversed.
35080!
35081 implicit none
35082
35083 integer ( kind = 4 ) n
35084
35085 real ( kind = 8 ) a(n)
35086
35087 a(1:n) = a(n:1:-1)
35088
35089 return

◆ r8vec_rms()

real ( kind = 8 ) function r8vec_rms ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35091 of file R8LIB.f90.

35092
35093!*****************************************************************************80
35094!
35095!! R8VEC_RMS returns the RMS norm of an R8VEC.
35096!
35097! Discussion:
35098!
35099! An R8VEC is a vector of R8's.
35100!
35101! The vector RMS norm is defined as:
35102!
35103! R8VEC_RMS = sqrt ( sum ( 1 <= I <= N ) A(I)^2 / N ).
35104!
35105! Licensing:
35106!
35107! This code is distributed under the GNU LGPL license.
35108!
35109! Modified:
35110!
35111! 26 October 2011
35112!
35113! Author:
35114!
35115! John Burkardt
35116!
35117! Parameters:
35118!
35119! Input, integer ( kind = 4 ) N, the number of entries in A.
35120!
35121! Input, real ( kind = 8 ) A(N), the vector.
35122!
35123! Output, real ( kind = 8 ) R8VEC_RMS, the RMS norm of A.
35124!
35125 implicit none
35126
35127 integer ( kind = 4 ) n
35128
35129 real ( kind = 8 ) a(n)
35130 real ( kind = 8 ) r8vec_rms
35131
35132 r8vec_rms = sqrt( sum( a(1:n)**2 ) / n )
35133
35134 return
r8vec_rms
real(kind=8) function r8vec_rms(n, a)
Definition R8LIB.f90:35092

References r8vec_rms().

Referenced by r8vec_rms().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_rotate()

subroutine r8vec_rotate ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  m 
)

Definition at line 35136 of file R8LIB.f90.

35137
35138!*****************************************************************************80
35139!
35140!! R8VEC_ROTATE "rotates" the entries of an R8VEC in place.
35141!
35142! Discussion:
35143!
35144! An R8VEC is a vector of R8's.
35145!
35146! This routine rotates an array of real "objects", but the same
35147! logic can be used to permute an array of objects of any arithmetic
35148! type, or an array of objects of any complexity. The only temporary
35149! storage required is enough to store a single object. The number
35150! of data movements made is N + the number of cycles of order 2 or more,
35151! which is never more than N + N/2.
35152!
35153! Example:
35154!
35155! Input:
35156!
35157! N = 5, M = 2
35158! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
35159!
35160! Output:
35161!
35162! A = ( 4.0, 5.0, 1.0, 2.0, 3.0 ).
35163!
35164! Licensing:
35165!
35166! This code is distributed under the GNU LGPL license.
35167!
35168! Modified:
35169!
35170! 20 March 2001
35171!
35172! Author:
35173!
35174! John Burkardt
35175!
35176! Parameters:
35177!
35178! Input, integer ( kind = 4 ) N, the number of objects.
35179!
35180! Input, integer ( kind = 4 ) M, the number of positions to the right that
35181! each element should be moved. Elements that shift pass position
35182! N "wrap around" to the beginning of the array.
35183!
35184! Input/output, real ( kind = 8 ) A(N), the array to be rotated.
35185!
35186 implicit none
35187
35188 integer ( kind = 4 ) n
35189
35190 real ( kind = 8 ) a(n)
35191 integer ( kind = 4 ) i4_modp
35192 integer ( kind = 4 ) iget
35193 integer ( kind = 4 ) iput
35194 integer ( kind = 4 ) istart
35195 integer ( kind = 4 ) m
35196 integer ( kind = 4 ) mcopy
35197 integer ( kind = 4 ) nset
35198 real ( kind = 8 ) temp
35199!
35200! Force M to be positive, between 0 and N-1.
35201!
35202 mcopy = i4_modp( m, n )
35203
35204 if ( mcopy == 0 ) then
35205 return
35206 end if
35207
35208 istart = 0
35209 nset = 0
35210
35211 do
35212
35213 istart = istart + 1
35214
35215 if ( n < istart ) then
35216 exit
35217 end if
35218
35219 temp = a(istart)
35220 iget = istart
35221!
35222! Copy the new value into the vacated entry.
35223!
35224 do
35225
35226 iput = iget
35227
35228 iget = iget - mcopy
35229 if ( iget < 1 ) then
35230 iget = iget + n
35231 end if
35232
35233 if ( iget == istart ) then
35234 exit
35235 end if
35236
35237 a(iput) = a(iget)
35238 nset = nset + 1
35239
35240 end do
35241
35242 a(iput) = temp
35243 nset = nset + 1
35244
35245 if ( n <= nset ) then
35246 exit
35247 end if
35248
35249 end do
35250
35251 return

◆ r8vec_scalar_triple_product()

real ( kind = 8 ) function r8vec_scalar_triple_product ( real ( kind = 8 ), dimension(3)  v1,
real ( kind = 8 ), dimension(3)  v2,
real ( kind = 8 ), dimension(3)  v3 
)

Definition at line 35253 of file R8LIB.f90.

35254
35255!*****************************************************************************80
35256!
35257!! R8VEC_SCALAR_TRIPLE_PRODUCT computes the scalar triple product.
35258!
35259! Discussion:
35260!
35261! STRIPLE = V1 dot ( V2 x V3 ).
35262!
35263! STRIPLE is the volume of the parallelogram whose sides are
35264! formed by V1, V2 and V3.
35265!
35266! Licensing:
35267!
35268! This code is distributed under the GNU LGPL license.
35269!
35270! Modified:
35271!
35272! 12 December 2004
35273!
35274! Author:
35275!
35276! John Burkardt
35277!
35278! Parameters:
35279!
35280! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), the three vectors.
35281!
35282! Output, real ( kind = 8 ) R8VEC_SCALAR_TRIPLE_PRODUCT, the scalar
35283! triple product.
35284!
35285 implicit none
35286
35287 real ( kind = 8 ) r8vec_scalar_triple_product
35288 real ( kind = 8 ) v1(3)
35289 real ( kind = 8 ) v2(3)
35290 real ( kind = 8 ) v3(3)
35291
35292 r8vec_scalar_triple_product = &
35293 v1(1) * ( v2(2) * v3(3) - v2(3) * v3(2) ) &
35294 + v1(2) * ( v2(3) * v3(1) - v2(1) * v3(3) ) &
35295 + v1(3) * ( v2(1) * v3(2) - v2(2) * v3(1) )
35296
35297 return
r8vec_scalar_triple_product
real(kind=8) function r8vec_scalar_triple_product(v1, v2, v3)
Definition R8LIB.f90:35254

References r8vec_scalar_triple_product().

Referenced by r8vec_scalar_triple_product().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_scale()

subroutine r8vec_scale ( real ( kind = 8 )  s,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 35299 of file R8LIB.f90.

35300
35301!*****************************************************************************80
35302!
35303!! R8VEC_SCALE multiplies an R8VEC by a scale factor.
35304!
35305! Discussion:
35306!
35307! An R8VEC is a vector of R8 values.
35308!
35309! Licensing:
35310!
35311! This code is distributed under the GNU LGPL license.
35312!
35313! Modified:
35314!
35315! 25 October 2013
35316!
35317! Author:
35318!
35319! John Burkardt
35320!
35321! Parameters:
35322!
35323! Input, real ( kind = 8 ) S, the scale factor.
35324!
35325! Input, integer ( kind = 4 ) N, the length of the vector.
35326!
35327! Input/output, real ( kind = 8 ) X(N), the vector to be scaled.
35328!
35329 implicit none
35330
35331 integer ( kind = 4 ) n
35332
35333 real ( kind = 8 ) s
35334 real ( kind = 8 ) x(n)
35335
35336 x(1:n) = s * x(1:n)
35337
35338 return

◆ r8vec_search_binary_a()

subroutine r8vec_search_binary_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  aval,
integer ( kind = 4 )  indx 
)

Definition at line 35340 of file R8LIB.f90.

35341
35342!*****************************************************************************80
35343!
35344!! R8VEC_SEARCH_BINARY_A searches an ascending sorted R8VEC.
35345!
35346! Discussion:
35347!
35348! An R8VEC is a vector of R8's.
35349!
35350! Binary search is used.
35351!
35352! Licensing:
35353!
35354! This code is distributed under the GNU LGPL license.
35355!
35356! Modified:
35357!
35358! 24 July 2000
35359!
35360! Author:
35361!
35362! John Burkardt
35363!
35364! Reference:
35365!
35366! Donald Kreher, Douglas Simpson,
35367! Algorithm 1.9,
35368! Combinatorial Algorithms,
35369! CRC Press, 1998, page 26.
35370!
35371! Parameters:
35372!
35373! Input, integer ( kind = 4 ) N, the number of elements in the array.
35374!
35375! Input, real ( kind = 8 ) A(N), the array to be searched. The array must
35376! be sorted in ascending order.
35377!
35378! Input, real ( kind = 8 ) AVAL, the value to be searched for.
35379!
35380! Output, integer ( kind = 4 ) INDX, the result of the search.
35381! -1, AVAL does not occur in the array.
35382! I, A(I) = AVAL.
35383!
35384 implicit none
35385
35386 integer ( kind = 4 ) n
35387
35388 real ( kind = 8 ) a(n)
35389 real ( kind = 8 ) aval
35390 integer ( kind = 4 ) high
35391 integer ( kind = 4 ) indx
35392 integer ( kind = 4 ) low
35393 integer ( kind = 4 ) mid
35394
35395 indx = -1
35396
35397 low = 1
35398 high = n
35399
35400 do while ( low <= high )
35401
35402 mid = ( low + high ) / 2
35403
35404 if ( a(mid) == aval ) then
35405 indx = mid
35406 exit
35407 else if ( a(mid) < aval ) then
35408 low = mid + 1
35409 else if ( aval < a(mid) ) then
35410 high = mid - 1
35411 end if
35412
35413 end do
35414
35415 return

◆ r8vec_shift()

subroutine r8vec_shift ( integer ( kind = 4 )  shift,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 35417 of file R8LIB.f90.

35418
35419!*****************************************************************************80
35420!
35421!! R8VEC_SHIFT performs a shift on an R8VEC.
35422!
35423! Discussion:
35424!
35425! An R8VEC is a vector of R8 values.
35426!
35427! Licensing:
35428!
35429! This code is distributed under the GNU LGPL license.
35430!
35431! Modified:
35432!
35433! 11 March 2011
35434!
35435! Author:
35436!
35437! John Burkardt
35438!
35439! Parameters:
35440!
35441! Input, integer ( kind = 4 ) SHIFT, the amount by which each entry is to
35442! be shifted.
35443!
35444! Input, integer ( kind = 4 ) N, the length of the vector.
35445!
35446! Input/output, real ( kind = 8 ) X(N), the vector to be shifted.
35447!
35448 implicit none
35449
35450 integer ( kind = 4 ) n
35451
35452 integer ( kind = 4 ) ihi
35453 integer ( kind = 4 ) ilo
35454 integer ( kind = 4 ) shift
35455 real ( kind = 8 ) x(n)
35456 real ( kind = 8 ) y(n)
35457
35458 y(1:n) = x(1:n)
35459
35460 x(1:n) = 0.0d+00
35461
35462 ilo = max( 1, 1 + shift )
35463 ihi = min( n, n + shift )
35464
35465 x(ilo:ihi) = y(ilo-shift:ihi-shift)
35466
35467 return

◆ r8vec_shift_circular()

subroutine r8vec_shift_circular ( integer ( kind = 4 )  shift,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x 
)

Definition at line 35469 of file R8LIB.f90.

35470
35471!*****************************************************************************80
35472!
35473!! R8VEC_SHIFT_CIRCULAR performs a circular shift on an R8VEC.
35474!
35475! Discussion:
35476!
35477! An R8VEC is a vector of R8 values.
35478!
35479! Licensing:
35480!
35481! This code is distributed under the GNU LGPL license.
35482!
35483! Modified:
35484!
35485! 11 March 2011
35486!
35487! Author:
35488!
35489! John Burkardt
35490!
35491! Parameters:
35492!
35493! Input, integer ( kind = 4 ) SHIFT, the amount by which each entry is to
35494! be shifted.
35495!
35496! Input, integer ( kind = 4 ) N, the length of the vector.
35497!
35498! Input/output, real ( kind = 8 ) X(N), the vector to be shifted.
35499!
35500 implicit none
35501
35502 integer ( kind = 4 ) n
35503
35504 integer ( kind = 4 ) i
35505 integer ( kind = 4 ) i4_wrap
35506 integer ( kind = 4 ) j
35507 integer ( kind = 4 ) shift
35508 real ( kind = 8 ) x(n)
35509 real ( kind = 8 ) y(n)
35510
35511 y(1:n) = x(1:n)
35512
35513 do i = 1, n
35514 j = i4_wrap( i - shift, 1, n )
35515 x(i) = y(j)
35516 end do
35517
35518 return

◆ r8vec_sort2_a()

subroutine r8vec_sort2_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  y 
)

Definition at line 36629 of file R8LIB.f90.

36630
36631!*****************************************************************************80
36632!
36633!! R8VEC_SORT2_A ascending sorts an R8VEC and adjusts an associated R8VEC.
36634!
36635! Discussion:
36636!
36637! An R8VEC is a vector of R8's.
36638!
36639! The routine sorts the elements of X, and whenever
36640! an element of X is moved, the corresponding element of
36641! Y is moved in the same way. This action means that after
36642! the sorting, every element of X is still paired to the
36643! same Y value.
36644!
36645! If you have more than one array associated with X, or
36646! an integer array, or some other complication, you may want to
36647! look at doing an "indexed sort" instead.
36648!
36649! Licensing:
36650!
36651! This code is distributed under the GNU LGPL license.
36652!
36653! Modified:
36654!
36655! 27 June 2000
36656!
36657! Author:
36658!
36659! John Burkardt
36660!
36661! Parameters:
36662!
36663! Input, integer ( kind = 4 ) N, length of input array.
36664!
36665! Input/output, real ( kind = 8 ) X(N). On input, an unsorted array.
36666! On output, X has been sorted.
36667!
36668! Input/output, real ( kind = 8 ) Y(N), an array which is to be
36669! shifted corresponding to the shifts made in X.
36670!
36671 implicit none
36672
36673 integer ( kind = 4 ) n
36674
36675 integer ( kind = 4 ) i
36676 integer ( kind = 4 ) indx
36677 integer ( kind = 4 ) isgn
36678 integer ( kind = 4 ) j
36679 real ( kind = 8 ) x(n)
36680 real ( kind = 8 ) y(n)
36681
36682 if ( n <= 1 ) then
36683 return
36684 end if
36685
36686 i = 0
36687 indx = 0
36688 isgn = 0
36689 j = 0
36690
36691 do
36692
36693 call sort_heap_external ( n, indx, i, j, isgn )
36694
36695 if ( 0 < indx ) then
36696
36697 call r8_swap ( x(i), x(j) )
36698 call r8_swap ( y(i), y(j) )
36699
36700 else if ( indx < 0 ) then
36701
36702 if ( x(i) <= x(j) ) then
36703 isgn = -1
36704 else
36705 isgn = + 1
36706 end if
36707
36708 else if ( indx == 0 ) then
36709
36710 exit
36711
36712 end if
36713
36714 end do
36715
36716 return

References r8_swap(), and sort_heap_external().

Here is the call graph for this function:

◆ r8vec_sort_bubble_a()

subroutine r8vec_sort_bubble_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35520 of file R8LIB.f90.

35521
35522!*****************************************************************************80
35523!
35524!! R8VEC_SORT_BUBBLE_A ascending sorts an R8VEC using bubble sort.
35525!
35526! Discussion:
35527!
35528! An R8VEC is a vector of R8's.
35529!
35530! Bubble sort is simple to program, but inefficient. It should not
35531! be used for large arrays.
35532!
35533! Licensing:
35534!
35535! This code is distributed under the GNU LGPL license.
35536!
35537! Modified:
35538!
35539! 01 February 2001
35540!
35541! Author:
35542!
35543! John Burkardt
35544!
35545! Parameters:
35546!
35547! Input, integer ( kind = 4 ) N, the number of entries in the array.
35548!
35549! Input/output, real ( kind = 8 ) A(N).
35550! On input, an unsorted array.
35551! On output, the array has been sorted.
35552!
35553 implicit none
35554
35555 integer ( kind = 4 ) n
35556
35557 real ( kind = 8 ) a(n)
35558 integer ( kind = 4 ) i
35559 integer ( kind = 4 ) j
35560 real ( kind = 8 ) t
35561
35562 do i = 1, n - 1
35563 do j = i + 1, n
35564 if ( a(j) < a(i) ) then
35565 t = a(i)
35566 a(i) = a(j)
35567 a(j) = t
35568 end if
35569 end do
35570 end do
35571
35572 return

◆ r8vec_sort_bubble_d()

subroutine r8vec_sort_bubble_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35574 of file R8LIB.f90.

35575
35576!*****************************************************************************80
35577!
35578!! R8VEC_SORT_BUBBLE_D descending sorts an R8VEC using bubble sort.
35579!
35580! Discussion:
35581!
35582! An R8VEC is a vector of R8's.
35583!
35584! Bubble sort is simple to program, but inefficient. It should not
35585! be used for large arrays.
35586!
35587! Licensing:
35588!
35589! This code is distributed under the GNU LGPL license.
35590!
35591! Modified:
35592!
35593! 31 January 2003
35594!
35595! Author:
35596!
35597! John Burkardt
35598!
35599! Parameters:
35600!
35601! Input, integer ( kind = 4 ) N, the number of entries in the array.
35602!
35603! Input/output, real ( kind = 8 ) A(N).
35604! On input, an unsorted array.
35605! On output, the array has been sorted.
35606!
35607 implicit none
35608
35609 integer ( kind = 4 ) n
35610
35611 real ( kind = 8 ) a(n)
35612 integer ( kind = 4 ) i
35613 integer ( kind = 4 ) j
35614 real ( kind = 8 ) t
35615
35616 do i = 1, n - 1
35617 do j = i + 1, n
35618 if ( a(i) < a(j) ) then
35619 t = a(i)
35620 a(i) = a(j)
35621 a(j) = t
35622 end if
35623 end do
35624 end do
35625
35626 return

◆ r8vec_sort_heap_a()

subroutine r8vec_sort_heap_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35628 of file R8LIB.f90.

35629
35630!*****************************************************************************80
35631!
35632!! R8VEC_SORT_HEAP_A ascending sorts an R8VEC using heap sort.
35633!
35634! Discussion:
35635!
35636! An R8VEC is a vector of R8's.
35637!
35638! Licensing:
35639!
35640! This code is distributed under the GNU LGPL license.
35641!
35642! Modified:
35643!
35644! 07 July 2003
35645!
35646! Author:
35647!
35648! John Burkardt
35649!
35650! Reference:
35651!
35652! Albert Nijenhuis, Herbert Wilf,
35653! Combinatorial Algorithms for Computers and Calculators,
35654! Academic Press, 1978,
35655! ISBN: 0-12-519260-6,
35656! LC: QA164.N54.
35657!
35658! Parameters:
35659!
35660! Input, integer ( kind = 4 ) N, the number of entries in the array.
35661!
35662! Input/output, real ( kind = 8 ) A(N).
35663! On input, the array to be sorted;
35664! On output, the array has been sorted.
35665!
35666 implicit none
35667
35668 integer ( kind = 4 ) n
35669
35670 real ( kind = 8 ) a(n)
35671 integer ( kind = 4 ) n1
35672 real ( kind = 8 ) temp
35673
35674 if ( n <= 1 ) then
35675 return
35676 end if
35677!
35678! 1: Put A into descending heap form.
35679!
35680 call r8vec_heap_d ( n, a )
35681!
35682! 2: Sort A.
35683!
35684! The largest object in the heap is in A(1).
35685! Move it to position A(N).
35686!
35687 temp = a(1)
35688 a(1) = a(n)
35689 a(n) = temp
35690!
35691! Consider the diminished heap of size N1.
35692!
35693 do n1 = n - 1, 2, -1
35694!
35695! Restore the heap structure of A(1) through A(N1).
35696!
35697 call r8vec_heap_d ( n1, a )
35698!
35699! Take the largest object from A(1) and move it to A(N1).
35700!
35701 temp = a(1)
35702 a(1) = a(n1)
35703 a(n1) = temp
35704
35705 end do
35706
35707 return
r8vec_heap_d
subroutine r8vec_heap_d(n, a)
Definition R8LIB.f90:30136

References r8vec_heap_d().

Here is the call graph for this function:

◆ r8vec_sort_heap_d()

subroutine r8vec_sort_heap_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 35709 of file R8LIB.f90.

35710
35711!*****************************************************************************80
35712!
35713!! R8VEC_SORT_HEAP_D descending sorts an R8VEC using heap sort.
35714!
35715! Discussion:
35716!
35717! An R8VEC is a vector of R8's.
35718!
35719! Licensing:
35720!
35721! This code is distributed under the GNU LGPL license.
35722!
35723! Modified:
35724!
35725! 07 July 2003
35726!
35727! Author:
35728!
35729! John Burkardt
35730!
35731! Reference:
35732!
35733! Albert Nijenhuis, Herbert Wilf,
35734! Combinatorial Algorithms for Computers and Calculators,
35735! Academic Press, 1978,
35736! ISBN: 0-12-519260-6,
35737! LC: QA164.N54.
35738!
35739! Parameters:
35740!
35741! Input, integer ( kind = 4 ) N, the number of entries in the array.
35742!
35743! Input/output, real ( kind = 8 ) A(N).
35744! On input, the array to be sorted;
35745! On output, the array has been sorted.
35746!
35747 implicit none
35748
35749 integer ( kind = 4 ) n
35750
35751 real ( kind = 8 ) a(n)
35752 integer ( kind = 4 ) n1
35753
35754 if ( n <= 1 ) then
35755 return
35756 end if
35757!
35758! 1: Put A into ascending heap form.
35759!
35760 call r8vec_heap_a ( n, a )
35761!
35762! 2: Sort A.
35763!
35764! The smallest object in the heap is in A(1).
35765! Move it to position A(N).
35766!
35767 call r8_swap ( a(1), a(n) )
35768!
35769! Consider the diminished heap of size N1.
35770!
35771 do n1 = n - 1, 2, -1
35772!
35773! Restore the heap structure of A(1) through A(N1).
35774!
35775 call r8vec_heap_a ( n1, a )
35776!
35777! Take the smallest object from A(1) and move it to A(N1).
35778!
35779 call r8_swap ( a(1), a(n1) )
35780
35781 end do
35782
35783 return
r8vec_heap_a
subroutine r8vec_heap_a(n, a)
Definition R8LIB.f90:30019

References r8_swap(), and r8vec_heap_a().

Referenced by r8vec_heap_d_extract().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_sort_heap_index_a()

subroutine r8vec_sort_heap_index_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 35785 of file R8LIB.f90.

35786
35787!*****************************************************************************80
35788!
35789!! R8VEC_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8VEC.
35790!
35791! Discussion:
35792!
35793! An R8VEC is a vector of R8's.
35794!
35795! The sorting is not actually carried out. Rather an index array is
35796! created which defines the sorting. This array may be used to sort
35797! or index the array, or to sort or index related arrays keyed on the
35798! original array.
35799!
35800! Once the index array is computed, the sorting can be carried out
35801! "implicitly:
35802!
35803! A(INDX(I:N)) is sorted,
35804!
35805! or explicitly, by the call
35806!
35807! call r8vec_permute ( n, indx, a )
35808!
35809! after which A(1:N) is sorted.
35810!
35811! Licensing:
35812!
35813! This code is distributed under the GNU LGPL license.
35814!
35815! Modified:
35816!
35817! 30 March 2004
35818!
35819! Author:
35820!
35821! John Burkardt
35822!
35823! Parameters:
35824!
35825! Input, integer ( kind = 4 ) N, the number of entries in the array.
35826!
35827! Input, real ( kind = 8 ) A(N), an array to be index-sorted.
35828!
35829! Output, integer ( kind = 4 ) INDX(N), the sort index. The
35830! I-th element of the sorted array is A(INDX(I)).
35831!
35832 implicit none
35833
35834 integer ( kind = 4 ) n
35835
35836 real ( kind = 8 ) a(n)
35837 real ( kind = 8 ) aval
35838 integer ( kind = 4 ) i
35839 integer ( kind = 4 ) indx(n)
35840 integer ( kind = 4 ) indxt
35841 integer ( kind = 4 ) ir
35842 integer ( kind = 4 ) j
35843 integer ( kind = 4 ) l
35844
35845 if ( n < 1 ) then
35846 return
35847 end if
35848
35849 do i = 1, n
35850 indx(i) = i
35851 end do
35852
35853 if ( n == 1 ) then
35854 return
35855 end if
35856
35857 l = n / 2 + 1
35858 ir = n
35859
35860 do
35861
35862 if ( 1 < l ) then
35863
35864 l = l - 1
35865 indxt = indx(l)
35866 aval = a(indxt)
35867
35868 else
35869
35870 indxt = indx(ir)
35871 aval = a(indxt)
35872 indx(ir) = indx(1)
35873 ir = ir - 1
35874
35875 if ( ir == 1 ) then
35876 indx(1) = indxt
35877 exit
35878 end if
35879
35880 end if
35881
35882 i = l
35883 j = l + l
35884
35885 do while ( j <= ir )
35886
35887 if ( j < ir ) then
35888 if ( a(indx(j)) < a(indx(j+1)) ) then
35889 j = j + 1
35890 end if
35891 end if
35892
35893 if ( aval < a(indx(j)) ) then
35894 indx(i) = indx(j)
35895 i = j
35896 j = j + j
35897 else
35898 j = ir + 1
35899 end if
35900
35901 end do
35902
35903 indx(i) = indxt
35904
35905 end do
35906
35907 return

Referenced by r8vec_undex().

Here is the caller graph for this function:

◆ r8vec_sort_heap_index_d()

subroutine r8vec_sort_heap_index_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 35909 of file R8LIB.f90.

35910
35911!*****************************************************************************80
35912!
35913!! R8VEC_SORT_HEAP_INDEX_D does an indexed heap descending sort of an R8VEC.
35914!
35915! Discussion:
35916!
35917! An R8VEC is a vector of R8's.
35918!
35919! The sorting is not actually carried out. Rather an index array is
35920! created which defines the sorting. This array may be used to sort
35921! or index the array, or to sort or index related arrays keyed on the
35922! original array.
35923!
35924! Once the index array is computed, the sorting can be carried out
35925! "implicitly:
35926!
35927! A(INDX(1:N)) is sorted,
35928!
35929! or explicitly, by the call
35930!
35931! call r8vec_permute ( n, indx, a )
35932!
35933! after which A(1:N) is sorted.
35934!
35935! Licensing:
35936!
35937! This code is distributed under the GNU LGPL license.
35938!
35939! Modified:
35940!
35941! 21 July 2000
35942!
35943! Author:
35944!
35945! John Burkardt
35946!
35947! Parameters:
35948!
35949! Input, integer ( kind = 4 ) N, the number of entries in the array.
35950!
35951! Input, real ( kind = 8 ) A(N), an array to be index-sorted.
35952!
35953! Output, integer ( kind = 4 ) INDX(N), the sort index. The
35954! I-th element of the sorted array is A(INDX(I)).
35955!
35956 implicit none
35957
35958 integer ( kind = 4 ) n
35959
35960 real ( kind = 8 ) a(n)
35961 real ( kind = 8 ) aval
35962 integer ( kind = 4 ) i
35963 integer ( kind = 4 ) indx(n)
35964 integer ( kind = 4 ) indxt
35965 integer ( kind = 4 ) ir
35966 integer ( kind = 4 ) j
35967 integer ( kind = 4 ) l
35968
35969 if ( n < 1 ) then
35970 return
35971 end if
35972
35973 do i = 1, n
35974 indx(i) = i
35975 end do
35976
35977 if ( n == 1 ) then
35978 return
35979 end if
35980
35981 l = n / 2 + 1
35982 ir = n
35983
35984 do
35985
35986 if ( 1 < l ) then
35987
35988 l = l - 1
35989 indxt = indx(l)
35990 aval = a(indxt)
35991
35992 else
35993
35994 indxt = indx(ir)
35995 aval = a(indxt)
35996 indx(ir) = indx(1)
35997 ir = ir - 1
35998
35999 if ( ir == 1 ) then
36000 indx(1) = indxt
36001 exit
36002 end if
36003
36004 end if
36005
36006 i = l
36007 j = l + l
36008
36009 do while ( j <= ir )
36010
36011 if ( j < ir ) then
36012 if ( a(indx(j+1)) < a(indx(j)) ) then
36013 j = j + 1
36014 end if
36015 end if
36016
36017 if ( a(indx(j)) < aval ) then
36018 indx(i) = indx(j)
36019 i = j
36020 j = j + j
36021 else
36022 j = ir + 1
36023 end if
36024
36025 end do
36026
36027 indx(i) = indxt
36028
36029 end do
36030
36031 return

◆ r8vec_sort_heap_mask_a()

subroutine r8vec_sort_heap_mask_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  mask_num,
integer ( kind = 4 ), dimension(mask_num)  mask,
integer ( kind = 4 ), dimension(mask_num)  indx 
)

Definition at line 36033 of file R8LIB.f90.

36034
36035!*****************************************************************************80
36036!
36037!! R8VEC_SORT_HEAP_MASK_A: indexed heap ascending sort of a masked R8VEC.
36038!
36039! Discussion:
36040!
36041! An R8VEC is a vector of R8's.
36042!
36043! An array A is given. An array MASK of indices into A is given.
36044! The routine produces a vector INDX, which is a permutation of the
36045! entries of MASK, so that:
36046!
36047! A(MASK(INDX(I)) <= A(MASK(INDX(J))
36048!
36049! whenever
36050!
36051! I <= J
36052!
36053! In other words, only the elements of A that are indexed by MASK
36054! are to be considered, and the only thing that happens is that
36055! a rearrangment of the indices in MASK is returned that orders the
36056! masked elements.
36057!
36058! Licensing:
36059!
36060! This code is distributed under the GNU LGPL license.
36061!
36062! Modified:
36063!
36064! 25 September 2001
36065!
36066! Author:
36067!
36068! John Burkardt
36069!
36070! Parameters:
36071!
36072! Input, integer ( kind = 4 ) N, the number of entries in the array.
36073!
36074! Input, real ( kind = 8 ) A(N), an array to be index-sorted.
36075!
36076! Input, integer ( kind = 4 ) MASK_NUM, the number of mask elements.
36077!
36078! Input, integer ( kind = 4 ) MASK(MASK_NUM), the mask array. This is
36079! simply a list of indices of A. The entries of MASK should
36080! be unique, and each one should be between 1 and N.
36081!
36082! Output, integer ( kind = 4 ) INDX(MASK_NUM), the sort index. There are
36083! MASK_NUM elements of A selected by MASK. If we want to list those
36084! elements in order, then the I-th element is A(MASK(INDX(I))).
36085!
36086 implicit none
36087
36088 integer ( kind = 4 ) mask_num
36089 integer ( kind = 4 ) n
36090
36091 real ( kind = 8 ) a(n)
36092 real ( kind = 8 ) aval
36093 integer ( kind = 4 ) i
36094 integer ( kind = 4 ) indx(mask_num)
36095 integer ( kind = 4 ) indxt
36096 integer ( kind = 4 ) ir
36097 integer ( kind = 4 ) j
36098 integer ( kind = 4 ) l
36099 integer ( kind = 4 ) mask(mask_num)
36100
36101 if ( n < 1 ) then
36102 return
36103 end if
36104
36105 if ( mask_num < 1 ) then
36106 return
36107 end if
36108
36109 if ( mask_num == 1 ) then
36110 indx(1) = 1
36111 return
36112 end if
36113
36114 call i4vec_indicator1 ( mask_num, indx )
36115
36116 l = mask_num / 2 + 1
36117 ir = mask_num
36118
36119 do
36120
36121 if ( 1 < l ) then
36122
36123 l = l - 1
36124 indxt = indx(l)
36125 aval = a(mask(indxt))
36126
36127 else
36128
36129 indxt = indx(ir)
36130 aval = a(mask(indxt))
36131 indx(ir) = indx(1)
36132 ir = ir - 1
36133
36134 if ( ir == 1 ) then
36135 indx(1) = indxt
36136 exit
36137 end if
36138
36139 end if
36140
36141 i = l
36142 j = l + l
36143
36144 do while ( j <= ir )
36145
36146 if ( j < ir ) then
36147 if ( a(mask(indx(j))) < a(mask(indx(j+1))) ) then
36148 j = j + 1
36149 end if
36150 end if
36151
36152 if ( aval < a(mask(indx(j))) ) then
36153 indx(i) = indx(j)
36154 i = j
36155 j = j + j
36156 else
36157 j = ir + 1
36158 end if
36159
36160 end do
36161
36162 indx(i) = indxt
36163
36164 end do
36165
36166 return

References i4vec_indicator1().

Here is the call graph for this function:

◆ r8vec_sort_insert_a()

subroutine r8vec_sort_insert_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 36168 of file R8LIB.f90.

36169
36170!*****************************************************************************80
36171!
36172!! R8VEC_SORT_INSERT_A ascending sorts an R8VEC using an insertion sort.
36173!
36174! Discussion:
36175!
36176! An R8VEC is a vector of R8's.
36177!
36178! Licensing:
36179!
36180! This code is distributed under the GNU LGPL license.
36181!
36182! Modified:
36183!
36184! 24 July 2000
36185!
36186! Author:
36187!
36188! John Burkardt
36189!
36190! Reference:
36191!
36192! Donald Kreher, Douglas Simpson,
36193! Algorithm 1.1,
36194! Combinatorial Algorithms,
36195! CRC Press, 1998, page 11.
36196!
36197! Parameters:
36198!
36199! Input, integer ( kind = 4 ) N, the number of items in the vector.
36200! N must be positive.
36201!
36202! Input/output, real ( kind = 8 ) A(N).
36203! On input, the array to be sorted;
36204! On output, the array has been sorted.
36205!
36206 implicit none
36207
36208 integer ( kind = 4 ) n
36209
36210 real ( kind = 8 ) a(n)
36211 integer ( kind = 4 ) i
36212 integer ( kind = 4 ) j
36213 real ( kind = 8 ) x
36214
36215 do i = 2, n
36216
36217 x = a(i)
36218
36219 j = i - 1
36220
36221 do while ( 1 <= j )
36222
36223 if ( a(j) <= x ) then
36224 exit
36225 end if
36226
36227 a(j+1) = a(j)
36228 j = j - 1
36229
36230 end do
36231
36232 a(j+1) = x
36233
36234 end do
36235
36236 return

◆ r8vec_sort_insert_index_a()

subroutine r8vec_sort_insert_index_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 36238 of file R8LIB.f90.

36239
36240!*****************************************************************************80
36241!
36242!! R8VEC_SORT_INSERT_INDEX_A ascending index sorts an R8VEC using insertion.
36243!
36244! Discussion:
36245!
36246! An R8VEC is a vector of R8's.
36247!
36248! Licensing:
36249!
36250! This code is distributed under the GNU LGPL license.
36251!
36252! Modified:
36253!
36254! 06 February 2001
36255!
36256! Author:
36257!
36258! John Burkardt
36259!
36260! Reference:
36261!
36262! Donald Kreher, Douglas Simpson,
36263! Algorithm 1.1,
36264! Combinatorial Algorithms,
36265! CRC Press, 1998, page 11.
36266!
36267! Parameters:
36268!
36269! Input, integer ( kind = 4 ) N, the number of items in the vector.
36270! N must be positive.
36271!
36272! Input, real ( kind = 8 ) A(N), the array to be sorted.
36273!
36274! Output, integer ( kind = 4 ) INDX(N), the sorted indices. The array
36275! is sorted when listed from A(INDX(1)) through A(INDX(N)).
36276!
36277 implicit none
36278
36279 integer ( kind = 4 ) n
36280
36281 real ( kind = 8 ) a(n)
36282 integer ( kind = 4 ) i
36283 integer ( kind = 4 ) indx(n)
36284 integer ( kind = 4 ) j
36285 real ( kind = 8 ) x
36286
36287 if ( n < 1 ) then
36288 return
36289 end if
36290
36291 do i = 1, n
36292 indx(i) = i
36293 end do
36294
36295 do i = 2, n
36296
36297 x = a(i)
36298
36299 j = i - 1
36300
36301 do while ( 1 <= j )
36302
36303 if ( a(indx(j)) <= x ) then
36304 exit
36305 end if
36306
36307 indx(j+1) = indx(j)
36308 j = j - 1
36309
36310 end do
36311
36312 indx(j+1) = i
36313
36314 end do
36315
36316 return

◆ r8vec_sort_insert_index_d()

subroutine r8vec_sort_insert_index_d ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 ), dimension(n)  indx 
)

Definition at line 36318 of file R8LIB.f90.

36319
36320!*****************************************************************************80
36321!
36322!! R8VEC_SORT_INSERT_INDEX_D descending index sorts an R8VEC using insertion.
36323!
36324! Discussion:
36325!
36326! An R8VEC is a vector of R8's.
36327!
36328! Licensing:
36329!
36330! This code is distributed under the GNU LGPL license.
36331!
36332! Modified:
36333!
36334! 07 February 2001
36335!
36336! Author:
36337!
36338! John Burkardt
36339!
36340! Reference:
36341!
36342! Donald Kreher, Douglas Simpson,
36343! Algorithm 1.1,
36344! Combinatorial Algorithms,
36345! CRC Press, 1998, page 11.
36346!
36347! Parameters:
36348!
36349! Input, integer ( kind = 4 ) N, the number of items in the vector.
36350! N must be positive.
36351!
36352! Input, real ( kind = 8 ) A(N), the array to be sorted.
36353!
36354! Output, integer ( kind = 4 ) INDX(N), the sorted indices. The array
36355! is sorted when listed from A(INDX(1)) through A(INDX(N)).
36356!
36357 implicit none
36358
36359 integer ( kind = 4 ) n
36360
36361 real ( kind = 8 ) a(n)
36362 integer ( kind = 4 ) i
36363 integer ( kind = 4 ) indx(n)
36364 integer ( kind = 4 ) j
36365 real ( kind = 8 ) x
36366
36367 if ( n < 1 ) then
36368 return
36369 end if
36370
36371 do i = 1, n
36372 indx(i) = i
36373 end do
36374
36375 do i = 2, n
36376
36377 x = a(i)
36378
36379 j = i - 1
36380
36381 do while ( 1 <= j )
36382
36383 if ( x <= a(indx(j)) ) then
36384 exit
36385 end if
36386
36387 indx(j+1) = indx(j)
36388 j = j - 1
36389
36390 end do
36391
36392 indx(j+1) = i
36393
36394 end do
36395
36396 return

◆ r8vec_sort_quick_a()

subroutine r8vec_sort_quick_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 36398 of file R8LIB.f90.

36399
36400!*****************************************************************************80
36401!
36402!! R8VEC_SORT_QUICK_A ascending sorts an R8VEC using quick sort.
36403!
36404! Discussion:
36405!
36406! An R8VEC is a vector of R8's.
36407!
36408! Example:
36409!
36410! Input:
36411!
36412! N = 7
36413! A = ( 6, 7, 3, 2, 9, 1, 8 )
36414!
36415! Output:
36416!
36417! A = ( 1, 2, 3, 6, 7, 8, 9 )
36418!
36419! Licensing:
36420!
36421! This code is distributed under the GNU LGPL license.
36422!
36423! Modified:
36424!
36425! 08 December 2004
36426!
36427! Author:
36428!
36429! John Burkardt
36430!
36431! Parameters:
36432!
36433! Input, integer ( kind = 4 ) N, the number of entries in the array.
36434!
36435! Input/output, real ( kind = 8 ) A(N).
36436! On input, the array to be sorted.
36437! On output, the array has been sorted.
36438!
36439 implicit none
36440
36441 integer ( kind = 4 ), parameter :: level_max = 30
36442 integer ( kind = 4 ) n
36443
36444 real ( kind = 8 ) a(n)
36445 integer ( kind = 4 ) base
36446 integer ( kind = 4 ) l_segment
36447 integer ( kind = 4 ) level
36448 integer ( kind = 4 ) n_segment
36449 integer ( kind = 4 ) rsave(level_max)
36450 integer ( kind = 4 ) r_segment
36451
36452 if ( n < 1 ) then
36453 write ( *, '(a)' ) ' '
36454 write ( *, '(a)' ) 'R8VEC_SORT_QUICK_A - Fatal error!'
36455 write ( *, '(a)' ) ' N < 1.'
36456 stop 1
36457 end if
36458
36459 if ( n == 1 ) then
36460 return
36461 end if
36462
36463 level = 1
36464 rsave(level) = n + 1
36465 base = 1
36466 n_segment = n
36467
36468 do
36469!
36470! Partition the segment.
36471!
36472 call r8vec_part_quick_a ( n_segment, a(base), l_segment, r_segment )
36473!
36474! If the left segment has more than one element, we need to partition it.
36475!
36476 if ( 1 < l_segment ) then
36477
36478 if ( level_max < level ) then
36479 write ( *, '(a)' ) ' '
36480 write ( *, '(a)' ) 'R8VEC_SORT_QUICK_A - Fatal error!'
36481 write ( *, '(a,i8)' ) ' Exceeding recursion maximum of ', level_max
36482 stop 1
36483 end if
36484
36485 level = level + 1
36486 n_segment = l_segment
36487 rsave(level) = r_segment + base - 1
36488!
36489! The left segment and the middle segment are sorted.
36490! Must the right segment be partitioned?
36491!
36492 else if ( r_segment < n_segment ) then
36493
36494 n_segment = n_segment + 1 - r_segment
36495 base = base + r_segment - 1
36496!
36497! Otherwise, we back up a level if there is an earlier one.
36498!
36499 else
36500
36501 do
36502
36503 if ( level <= 1 ) then
36504 return
36505 end if
36506
36507 base = rsave(level)
36508 n_segment = rsave(level-1) - rsave(level)
36509 level = level - 1
36510
36511 if ( 0 < n_segment ) then
36512 exit
36513 end if
36514
36515 end do
36516
36517 end if
36518
36519 end do
36520
36521 return
r8vec_part_quick_a
subroutine r8vec_part_quick_a(n, a, l, r)
Definition R8LIB.f90:34093

References r8vec_part_quick_a().

Here is the call graph for this function:

◆ r8vec_sort_shell_a()

subroutine r8vec_sort_shell_a ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 36523 of file R8LIB.f90.

36524
36525!*****************************************************************************80
36526!
36527!! R8VEC_SORT_SHELL_A ascending sorts an R8VEC using Shell's sort.
36528!
36529! Discussion:
36530!
36531! An R8VEC is a vector of R8's.
36532!
36533! Licensing:
36534!
36535! This code is distributed under the GNU LGPL license.
36536!
36537! Modified:
36538!
36539! 01 February 2001
36540!
36541! Author:
36542!
36543! John Burkardt
36544!
36545! Parameters:
36546!
36547! Input, integer ( kind = 4 ) N, the number of entries in the array.
36548!
36549! Input/output, real ( kind = 8 ) A(N).
36550! On input, an array to be sorted.
36551! On output, the sorted array.
36552!
36553 implicit none
36554
36555 integer ( kind = 4 ) n
36556
36557 real ( kind = 8 ) a(n)
36558 real ( kind = 8 ) asave
36559 integer ( kind = 4 ) i
36560 integer ( kind = 4 ) ifree
36561 integer ( kind = 4 ) inc
36562 integer ( kind = 4 ) ipow
36563 integer ( kind = 4 ) j
36564 integer ( kind = 4 ) k
36565 integer ( kind = 4 ) maxpow
36566
36567 if ( n <= 1 ) then
36568 return
36569 end if
36570!
36571! Determine the smallest MAXPOW so that
36572! N <= ( 3**MAXPOW - 1 ) / 2
36573!
36574 maxpow = 1
36575
36576 do while ( 3**maxpow < 2 * n + 1 )
36577 maxpow = maxpow + 1
36578 end do
36579
36580 if ( 1 < maxpow ) then
36581 maxpow = maxpow - 1
36582 end if
36583!
36584! Now sort groups of size ( 3^IPOW - 1 ) / 2.
36585!
36586 do ipow = maxpow, 1, -1
36587
36588 inc = ( 3**ipow - 1 ) / 2
36589!
36590! Sort the values with indices equal to K mod INC.
36591!
36592 do k = 1, inc
36593!
36594! Insertion sort of the items with index
36595! INC+K, 2*INC+K, 3*INC+K, ...
36596!
36597 do i = inc+k, n, inc
36598
36599 asave = a(i)
36600 ifree = i
36601 j = i - inc
36602
36603 do
36604
36605 if ( j < 1 ) then
36606 exit
36607 end if
36608
36609 if ( a(j) <= asave ) then
36610 exit
36611 end if
36612
36613 ifree = j
36614 a(j+inc) = a(j)
36615 j = j - inc
36616
36617 end do
36618
36619 a(ifree) = asave
36620
36621 end do
36622
36623 end do
36624
36625 end do
36626
36627 return

◆ r8vec_sorted_merge_a()

subroutine r8vec_sorted_merge_a ( integer ( kind = 4 )  na,
real ( kind = 8 ), dimension(na)  a,
integer ( kind = 4 )  nb,
real ( kind = 8 ), dimension(nb)  b,
integer ( kind = 4 )  nc,
real ( kind = 8 ), dimension(na+nb)  c 
)

Definition at line 36718 of file R8LIB.f90.

36719
36720!*****************************************************************************80
36721!
36722!! R8VEC_SORTED_MERGE_A merges two ascending sorted R8VEC's.
36723!
36724! Discussion:
36725!
36726! An R8VEC is a vector of R8's.
36727!
36728! The elements of A and B should be sorted in ascending order.
36729!
36730! The elements in the output array C will also be in ascending order,
36731! and unique.
36732!
36733! The output vector C may share storage with A or B.
36734!
36735! Licensing:
36736!
36737! This code is distributed under the GNU LGPL license.
36738!
36739! Modified:
36740!
36741! 23 April 2005
36742!
36743! Author:
36744!
36745! John Burkardt
36746!
36747! Parameters:
36748!
36749! Input, integer ( kind = 4 ) NA, the dimension of A.
36750!
36751! Input, real ( kind = 8 ) A(NA), the first sorted array.
36752!
36753! Input, integer ( kind = 4 ) NB, the dimension of B.
36754!
36755! Input, real ( kind = 8 ) B(NB), the second sorted array.
36756!
36757! Output, integer ( kind = 4 ) NC, the number of elements in the output
36758! array. Note that C should usually be dimensioned at least NA+NB in the
36759! calling routine.
36760!
36761! Output, real ( kind = 8 ) C(NC), the merged unique sorted array.
36762!
36763 implicit none
36764
36765 integer ( kind = 4 ) na
36766 integer ( kind = 4 ) nb
36767
36768 real ( kind = 8 ) a(na)
36769 real ( kind = 8 ) b(nb)
36770 real ( kind = 8 ) c(na+nb)
36771 real ( kind = 8 ) d(na+nb)
36772 integer ( kind = 4 ) j
36773 integer ( kind = 4 ) ja
36774 integer ( kind = 4 ) jb
36775 integer ( kind = 4 ) na2
36776 integer ( kind = 4 ) nb2
36777 integer ( kind = 4 ) nc
36778 integer ( kind = 4 ) order
36779
36780 na2 = na
36781 nb2 = nb
36782
36783 ja = 0
36784 jb = 0
36785 nc = 0
36786
36787 call r8vec_order_type ( na2, a, order )
36788
36789 if ( order < 0 .or. 2 < order ) then
36790 write ( *, '(a)' ) ' '
36791 write ( *, '(a)' ) 'R8VEC_SORTED_MERGE_A - Fatal error!'
36792 write ( *, '(a)' ) ' The input array A is not ascending sorted!'
36793 stop 1
36794 end if
36795
36796 call r8vec_order_type ( nb2, b, order )
36797
36798 if ( order < 0 .or. 2 < order ) then
36799 write ( *, '(a)' ) ' '
36800 write ( *, '(a)' ) 'R8VEC_SORTED_MERGE_A - Fatal error!'
36801 write ( *, '(a)' ) ' The input array B is not ascending sorted!'
36802 stop 1
36803 end if
36804
36805 do
36806!
36807! If we've used up all the entries of A, stick the rest of B on the end.
36808!
36809 if ( na2 <= ja ) then
36810
36811 do j = 1, nb2 - jb
36812 jb = jb + 1
36813 if ( nc == 0 ) then
36814 nc = nc + 1
36815 d(nc) = b(jb)
36816 else if ( d(nc) < b(jb) ) then
36817 nc = nc + 1
36818 d(nc) = b(jb)
36819 end if
36820 end do
36821
36822 c(1:nc) = d(1:nc)
36823
36824 exit
36825!
36826! If we've used up all the entries of B, stick the rest of A on the end.
36827!
36828 else if ( nb2 <= jb ) then
36829
36830 do j = 1, na2 - ja
36831 ja = ja + 1
36832 if ( nc == 0 ) then
36833 nc = nc + 1
36834 d(nc) = a(ja)
36835 else if ( d(nc) < a(ja) ) then
36836 nc = nc + 1
36837 d(nc) = a(ja)
36838 end if
36839 end do
36840
36841 c(1:nc) = d(1:nc)
36842
36843 exit
36844!
36845! Otherwise, if the next entry of A is smaller, that's our candidate.
36846!
36847 else if ( a(ja+1) <= b(jb+1) ) then
36848
36849 ja = ja + 1
36850 if ( nc == 0 ) then
36851 nc = nc + 1
36852 d(nc) = a(ja)
36853 else if ( d(nc) < a(ja) ) then
36854 nc = nc + 1
36855 d(nc) = a(ja)
36856 end if
36857!
36858! ...or if the next entry of B is the smaller, consider that.
36859!
36860 else
36861
36862 jb = jb + 1
36863 if ( nc == 0 ) then
36864 nc = nc + 1
36865 d(nc) = b(jb)
36866 else if ( d(nc) < b(jb) ) then
36867 nc = nc + 1
36868 d(nc) = b(jb)
36869 end if
36870 end if
36871
36872 end do
36873
36874 return
r8vec_order_type
subroutine r8vec_order_type(n, a, order)
Definition R8LIB.f90:33968

References r8vec_order_type().

Here is the call graph for this function:

◆ r8vec_sorted_nearest()

integer ( kind = 4 ) function r8vec_sorted_nearest ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  value 
)

Definition at line 36876 of file R8LIB.f90.

36877
36878!*****************************************************************************80
36879!
36880!! R8VEC_SORTED_NEAREST returns the nearest element in a sorted R8VEC.
36881!
36882! Discussion:
36883!
36884! An R8VEC is a vector of R8's.
36885!
36886! Licensing:
36887!
36888! This code is distributed under the GNU LGPL license.
36889!
36890! Modified:
36891!
36892! 29 April 2004
36893!
36894! Author:
36895!
36896! John Burkardt
36897!
36898! Parameters:
36899!
36900! Input, integer ( kind = 4 ) N, the number of elements of A.
36901!
36902! Input, real ( kind = 8 ) A(N), a sorted vector.
36903!
36904! Input, real ( kind = 8 ) VALUE, the value whose nearest vector
36905! entry is sought.
36906!
36907! Output, integer ( kind = 4 ) R8VEC_SORTED_NEAREST, the index of the nearest
36908! entry in the vector.
36909!
36910 implicit none
36911
36912 integer ( kind = 4 ) n
36913
36914 real ( kind = 8 ) a(n)
36915 integer ( kind = 4 ) r8vec_sorted_nearest
36916 integer ( kind = 4 ) hi
36917 integer ( kind = 4 ) lo
36918 integer ( kind = 4 ) mid
36919 real ( kind = 8 ) value
36920
36921 if ( n < 1 ) then
36922 r8vec_sorted_nearest = -1
36923 return
36924 end if
36925
36926 if ( n == 1 ) then
36927 r8vec_sorted_nearest = 1
36928 return
36929 end if
36930
36931 if ( a(1) < a(n) ) then
36932
36933 if ( value < a(1) ) then
36934 r8vec_sorted_nearest = 1
36935 return
36936 else if ( a(n) < value ) then
36937 r8vec_sorted_nearest = n
36938 return
36939 end if
36940!
36941! Seek an interval containing the value.
36942!
36943 lo = 1
36944 hi = n
36945
36946 do while ( lo < hi - 1 )
36947
36948 mid = ( lo + hi ) / 2
36949
36950 if ( value == a(mid) ) then
36951 r8vec_sorted_nearest = mid
36952 return
36953 else if ( value < a(mid) ) then
36954 hi = mid
36955 else
36956 lo = mid
36957 end if
36958
36959 end do
36960!
36961! Take the nearest.
36962!
36963 if ( abs( value - a(lo) ) < abs( value - a(hi) ) ) then
36964 r8vec_sorted_nearest = lo
36965 else
36966 r8vec_sorted_nearest = hi
36967 end if
36968
36969 return
36970!
36971! A descending sorted vector A.
36972!
36973 else
36974
36975 if ( value < a(n) ) then
36976 r8vec_sorted_nearest = n
36977 return
36978 else if ( a(1) < value ) then
36979 r8vec_sorted_nearest = 1
36980 return
36981 end if
36982!
36983! Seek an interval containing the value.
36984!
36985 lo = n
36986 hi = 1
36987
36988 do while ( lo < hi - 1 )
36989
36990 mid = ( lo + hi ) / 2
36991
36992 if ( value == a(mid) ) then
36993 r8vec_sorted_nearest = mid
36994 return
36995 else if ( value < a(mid) ) then
36996 hi = mid
36997 else
36998 lo = mid
36999 end if
37000
37001 end do
37002!
37003! Take the nearest.
37004!
37005 if ( abs( value - a(lo) ) < abs( value - a(hi) ) ) then
37006 r8vec_sorted_nearest = lo
37007 else
37008 r8vec_sorted_nearest = hi
37009 end if
37010
37011 return
37012
37013 end if
37014
37015 return
r8vec_sorted_nearest
integer(kind=4) function r8vec_sorted_nearest(n, a, value)
Definition R8LIB.f90:36877

References r8vec_sorted_nearest().

Referenced by r8vec_sorted_nearest().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_sorted_range()

subroutine r8vec_sorted_range ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r,
real ( kind = 8 )  r_lo,
real ( kind = 8 )  r_hi,
integer ( kind = 4 )  i_lo,
integer ( kind = 4 )  i_hi 
)

Definition at line 37017 of file R8LIB.f90.

37018
37019!*****************************************************************************80
37020!
37021!! R8VEC_SORTED_RANGE searches a sorted vector for elements in a range.
37022!
37023! Licensing:
37024!
37025! This code is distributed under the GNU LGPL license.
37026!
37027! Modified:
37028!
37029! 24 September 2010
37030!
37031! Author:
37032!
37033! John Burkardt
37034!
37035! Parameters:
37036!
37037! Input, integer ( kind = 4 ) N, the number of items in the vector.
37038!
37039! Input, real ( kind = 8 ) R(N), the sorted vector.
37040!
37041! Input, real ( kind = 8 ) R_LO, R_HI, the limits of the range.
37042!
37043! Output, integer ( kind = 4 ) I_LO, I_HI, the range of indices
37044! so that I_LO <= I <= I_HI => R_LO <= R(I) <= R_HI. If no
37045! values in R lie in the range, then I_HI < I_LO will be returned.
37046!
37047 implicit none
37048
37049 integer ( kind = 4 ) n
37050
37051 integer ( kind = 4 ) i_hi
37052 integer ( kind = 4 ) i_lo
37053 integer ( kind = 4 ) i1
37054 integer ( kind = 4 ) i2
37055 integer ( kind = 4 ) j1
37056 integer ( kind = 4 ) j2
37057 real ( kind = 8 ) r(n)
37058 real ( kind = 8 ) r_hi
37059 real ( kind = 8 ) r_lo
37060!
37061! Cases we can handle immediately.
37062!
37063 if ( r(n) < r_lo ) then
37064 i_lo = 0
37065 i_hi = - 1
37066 return
37067 end if
37068
37069 if ( r_hi < r(1) ) then
37070 i_lo = 0
37071 i_hi = - 1
37072 return
37073 end if
37074!
37075! Are there are least two intervals?
37076!
37077 if ( n == 1 ) then
37078 if ( r_lo <= r(1) .and. r(1) <= r_hi ) then
37079 i_lo = 1
37080 i_hi = 1
37081 else
37082 i_lo = 0
37083 i_hi = -1
37084 end if
37085 return
37086 end if
37087!
37088! Bracket R_LO.
37089!
37090 if ( r_lo <= r(1) ) then
37091
37092 i_lo = 1
37093
37094 else
37095!
37096! R_LO is in one of the intervals spanned by R(J1) to R(J2).
37097! Examine the intermediate interval [R(I1), R(I1+1)].
37098! Does R_LO lie here, or below or above?
37099!
37100 j1 = 1
37101 j2 = n
37102 i1 = ( j1 + j2 - 1 ) / 2
37103 i2 = i1 + 1
37104
37105 do
37106
37107 if ( r_lo < r(i1) ) then
37108 j2 = i1
37109 i1 = ( j1 + j2 - 1 ) / 2
37110 i2 = i1 + 1
37111 else if ( r(i2) < r_lo ) then
37112 j1 = i2
37113 i1 = ( j1 + j2 - 1 ) / 2
37114 i2 = i1 + 1
37115 else
37116 i_lo = i1
37117 exit
37118 end if
37119
37120 end do
37121
37122 end if
37123!
37124! Bracket R_HI
37125!
37126 if ( r(n) <= r_hi ) then
37127
37128 i_hi = n
37129
37130 else
37131
37132 j1 = i_lo
37133 j2 = n
37134 i1 = ( j1 + j2 - 1 ) / 2
37135 i2 = i1 + 1
37136
37137 do
37138
37139 if ( r_hi < r(i1) ) then
37140 j2 = i1
37141 i1 = ( j1 + j2 - 1 ) / 2
37142 i2 = i1 + 1
37143 else if ( r(i2) < r_hi ) then
37144 j1 = i2
37145 i1 = ( j1 + j2 - 1 ) / 2
37146 i2 = i1 + 1
37147 else
37148 i_hi = i2
37149 exit
37150 end if
37151
37152 end do
37153
37154 end if
37155!
37156! We expect to have computed the largest I_LO and smallest I_HI such that
37157! R(I_LO) <= R_LO <= R_HI <= R(I_HI)
37158! but what we want is actually
37159! R_LO <= R(I_LO) <= R(I_HI) <= R_HI
37160! which we can usually get simply by incrementing I_LO and decrementing I_HI.
37161!
37162 if ( r(i_lo) < r_lo ) then
37163 i_lo = i_lo + 1
37164 if ( n < i_lo ) then
37165 i_hi = i_lo - 1
37166 end if
37167 end if
37168
37169 if ( r_hi < r(i_hi) ) then
37170 i_hi = i_hi - 1
37171 if ( i_hi < 1 ) then
37172 i_lo = i_hi + 1
37173 end if
37174 end if
37175
37176 return

◆ r8vec_sorted_split()

subroutine r8vec_sorted_split ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  split,
integer ( kind = 4 )  i_lt,
integer ( kind = 4 )  i_gt 
)

Definition at line 37178 of file R8LIB.f90.

37179
37180!*****************************************************************************80
37181!
37182!! R8VEC_SORTED_SPLIT "splits" a sorted R8VEC, given a splitting value.
37183!
37184! Discussion:
37185!
37186! An R8VEC is a vector of R8's.
37187!
37188! Given a splitting value SPLIT, the routine seeks indices
37189! I_LT and I_GT so that
37190!
37191! A(I_LT) < SPLIT < A(I_GT),
37192!
37193! and if there are intermediate index values between I_LT and
37194! I_GT, then those entries of A are exactly equal to SPLIT.
37195!
37196! Licensing:
37197!
37198! This code is distributed under the GNU LGPL license.
37199!
37200! Modified:
37201!
37202! 18 November 2000
37203!
37204! Author:
37205!
37206! John Burkardt
37207!
37208! Parameters
37209!
37210! Input, integer ( kind = 4 ) N, the number of entries in A.
37211!
37212! Input, real ( kind = 8 ) A(N), a sorted array.
37213!
37214! Input, real ( kind = 8 ) SPLIT, a value to which the entries in A are
37215! to be compared.
37216!
37217! Output, integer ( kind = 4 ) I_LT:
37218! 0 if no entries are less than SPLIT;
37219! N if all entries are less than SPLIT;
37220! otherwise, the index of the last entry in A less than SPLIT.
37221!
37222! Output, integer ( kind = 4 ) I_GT:
37223! 1 if all entries are greater than SPLIT;
37224! N+1 if no entries are greater than SPLIT;
37225! otherwise the index of the first entry in A greater than SPLIT.
37226!
37227 implicit none
37228
37229 integer ( kind = 4 ) n
37230
37231 real ( kind = 8 ) a(n)
37232 integer ( kind = 4 ) hi
37233 integer ( kind = 4 ) i
37234 integer ( kind = 4 ) i_gt
37235 integer ( kind = 4 ) i_lt
37236 integer ( kind = 4 ) lo
37237 integer ( kind = 4 ) mid
37238 real ( kind = 8 ) split
37239
37240 if ( n < 1 ) then
37241 i_lt = -1
37242 i_gt = -1
37243 return
37244 end if
37245
37246 if ( split < a(1) ) then
37247 i_lt = 0
37248 i_gt = 1
37249 return
37250 end if
37251
37252 if ( a(n) < split ) then
37253 i_lt = n
37254 i_gt = n + 1
37255 return
37256 end if
37257
37258 lo = 1
37259 hi = n
37260
37261 do
37262
37263 if ( lo + 1 == hi ) then
37264 i_lt = lo
37265 exit
37266 end if
37267
37268 mid = ( lo + hi ) / 2
37269
37270 if ( split <= a(mid) ) then
37271 hi = mid
37272 else
37273 lo = mid
37274 end if
37275
37276 end do
37277
37278 do i = i_lt + 1, n
37279 if ( split < a(i) ) then
37280 i_gt = i
37281 return
37282 end if
37283 end do
37284
37285 i_gt = n + 1
37286
37287 return

◆ r8vec_sorted_undex()

subroutine r8vec_sorted_undex ( integer ( kind = 4 )  x_num,
real ( kind = 8 ), dimension(x_num)  x_val,
integer ( kind = 4 )  x_unique_num,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(x_unique_num)  undx,
integer ( kind = 4 ), dimension(x_num)  xdnu 
)

Definition at line 37289 of file R8LIB.f90.

37290
37291!*****************************************************************************80
37292!
37293!! R8VEC_SORTED_UNDEX returns unique sorted indexes for a sorted R8VEC.
37294!
37295! Discussion:
37296!
37297! An R8VEC is a vector of R8's.
37298!
37299! The goal of this routine is to determine a vector UNDX,
37300! which points, to the unique elements of X, in sorted order,
37301! and a vector XDNU, which identifies, for each entry of X, the index of
37302! the unique sorted element of X.
37303!
37304! This is all done with index vectors, so that the elements of
37305! X are never moved.
37306!
37307! Assuming X is already sorted, we examine the entries of X in order,
37308! noting the unique entries, creating the entries of XDNU and
37309! UNDX as we go.
37310!
37311! Once this process has been completed, the vector X could be
37312! replaced by a compressed vector XU, containing the unique entries
37313! of X in sorted order, using the formula
37314!
37315! XU(I) = X(UNDX(I)).
37316!
37317! We could then, if we wished, reconstruct the entire vector X, or
37318! any element of it, by index, as follows:
37319!
37320! X(I) = XU(XDNU(I)).
37321!
37322! We could then replace X by the combination of XU and XDNU.
37323!
37324! Later, when we need the I-th entry of X, we can locate it as
37325! the XDNU(I)-th entry of XU.
37326!
37327! Here is an example of a vector X, the sort and inverse sort
37328! index vectors, and the unique sort and inverse unique sort vectors
37329! and the compressed unique sorted vector.
37330!
37331! Here is an example of a vector X, the unique sort and
37332! inverse unique sort vectors and the compressed unique sorted vector.
37333!
37334! I X XU Undx Xdnu
37335! ----+------+------+-----+-----+
37336! 1 | 11.0 | 11.0 1 1
37337! 2 | 11.0 | 22.0 5 1
37338! 3 | 11.0 | 33.0 8 1
37339! 4 | 11.0 | 55.0 9 1
37340! 5 | 22.0 | 2
37341! 6 | 22.0 | 2
37342! 7 | 22.0 | 2
37343! 8 | 33.0 | 3
37344! 9 | 55.0 |
37345!
37346! INDX(2) = 3 means that sorted item(2) is X(3).
37347! XDNI(2) = 5 means that X(2) is sorted item(5).
37348!
37349! UNDX(3) = 4 means that unique sorted item(3) is at X(4).
37350! XDNU(8) = 2 means that X(8) is at unique sorted item(2).
37351!
37352! XU(XDNU(I))) = X(I).
37353! XU(I) = X(UNDX(I)).
37354!
37355! Licensing:
37356!
37357! This code is distributed under the GNU LGPL license.
37358!
37359! Modified:
37360!
37361! 27 October 2008
37362!
37363! Author:
37364!
37365! John Burkardt
37366!
37367! Parameters:
37368!
37369! Input, integer ( kind = 4 ) X_NUM, the number of data values.
37370!
37371! Input, real ( kind = 8 ) X_VAL(X_NUM), the data values.
37372!
37373! Input, integer ( kind = 4 ) X_UNIQUE_NUM, the number of unique values
37374! in X_VAL. This value is only required for languages in which the size of
37375! UNDX must be known in advance.
37376!
37377! Input, real ( kind = 8 ) TOL, a tolerance for equality.
37378!
37379! Output, integer ( kind = 4 ) UNDX(X_UNIQUE_NUM), the UNDX vector.
37380!
37381! Output, integer ( kind = 4 ) XDNU(X_NUM), the XDNU vector.
37382!
37383 implicit none
37384
37385 integer ( kind = 4 ) x_num
37386 integer ( kind = 4 ) x_unique_num
37387
37388 integer ( kind = 4 ) i
37389 integer ( kind = 4 ) j
37390 real ( kind = 8 ) tol
37391 integer ( kind = 4 ) undx(x_unique_num)
37392 real ( kind = 8 ) x_val(x_num)
37393 integer ( kind = 4 ) xdnu(x_num)
37394!
37395! Walk through the sorted array X.
37396!
37397 i = 1
37398
37399 j = 1
37400 undx(j) = i
37401
37402 xdnu(i) = j
37403
37404 do i = 2, x_num
37405
37406 if ( tol < abs( x_val(i) - x_val(undx(j)) ) ) then
37407 j = j + 1
37408 undx(j) = i
37409 end if
37410
37411 xdnu(i) = j
37412
37413 end do
37414
37415 return

◆ r8vec_sorted_unique()

subroutine r8vec_sorted_unique ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 37417 of file R8LIB.f90.

37418
37419!*****************************************************************************80
37420!
37421!! R8VEC_SORTED_UNIQUE keeps the unique elements in a sorted R8VEC.
37422!
37423! Discussion:
37424!
37425! An R8VEC is a vector of R8's.
37426!
37427! Licensing:
37428!
37429! This code is distributed under the GNU LGPL license.
37430!
37431! Modified:
37432!
37433! 29 April 2004
37434!
37435! Author:
37436!
37437! John Burkardt
37438!
37439! Parameters:
37440!
37441! Input, integer ( kind = 4 ) N, the number of elements of A.
37442!
37443! Input/output, real ( kind = 8 ) A(N).
37444! On input, the sorted array of N elements;
37445! On output, the sorted unique array of UNIQUE_NUM elements.
37446!
37447! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
37448! Set it to 0.0 for the strictest test.
37449!
37450! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements
37451! of A.
37452!
37453 implicit none
37454
37455 integer ( kind = 4 ) n
37456
37457 real ( kind = 8 ) a(n)
37458 integer ( kind = 4 ) i
37459 integer ( kind = 4 ) unique_num
37460 real ( kind = 8 ) tol
37461
37462 if ( n <= 0 ) then
37463 unique_num = 0
37464 return
37465 end if
37466
37467 unique_num = 1
37468
37469 do i = 2, n
37470
37471 if ( tol < abs( a(i) - a(unique_num) ) ) then
37472 unique_num = unique_num + 1
37473 a(unique_num) = a(i)
37474 end if
37475
37476 end do
37477
37478 return

◆ r8vec_sorted_unique_count()

subroutine r8vec_sorted_unique_count ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 37480 of file R8LIB.f90.

37481
37482!*****************************************************************************80
37483!
37484!! R8VEC_SORTED_UNIQUE_COUNT counts the unique elements in a sorted R8VEC.
37485!
37486! Discussion:
37487!
37488! An R8VEC is a vector of R8's.
37489!
37490! Because the array is sorted, this algorithm is O(N).
37491!
37492! Licensing:
37493!
37494! This code is distributed under the GNU LGPL license.
37495!
37496! Modified:
37497!
37498! 29 April 2004
37499!
37500! Author:
37501!
37502! John Burkardt
37503!
37504! Parameters:
37505!
37506! Input, integer ( kind = 4 ) N, the number of elements of A.
37507!
37508! Input, real ( kind = 8 ) A(N), the sorted array to examine.
37509!
37510! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
37511! Set it to 0.0 for the strictest test.
37512!
37513! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements
37514! of A.
37515!
37516 implicit none
37517
37518 integer ( kind = 4 ) n
37519
37520 real ( kind = 8 ) a(n)
37521 integer ( kind = 4 ) i
37522 integer ( kind = 4 ) unique_num
37523 real ( kind = 8 ) tol
37524
37525 if ( n < 1 ) then
37526 unique_num = 0
37527 return
37528 end if
37529
37530 unique_num = 1
37531
37532 do i = 2, n
37533
37534 if ( tol < abs( a(i-1) - a(i) ) ) then
37535 unique_num = unique_num + 1
37536 end if
37537
37538 end do
37539
37540 return

◆ r8vec_sorted_unique_hist()

subroutine r8vec_sorted_unique_hist ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  maxuniq,
integer ( kind = 4 )  unique_num,
real ( kind = 8 ), dimension(maxuniq)  auniq,
integer ( kind = 4 ), dimension(maxuniq)  acount 
)

Definition at line 37542 of file R8LIB.f90.

37544
37545!*****************************************************************************80
37546!
37547!! R8VEC_SORTED_UNIQUE_HIST histograms the unique elements of a sorted R8VEC.
37548!
37549! Discussion:
37550!
37551! An R8VEC is a vector of R8's.
37552!
37553! Licensing:
37554!
37555! This code is distributed under the GNU LGPL license.
37556!
37557! Modified:
37558!
37559! 09 April 1999
37560!
37561! Author:
37562!
37563! John Burkardt
37564!
37565! Parameters:
37566!
37567! Input, integer ( kind = 4 ) N, the number of elements of A.
37568!
37569! Input, real ( kind = 8 ) A(N), the array to examine. The elements of A
37570! should have been sorted.
37571!
37572! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
37573! Set it to 0.0 for the strictest test.
37574!
37575! Input, integer ( kind = 4 ) MAXUNIQ, the maximum number of unique elements
37576! that can be handled. If there are more than MAXUNIQ unique
37577! elements in A, the excess will be ignored.
37578!
37579! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements
37580! of A.
37581!
37582! Output, real ( kind = 8 ) AUNIQ(UNIQUE_NUM), the unique elements of A.
37583!
37584! Output, integer ( kind = 4 ) ACOUNT(UNIQUE_NUM), the number of times
37585! each element of AUNIQ occurs in A.
37586!
37587 implicit none
37588
37589 integer ( kind = 4 ) maxuniq
37590 integer ( kind = 4 ) n
37591
37592 real ( kind = 8 ) a(n)
37593 integer ( kind = 4 ) acount(maxuniq)
37594 real ( kind = 8 ) auniq(maxuniq)
37595 integer ( kind = 4 ) i
37596 integer ( kind = 4 ) unique_num
37597 real ( kind = 8 ) tol
37598!
37599! Start taking statistics.
37600!
37601 unique_num = 0
37602
37603 do i = 1, n
37604
37605 if ( i == 1 ) then
37606
37607 unique_num = 1
37608 auniq(unique_num) = a(1)
37609 acount(unique_num) = 1
37610
37611 else if ( abs( a(i) - auniq(unique_num) ) <= tol ) then
37612
37613 acount(unique_num) = acount(unique_num) + 1
37614
37615 else if ( unique_num < maxuniq ) then
37616
37617 unique_num = unique_num + 1
37618 auniq(unique_num) = a(i)
37619 acount(unique_num) = 1
37620
37621 end if
37622
37623 end do
37624
37625 return

◆ r8vec_split()

subroutine r8vec_split ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  split,
integer ( kind = 4 )  isplit 
)

Definition at line 37627 of file R8LIB.f90.

37628
37629!*****************************************************************************80
37630!
37631!! R8VEC_SPLIT "splits" an unsorted R8VEC based on a splitting value.
37632!
37633! Discussion:
37634!
37635! An R8VEC is a vector of R8's.
37636!
37637! If the vector is already sorted, it is simpler to do a binary search
37638! on the data than to call this routine.
37639!
37640! The vector is not assumed to be sorted before input, and is not
37641! sorted during processing. If sorting is not needed, then it is
37642! more efficient to use this routine.
37643!
37644! Licensing:
37645!
37646! This code is distributed under the GNU LGPL license.
37647!
37648! Modified:
37649!
37650! 21 October 2001
37651!
37652! Author:
37653!
37654! John Burkardt
37655!
37656! Parameters:
37657!
37658! Input, integer ( kind = 4 ) N, the number of elements of A.
37659!
37660! Input/output, real ( kind = 8 ) A(N), the array to split. On output,
37661! all the entries of A that are less than or equal to SPLIT
37662! are in A(1:ISPLIT).
37663!
37664! Input, real ( kind = 8 ) SPLIT, the value used to split the vector.
37665! It is not necessary that any value of A actually equal SPLIT.
37666!
37667! Output, integer ( kind = 4 ) ISPLIT, indicates the position of the last
37668! entry of the split vector that is less than or equal to SPLIT.
37669!
37670 implicit none
37671
37672 integer ( kind = 4 ) n
37673
37674 real ( kind = 8 ) a(n)
37675 integer ( kind = 4 ) i
37676 integer ( kind = 4 ) i1
37677 integer ( kind = 4 ) i2
37678 integer ( kind = 4 ) i3
37679 integer ( kind = 4 ) isplit
37680 integer ( kind = 4 ) j1
37681 integer ( kind = 4 ) j2
37682 integer ( kind = 4 ) j3
37683 real ( kind = 8 ) split
37684!
37685! Partition the vector into A1, A2, A3, where
37686! A1 = A(I1:J1) holds values <= SPLIT,
37687! A2 = A(I2:J2) holds untested values,
37688! A3 = A(I3:J3) holds values > SPLIT.
37689!
37690 i1 = 1
37691 j1 = 0
37692
37693 i2 = 1
37694 j2 = n
37695
37696 i3 = n + 1
37697 j3 = n
37698!
37699! Pick the next item from A2, and move it into A1 or A3.
37700! Adjust indices appropriately.
37701!
37702 do i = 1, n
37703
37704 if ( a(i2) <= split ) then
37705 i2 = i2 + 1
37706 j1 = j1 + 1
37707 else
37708 call r8_swap ( a(i2), a(i3-1) )
37709 i3 = i3 - 1
37710 j2 = j2 - 1
37711 end if
37712
37713 end do
37714
37715 isplit = j1
37716
37717 return

References r8_swap().

Here is the call graph for this function:

◆ r8vec_std()

subroutine r8vec_std ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  std 
)

Definition at line 37719 of file R8LIB.f90.

37720
37721!*****************************************************************************80
37722!
37723!! R8VEC_STD returns the standard deviation of an R8VEC.
37724!
37725! Discussion:
37726!
37727! An R8VEC is a vector of R8's.
37728!
37729! The standard deviation of a vector X of length N is defined as
37730!
37731! mean ( X(1:n) ) = sum ( X(1:n) ) / n
37732!
37733! std ( X(1:n) ) = sqrt ( sum ( ( X(1:n) - mean )^2 ) / ( n - 1 ) )
37734!
37735! Licensing:
37736!
37737! This code is distributed under the GNU LGPL license.
37738!
37739! Modified:
37740!
37741! 06 February 2003
37742!
37743! Author:
37744!
37745! John Burkardt
37746!
37747! Parameters:
37748!
37749! Input, integer ( kind = 4 ) N, the number of entries in the vector.
37750! N should be at least 2.
37751!
37752! Input, real ( kind = 8 ) A(N), the vector.
37753!
37754! Output, real ( kind = 8 ) STD, the standard deviation of the vector.
37755!
37756 implicit none
37757
37758 integer ( kind = 4 ) n
37759
37760 real ( kind = 8 ) a(n)
37761 real ( kind = 8 ) mean
37762 real ( kind = 8 ) std
37763
37764 if ( n < 2 ) then
37765
37766 std = 0.0d+00
37767
37768 else
37769
37770 mean = sum( a(1:n) ) / real( n, kind = 8 )
37771
37772 std = sum( ( a(1:n) - mean )**2 )
37773
37774 std = sqrt( std / real( n - 1, kind = 8 ) )
37775
37776 end if
37777
37778 return

◆ r8vec_step()

subroutine r8vec_step ( real ( kind = 8 )  x0,
integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(n)  fx 
)

Definition at line 37780 of file R8LIB.f90.

37781
37782!*****************************************************************************80
37783!
37784!! R8VEC_STEP evaluates a unit step function.
37785!
37786! Discussion:
37787!
37788! F(X) = 0 if X < X0
37789! 1 if X0 <= X
37790!
37791! Licensing:
37792!
37793! This code is distributed under the GNU LGPL license.
37794!
37795! Modified:
37796!
37797! 30 May 2013
37798!
37799! Author:
37800!
37801! John Burkardt
37802!
37803! Parameters:
37804!
37805! Input, real ( kind = 8 ) X0, the location of the jump.
37806!
37807! Input, integer ( kind = 4 ) N, the number of argument values.
37808!
37809! Output, real ( kind = 8 ) X(N), the arguments.
37810!
37811! Output, real ( kind = 8 ) FX(N), the function values.
37812!
37813 implicit none
37814
37815 integer ( kind = 4 ) n
37816
37817 real ( kind = 8 ) fx(n)
37818 real ( kind = 8 ) x(n)
37819 real ( kind = 8 ) x0
37820
37821 where ( x < x0 )
37822 fx = 0.0d+00
37823 else where
37824 fx = 1.0d+00
37825 end where
37826
37827 return

◆ r8vec_stutter()

subroutine r8vec_stutter ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
integer ( kind = 4 )  m,
real ( kind = 8 ), dimension(m*n)  am 
)

Definition at line 37829 of file R8LIB.f90.

37830
37831!*****************************************************************************80
37832!
37833!! R8VEC_STUTTER makes a "stuttering" copy of an R8VEC.
37834!
37835! Discussion:
37836!
37837! An R8VEC is a vector of R8's.
37838!
37839! Applying a stuttering factor M of 3, the vector A = ( 1, 5, 8 ) becomes
37840! AM = ( 1, 1, 1, 5, 5, 5, 8, 8, 8 ).
37841!
37842! Licensing:
37843!
37844! This code is distributed under the GNU LGPL license.
37845!
37846! Modified:
37847!
37848! 23 March 2011
37849!
37850! Author:
37851!
37852! John Burkardt
37853!
37854! Parameters:
37855!
37856! Input, integer ( kind = 4 ) N, the size of the input vector.
37857!
37858! Input, real ( kind = 8 ) A(N), the vector.
37859!
37860! Input, integer ( kind = 4 ) M, the "stuttering factor".
37861!
37862! Output, real ( kind = 8 ) AM(M*N), the stuttering vector.
37863!
37864 implicit none
37865
37866 integer ( kind = 4 ) m
37867 integer ( kind = 4 ) n
37868
37869 real ( kind = 8 ) a(n)
37870 real ( kind = 8 ) am(m*n)
37871 integer ( kind = 4 ) i
37872 integer ( kind = 4 ) jhi
37873 integer ( kind = 4 ) jlo
37874
37875 do i = 1, n
37876 jlo = m * ( i - 1 ) + 1
37877 jhi = m * i
37878 am(jlo:jhi) = a(i)
37879 end do
37880
37881 return

◆ r8vec_sum()

real ( kind = 8 ) function r8vec_sum ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 37883 of file R8LIB.f90.

37884
37885!*****************************************************************************80
37886!
37887!! R8VEC_SUM returns the sum of the entries of an R8VEC.
37888!
37889! Discussion:
37890!
37891! An R8VEC is a vector of R8's.
37892!
37893! In FORTRAN90, this facility is offered by the built in
37894! SUM function:
37895!
37896! R8VEC_SUM ( N, A ) = SUM ( A(1:N) )
37897!
37898! Licensing:
37899!
37900! This code is distributed under the GNU LGPL license.
37901!
37902! Modified:
37903!
37904! 09 December 2004
37905!
37906! Author:
37907!
37908! John Burkardt
37909!
37910! Parameters:
37911!
37912! Input, integer ( kind = 4 ) N, the number of entries in the array.
37913!
37914! Input, real ( kind = 8 ) A(N), the array.
37915!
37916! Output, real ( kind = 8 ) R8VEC_SUM, the sum of the entries.
37917!
37918 implicit none
37919
37920 integer ( kind = 4 ) n
37921
37922 real ( kind = 8 ) a(n)
37923 real ( kind = 8 ) r8vec_sum
37924
37925 r8vec_sum = sum( a(1:n) )
37926
37927 return
r8vec_sum
real(kind=8) function r8vec_sum(n, a)
Definition R8LIB.f90:37884

References r8vec_sum().

Referenced by r8vec_sum().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ r8vec_swap()

subroutine r8vec_swap ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a1,
real ( kind = 8 ), dimension(n)  a2 
)

Definition at line 37929 of file R8LIB.f90.

37930
37931!*****************************************************************************80
37932!
37933!! R8VEC_SWAP swaps the entries of two R8VECs.
37934!
37935! Discussion:
37936!
37937! An R8VEC is a vector of R8's.
37938!
37939! Licensing:
37940!
37941! This code is distributed under the GNU LGPL license.
37942!
37943! Modified:
37944!
37945! 04 December 2004
37946!
37947! Author:
37948!
37949! John Burkardt
37950!
37951! Parameters:
37952!
37953! Input, integer ( kind = 4 ) N, the number of entries in the arrays.
37954!
37955! Input/output, real ( kind = 8 ) A1(N), A2(N), the vectors to swap.
37956!
37957 implicit none
37958
37959 integer ( kind = 4 ) n
37960
37961 real ( kind = 8 ) a1(n)
37962 real ( kind = 8 ) a2(n)
37963 real ( kind = 8 ) a3(n)
37964
37965 a3(1:n) = a1(1:n)
37966 a1(1:n) = a2(1:n)
37967 a2(1:n) = a3(1:n)
37968
37969 return

Referenced by r82vec_part_quick_a(), r8col_part_quick_a(), and r8row_part_quick_a().

Here is the caller graph for this function:

◆ r8vec_transpose_print()

subroutine r8vec_transpose_print ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
character ( len = * )  title 
)

Definition at line 37971 of file R8LIB.f90.

37972
37973!*****************************************************************************80
37974!
37975!! R8VEC_TRANSPOSE_PRINT prints an R8VEC "transposed".
37976!
37977! Discussion:
37978!
37979! An R8VEC is a vector of R8's.
37980!
37981! Example:
37982!
37983! A = (/ 1.0, 2.1, 3.2, 4.3, 5.4, 6.5, 7.6, 8.7, 9.8, 10.9, 11.0 /)
37984! TITLE = 'My vector: '
37985!
37986! My vector: 1.0 2.1 3.2 4.3 5.4
37987! 6.5 7.6 8.7 9.8 10.9
37988! 11.0
37989!
37990! Licensing:
37991!
37992! This code is distributed under the GNU LGPL license.
37993!
37994! Modified:
37995!
37996! 11 May 2014
37997!
37998! Author:
37999!
38000! John Burkardt
38001!
38002! Parameters:
38003!
38004! Input, integer ( kind = 4 ) N, the number of components of the vector.
38005!
38006! Input, real ( kind = 8 ) A(N), the vector to be printed.
38007!
38008! Input, character ( len = * ) TITLE, a title.
38009!
38010 implicit none
38011
38012 integer ( kind = 4 ) n
38013
38014 real ( kind = 8 ) a(n)
38015 integer ( kind = 4 ) i
38016 integer ( kind = 4 ) ihi
38017 integer ( kind = 4 ) ilo
38018 character ( len = * ) title
38019 integer ( kind = 4 ) title_length
38020
38021 title_length = len_trim( title )
38022
38023 do ilo = 1, n, 5
38024 if ( ilo == 1 ) then
38025 write ( *, '(a)', advance = 'NO' ) trim( title )
38026 else
38027 write ( *, '(a)', advance = 'NO' ) ( ' ', i = 1, title_length )
38028 end if
38029 write ( *, '(2x)', advance = 'NO' )
38030 ihi = min( ilo + 5 - 1, n )
38031 write ( *, '(5g14.6)' ) a(ilo:ihi)
38032 end do
38033
38034 return

◆ r8vec_undex()

subroutine r8vec_undex ( integer ( kind = 4 )  x_num,
real ( kind = 8 ), dimension(x_num)  x_val,
integer ( kind = 4 )  x_unique_num,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(x_unique_num)  undx,
integer ( kind = 4 ), dimension(x_num)  xdnu 
)

Definition at line 38036 of file R8LIB.f90.

38037
38038!*****************************************************************************80
38039!
38040!! R8VEC_UNDEX returns unique sorted indexes for an R8VEC.
38041!
38042! Discussion:
38043!
38044! An R8VEC is a vector of R8's.
38045!
38046! The goal of this routine is to determine a vector UNDX,
38047! which points, to the unique elements of X, in sorted order,
38048! and a vector XDNU, which identifies, for each entry of X, the index of
38049! the unique sorted element of X.
38050!
38051! This is all done with index vectors, so that the elements of
38052! X are never moved.
38053!
38054! The first step of the algorithm requires the indexed sorting
38055! of X, which creates arrays INDX and XDNI. (If all the entries
38056! of X are unique, then these arrays are the same as UNDX and XDNU.)
38057!
38058! We then use INDX to examine the entries of X in sorted order,
38059! noting the unique entries, creating the entries of XDNU and
38060! UNDX as we go.
38061!
38062! Once this process has been completed, the vector X could be
38063! replaced by a compressed vector XU, containing the unique entries
38064! of X in sorted order, using the formula
38065!
38066! XU(1:X_UNIQUE_NUM) = X(UNDX(1:X_UNIQUE_NUM)).
38067!
38068! We could then, if we wished, reconstruct the entire vector X, or
38069! any element of it, by index, as follows:
38070!
38071! X(I) = XU(XDNU(I)).
38072!
38073! We could then replace X by the combination of XU and XDNU.
38074!
38075! Later, when we need the I-th entry of X, we can locate it as
38076! the XDNU(I)-th entry of XU.
38077!
38078! Here is an example of a vector X, the sort and inverse sort
38079! index vectors, and the unique sort and inverse unique sort vectors
38080! and the compressed unique sorted vector.
38081!
38082! I X Indx Xdni XU Undx Xdnu
38083! ----+-----+-----+-----+--------+-----+-----+
38084! 1 | 11. 1 1 | 11, 1 1
38085! 2 | 22. 3 5 | 22, 2 2
38086! 3 | 11. 6 2 | 33, 4 1
38087! 4 | 33. 9 8 | 55, 5 3
38088! 5 | 55. 2 9 | 4
38089! 6 | 11. 7 3 | 1
38090! 7 | 22. 8 6 | 2
38091! 8 | 22. 4 7 | 2
38092! 9 | 11. 5 4 | 1
38093!
38094! INDX(2) = 3 means that sorted item(2) is X(3).
38095! XDNI(2) = 5 means that X(2) is sorted item(5).
38096!
38097! UNDX(3) = 4 means that unique sorted item(3) is at X(4).
38098! XDNU(8) = 2 means that X(8) is at unique sorted item(2).
38099!
38100! XU(XDNU(I))) = X(I).
38101! XU(I) = X(UNDX(I)).
38102!
38103! Licensing:
38104!
38105! This code is distributed under the GNU LGPL license.
38106!
38107! Modified:
38108!
38109! 27 October 2008
38110!
38111! Author:
38112!
38113! John Burkardt
38114!
38115! Parameters:
38116!
38117! Input, integer ( kind = 4 ) X_NUM, the number of data values.
38118!
38119! Input, real ( kind = 8 ) X_VAL(X_NUM), the data values.
38120!
38121! Input, integer ( kind = 4 ) X_UNIQUE_NUM, the number of unique values
38122! in X_VAL. This value is only required for languages in which the size of
38123! UNDX must be known in advance.
38124!
38125! Input, real ( kind = 8 ) TOL, a tolerance for equality.
38126!
38127! Output, integer ( kind = 4 ) UNDX(X_UNIQUE_NUM), the UNDX vector.
38128!
38129! Output, integer ( kind = 4 ) XDNU(X_NUM), the XDNU vector.
38130!
38131 implicit none
38132
38133 integer ( kind = 4 ) x_num
38134 integer ( kind = 4 ) x_unique_num
38135
38136 integer ( kind = 4 ) i
38137 integer ( kind = 4 ) indx(x_num)
38138 integer ( kind = 4 ) j
38139 real ( kind = 8 ) tol
38140 integer ( kind = 4 ) undx(x_unique_num)
38141 real ( kind = 8 ) x_val(x_num)
38142 integer ( kind = 4 ) xdnu(x_num)
38143!
38144! Implicitly sort the array.
38145!
38146 call r8vec_sort_heap_index_a ( x_num, x_val, indx )
38147!
38148! Walk through the implicitly sorted array X.
38149!
38150 i = 1
38151
38152 j = 1
38153 undx(j) = indx(i)
38154
38155 xdnu(indx(i)) = j
38156
38157 do i = 2, x_num
38158
38159 if ( tol < abs( x_val(indx(i)) - x_val(undx(j)) ) ) then
38160 j = j + 1
38161 undx(j) = indx(i)
38162 end if
38163
38164 xdnu(indx(i)) = j
38165
38166 end do
38167
38168 return
r8vec_sort_heap_index_a
subroutine r8vec_sort_heap_index_a(n, a, indx)
Definition R8LIB.f90:35786

References r8vec_sort_heap_index_a().

Here is the call graph for this function:

◆ r8vec_uniform_01()

subroutine r8vec_uniform_01 ( integer ( kind = 4 )  n,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(n)  r 
)

Definition at line 38170 of file R8LIB.f90.

38171
38172!*****************************************************************************80
38173!
38174!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
38175!
38176! Discussion:
38177!
38178! An R8VEC is a vector of R8's.
38179!
38180! Licensing:
38181!
38182! This code is distributed under the GNU LGPL license.
38183!
38184! Modified:
38185!
38186! 13 August 2014
38187!
38188! Author:
38189!
38190! John Burkardt
38191!
38192! Reference:
38193!
38194! Paul Bratley, Bennett Fox, Linus Schrage,
38195! A Guide to Simulation,
38196! Springer Verlag, pages 201-202, 1983.
38197!
38198! Bennett Fox,
38199! Algorithm 647:
38200! Implementation and Relative Efficiency of Quasirandom
38201! Sequence Generators,
38202! ACM Transactions on Mathematical Software,
38203! Volume 12, Number 4, pages 362-376, 1986.
38204!
38205! Peter Lewis, Allen Goodman, James Miller
38206! A Pseudo-Random Number Generator for the System/360,
38207! IBM Systems Journal,
38208! Volume 8, pages 136-143, 1969.
38209!
38210! Parameters:
38211!
38212! Input, integer ( kind = 4 ) N, the number of entries in the vector.
38213!
38214! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
38215! should NOT be 0. On output, SEED has been updated.
38216!
38217! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
38218!
38219 implicit none
38220
38221 integer ( kind = 4 ) n
38222
38223 integer ( kind = 4 ) i
38224 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
38225 integer ( kind = 4 ) k
38226 integer ( kind = 4 ) seed
38227 real ( kind = 8 ) r(n)
38228
38229 if ( seed == 0 ) then
38230 write ( *, '(a)' ) ' '
38231 write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!'
38232 write ( *, '(a)' ) ' Input value of SEED = 0.'
38233 stop 1
38234 end if
38235
38236 do i = 1, n
38237
38238 k = seed / 127773
38239
38240 seed = 16807 * ( seed - k * 127773 ) - k * 2836
38241
38242 if ( seed < 0 ) then
38243 seed = seed + i4_huge
38244 end if
38245
38246 r(i) = real( seed, kind = 8 ) * 4.656612875d-10
38247
38248 end do
38249
38250 return

Referenced by r8vec_normal_01().

Here is the caller graph for this function:

◆ r8vec_uniform_ab()

subroutine r8vec_uniform_ab ( integer ( kind = 4 )  n,
real ( kind = 8 )  a,
real ( kind = 8 )  b,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(n)  r 
)

Definition at line 38252 of file R8LIB.f90.

38253
38254!*****************************************************************************80
38255!
38256!! R8VEC_UNIFORM_AB returns a scaled pseudorandom R8VEC.
38257!
38258! Discussion:
38259!
38260! An R8VEC is a vector of R8's.
38261!
38262! Each dimension ranges from A to B.
38263!
38264! Licensing:
38265!
38266! This code is distributed under the GNU LGPL license.
38267!
38268! Modified:
38269!
38270! 31 May 2007
38271!
38272! Author:
38273!
38274! John Burkardt
38275!
38276! Reference:
38277!
38278! Paul Bratley, Bennett Fox, Linus Schrage,
38279! A Guide to Simulation,
38280! Second Edition,
38281! Springer, 1987,
38282! ISBN: 0387964673,
38283! LC: QA76.9.C65.B73.
38284!
38285! Bennett Fox,
38286! Algorithm 647:
38287! Implementation and Relative Efficiency of Quasirandom
38288! Sequence Generators,
38289! ACM Transactions on Mathematical Software,
38290! Volume 12, Number 4, December 1986, pages 362-376.
38291!
38292! Pierre L'Ecuyer,
38293! Random Number Generation,
38294! in Handbook of Simulation,
38295! edited by Jerry Banks,
38296! Wiley, 1998,
38297! ISBN: 0471134031,
38298! LC: T57.62.H37.
38299!
38300! Peter Lewis, Allen Goodman, James Miller,
38301! A Pseudo-Random Number Generator for the System/360,
38302! IBM Systems Journal,
38303! Volume 8, Number 2, 1969, pages 136-143.
38304!
38305! Parameters:
38306!
38307! Input, integer ( kind = 4 ) N, the number of entries in the vector.
38308!
38309! Input, real ( kind = 8 ) A, B, the lower and upper limits.
38310!
38311! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
38312! should NOT be 0. On output, SEED has been updated.
38313!
38314! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
38315!
38316 implicit none
38317
38318 integer ( kind = 4 ) n
38319
38320 real ( kind = 8 ) a
38321 real ( kind = 8 ) b
38322 integer ( kind = 4 ) i
38323 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
38324 integer ( kind = 4 ) k
38325 integer ( kind = 4 ) seed
38326 real ( kind = 8 ) r(n)
38327
38328 if ( seed == 0 ) then
38329 write ( *, '(a)' ) ' '
38330 write ( *, '(a)' ) 'R8VEC_UNIFORM_AB - Fatal error!'
38331 write ( *, '(a)' ) ' Input value of SEED = 0.'
38332 stop 1
38333 end if
38334
38335 do i = 1, n
38336
38337 k = seed / 127773
38338
38339 seed = 16807 * ( seed - k * 127773 ) - k * 2836
38340
38341 if ( seed < 0 ) then
38342 seed = seed + i4_huge
38343 end if
38344
38345 r(i) = a + ( b - a ) * real( seed, kind = 8 ) * 4.656612875d-10
38346
38347 end do
38348
38349 return

◆ r8vec_uniform_abvec()

subroutine r8vec_uniform_abvec ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 ), dimension(n)  b,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(n)  r 
)

Definition at line 38351 of file R8LIB.f90.

38352
38353!*****************************************************************************80
38354!
38355!! R8VEC_UNIFORM_ABVEC returns a scaled pseudorandom R8VEC.
38356!
38357! Discussion:
38358!
38359! An R8VEC is a vector of R8's.
38360!
38361! Dimension I ranges from A(I) to B(I).
38362!
38363! Licensing:
38364!
38365! This code is distributed under the GNU LGPL license.
38366!
38367! Modified:
38368!
38369! 01 October 2012
38370!
38371! Author:
38372!
38373! John Burkardt
38374!
38375! Reference:
38376!
38377! Paul Bratley, Bennett Fox, Linus Schrage,
38378! A Guide to Simulation,
38379! Second Edition,
38380! Springer, 1987,
38381! ISBN: 0387964673,
38382! LC: QA76.9.C65.B73.
38383!
38384! Bennett Fox,
38385! Algorithm 647:
38386! Implementation and Relative Efficiency of Quasirandom
38387! Sequence Generators,
38388! ACM Transactions on Mathematical Software,
38389! Volume 12, Number 4, December 1986, pages 362-376.
38390!
38391! Pierre L'Ecuyer,
38392! Random Number Generation,
38393! in Handbook of Simulation,
38394! edited by Jerry Banks,
38395! Wiley, 1998,
38396! ISBN: 0471134031,
38397! LC: T57.62.H37.
38398!
38399! Peter Lewis, Allen Goodman, James Miller,
38400! A Pseudo-Random Number Generator for the System/360,
38401! IBM Systems Journal,
38402! Volume 8, Number 2, 1969, pages 136-143.
38403!
38404! Parameters:
38405!
38406! Input, integer ( kind = 4 ) N, the number of entries in the vector.
38407!
38408! Input, real ( kind = 8 ) A(N), B(N), the lower and upper limits
38409! for each dimension.
38410!
38411! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
38412! should NOT be 0. On output, SEED has been updated.
38413!
38414! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
38415!
38416 implicit none
38417
38418 integer ( kind = 4 ) n
38419
38420 real ( kind = 8 ) a(n)
38421 real ( kind = 8 ) b(n)
38422 integer ( kind = 4 ) i
38423 integer ( kind = 4 ), parameter :: i4_huge = 2147483647
38424 integer ( kind = 4 ) k
38425 integer ( kind = 4 ) seed
38426 real ( kind = 8 ) r(n)
38427
38428 if ( seed == 0 ) then
38429 write ( *, '(a)' ) ' '
38430 write ( *, '(a)' ) 'R8VEC_UNIFORM_ABVEC - Fatal error!'
38431 write ( *, '(a)' ) ' Input value of SEED = 0.'
38432 stop 1
38433 end if
38434
38435 do i = 1, n
38436
38437 k = seed / 127773
38438
38439 seed = 16807 * ( seed - k * 127773 ) - k * 2836
38440
38441 if ( seed < 0 ) then
38442 seed = seed + i4_huge
38443 end if
38444
38445 r(i) = a(i) + ( b(i) - a(i) ) * real( seed, kind = 8 ) * 4.656612875d-10
38446
38447 end do
38448
38449 return

◆ r8vec_uniform_unit()

subroutine r8vec_uniform_unit ( integer ( kind = 4 )  m,
integer ( kind = 4 )  seed,
real ( kind = 8 ), dimension(m)  w 
)

Definition at line 38451 of file R8LIB.f90.

38452
38453!*****************************************************************************80
38454!
38455!! R8VEC_UNIFORM_UNIT generates a uniformly random unit vector.
38456!
38457! Discussion:
38458!
38459! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
38460!
38461! Licensing:
38462!
38463! This code is distributed under the GNU LGPL license.
38464!
38465! Modified:
38466!
38467! 04 October 2012
38468!
38469! Author:
38470!
38471! John Burkardt
38472!
38473! Parameters:
38474!
38475! Input, integer ( kind = 4 ) M, the spatial dimension.
38476!
38477! Input/output, integer ( kind = 4 ) SEED, a seed for the random number
38478! generator.
38479!
38480! Output, real ( kind = 8 ) W(M), a random direction vector,
38481! with unit norm.
38482!
38483 implicit none
38484
38485 integer ( kind = 4 ) m
38486
38487 real ( kind = 8 ) norm
38488 integer ( kind = 4 ) seed
38489 real ( kind = 8 ) w(m)
38490!
38491! Get M values from a standard normal distribution.
38492!
38493 call r8vec_normal_01 ( m, seed, w )
38494!
38495! Compute the length of the vector.
38496!
38497 norm = sqrt( sum( w(1:m)**2 ) )
38498!
38499! Normalize the vector.
38500!
38501 w(1:m) = w(1:m) / norm
38502
38503 return

References r8vec_normal_01().

Here is the call graph for this function:

◆ r8vec_unique_count()

subroutine r8vec_unique_count ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 )  unique_num 
)

Definition at line 38505 of file R8LIB.f90.

38506
38507!*****************************************************************************80
38508!
38509!! R8VEC_UNIQUE_COUNT counts the unique elements in an unsorted R8VEC.
38510!
38511! Discussion:
38512!
38513! An R8VEC is a vector of R8's.
38514!
38515! Because the array is unsorted, this algorithm is O(N^2).
38516!
38517! Licensing:
38518!
38519! This code is distributed under the GNU LGPL license.
38520!
38521! Modified:
38522!
38523! 08 December 2004
38524!
38525! Author:
38526!
38527! John Burkardt
38528!
38529! Parameters:
38530!
38531! Input, integer ( kind = 4 ) N, the number of elements of A.
38532!
38533! Input, real ( kind = 8 ) A(N), the unsorted array to examine.
38534!
38535! Input, real ( kind = 8 ) TOL, a nonnegative tolerance for equality.
38536! Set it to 0.0 for the strictest test.
38537!
38538! Output, integer ( kind = 4 ) UNIQUE_NUM, the number of unique elements
38539! of A.
38540!
38541 implicit none
38542
38543 integer ( kind = 4 ) n
38544
38545 real ( kind = 8 ) a(n)
38546 integer ( kind = 4 ) i
38547 integer ( kind = 4 ) j
38548 integer ( kind = 4 ) unique_num
38549 real ( kind = 8 ) tol
38550
38551 unique_num = 0
38552
38553 do i = 1, n
38554
38555 unique_num = unique_num + 1
38556
38557 do j = 1, i - 1
38558
38559 if ( abs( a(i) - a(j) ) <= tol ) then
38560 unique_num = unique_num - 1
38561 exit
38562 end if
38563
38564 end do
38565
38566 end do
38567
38568 return

◆ r8vec_unique_index()

subroutine r8vec_unique_index ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  tol,
integer ( kind = 4 ), dimension(n)  unique_index 
)

Definition at line 38570 of file R8LIB.f90.

38571
38572!*****************************************************************************80
38573!
38574!! R8VEC_UNIQUE_INDEX indexes the unique occurrence of values in an R8VEC.
38575!
38576! Discussion:
38577!
38578! An R8VEC is a vector of R8's.
38579!
38580! For element A(I) of the vector, UNIQUE_INDEX(I) is the uniqueness index
38581! of A(I). That is, if A_UNIQUE contains the unique elements of A,
38582! gathered in order, then
38583!
38584! A_UNIQUE ( UNIQUE_INDEX(I) ) = A(I)
38585!
38586! Licensing:
38587!
38588! This code is distributed under the GNU LGPL license.
38589!
38590! Modified:
38591!
38592! 24 August 2008
38593!
38594! Author:
38595!
38596! John Burkardt
38597!
38598! Parameters:
38599!
38600! Input, integer ( kind = 4 ) N, the number of elements of A.
38601!
38602! Input, real ( kind = 8 ) A(N), the array.
38603!
38604! Input, real ( kind = 8 ) TOL, a tolerance for equality.
38605!
38606! Output, integer ( kind = 4 ) UNIQUE_INDEX(N), the unique index.
38607!
38608 implicit none
38609
38610 integer ( kind = 4 ) n
38611
38612 real ( kind = 8 ) a(n)
38613 integer ( kind = 4 ) i
38614 integer ( kind = 4 ) j
38615 real ( kind = 8 ) tol
38616 integer ( kind = 4 ) unique_index(n)
38617 integer ( kind = 4 ) unique_num
38618
38619 unique_index(1:n) = -1
38620 unique_num = 0
38621
38622 do i = 1, n
38623
38624 if ( unique_index(i) == -1 ) then
38625
38626 unique_num = unique_num + 1
38627 unique_index(i) = unique_num
38628
38629 do j = i + 1, n
38630 if ( abs( a(i) - a(j) ) <= tol ) then
38631 unique_index(j) = unique_num
38632 end if
38633 end do
38634
38635 end if
38636
38637 end do
38638
38639 return

◆ r8vec_variance()

subroutine r8vec_variance ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a,
real ( kind = 8 )  variance 
)

Definition at line 38641 of file R8LIB.f90.

38642
38643!*****************************************************************************80
38644!
38645!! R8VEC_VARIANCE returns the variance of an R8VEC.
38646!
38647! Discussion:
38648!
38649! An R8VEC is a vector of R8's.
38650!
38651! The variance of a vector X of length N is defined as
38652!
38653! mean ( X(1:n) ) = sum ( X(1:n) ) / n
38654!
38655! var ( X(1:n) ) = sum ( ( X(1:n) - mean )^2 ) / ( n - 1 )
38656!
38657! Licensing:
38658!
38659! This code is distributed under the GNU LGPL license.
38660!
38661! Modified:
38662!
38663! 14 February 1999
38664!
38665! Author:
38666!
38667! John Burkardt
38668!
38669! Parameters:
38670!
38671! Input, integer ( kind = 4 ) N, the number of entries in the vector.
38672! N should be at least 2.
38673!
38674! Input, real ( kind = 8 ) A(N), the vector.
38675!
38676! Output, real ( kind = 8 ) VARIANCE, the variance of the vector.
38677!
38678 implicit none
38679
38680 integer ( kind = 4 ) n
38681
38682 real ( kind = 8 ) a(n)
38683 real ( kind = 8 ) mean
38684 real ( kind = 8 ) variance
38685
38686 if ( n < 2 ) then
38687
38688 variance = 0.0d+00
38689
38690 else
38691
38692 mean = sum( a(1:n) ) / real( n, kind = 8 )
38693
38694 variance = sum( ( a(1:n) - mean )**2 )
38695
38696 variance = variance / real( n - 1, kind = 8 )
38697
38698 end if
38699
38700 return

◆ r8vec_vector_triple_product()

subroutine r8vec_vector_triple_product ( real ( kind = 8 ), dimension(3)  v1,
real ( kind = 8 ), dimension(3)  v2,
real ( kind = 8 ), dimension(3)  v3,
real ( kind = 8 ), dimension(3)  v 
)

Definition at line 38702 of file R8LIB.f90.

38703
38704!*****************************************************************************80
38705!
38706!! R8VEC_VECTOR_TRIPLE_PRODUCT computes the vector triple product.
38707!
38708! Discussion:
38709!
38710! VTRIPLE = V1 x ( V2 x V3 )
38711!
38712! VTRIPLE is a vector perpendicular to V1, lying in the plane
38713! spanned by V2 and V3. The norm of VTRIPLE is the product
38714! of the norms of V1, V2 and V3.
38715!
38716! Licensing:
38717!
38718! This code is distributed under the GNU LGPL license.
38719!
38720! Modified:
38721!
38722! 27 October 2010
38723!
38724! Author:
38725!
38726! John Burkardt
38727!
38728! Parameters:
38729!
38730! Input, real ( kind = 8 ) V1(3), V2(3), V3(3), three vectors.
38731!
38732! Output, real ( kind = 8 ) V(3), the vector triple product.
38733!
38734 implicit none
38735
38736 real ( kind = 8 ) v(3)
38737 real ( kind = 8 ) v1(3)
38738 real ( kind = 8 ) v2(3)
38739 real ( kind = 8 ) v3(3)
38740 real ( kind = 8 ) v4(3)
38741
38742 call r8vec_cross_product_3d ( v2, v3, v4 )
38743
38744 call r8vec_cross_product_3d ( v1, v4, v )
38745
38746 return
r8vec_cross_product_3d
subroutine r8vec_cross_product_3d(v1, v2, v3)
Definition R8LIB.f90:27779

References r8vec_cross_product_3d().

Here is the call graph for this function:

◆ r8vec_write()

subroutine r8vec_write ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  r,
character ( len = * )  output_file 
)

Definition at line 38748 of file R8LIB.f90.

38749
38750!*****************************************************************************80
38751!
38752!! R8VEC_WRITE writes an R8VEC to a file.
38753!
38754! Discussion:
38755!
38756! An R8VEC is a vector of R8's.
38757!
38758! Licensing:
38759!
38760! This code is distributed under the GNU LGPL license.
38761!
38762! Modified:
38763!
38764! 31 July 2006
38765!
38766! Author:
38767!
38768! John Burkardt
38769!
38770! Parameters:
38771!
38772! Input, integer ( kind = 4 ) N, the order of the matrix.
38773!
38774! Input, real ( kind = 8 ) R(N), the vector to be written.
38775!
38776! Input, character ( len = * ) OUTPUT_FILE, the name of the file to which
38777! the information is to be written.
38778!
38779 implicit none
38780
38781 integer ( kind = 4 ) n
38782
38783 integer ( kind = 4 ) i
38784 character ( len = * ) output_file
38785 integer ( kind = 4 ) output_unit
38786 real ( kind = 8 ) r(n)
38787
38788 call get_unit ( output_unit )
38789
38790 open ( unit = output_unit, file = output_file, status = 'replace' )
38791
38792 do i = 1, n
38793 write ( output_unit, '(2x,g16.8)' ) r(i)
38794 end do
38795
38796 close ( unit = output_unit )
38797
38798 return
get_unit
subroutine get_unit(iunit)
Definition R8LIB.f90:258

References get_unit().

Here is the call graph for this function:

◆ r8vec_zero()

subroutine r8vec_zero ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  a 
)

Definition at line 38800 of file R8LIB.f90.

38801
38802!*****************************************************************************80
38803!
38804!! R8VEC_ZERO zeroes out an R8VEC.
38805!
38806! Discussion:
38807!
38808! An R8VEC is a vector of R8's.
38809!
38810! Licensing:
38811!
38812! This code is distributed under the GNU LGPL license.
38813!
38814! Modified:
38815!
38816! 10 March 2003
38817!
38818! Author:
38819!
38820! John Burkardt
38821!
38822! Parameters:
38823!
38824! Input, integer ( kind = 4 ) N, the number of entries in the vector.
38825!
38826! Output, real ( kind = 8 ) A(N), the vector to be zeroed.
38827!
38828 implicit none
38829
38830 integer ( kind = 4 ) n
38831
38832 real ( kind = 8 ) a(n)
38833
38834 a(1:n) = 0.0d+00
38835
38836 return

◆ roots_to_r8poly()

subroutine roots_to_r8poly ( integer ( kind = 4 )  n,
real ( kind = 8 ), dimension(n)  x,
real ( kind = 8 ), dimension(0:n)  c 
)

Definition at line 39633 of file R8LIB.f90.

39634
39635!*****************************************************************************80
39636!
39637!! ROOTS_TO_R8POLY converts polynomial roots to polynomial coefficients.
39638!
39639! Licensing:
39640!
39641! This code is distributed under the GNU LGPL license.
39642!
39643! Modified:
39644!
39645! 09 December 2004
39646!
39647! Author:
39648!
39649! John Burkardt
39650!
39651! Parameters:
39652!
39653! Input, integer ( kind = 4 ) N, the number of roots specified.
39654!
39655! Input, real ( kind = 8 ) X(N), the roots.
39656!
39657! Output, real ( kind = 8 ) C(0:N), the coefficients of the polynomial.
39658!
39659 implicit none
39660
39661 integer ( kind = 4 ) n
39662
39663 real ( kind = 8 ) c(0:n)
39664 integer ( kind = 4 ) i
39665 integer ( kind = 4 ) j
39666 real ( kind = 8 ) x(n)
39667!
39668! Initialize C to (0, 0, ..., 0, 1).
39669! Essentially, we are setting up a divided difference table.
39670!
39671 c(0:n-1) = 0.0d+00
39672 c(n) = 1.0d+00
39673!
39674! Convert to standard polynomial form by shifting the abscissas
39675! of the divided difference table to 0.
39676!
39677 do j = 1, n
39678 do i = 1, n + 1 - j
39679 c(n-i) = c(n-i) - x(n+1-i-j+1) * c(n-i+1)
39680 end do
39681 end do
39682
39683 return

◆ sort_heap_external()

subroutine sort_heap_external ( integer ( kind = 4 )  n,
integer ( kind = 4 )  indx,
integer ( kind = 4 )  i,
integer ( kind = 4 )  j,
integer ( kind = 4 )  isgn 
)

Definition at line 39685 of file R8LIB.f90.

39686
39687!*****************************************************************************80
39688!
39689!! SORT_HEAP_EXTERNAL externally sorts a list of items into ascending order.
39690!
39691! Discussion:
39692!
39693! The actual list of data is not passed to the routine. Hence this
39694! routine may be used to sort integers, reals, numbers, names,
39695! dates, shoe sizes, and so on. After each call, the routine asks
39696! the user to compare or interchange two items, until a special
39697! return value signals that the sorting is completed.
39698!
39699! Licensing:
39700!
39701! This code is distributed under the GNU LGPL license.
39702!
39703! Modified:
39704!
39705! 05 February 2004
39706!
39707! Author:
39708!
39709! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf.
39710! FORTRAN90 version by John Burkardt.
39711!
39712! Reference:
39713!
39714! Albert Nijenhuis, Herbert Wilf,
39715! Combinatorial Algorithms for Computers and Calculators,
39716! Academic Press, 1978,
39717! ISBN: 0-12-519260-6,
39718! LC: QA164.N54.
39719!
39720! Parameters:
39721!
39722! Input, integer ( kind = 4 ) N, the number of items to be sorted.
39723!
39724! Input/output, integer ( kind = 4 ) INDX, the main communication signal.
39725! The user must set INDX to 0 before the first call.
39726! Thereafter, the user should not change the value of INDX until
39727! the sorting is done.
39728! On return, if INDX is
39729! * greater than 0,
39730! > interchange items I and J;
39731! > call again.
39732! * less than 0,
39733! > compare items I and J;
39734! > set ISGN = -1 if I < J, ISGN = +1 if J < I;
39735! > call again.
39736! * equal to 0, the sorting is done.
39737!
39738! Output, integer ( kind = 4 ) I, J, the indices of two items.
39739! On return with INDX positive, elements I and J should be interchanged.
39740! On return with INDX negative, elements I and J should be compared, and
39741! the result reported in ISGN on the next call.
39742!
39743! Input, integer ( kind = 4 ) ISGN, results of comparison of elements
39744! I and J. (Used only when the previous call returned INDX less than 0).
39745! ISGN <= 0 means I is less than or equal to J;
39746! 0 <= ISGN means I is greater than or equal to J.
39747!
39748 implicit none
39749
39750 integer ( kind = 4 ) i
39751 integer ( kind = 4 ), save :: i_save = 0
39752 integer ( kind = 4 ) indx
39753 integer ( kind = 4 ) isgn
39754 integer ( kind = 4 ) j
39755 integer ( kind = 4 ), save :: j_save = 0
39756 integer ( kind = 4 ), save :: k = 0
39757 integer ( kind = 4 ), save :: k1 = 0
39758 integer ( kind = 4 ) n
39759 integer ( kind = 4 ), save :: n1 = 0
39760!
39761! INDX = 0: This is the first call.
39762!
39763 if ( indx == 0 ) then
39764
39765 i_save = 0
39766 j_save = 0
39767 k = n / 2
39768 k1 = k
39769 n1 = n
39770!
39771! INDX < 0: The user is returning the results of a comparison.
39772!
39773 else if ( indx < 0 ) then
39774
39775 if ( indx == -2 ) then
39776
39777 if ( isgn < 0 ) then
39778 i_save = i_save + 1
39779 end if
39780
39781 j_save = k1
39782 k1 = i_save
39783 indx = -1
39784 i = i_save
39785 j = j_save
39786 return
39787
39788 end if
39789
39790 if ( 0 < isgn ) then
39791 indx = 2
39792 i = i_save
39793 j = j_save
39794 return
39795 end if
39796
39797 if ( k <= 1 ) then
39798
39799 if ( n1 == 1 ) then
39800 i_save = 0
39801 j_save = 0
39802 indx = 0
39803 else
39804 i_save = n1
39805 n1 = n1 - 1
39806 j_save = 1
39807 indx = 1
39808 end if
39809
39810 i = i_save
39811 j = j_save
39812 return
39813
39814 end if
39815
39816 k = k - 1
39817 k1 = k
39818!
39819! 0 < INDX, the user was asked to make an interchange.
39820!
39821 else if ( indx == 1 ) then
39822
39823 k1 = k
39824
39825 end if
39826
39827 do
39828
39829 i_save = 2 * k1
39830
39831 if ( i_save == n1 ) then
39832 j_save = k1
39833 k1 = i_save
39834 indx = -1
39835 i = i_save
39836 j = j_save
39837 return
39838 else if ( i_save <= n1 ) then
39839 j_save = i_save + 1
39840 indx = -2
39841 i = i_save
39842 j = j_save
39843 return
39844 end if
39845
39846 if ( k <= 1 ) then
39847 exit
39848 end if
39849
39850 k = k - 1
39851 k1 = k
39852
39853 end do
39854
39855 if ( n1 == 1 ) then
39856 i_save = 0
39857 j_save = 0
39858 indx = 0
39859 i = i_save
39860 j = j_save
39861 else
39862 i_save = n1
39863 n1 = n1 - 1
39864 j_save = 1
39865 indx = 1
39866 i = i_save
39867 j = j_save
39868 end if
39869
39870 return

Referenced by r8col_sort_heap_a(), r8col_sortr_a(), r8row_sort_heap_a(), r8vec2_sort_a(), r8vec2_sort_d(), and r8vec_sort2_a().

Here is the caller graph for this function:

◆ timestamp()

subroutine timestamp

Definition at line 39872 of file R8LIB.f90.

39873
39874!*****************************************************************************80
39875!
39876!! TIMESTAMP prints the current YMDHMS date as a time stamp.
39877!
39878! Example:
39879!
39880! 31 May 2001 9:45:54.872 AM
39881!
39882! Licensing:
39883!
39884! This code is distributed under the GNU LGPL license.
39885!
39886! Modified:
39887!
39888! 18 May 2013
39889!
39890! Author:
39891!
39892! John Burkardt
39893!
39894! Parameters:
39895!
39896! None
39897!
39898 implicit none
39899
39900 character ( len = 8 ) ampm
39901 integer ( kind = 4 ) d
39902 integer ( kind = 4 ) h
39903 integer ( kind = 4 ) m
39904 integer ( kind = 4 ) mm
39905 character ( len = 9 ), parameter, dimension(12) :: month = (/ &
39906 'January ', 'February ', 'March ', 'April ', &
39907 'May ', 'June ', 'July ', 'August ', &
39908 'September', 'October ', 'November ', 'December ' /)
39909 integer ( kind = 4 ) n
39910 integer ( kind = 4 ) s
39911 integer ( kind = 4 ) values(8)
39912 integer ( kind = 4 ) y
39913
39914 call date_and_time ( values = values )
39915
39916 y = values(1)
39917 m = values(2)
39918 d = values(3)
39919 h = values(5)
39920 n = values(6)
39921 s = values(7)
39922 mm = values(8)
39923
39924 if ( h < 12 ) then
39925 ampm = 'AM'
39926 else if ( h == 12 ) then
39927 if ( n == 0 .and. s == 0 ) then
39928 ampm = 'Noon'
39929 else
39930 ampm = 'PM'
39931 end if
39932 else
39933 h = h - 12
39934 if ( h < 12 ) then
39935 ampm = 'PM'
39936 else if ( h == 12 ) then
39937 if ( n == 0 .and. s == 0 ) then
39938 ampm = 'Midnight'
39939 else
39940 ampm = 'AM'
39941 end if
39942 end if
39943 end if
39944
39945 write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
39946 d, trim( month(m) ), y, h, ':', n, ':', s, '.', mm, trim( ampm )
39947
39948 return