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