Line data Source code
1 1 : program test_interp
2 1 : use const_def, only: dp, pi
3 : use const_lib, only: const_init
4 : use interp_2d_lib_db
5 : use interp_2d_lib_sg
6 : use interp_2d_support
7 : use utils_lib, only: mesa_error
8 :
9 : implicit none
10 :
11 : character(len=32) :: my_mesa_dir
12 : integer :: ierr
13 :
14 1 : my_mesa_dir = '../..'
15 1 : call const_init(my_mesa_dir, ierr)
16 1 : if (ierr /= 0) then
17 0 : write (*, *) 'const_init failed'
18 0 : call mesa_error(__FILE__, __LINE__)
19 : end if
20 :
21 1 : call math_init()
22 1 : call test
23 :
24 : contains
25 :
26 1 : subroutine test
27 :
28 1 : xpts_sg => xpts_sg_ary
29 1 : ypts_sg => ypts_sg_ary
30 1 : xpts_db => xpts_db_ary
31 1 : ypts_db => ypts_db_ary
32 :
33 1 : f_db1 => f_db_ary
34 1 : f_db(1:sz_per_pt, 1:num_xpts, 1:num_ypts) => f_db_ary(1:sz_per_pt*num_xpts*num_ypts)
35 :
36 1 : f_sg1 => f_sg_ary
37 1 : f_sg(1:sz_per_pt, 1:num_xpts, 1:num_ypts) => f_sg_ary(1:sz_per_pt*num_xpts*num_ypts)
38 :
39 : !write(*,*)
40 : !call TEST_RENKA790_DB
41 :
42 : !write(*,*)
43 : !call TEST_RENKA790_SG
44 :
45 : !write(*,*)
46 : !call TEST_AKIMA_DB
47 :
48 : !write(*,*)
49 : !call TEST_AKIMA_SG
50 :
51 1 : write (*, *)
52 1 : call test2D_db(.true.)
53 :
54 1 : write (*, *)
55 1 : call test2D_db(.false.)
56 :
57 1 : write (*, *)
58 1 : call test2D_sg(.true.)
59 :
60 1 : write (*, *)
61 1 : call test2D_sg(.false.)
62 :
63 1 : write (*, *)
64 :
65 1 : end subroutine test
66 :
67 2 : subroutine test2D_db(bicub_flag)
68 : logical, intent(in) :: bicub_flag
69 :
70 : integer :: x_points, y_points, i, j
71 10 : real(dp) :: x_max, x_min, y_max, y_min, dx, dy, x, y, z, dz_dx, dz_dy, tmp(4)
72 :
73 : include 'formats'
74 :
75 2 : write (*, *) 'bicub_flag', bicub_flag
76 :
77 2 : x_points = 2
78 2 : y_points = 3
79 2 : x_max = 0.8d0*pi; x_min = 0.1d0
80 2 : y_max = 0.6d0*pi; y_min = 0.2d0
81 2 : dx = (x_max - x_min)/(x_points - 1)
82 2 : dy = (y_max - y_min)/(y_points - 1)
83 :
84 2 : call get_2D_test_values_db
85 2 : call setup_to_interp_2D_db(bicub_flag)
86 :
87 2 : write (*, *)
88 2 : write (*, *) 'interpolant coefficients at midpoint'
89 10 : tmp(1:4) = f_db(1:4, num_xpts/2, num_ypts/2)
90 2 : write (*, 1) 'tmp', tmp
91 :
92 8 : do j = 1, y_points
93 6 : y = y_min + (j - 1)*dy
94 20 : do i = 1, x_points
95 12 : x = x_min + (i - 1)*dx
96 12 : call eval_2D_interp_db(bicub_flag, x, y, z, dz_dx, dz_dy)
97 18 : if (bicub_flag) then
98 6 : write (*, 3) 'test2D_db', i, j, x, y, z, dz_dx, dz_dy
99 : else
100 6 : write (*, 3) 'test2D_db', i, j, x, y, z
101 : end if
102 : end do
103 : end do
104 :
105 2 : write (*, *)
106 :
107 2 : end subroutine test2D_db
108 :
109 2 : subroutine test2D_sg(bicub_flag)
110 : logical, intent(in) :: bicub_flag
111 :
112 : integer :: x_points, y_points, i, j
113 2 : real :: x_max, x_min, y_max, y_min, dx, dy, x, y, z, dz_dx, dz_dy
114 :
115 : include 'formats'
116 :
117 2 : x_points = 2
118 2 : y_points = 3
119 2 : x_max = 0.8*pi_sg; x_min = 0.1
120 2 : y_max = 0.6*pi_sg; y_min = 0.2
121 2 : dx = (x_max - x_min)/(x_points - 1)
122 2 : dy = (y_max - y_min)/(y_points - 1)
123 :
124 2 : call get_2D_test_values_sg
125 2 : call setup_to_interp_2D_sg(bicub_flag)
126 :
127 8 : do j = 1, y_points
128 6 : y = y_min + (j - 1)*dy
129 20 : do i = 1, x_points
130 12 : x = x_min + (i - 1)*dx
131 12 : call eval_2D_interp_sg(bicub_flag, x, y, z, dz_dx, dz_dy)
132 18 : if (bicub_flag) then
133 6 : write (*, 3) 'test2D_sg', i, j, x, y, z, dz_dx, dz_dy
134 : else
135 6 : write (*, 3) 'test2D_sg', i, j, x, y, z
136 : end if
137 : end do
138 : end do
139 :
140 2 : write (*, *)
141 :
142 2 : end subroutine test2D_sg
143 :
144 : end program test_interp
|
