program main !*****************************************************************************80 ! !! geometry_test() tests geometry(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 April 2022 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) call timestamp ( ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'geometry_test():' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' Test geometry().' call angle_box_2d_test ( ) call angle_contains_point_2d_test ( ) call angle_degrees_2d_test ( ) call angle_half_2d_test ( ) call angle_rad_2d_test ( ) call angle_rad_3d_test ( ) call angle_rad_nd_test ( ) call angle_turn_2d_test ( ) call annulus_sector_centroid_2d_test ( ) call ball01_sample_2d_test ( ) call ball01_sample_3d_test ( ) call ball01_sample_nd_test ( ) call ball01_volume_test ( ) call basis_map_3d_test ( ) call box_contains_point_2d_test ( ) call box_segment_clip_2d_test ( ) call box_ray_int_2d_test ( ) call box01_contains_point_2d_test ( ) call circle_area_2d_test ( ) call circle_dia2imp_2d_test ( ) call circle_exp_contains_point_2d_test ( ) call circle_exp2imp_2d_test ( ) call circle_imp_line_exp_dist_2d_test ( ) call circle_imp_line_exp_intersect_test ( ) call circle_imp_line_par_int_2d_test ( ) call circle_imp_point_dist_2d_test ( ) call circle_imp_points_2d_test ( ) call circle_imp_points_3d_test ( ) call circle_imp_points_arc_2d_test ( ) call circle_imp_segment_intersect_test ( ) call circle_imp2exp_2d_test ( ) call circle_llr2imp_2d_test ( ) call circle_lune_angle_by_height_2d_test ( ) call circle_lune_area_by_angle_2d_test ( ) call circle_lune_area_by_height_2d_test ( ) call circle_lune_centroid_2d_test ( ) call circle_lune_height_by_angle_2d_test ( ) call circle_pppr2imp_3d_test ( ) call circle_ppr2imp_2d_test ( ) call circle_sector_area_2d_test ( ) call circle_sector_centroid_2d_test ( ) call circle_triangle_area_2d_test ( ) call circle_triple_angles_2d_test ( ) call circles_intersect_points_2d_test ( ) call test020 ( ) call cube01_volume_test ( ) call cylinder_point_dist_3d_test ( ) call cylinder_point_dist_signed_3d_test ( ) call cylinder_point_inside_3d_test ( ) call cylinder_point_near_3d_test ( ) call cylinder_sample_3d_test ( ) call cylinder_volume_3d_test ( ) call degrees_to_radians_test ( ) call test021 ( ) call disk_point_dist_3d_test ( ) call dms_to_radians_test ( ) call test0236 ( ) call dual_size_3d_test ( ) call dual_shape_3d_test ( ) call test028 ( ) call test029 ( ) call test030 ( ) call test031 ( ) call test0315 ( ) call test032 ( ) call test0321 ( ) call i4col_find_item_test ( ) call test0323 ( ) call test0325 ( ) call line_exp_normal_2d_test ( ) call test033 ( ) call test0335 ( ) call test0336 ( ) call test0337 ( ) call test034 ( ) call test0345 ( ) call test0346 ( ) call test035 ( ) call test0351 ( ) call test0352 ( ) call test038 ( ) call test0385 ( ) call test03855 ( ) call test0386 ( ) call test039 ( ) call test040 ( ) call test041 ( ) call test0415 ( ) call test0416 ( ) call minabs_test ( ) call test047 ( ) call test0475 ( ) call test0477 ( ) call test0478 ( ) call test048 ( ) call test0485 ( ) call test049 ( ) call test0493 ( ) call test0495 ( ) call test050 ( ) call plane_exp2imp_3d_test ( ) call plane_exp2normal_3d_test ( ) call test053 ( ) call test054 ( ) call test055 ( ) call test056 ( ) call test057 ( ) call test058 ( ) call test059 ( ) call test060 ( ) call test061 ( ) call test0615 ( ) call test0616 ( ) call test0617 ( ) call test062 ( ) call test063 ( ) call test064 ( ) call points_centroid_2d_test ( ) call test066 ( ) call points_hull_2d_test ( ) call test0126 ( ) call test0127 ( ) call test068 ( ) call polar_to_xy_test ( ) call polygon_area_2d_test ( ) call polygon_area_3d_test ( ) call polygon_centroid_3d_test ( ) call polygon_solid_angle_3d_test ( ) call polyhedron_area_3d_test ( ) call polyhedron_centroid_3d_test ( ) call polyhedron_contains_point_3d_test ( ) call test083 ( ) call test084 ( ) call polyline_points_nd_test ( ) call polyloop_arclength_nd_test ( ) call polyloop_points_nd_test ( ) call test085 ( ) call test170 ( ) call test171 ( ) call test1712 ( ) call test1715 ( ) call r8_acos_test ( ) call r8_asin_test ( ) call r8_atan_test ( ) call r8mat_inverse_3d_test ( ) call r8mat_solve_test ( ) call r8mat_solve_2d_test ( ) call r8vec_any_normal_test ( ) call r8vec_uniform_unit_test ( ) call radec_distance_3d_test ( ) call radec_to_xyz_test ( ) call radians_to_degrees_test ( ) call radians_to_dms_test ( ) call test1787 ( ) call rtp_to_xyz_test ( ) call segment_contains_point_1d_test ( ) call segment_point_coords_2d_test ( ) call segment_point_dist_2d_test ( ) call segment_point_dist_3d_test ( ) call segment_point_near_2d_test ( ) call segment_point_near_3d_test ( ) call segments_curvature_2d_test ( ) call segments_dist_2d_test ( ) call segments_dist_3d_test ( ) call segments_int_1d_test ( ) call segments_int_2d_test ( ) call test1788 ( ) call simplex_lattice_point_next_test ( ) call test179 ( ) call test180 ( ) call test1804 ( ) call test1805 ( ) call sphere_cap_volume_2d_test ( ) call sphere_dia2imp_3d_test ( ) call test182 ( ) call test183 ( ) call test1835 ( ) call sphere_exp2imp_nd_test ( ) call sphere_imp_point_project_3d_test ( ) call sphere_triangle_sides_to_angles_test ( ) call test189 ( ) call test1895 ( ) call sphere01_sample_2d_test ( ) call sphere01_sample_3d_test ( ) call test192 ( ) call test193 ( ) call test194 ( ) call test195 ( ) call test1955 ( ) call test196 ( ) call test197 ( ) call test198 ( ) call test199 ( ) call test201 ( ) call test202 ( ) call tetrahedron_centroid_3d_test ( ) call tetrahedron_circumsphere_3d_test ( ) call tetrahedron_volume_3d_test ( ) call test204 ( ) call test205 ( ) call test206 ( ) call test20605 ( ) call test2061 ( ) call test2062 ( ) call test209 ( ) call test20655 ( ) call test2066 ( ) call test2094 ( ) call test2101 ( ) call test21011 ( ) call test2067 ( ) call test21015 ( ) call test2068 ( ) call test2069 ( ) call test207 ( ) call test2075 ( ) call test208 ( ) call test2102 ( ) call test2070 ( ) call test20701 ( ) call test2104 ( ) call test2105 ( ) call test211 ( ) call test2103 ( ) call test2071 ( ) call test20715 ( ) call test2095 ( ) call test2072 ( ) call test2115 ( ) call test212 ( ) call test213 ( ) call tube_2d_test ( ) call test220 ( ) call vector_directions_nd_test ( ) call vector_rotate_2d_test ( ) call vector_rotate_3d_test ( ) call vector_rotate_base_2d_test ( ) call vector_separation_nd_test ( ) call voxels_dist_l1_nd_test ( ) call voxels_line_3d_test ( ) call voxels_region_3d_test ( ) call voxels_step_3d_test ( ) call wedge01_volume_test ( ) call xy_to_polar_test ( ) call xyz_to_radec_test ( ) call xyz_to_rtp_test ( ) ! ! Terminate. ! write ( *, '(a)' ) '' write ( *, '(a)' ) 'geometry_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) '' call timestamp ( ) stop 0 end subroutine angle_box_2d_test ( ) !*****************************************************************************80 ! !! angle_box_2d_test tests angle_box_2d. ! ! Discussion: ! ! Test 1: ! ! y = 0 ! y = 2x-6 ! ! Test 2: ! ! y = 0 ! y = 2x-6 ! ! Test 3: ! ! By setting P1 = P2, we are asking to extend the line ! y = 2x-6 ! from P3 to P2 through to the other side. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2015 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ), dimension ( test_num ) :: dist_test = (/ & 1.0D+00, 1.0D+00, 1.0D+00 /) real ( kind = rk ) p1(2) real ( kind = rk ), dimension(2,test_num) :: p1_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 3.0D+00, 0.0D+00 /), (/ 2, test_num /) ) real ( kind = rk ) p2(2) real ( kind = rk ), dimension(2,test_num) :: p2_test = reshape ( (/ & 3.0D+00, 0.0D+00, & 3.0D+00, 0.0D+00, & 3.0D+00, 0.0D+00 /), (/ 2, test_num /) ) real ( kind = rk ) p3(2) real ( kind = rk ), dimension(2,test_num) :: p3_test = reshape ( (/ & 4.0D+00, 2.0D+00, & 2.0D+00, -2.0D+00, & 2.0D+00, -2.0D+00 /), (/ 2, test_num /) ) real ( kind = rk ) p4(2) real ( kind = rk ) p5(2) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_BOX_2D_TEST' write ( *, '(a)' ) ' ANGLE_BOX_2D' write ( *, '(a)' ) ' Compute points P4 and P5, normal to ' write ( *, '(a)' ) ' line through P1 and P2, and' write ( *, '(a)' ) ' line through P2 and P3, ' write ( *, '(a)' ) ' and DIST units from P2.' do test = 1, test_num p1(1:2) = p1_test(1:2,test) p2(1:2) = p2_test(1:2,test) p3(1:2) = p3_test(1:2,test) dist = dist_test(test) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' DIST = ', dist write ( *, '(a,2g14.6)' ) ' P1:', p1(1:2) write ( *, '(a,2g14.6)' ) ' P2:', p2(1:2) write ( *, '(a,2g14.6)' ) ' P3:', p3(1:2) call angle_box_2d ( dist, p1, p2, p3, p4, p5 ) write ( *, '(a,2g14.6)' ) ' P4:', p4(1:2) write ( *, '(a,2g14.6)' ) ' P5:', p5(1:2) end do return end subroutine angle_contains_point_2d_test ( ) !*****************************************************************************80 ! !! angle_contains_point_2d_test tests angle_contains_point_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2015 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 6 integer angle integer, parameter :: angle_num = 12 real ( kind = rk ) angle_rad logical inside real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = reshape ( (/ & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, -1.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p3(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p3_test = reshape ( (/ & 1.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, & -1.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, & 1.0D+00, -0.01D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_CONTAINS_POINT_2D_TEST' write ( *, '(a)' ) ' ANGLE_CONTAINS_POINT_2D sees if a point' write ( *, '(a)' ) ' lies within an angle.' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) p3(1:dim_num) = p3_test(1:dim_num,test) call r8vec_print ( dim_num, p1, ' Vertex P1' ) call r8vec_print ( dim_num, p2, ' Vertex P2' ) call r8vec_print ( dim_num, p3, ' Vertex P3' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y Inside?' write ( *, '(a)' ) '' do angle = 0, angle_num angle_rad = real ( angle, kind = rk ) * 2.0D+00 * pi & / real ( angle_num, kind = rk ) p(1:2) = (/ cos ( angle_rad ), sin ( angle_rad ) /) call angle_contains_point_2d ( p1, p2, p3, p, inside ) write ( *, '(2x,2g14.6,2x,l1)' ) p(1:2), inside end do end do return end subroutine angle_degrees_2d_test ( ) !*****************************************************************************80 ! !! angle_degrees_2d_test() tests angle_degrees_2d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) angle_degrees_2d integer, parameter :: angle_num = 12 real ( kind = rk ) degrees_to_radians integer i real ( kind = rk ) radians_to_degrees real ( kind = rk ) temp1 real ( kind = rk ) temp2 real ( kind = rk ) thetad real ( kind = rk ) thetar real ( kind = rk ), dimension(dim_num) :: v1 = (/ 1.0D+00, 0.0D+00 /) real ( kind = rk ) v2(dim_num) real ( kind = rk ), dimension(dim_num) :: v3 = (/ 0.0D+00, 0.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'angle_degrees_2d_test' write ( *, '(a)' ) ' angle_degrees_2d computes an angle.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y Theta ATAN2(y, x), ' // & 'angle_degrees_2d' write ( *, '(a)' ) '' do i = 0, angle_num thetad = real ( i, kind = rk ) * 360.0D+00 / real ( angle_num, kind = rk ) thetar = degrees_to_radians ( thetad ) v2(1) = cos ( thetar ) v2(2) = sin ( thetar ) temp1 = radians_to_degrees ( atan2 ( v2(2), v2(1) ) ) temp2 = angle_degrees_2d ( v1, v3, v2 ) write ( *, '(2x,7f10.3)') v2(1:2), thetad, temp1, temp2 end do return end subroutine angle_half_2d_test ( ) !*****************************************************************************80 ! !! angle_half_2d_test tests angle_half_2d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) angle_degrees real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) real ( kind = rk ) p4(dim_num) real ( kind = rk ) r real ( kind = rk ) r8_cosd real ( kind = rk ) r8_sind write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_HALF_2D_TEST' write ( *, '(a)' ) ' ANGLE_HALF_2D computes the half angle between two rays;' write ( *, '(a)' ) ' The angle is defined by the points (P1,P2,P3)' write ( *, '(a)' ) ' or by the rays P2-->P3, P2-->P1.' p2(1:dim_num) = (/ 5.0D+00, 3.0D+00 /) angle_degrees = 75.0D+00 r = 3.0D+00 p1(1:dim_num) = p2(1:dim_num) & + r * (/ r8_cosd ( angle_degrees ), r8_sind ( angle_degrees ) /) angle_degrees = 15.0D+00 r = 2.0D+00 p3(1:dim_num) = p2(1:dim_num) & + r * (/ r8_cosd ( angle_degrees ), r8_sind ( angle_degrees ) /) call r8vec_print ( dim_num, p1, ' Point P1:' ) call r8vec_print ( dim_num, p2, ' Point P2:' ) call r8vec_print ( dim_num, p3, ' Point P3:' ) call angle_half_2d ( p1, p2, p3, p4 ) call r8vec_print ( dim_num, p4, & ' End point of unit ray from P2, defining half angle, P4:' ) angle_degrees = 45.0D+00 r = 1.0D+00 p4(1:dim_num) = p2(1:dim_num) & + r * (/ r8_cosd ( angle_degrees ), r8_sind ( angle_degrees ) /) call r8vec_print ( dim_num, p4, ' Expected value of P4:' ) return end subroutine angle_rad_2d_test ( ) !*****************************************************************************80 ! !! angle_rad_2d_test tests angle_rad_2d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 6 real ( kind = rk ) angle_rad real ( kind = rk ) angle_rad_2d real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p1_test = reshape ( (/ & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, -1.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p2_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p3(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p3_test = reshape ( (/ & 1.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, & -1.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, & 1.0D+00, -0.01D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_RAD_2D_TEST' write ( *, '(a)' ) ' ANGLE_RAD_2D computes the angle between two rays;' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) p3(1:dim_num) = p3_test(1:dim_num,test) angle_rad = angle_rad_2d ( p1, p2, p3 ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Angle = ', angle_rad end do return end subroutine angle_rad_3d_test ( ) !*****************************************************************************80 ! !! angle_rad_3d_test tests angle_rad_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) angle_rad_3d real ( kind = rk ) radians_to_degrees real ( kind = rk ), dimension ( dim_num ) :: p1 real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 3.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 0.0D+00, 0.0D+00, 1.0D+00 /) real ( kind = rk ) temp1 real ( kind = rk ) temp2 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_RAD_3D_TEST' write ( *, '(a)' ) ' ANGLE_RAD_3D computes an angle;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P, ANGLE_RAD_3D, (Degrees)' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) temp1 = angle_rad_3d ( p1, p2, p3 ) temp2 = radians_to_degrees ( temp1 ) write ( *, '(2x,6g12.4)') p1(1:dim_num), temp1, temp2 end do return end subroutine angle_rad_nd_test ( ) !*****************************************************************************80 ! !! angle_rad_nd_test tests angle_rad_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: angle_num = 12 real ( kind = rk ) angle_rad_nd real ( kind = rk ) degrees_to_radians integer i real ( kind = rk ) radians_to_degrees real ( kind = rk ) temp1 real ( kind = rk ) temp2 real ( kind = rk ) thetad real ( kind = rk ) thetar real ( kind = rk ), dimension(dim_num) :: v1 = (/ 1.0D+00, 0.0D+00 /) real ( kind = rk ) v2(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_RAD_ND_TEST' write ( *, '(a)' ) ' ANGLE_RAD_ND computes an angle in N dimensions.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y Theta ATAN2(y, x), ' // & 'ANGLE_RAD_ND' write ( *, '(a)' ) '' do i = 0, angle_num thetad = real ( i, kind = rk ) * 360.0D+00 / real ( angle_num, kind = rk ) thetar = degrees_to_radians ( thetad ) v2(1) = cos ( thetar ) v2(2) = sin ( thetar ) temp1 = radians_to_degrees ( atan2 ( v2(2), v2(1) ) ) temp2 = angle_rad_nd ( dim_num, v1, v2 ) write ( *, '(2x,5f10.3)') v2(1:2), thetad, temp1, temp2 end do return end subroutine angle_turn_2d_test ( ) !*****************************************************************************80 ! !! angle_turn_2d_test tests angle_turn_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 13 real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p3 = (/ 1.0D+00, 0.0D+00 /) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 integer test real ( kind = rk ) theta real ( kind = rk ) theta_degrees real ( kind = rk ) turn write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANGLE_TURN_2D_TEST' write ( *, '(a)' ) ' ANGLE_TURN_2D computes the turning angle ' write ( *, '(a)' ) ' defined by the line segments [P1,P2] and [P2,P3].' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Our three points are:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 = (C,S)' write ( *, '(a)' ) ' P2 = (0,0)' write ( *, '(a)' ) ' P3 = (1,0)' write ( *, '(a)' ) '' write ( *, '(a)' ) ' C = cosine ( theta ), S = sine ( theta ).' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test Theta Turn' write ( *, '(a)' ) '' do test = 1, test_num theta = 2.0D+00 * r8_pi * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) theta_degrees = 360.0D+00 * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) p1(1:dim_num) = (/ cos ( theta ), sin ( theta ) /) call angle_turn_2d ( p1, p2, p3, turn ) write ( *, '(2x,i4,2x,f5.0,2x,g14.6)' ) test, theta_degrees, turn end do return end subroutine annulus_sector_centroid_2d_test ( ) !*****************************************************************************80 ! !! annulus_sector_centroid_2d_test tests annulus_sector_centroid_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 December 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) centroid(dim_num) real ( kind = rk ) degrees_to_radians real ( kind = rk ), dimension(dim_num) :: pc = (/ 5.0D+00, 3.0D+00 /) real ( kind = rk ) :: r1 = 2.0D+00 real ( kind = rk ) :: r2 = 3.0D+00 real ( kind = rk ) theta1 real ( kind = rk ) theta2 theta1 = degrees_to_radians ( 30.0D+00 ) theta2 = degrees_to_radians ( 60.0D+00 ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'ANNULUS_SECTOR_CENTROID_2D_TEST' write ( *, '(a)' ) ' ANNULUS_SECTOR_CENTROID_2D computes the centroid of a' write ( *, '(a)' ) ' circular annulus.' write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' The annulus has center ', pc(1:2) write ( *, '(a,g14.6)' ) ' The inner radius is R1 = ', r1 write ( *, '(a,g14.6)' ) ' The outer radius is R2 = ', r2 write ( *, '(a,g14.6)' ) ' The first angle is THETA1 = ', theta1 write ( *, '(a,g14.6)' ) ' The second angle is THETA2 = ', theta2 call annulus_sector_centroid_2d ( pc, r1, r2, theta1, theta2, centroid ) write ( *, '(a)' ) '' write ( *, '(a,2f14.8)' ) ' Centroid: ', centroid(1:2) return end subroutine ball01_sample_2d_test ( ) !*****************************************************************************80 ! !! ball01_sample_2d_test tests ball01_sample_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) average(dim_num) real ( kind = rk ) average_r real ( kind = rk ) average_theta integer i integer, parameter :: sample_num = 1000 real ( kind = rk ) r8_atan real ( kind = rk ) theta real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'BALL01_SAMPLE_2D_TEST' write ( *, '(a)' ) ' BALL01_SAMPLE_2D samples the unit ball in 2 dimensions;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call ball01_sample_2d ( x ) write ( *, '(2x,2f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call ball01_sample_2d ( x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,2f8.4)' ) ' Average: ', average(1:dim_num) average_r = 0.0D+00 do i = 1, sample_num call ball01_sample_2d ( x ) average_r = average_r + sqrt ( sum ( x(1:dim_num)**2 ) ) end do average_r = average_r / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the distance of the points from' write ( *, '(a,f8.4)' ) ' the center, which should be 1/sqrt(2) = ', & 1.0D+00 / sqrt ( 2.0D+00 ) write ( *, '(a)' ) '' write ( *, '(a,2f8.4)' ) ' Average: ', average_r average_theta = 0.0D+00 do i = 1, sample_num call ball01_sample_2d ( x ) theta = r8_atan ( x(2), x(1) ) average_theta = average_theta + theta end do average_theta = average_theta / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the angle THETA,' write ( *, '(a)' ) ' which should be PI.' write ( *, '(a)' ) '' write ( *, '(a,2f8.4)' ) ' Average: ', average_theta return end subroutine ball01_sample_3d_test ( ) !*****************************************************************************80 ! !! ball01_sample_3d_test tests ball01_sample_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) average_phi real ( kind = rk ) average_r real ( kind = rk ) average_theta integer i integer, parameter :: sample_num = 1000 real ( kind = rk ) phi real ( kind = rk ) r real ( kind = rk ) r8_atan real ( kind = rk ) theta real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'BALL01_SAMPLE_3D_TEST' write ( *, '(a)' ) ' BALL01_SAMPLE_3D samples the unit ball in 3 dimensions;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call ball01_sample_3d ( x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call ball01_sample_3d ( x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) average_r = 0.0D+00 do i = 1, sample_num call ball01_sample_3d ( x ) r = sqrt ( sum ( x(1:dim_num)**2 ) ) average_r = average_r + r end do average_r = average_r / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the distance of the points from' write ( *, '(a,f8.4)' ) ' the center, which should be the ' write ( *, '(a,f8.4)' ) ' 1/2**(1/dim_num) = ', & 0.5D+00**( 1.0D+00 / real ( dim_num, kind = rk ) ) write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_r average_theta = 0.0D+00 do i = 1, sample_num call ball01_sample_3d ( x ) theta = r8_atan ( x(2), x(1) ) average_theta = average_theta + theta end do average_theta = average_theta / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the angle THETA,' write ( *, '(a)' ) ' which should be PI.' write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_theta average_phi = 0.0D+00 do i = 1, sample_num call ball01_sample_3d ( x ) r = sqrt ( sum ( x(1:dim_num)**2 ) ) phi = acos ( x(3) / r ) average_phi = average_phi + phi end do average_phi = average_phi / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the angle PHI,' write ( *, '(a)' ) ' which should be PI/2.' write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_phi return end subroutine ball01_sample_nd_test ( ) !*****************************************************************************80 ! !! ball01_sample_nd_test tests ball01_sample_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) average_phi real ( kind = rk ) average_r real ( kind = rk ) average_theta integer i integer, parameter :: sample_num = 1000 real ( kind = rk ) phi real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r real ( kind = rk ) r8_atan real ( kind = rk ) theta real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'BALL01_SAMPLE_ND_TEST' write ( *, '(a)' ) ' BALL01_SAMPLE_ND samples the unit ball in N dimensions;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call ball01_sample_nd ( dim_num, x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call ball01_sample_nd ( dim_num, x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as N increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) average_r = 0.0D+00 do i = 1, sample_num call ball01_sample_nd ( dim_num, x ) r = sqrt ( sum ( x(1:dim_num)**2 ) ) average_r = average_r + r end do average_r = average_r / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the distance of the points from' write ( *, '(a,f8.4)' ) ' the center, which should be the ' write ( *, '(a,f8.4)' ) ' 1/2**(1/dim_num) = ', & 0.5D+00**( 1.0D+00 / real ( dim_num, kind = rk ) ) write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_r average_theta = 0.0D+00 do i = 1, sample_num call ball01_sample_nd ( dim_num, x ) theta = r8_atan ( x(2), x(1) ) average_theta = average_theta + theta end do average_theta = average_theta / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the angle THETA,' write ( *, '(a)' ) ' which should be PI.' write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_theta average_phi = 0.0D+00 do i = 1, sample_num call ball01_sample_nd ( dim_num, x ) r = sqrt ( sum ( x(1:dim_num)**2 ) ) phi = acos ( x(3) / r ) average_phi = average_phi + phi end do average_phi = average_phi / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the angle PHI,' write ( *, '(a)' ) ' which should be PI/2.' write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Average: ', average_phi return end subroutine ball01_volume_test ( ) !*****************************************************************************80 ! !! ball01_volume_test tests ball01_volume. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ball01_volume real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'BALL01_VOLUME_TEST' write ( *, '(a)' ) ' BALL01_VOLUME returns the volume of the unit ball.' volume = ball01_volume ( ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Volume = ', volume return end subroutine basis_map_3d_test ( ) !*****************************************************************************80 ! !! basis_map_3d_test tests basis_map_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) real ( kind = rk ) c(3,3) integer ierror real ( kind = rk ), dimension ( 3, 3 ) :: u = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 0.0D+00, 2.0D+00 /), (/ 3, 3 /) ) real ( kind = rk ), dimension ( 3, 3 ) :: v = reshape ( (/ & 14.0D+00, 4.0D+00, 4.0D+00, & 3.0D+00, 1.0D+00, 0.0D+00, & 7.0D+00, 3.0D+00, 2.0D+00 /), (/ 3, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'BASIS_MAP_3D_TEST' write ( *, '(a)' ) ' BASIS_MAP_3D computes the linear transform A' write ( *, '(a)' ) ' which maps vectors U1, U2 and U3 to vectors' write ( *, '(a)' ) ' V1, V2 and V3.' call r8mat_print ( 3, 3, u, ' The matrix U' ) call r8mat_print ( 3, 3, v, ' The matrix V' ) call basis_map_3d ( u, v, a, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The matrix [ U1 | U2 | U3 ] was singular.' write ( *, '(a)' ) ' No transformation was computed.' return end if call r8mat_print ( 3, 3, a, ' The transformation matrix' ) c(1:3,1:3) = matmul ( a(1:3,1:3), u(1:3,1:3) ) call r8mat_print ( 3, 3, c, & ' The product matrix A * [ U1 | U2 | U3 ]' ) return end subroutine box_contains_point_2d_test ( ) !*****************************************************************************80 ! !! box_contains_point_2d_test tests box_contains_point_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 46 integer, parameter :: dim_num = 2 logical box_contains_point_2d character dot(n) integer i integer j real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ -0.1D+00, 0.3D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 1.1D+00, 0.9D+00 /) real ( kind = rk ), parameter :: xhi = 1.2D+00 real ( kind = rk ), parameter :: xlo = -0.3D+00 real ( kind = rk ), parameter :: yhi = 1.4D+00 real ( kind = rk ), parameter :: ylo = -0.1D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'BOX_CONTAINS_POINT_2D_TEST' write ( *, '(a)' ) ' BOX_CONTAINS_POINT_2D reports if a box' write ( *, '(a)' ) ' contains a point.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will call the function repeatedly, and draw' write ( *, '(a)' ) ' a sketch of the box.' write ( *, '(a)' ) '' do i = 1, n p(2) = ( real ( n - i, kind = rk ) * yhi & + real ( i - 1, kind = rk ) * ylo ) & / real ( n - 1, kind = rk ) do j = 1, n p(1) = ( real ( n - j, kind = rk ) * xlo & + real ( j - 1, kind = rk ) * xhi ) & / real ( n - 1, kind = rk ) if ( box_contains_point_2d ( p1, p2, p ) ) then dot(j) = '*' else dot(j) = '-' end if end do write ( *, '(2x,45a1)' ) dot(1:n) end do return end subroutine box_segment_clip_2d_test ( ) !*****************************************************************************80 ! !! box_segment_clip_2d_test tests box_segment_clip_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 5 integer ival real ( kind = rk ), dimension(dim_num) :: p1 = (/ -10.0D+00, 10.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 10.0D+00, 20.0D+00 /) real ( kind = rk ) pa(dim_num) real ( kind = rk ) pb(dim_num) real ( kind = rk ) qa(dim_num) real ( kind = rk ) qb(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = reshape ( (/ & 1.0D+00, 2.0D+00, & -3.0D+00, 12.0D+00, & -20.0D+00, 20.0D+00, & -20.0D+00, 40.0D+00, & 10.0D+00, 40.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = reshape ( (/ & 8.0D+00, 16.0D+00, & 5.0D+00, 12.0D+00, & 7.0D+00, 20.0D+00, & 0.0D+00, 0.0D+00, & 20.0D+00, 30.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'BOX_SEGMENT_CLIP_2D_TEST' write ( *, '(a)' ) ' BOX_SEGMENT_CLIP_2D clips a line with respect to a box.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The lower left box corner is:' write ( *, '(a)' ) '' write ( *, '(2x,4f8.4)' ) p1(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The upper right box corner is:' write ( *, '(a)' ) '' write ( *, '(2x,4f8.4)' ) p2(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' We list the points PA and PB, and then' write ( *, '(a)' ) ' the clipped values.' write ( *, '(a)' ) '' do test = 1, test_num pa(1:2) = p1_test(1:2,test) pb(1:2) = p2_test(1:2,test) qa(1:2) = pa(1:2) qb(1:2) = pb(1:2) call box_segment_clip_2d ( p1, p2, qa, qb, ival ) write ( *, '(a)' ) '' write ( *, '(2x,4f8.4)' ) pa(1:dim_num), pb(1:dim_num) if ( ival == -1 ) then write ( *, '(a)' ) ' Line is outside the box.' else if ( ival == 0 ) then write ( *, '(a)' ) ' Line is inside the box.' else if ( ival == 1 ) then write ( *, '(2x,2f8.4)' ) qa(1:dim_num) else if ( ival == 2 ) then write ( *, '(2x,16x,2f8.4)' ) qb(1:dim_num) else if ( ival == 3 ) then write ( *, '(2x,4f8.4)' ) qa(1:dim_num), qb(1:dim_num) end if end do return end subroutine box_ray_int_2d_test ( ) !*****************************************************************************80 ! !! box_ray_int_2d_test tests box_ray_int_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ), dimension(dim_num) :: p1 = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 5.0D+00, 3.0D+00 /) real ( kind = rk ) pa(1:dim_num) real ( kind = rk ), dimension(1:dim_num,test_num) :: pa_test = reshape ( (/ & 3.0D+00, 1.0D+00, & 4.0D+00, 1.0D+00, & 3.0D+00, 1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pb(1:dim_num) real ( kind = rk ), dimension(1:dim_num,test_num) :: pb_test = reshape ( (/ & 5.0D+00, 5.0D+00, & 3.0D+00, 1.0D+00, & 4.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(1:dim_num,test_num) :: pc_test = reshape ( (/ & 4.0D+00, 3.0D+00, & 0.0D+00, 1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pint(1:dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'BOX_RAY_INT_2D_TEST' write ( *, '(a)' ) ' For a box with coordinate line sides in 2D,' write ( *, '(a)' ) ' BOX_RAY_INT_2D computes the intersection of' write ( *, '(a)' ) ' a shape and a ray whose origin is within' write ( *, '(a)' ) ' the shape.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Lower left box corner:' write ( *, '(a)' ) '' write ( *, '(2x,2g14.6)' ) p1(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Upper right box corner:' write ( *, '(a)' ) '' write ( *, '(2x,2g14.6)' ) p2(1:dim_num) write ( *, '(a)' ) '' do test = 1, test_num pa(1:2) = pa_test(1:2,test) pb(1:2) = pb_test(1:2,test) call box_ray_int_2d ( p1, p2, pa, pb, pint ) write ( *, '(a)' ) '' write ( *, '(a,2f12.4)' ) ' Origin: ', pa(1:2) write ( *, '(a,2f12.4)' ) ' Point 2: ', pb(1:2) write ( *, '(a,2f12.4)' ) ' Intersection: ', pint(1:2) write ( *, '(a,2f12.4)' ) ' Correct: ', pc_test(1:2,test) end do return end subroutine box01_contains_point_2d_test ( ) !*****************************************************************************80 ! !! box01_contains_point_2d_test tests box01_contains_point_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 46 integer, parameter :: dim_num = 2 logical box01_contains_point_2d character dot(n) integer i integer j real ( kind = rk ) p(dim_num) real ( kind = rk ), parameter :: xhi = 1.2D+00 real ( kind = rk ), parameter :: xlo = -0.3D+00 real ( kind = rk ), parameter :: yhi = 1.4D+00 real ( kind = rk ), parameter :: ylo = -0.1D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'BOX01_CONTAINS_POINT_2D_TEST' write ( *, '(a)' ) ' BOX01_CONTAINS_POINT_2D reports if the unit box' write ( *, '(a)' ) ' contains a point.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will call the function repeatedly, and draw' write ( *, '(a)' ) ' a sketch of the unit square.' write ( *, '(a)' ) '' do i = 1, n p(2) = ( real ( n - i, kind = rk ) * yhi & + real ( i - 1, kind = rk ) * ylo ) & / real ( n - 1, kind = rk ) do j = 1, n p(1) = ( real ( n - j, kind = rk ) * xlo & + real ( j - 1, kind = rk ) * xhi ) & / real ( n - 1, kind = rk ) if ( box01_contains_point_2d ( p ) ) then dot(j) = '*' else dot(j) = '-' end if end do write ( *, '(2x,46a1)' ) dot(1:n) end do return end subroutine circle_area_2d_test ( ) !*****************************************************************************80 ! !! circle_area_2d_test() tests circle_area_2d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 September 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area integer i real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_area_2d_test' write ( *, '(a)' ) ' circle_area_2d computes the area of a circle of radius R.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' R Area' write ( *, '(a)' ) '' r = 1.0D+00 do i = 1, 4 call circle_area_2d ( r, area ) write ( *, '(2x,f10.4,2x,f10.4)' ) r, area r = r * 2.0D+00 end do return end subroutine circle_dia2imp_2d_test ( ) !*****************************************************************************80 ! !! CIRCLE_DIA2IMP_2D_TEST tests CIRCLE_DIA2IMP_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) pc(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) r real ( kind = rk ) theta write ( *, '(a)' ) '' write ( *, '(a)' ) 'CIRCLE_DIA2IMP_2D_TEST' write ( *, '(a)' ) ' CIRCLE_DIA2IMP_2D converts a diameter to an' write ( *, '(a)' ) ' implicit circle in 2D.' theta = 2.0D+00 p1(1:dim_num) = 2.0D+00 + 5.0D+00 * (/ cos ( theta ), sin ( theta ) /) p2(1:dim_num) = 2.0D+00 - 5.0D+00 * (/ cos ( theta ), sin ( theta ) /) call r8vec_print ( dim_num, p1, ' P1:' ) call r8vec_print ( dim_num, p2, ' P2:' ) call circle_dia2imp_2d ( p1, p2, r, pc ) call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) return end subroutine circle_exp_contains_point_2d_test ( ) !*****************************************************************************80 ! !! circle_exp_contains_point_2d_test tests circle_exp_contains_point_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer inside character ( len = 60 ) message(-1:7) real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) message(-1) = 'The point is inside the circle.' message(0) = 'The point is on the circle.' message(1) = 'The point is outside the circle' message(2) = 'Colinear data, the point is on the line.' message(3) = 'Colinear data, the point is not on the line.' message(4) = 'Two equal data points, the point is on the line.' message(5) = 'Two equal data points, the point is not on the line.' message(6) = 'All data points equal, the point is equal.' message(7) = 'All data points equal, the point is not equal.' write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_exp_contains_point_2d_test' write ( *, '(a)' ) ' circle_exp_contains_point_2d determines if a' write ( *, '(a)' ) ' point lies inside a circle.' ! ! This point is inside. ! p1(1:dim_num) = (/ 4.0D+00, 2.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 5.0D+00 /) p3(1:dim_num) = (/ -2.0D+00, 2.0D+00 /) p(1:dim_num) = (/ 2.0D+00, 3.0D+00 /) call r8vec_print ( dim_num, p1, ' P1:' ) call r8vec_print ( dim_num, p2, ' P2:' ) call r8vec_print ( dim_num, p3, ' P3:' ) call r8vec_print ( dim_num, p, ' P:' ) call circle_exp_contains_point_2d ( p1, p2, p3, p, inside ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' INSIDE = ', inside write ( *, '(2x,a)' ) message(inside) ! ! This point is actually right on the circle. ! p1(1:dim_num) = (/ 4.0D+00, 2.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 5.0D+00 /) p3(1:dim_num) = (/ -2.0D+00, 2.0D+00 /) p(1:dim_num) = (/ 1.0D+00, -1.0D+00 /) call r8vec_print ( dim_num, p1, ' P1:' ) call r8vec_print ( dim_num, p2, ' P2:' ) call r8vec_print ( dim_num, p3, ' P3:' ) call r8vec_print ( dim_num, p, ' P:' ) call circle_exp_contains_point_2d ( p1, p2, p3, p, inside ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' INSIDE = ', inside write ( *, '(2x,a)' ) message(inside) ! ! This point is outside. ! p1(1:dim_num) = (/ 4.0D+00, 2.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 5.0D+00 /) p3(1:dim_num) = (/ -2.0D+00, 2.0D+00 /) p(1:dim_num) = (/ 4.0D+00, 6.0D+00 /) call r8vec_print ( dim_num, p1, ' P1:' ) call r8vec_print ( dim_num, p2, ' P2:' ) call r8vec_print ( dim_num, p3, ' P3:' ) call r8vec_print ( dim_num, p, ' P:' ) call circle_exp_contains_point_2d ( p1, p2, p3, p, inside ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' INSIDE = ', inside write ( *, '(2x,a)' ) message(inside) return end subroutine circle_exp2imp_2d_test ( ) !*****************************************************************************80 ! !! circle_exp2imp_2d_test tests circle_exp2imp_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 March 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) curvature real ( kind = rk ) pc(2) real ( kind = rk ) p1(2) real ( kind = rk ) p2(2) real ( kind = rk ) p3(2) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) r real ( kind = rk ) theta real ( kind = rk ) theta_degrees integer test integer, parameter :: test_num = 13 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_exp2imp_2d_test' write ( *, '(a)' ) ' circle_exp2imp_2d() computes the radius and ' write ( *, '(a)' ) ' center of the circle through three points.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We can use this routine to compute, for three' write ( *, '(a)' ) ' points in space, the circle incident to those' write ( *, '(a)' ) ' points, and hence the radius of that circle,' write ( *, '(a)' ) ' and hence the curvature of those points.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Our three points are:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' (0,0)' write ( *, '(a)' ) ' (1,0)' write ( *, '(a)' ) ' (C,S)' write ( *, '(a)' ) '' write ( *, '(a)' ) ' C = cosine ( theta), S = sine ( theta ).' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test Theta Curvature' write ( *, '(a)' ) '' p1 = (/ 0.0D+00, 0.0D+00 /) p2 = (/ 1.0D+00, 0.0D+00 /) do test = 1, test_num theta = 2.0D+00 * r8_pi * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) theta_degrees = 360.0D+00 * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) p3 = (/ cos ( theta ), sin ( theta ) /) call circle_exp2imp_2d ( p1, p2, p3, r, pc ) if ( 0.0D+00 < r ) then curvature = 1.0D+00 / r else curvature = 0.0D+00 end if write ( *, '(2x,i4,2x,f5.0,2x,g14.6)' ) test, theta_degrees, curvature end do return end subroutine circle_imp_line_exp_dist_2d_test ( ) !*****************************************************************************80 ! !! circle_imp_line_exp_dist_2d_test tests circle_imp_line_exp_dist_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) dist real ( kind = rk ) p1(2) real ( kind = rk ) p2(2) real ( kind = rk ) pc(2) real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_line_exp_dist_2d_test' write ( *, '(a)' ) ' circle_imp_line_exp_dist_2d() finds the distance' write ( *, '(a)' ) ' between an implicit circle and an explicit line.' r = 5.0D+00 pc = (/ 5.0D+00, 2.0D+00 /) call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) p1 = (/ 13.0D+00, 8.0D+00 /) p2 = (/ 17.0D+00, 11.0D+00/) call line_exp_print_2d ( p1, p2, ' The explicit line:' ) call circle_imp_line_exp_dist_2d ( r, pc, p1, p2, dist ) write ( *, '(a)' ) '' write ( *, '(a,f8.4)' ) ' Distance is ', dist return end subroutine circle_imp_line_exp_intersect_test ( ) !*****************************************************************************80 ! !! circle_imp_line_exp_intersect_test tests circle_imp_line_exp_intersect. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer int_num integer j real ( kind = rk ) p(2,2) real ( kind = rk ) p1(2) real ( kind = rk ) p2(2) real ( kind = rk ) pc(2) real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_line_exp_intersect_test' write ( *, '(a)' ) ' circle_imp_line_exp_intersect() finds the intersection' write ( *, '(a)' ) ' of an implicit circle and an explicit line.' r = 5.0D+00 pc = (/ 5.0D+00, 2.0D+00 /) call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) p1 = (/ 13.0D+00, 8.0D+00 /) p2 = (/ 17.0D+00, 11.0D+00/) call line_exp_print_2d ( p1, p2, ' The explicit line:' ) call circle_imp_line_exp_intersect ( r, pc, p1, p2, int_num, p ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' Number of intersections found = ', int_num do j = 1, int_num write ( *, '(2x,i1,2x,f8.4,2x,f8.4)' ) j, p(1,j), p(2,j) end do return end subroutine circle_imp_line_par_int_2d_test ( ) !*****************************************************************************80 ! !! circle_imp_line_par_int_2d_test tests circle_imp_line_par_int_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) f real ( kind = rk ) g integer int_num integer j real ( kind = rk ) p(2,2) real ( kind = rk ) pc(2) real ( kind = rk ) r real ( kind = rk ) x0 real ( kind = rk ) y0 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_line_par_int_2d_test' write ( *, '(a)' ) ' circle_imp_line_par_int_2d finds the intersection' write ( *, '(a)' ) ' of an implicit circle and a parametric line.' r = 5.0D+00 pc = (/ 5.0D+00, 2.0D+00 /) call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) f = 0.8D+00 g = 0.6D+00 x0 = 13.0D+00 y0 = 8.0D+00 call line_par_print_2d ( f, g, x0, y0, ' The parametric line' ) call circle_imp_line_par_int_2d ( r, pc, x0, y0, f, g, int_num, p ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' Number of intersections found = ', int_num do j = 1, int_num write ( *, '(2x,i1,2x,f8.4,2x,f8.4)' ) j, p(1,j), p(2,j) end do return end subroutine circle_imp_point_dist_2d_test ( ) !*****************************************************************************80 ! !! circle_imp_point_dist_2d_test tests circle_imp_point_dist_2d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) d real ( kind = rk ) center(2) integer i real ( kind = rk ) p(2) real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_point_dist_2d_test' write ( *, '(a)' ) ' circle_imp_point_dist_2d() finds the' write ( *, '(a)' ) ' distance from a point to a circle.' r = 5.0D+00 center = (/ 0.0D+00, 0.0D+00 /) call circle_imp_print_2d ( r, center, ' The circle:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y D' write ( *, '(a)' ) '' do i = 1, 10 call r8vec_uniform_ab ( 2, -10.0D+00, +10.0D+00, p ) call circle_imp_point_dist_2d ( r, center, p, d ) write ( *, '(2x,3f8.4)' ) p(1:2), d end do return end subroutine circle_imp_points_2d_test ( ) !*****************************************************************************80 ! !! circle_imp_points_2d_test tests circle_imp_points_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer n real ( kind = rk ), allocatable, dimension ( :, : ) :: p real ( kind = rk ) pc(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) :: r = 2.0D+00 real ( kind = rk ) result pc(1:2) = (/ 5.0D+00, -2.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_points_2d_test' write ( *, '(a)' ) ' circle_imp_points_2d() gets points on a circle;' call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' The area = ', pi * r * r n = 8 allocate ( p(1:dim_num,1:n) ) call circle_imp_points_2d ( r, pc, n, p ) call r8mat_transpose_print ( dim_num, n, p, ' Sample results:' ) deallocate ( p ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' For any N, the sampled points define a polygon' write ( *, '(a)' ) ' whose area approximates the circle area.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' N Area' write ( *, '(a)' ) '' do n = 3, 24 allocate ( p(1:dim_num,1:n) ) call circle_imp_points_2d ( r, pc, n, p ) call polygon_area_2d ( n, p, result ) write ( *, '(2x,i8,2x,g14.6)' ) n, result deallocate ( p ) end do return end subroutine circle_imp_points_3d_test ( ) !*****************************************************************************80 ! !! circle_imp_points_3d_test tests circle_imp_points_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: n = 12 real ( kind = rk ), dimension ( dim_num ) :: nc = (/ & 1.0D+00, 1.0D+00, 1.0D+00 /) real ( kind = rk ), dimension(dim_num,n) :: p real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 5.0D+00, -2.0D+00, 1.0D+00 /) real ( kind = rk ) :: r = 2.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_points_3d_test' write ( *, '(a)' ) ' circle_imp_points_3d() gets points on a circle in 3D;' call circle_imp_print_3d ( r, pc, nc, ' The implicit circle:' ) call circle_imp_points_3d ( r, pc, nc, n, p ) call r8mat_transpose_print ( dim_num, n, p, ' Points on the circle:' ) return end subroutine circle_imp_points_arc_2d_test ( ) !*****************************************************************************80 ! !! circle_imp_points_arc_2d_test tests circle_imp_points_arc_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 13 integer, parameter :: dim_num = 2 real ( kind = rk ) p(dim_num,n) real ( kind = rk ) pc(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) :: r = 2.0D+00 real ( kind = rk ) theta1 real ( kind = rk ) theta2 pc(1:2) = (/ 5.0D+00, -2.0D+00 /) theta1 = pi / 2.0D+00 theta2 = 3.0D+00 * pi / 2.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_points_arc_2d_test' write ( *, '(a)' ) ' circle_imp_points_arc_2d() returns points on a' write ( *, '(a)' ) ' circular arc.' call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' The arc extends from THETA1 = ', theta1 write ( *, '(a,2g14.6)' ) ' to THETA2 = ', theta2 call circle_imp_points_arc_2d ( r, pc, theta1, theta2, n, p ) call r8mat_transpose_print ( dim_num, n, p, ' Sample results:' ) return end subroutine circle_imp_segment_intersect_test ( ) !*****************************************************************************80 ! !! circle_imp_segment_intersect_test tests circle_imp_segment_intersect. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer int_num integer j real ( kind = rk ) p(2,2) real ( kind = rk ) p1(2) real ( kind = rk ) p2(2) real ( kind = rk ) pc(2) real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp_segment_intersect_test' write ( *, '(a)' ) ' circle_imp_segment_intersect() finds the intersection' write ( *, '(a)' ) ' of an implicit circle and a line segment.' r = 5.0D+00 pc = (/ 5.0D+00, 2.0D+00 /) call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) do i = 1, 3 if ( i == 1 ) then p1 = (/ 13.0D+00, 8.0D+00 /) p2 = (/ 17.0D+00, 11.0D+00 /) else if ( i == 2 ) then p1 = (/ -3.0D+00, -4.0D+00 /) p2 = (/ 17.0D+00, 11.0D+00 /) else if ( i == 3 ) then p1 = (/ -3.0D+00, -4.0D+00 /) p2 = (/ 5.0D+00, 2.0D+00 /) end if call line_exp_print_2d ( p1, p2, ' The line segment:' ) call circle_imp_segment_intersect ( r, pc, p1, p2, int_num, p ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' Number of intersections found = ', int_num do j = 1, int_num write ( *, '(2x,i1,2x,f8.4,2x,f8.4)' ) j, p(1,j), p(2,j) end do end do return end subroutine circle_imp2exp_2d_test ( ) !*****************************************************************************80 ! !! circle_imp2exp_2d_test tests circle_imp2exp_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) real ( kind = rk ) pc1(dim_num) real ( kind = rk ) pc2(dim_num) real ( kind = rk ) r1 real ( kind = rk ) r2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_imp2exp_2d_test' write ( *, '(a)' ) ' circle_imp2exp_2d() converts an implicit circle' write ( *, '(a)' ) ' to an explicit circle.' pc1(1) = 10.0D+00 pc1(2) = 5.0D+00 r1 = 3.0D+00 call circle_imp_print_2d ( r1, pc1, ' The implicit circle:' ) call circle_imp2exp_2d ( r1, pc1, p1, p2, p3 ) call r8vec_print ( dim_num, p1, ' P1:' ) call r8vec_print ( dim_num, p2, ' P2:' ) call r8vec_print ( dim_num, p3, ' P3:' ) call circle_exp2imp_2d ( p1, p2, p3, r2, pc2 ) call circle_imp_print_2d ( r2, pc2, ' The recovered implicit circle:' ) return end subroutine circle_llr2imp_2d_test ( ) !*****************************************************************************80 ! !! circle_llr2imp_2d_test tests circle_llr2imp_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) :: d1 real ( kind = rk ) :: d2 real ( kind = rk ) :: d3 real ( kind = rk ) :: d4 real ( kind = rk ) :: p_hi = 10.0D+00 real ( kind = rk ) :: p_lo = -10.0D+00 real ( kind = rk ) pc(dim_num,4) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) q1(dim_num) real ( kind = rk ) q2(dim_num) real ( kind = rk ) r real ( kind = rk ) r_hi real ( kind = rk ) r_lo real ( kind = rk ) r8_uniform_ab integer test integer, parameter :: test_num = 5 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_llr2imp_2d_test' write ( *, '(a)' ) ' circle_llr2imp_2d() is given:' write ( *, '(a)' ) ' an explicit line through P1 and P2,' write ( *, '(a)' ) ' an explicit line through Q1 and Q2,' write ( *, '(a)' ) ' and a radius R,' write ( *, '(a)' ) ' and determines the centers C of 4 circles' write ( *, '(a)' ) ' of the given radius, tangent to both lines.' do test = 1, test_num call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p1 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p2 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, q1 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, q2 ) r_lo = 1.0D+00 r_hi = 5.0D+00 r = r8_uniform_ab ( r_lo, r_hi ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r call line_exp_print_2d ( p1, p2, ' The first explicit line:' ) call line_exp_print_2d ( q1, q2, ' The second explicit line:' ) call circle_llr2imp_2d ( p1, p2, q1, q2, r, pc ) write ( *, '(a,2g14.6)' ) ' Center #1: ', pc(1:dim_num,1) write ( *, '(a,2g14.6)' ) ' Center #2: ', pc(1:dim_num,2) write ( *, '(a,2g14.6)' ) ' Center #3: ', pc(1:dim_num,3) write ( *, '(a,2g14.6)' ) ' Center #4: ', pc(1:dim_num,4) call line_exp_point_dist_2d ( p1, p2, pc(1:dim_num,1), d1 ) call line_exp_point_dist_2d ( p1, p2, pc(1:dim_num,2), d2 ) call line_exp_point_dist_2d ( p1, p2, pc(1:dim_num,3), d3 ) call line_exp_point_dist_2d ( p1, p2, pc(1:dim_num,4), d4 ) write ( *, '(2x,4g14.6)' ) d1, d2, d3, d4 call line_exp_point_dist_2d ( q1, q2, pc(1:dim_num,1), d1 ) call line_exp_point_dist_2d ( q1, q2, pc(1:dim_num,2), d2 ) call line_exp_point_dist_2d ( q1, q2, pc(1:dim_num,3), d3 ) call line_exp_point_dist_2d ( q1, q2, pc(1:dim_num,4), d4 ) write ( *, '(2x,4g14.6)' ) d1, d2, d3, d4 end do return end subroutine circle_lune_angle_by_height_2d_test ( ) !*****************************************************************************80 ! !! circle_lune_angle_by_height_2d_test tests circle_lune_angle_by_height_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) angle real ( kind = rk ) h integer i integer n_test real ( kind = rk ) r n_test = 6 r = 2.0 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_lune_angle_by_height_2d_test' write ( *, '(a)' ) ' circle_lune_angle_by_height_2d() computes the angle of a' write ( *, '(a)' ) ' circular lune based on the "height" of the circular triangle.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' R H Angle' write ( *, '(a)' ) '' do i = - n_test, n_test h = real ( i, kind = rk ) * r / real ( n_test, kind = rk ) call circle_lune_angle_by_height_2d ( r, h, angle ) write ( *, '(3f12.4)' ) r, h, angle end do return end subroutine circle_lune_area_by_angle_2d_test ( ) !*****************************************************************************80 ! !! circle_lune_area_by_angle_2d_test tests circle_lune_area_by_angle_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ), dimension(2) :: pc = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) :: r = 1.0D+00 integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_lune_area_by_angle_2d_test' write ( *, '(a)' ) ' circle_lune_area_by_angle_2d() computes the area of a' write ( *, '(a)' ) ' circular lune, defined by joining the endpoints' write ( *, '(a)' ) ' of a circular arc.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' R Theta1 Theta2 Area' write ( *, '(a)' ) '' do test = 0, test_num theta1 = 0.0D+00 theta2 = real ( test, kind = rk ) * 2.0D+00 * pi & / real ( test_num, kind = rk ) call circle_lune_area_by_angle_2d ( r, pc, theta1, theta2, area ) write ( *, '(2x,4f12.6)' ) r, theta1, theta2, area end do return end subroutine circle_lune_area_by_height_2d_test ( ) !*****************************************************************************80 ! !! circle_lune_area_by_height_2d_test tests circle_lune_area_by_height_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ) h integer i integer, parameter :: n_test = 6 real ( kind = rk ) :: r = 2.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_lune_area_by_height_2d_test' write ( *, '(a)' ) ' circle_lune_area_by_height_2d() computes the area of a' write ( *, '(a)' ) ' circular lune based on the "height" of the circular' write ( *, '(a)' ) ' triangle.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' R H Area' write ( *, '(a)' ) '' do i = - n_test, n_test h = real ( i, kind = rk ) * r / real ( n_test, kind = rk ) call circle_lune_area_by_height_2d ( r, h, area ) write ( *, '(2x,3f12.6)' ) r, h, area end do return end subroutine circle_lune_centroid_2d_test ( ) !*****************************************************************************80 ! !! circle_lune_centroid_2d_test tests circle_lune_centroid_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) centroid(dim_num) real ( kind = rk ) pc(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 r = 2.0D+00 pc(1:2) = (/ 5.0D+00, 3.0D+00 /) theta1 = 0.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_lune_centroid_2d_test' write ( *, '(a)' ) ' circle_lune_centroid_2d() computes the centroid of a' write ( *, '(a)' ) ' circular lune, defined by joining the endpoints' write ( *, '(a)' ) ' of a circular arc.' call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The first angle of our lune is always 0.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Lune' write ( *, '(a)' ) ' THETA2 X Y' write ( *, '(a)' ) '' do test = 0, test_num theta2 = real ( test, kind = rk ) * 2.0D+00 * pi & / real ( test_num, kind = rk ) call circle_lune_centroid_2d ( r, pc, theta1, theta2, centroid ) write ( *, '(2x,3f14.8)' ) theta2, centroid(1:2) end do return end subroutine circle_lune_height_by_angle_2d_test ( ) !*****************************************************************************80 ! !! circle_lune_height_by_angle_2d_test tests circle_lune_height_by_angle_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) angle real ( kind = rk ) height integer i integer n_test real ( kind = rk ) r real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 n_test = 12 r = 2.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_lune_height_by_angle_2d_test' write ( *, '(a)' ) ' circle_lune_height_by_angle_2d() computes the height of' write ( *, '(a)' ) ' the triangle of a circular lune, given the subtended angle.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' R Angle Height' write ( *, '(a)' ) '' do i = 0, n_test angle = real ( i, kind = rk ) * 2.0D+00 * r8_pi / real ( n_test, kind = rk ) call circle_lune_height_by_angle_2d ( r, angle, height ) write ( *, '(3f12.4)' ) r, angle, height end do return end subroutine circle_pppr2imp_3d_test ( ) !*****************************************************************************80 ! !! circle_pppr2imp_3d_test tests circle_pppr2imp_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) :: d11 real ( kind = rk ) :: d12 real ( kind = rk ) :: d21 real ( kind = rk ) :: d22 real ( kind = rk ) :: p_hi = 10.0D+00 real ( kind = rk ) :: p_lo = -10.0D+00 real ( kind = rk ) normal(dim_num) real ( kind = rk ) pc(dim_num,2) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) real ( kind = rk ) r real ( kind = rk ) r_hi real ( kind = rk ) r_lo real ( kind = rk ) r8_uniform_ab integer test integer, parameter :: test_num = 5 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_pppr2imp_3d_test' write ( *, '(a)' ) ' circle_pppr2imp_3d() is given 3D points P1, P2, P3,' write ( *, '(a)' ) ' and a radius R,' write ( *, '(a)' ) ' and determines the centers C of two circles' write ( *, '(a)' ) ' of the given radius, passing through P1 and P2' write ( *, '(a)' ) ' and lying in the plane of P1, P2 and P3.' do test = 1, test_num call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p1 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p2 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p3 ) r_lo = sqrt ( sum ( ( p1(1:dim_num) - p2(1:dim_num) )**2 ) ) r_hi = r_lo + 5.0D+00 r = r8_uniform_ab ( r_lo, r_hi ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Point #1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Point #2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' Point #3: ', p3(1:dim_num) call circle_pppr2imp_3d ( p1, p2, p3, r, pc, normal ) write ( *, '(a,3g14.6)' ) ' Center #1: ', pc(1:dim_num,1) write ( *, '(a,3g14.6)' ) ' Center #2: ', pc(1:dim_num,2) ! ! Check that the points are the right distance from the center. ! d11 = sqrt ( sum ( ( p1(1:dim_num) - pc(1:dim_num,1) )**2 ) ) d21 = sqrt ( sum ( ( p2(1:dim_num) - pc(1:dim_num,1) )**2 ) ) d12 = sqrt ( sum ( ( p1(1:dim_num) - pc(1:dim_num,2) )**2 ) ) d22 = sqrt ( sum ( ( p2(1:dim_num) - pc(1:dim_num,2) )**2 ) ) write ( *, '(2x,4g14.6)' ) d11, d21, d12, d22 ! ! Check that the radial vector to the point is perpendicular to NORMAL. ! d11 = dot_product ( normal(1:dim_num), p1(1:dim_num) - pc(1:dim_num,1) ) d21 = dot_product ( normal(1:dim_num), p2(1:dim_num) - pc(1:dim_num,1) ) d12 = dot_product ( normal(1:dim_num), p1(1:dim_num) - pc(1:dim_num,2) ) d22 = dot_product ( normal(1:dim_num), p2(1:dim_num) - pc(1:dim_num,2) ) write ( *, '(2x,4g14.6)' ) d11, d21, d12, d22 end do return end subroutine circle_ppr2imp_2d_test ( ) !*****************************************************************************80 ! !! circle_ppr2imp_2d_test tests circle_ppr2imp_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 November 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) :: d11 real ( kind = rk ) :: d12 real ( kind = rk ) :: d21 real ( kind = rk ) :: d22 real ( kind = rk ) :: p_hi = 10.0D+00 real ( kind = rk ) :: p_lo = -10.0D+00 real ( kind = rk ) pc(dim_num,2) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) r real ( kind = rk ) r_hi real ( kind = rk ) r_lo real ( kind = rk ) r8_uniform_ab integer test integer, parameter :: test_num = 5 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_ppr2imp_2d_test' write ( *, '(a)' ) ' circle_ppr2imp_2d() is given 2D points P1 and P2,' write ( *, '(a)' ) ' and a radius R,' write ( *, '(a)' ) ' and determines the centers C of two circles' write ( *, '(a)' ) ' of the given radius, passing through P1 and P2.' do test = 1, test_num call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p1 ) call r8vec_uniform_ab ( dim_num, p_lo, p_hi, p2 ) r_lo = sqrt ( sum ( ( p1(1:dim_num) - p2(1:dim_num) )**2 ) ) r_hi = r_lo + 5.0D+00 r = r8_uniform_ab ( r_lo, r_hi ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,2g14.6)' ) ' Point #1: ', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' Point #2: ', p2(1:dim_num) call circle_ppr2imp_2d ( p1, p2, r, pc ) write ( *, '(a,2g14.6)' ) ' Center #1: ', pc(1:dim_num,1) write ( *, '(a,2g14.6)' ) ' Center #2: ', pc(1:dim_num,2) d11 = sqrt ( sum ( ( p1(1:dim_num) - pc(1:dim_num,1) )**2 ) ) d21 = sqrt ( sum ( ( p2(1:dim_num) - pc(1:dim_num,1) )**2 ) ) d12 = sqrt ( sum ( ( p1(1:dim_num) - pc(1:dim_num,2) )**2 ) ) d22 = sqrt ( sum ( ( p2(1:dim_num) - pc(1:dim_num,2) )**2 ) ) write ( *, '(2x,4g14.6)' ) d11, d21, d12, d22 end do return end subroutine circle_sector_area_2d_test ( ) !*****************************************************************************80 ! !! circle_sector_area_2d_test tests circle_sector_area_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ), dimension(2) :: pc = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) :: r = 1.0D+00 integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_sector_area_2d_test' write ( *, '(a)' ) ' circle_sector_area_2d() computes the area of a' write ( *, '(a)' ) ' circular sector, defined by joining the endpoints' write ( *, '(a)' ) ' of a circular arc to the center.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' R Theta1 Theta2 Area' write ( *, '(a)' ) '' do test = 0, test_num theta1 = 0.0D+00 theta2 = real ( test, kind = rk ) * 2.0D+00 * r8_pi & / real ( test_num, kind = rk ) call circle_sector_area_2d ( r, pc, theta1, theta2, area ) write ( *, '(2x,4f12.6)' ) r, theta1, theta2, area end do return end subroutine circle_sector_centroid_2d_test ( ) !*****************************************************************************80 ! !! circle_sector_centroid_2d_test tests circle_sector_centroid_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) centroid(dim_num) real ( kind = rk ) pc(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 r = 2.0D+00 pc(1:2) = (/ 5.0D+00, 3.0D+00 /) theta1 = 0.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_sector_centroid_2d_test' write ( *, '(a)' ) ' circle_sector_centroid_2d() computes the centroid of a' write ( *, '(a)' ) ' circular sector, defined by joining the endpoints' write ( *, '(a)' ) ' of a circular arc to the center.' call circle_imp_print_2d ( r, pc, ' The implicit circle:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The first angle of our sector is always 0.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Sector' write ( *, '(a)' ) ' THETA2 X Y' write ( *, '(a)' ) '' do test = 0, test_num theta2 = real ( test, kind = rk ) * 2.0D+00 * pi & / real ( test_num, kind = rk ) call circle_sector_centroid_2d ( r, pc, theta1, theta2, centroid ) write ( *, '(2x,3f14.8)' ) theta2, centroid(1:2) end do return end subroutine circle_triangle_area_2d_test ( ) !*****************************************************************************80 ! !! circle_triangle_area_2d_test tests circle_triangle_area_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ), dimension(2) :: pc = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) :: r = 1.0D+00 integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_triangle_area_2d_test' write ( *, '(a)' ) ' circle_triangle_area_2d() computes the signed area of a' write ( *, '(a)' ) ' triangle, defined by joining the endpoints' write ( *, '(a)' ) ' of a circular arc and the center.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' R Theta1 Theta2 Sector Triangle Lune' write ( *, '(a)' ) '' do test = 0, test_num theta1 = 0.0D+00 theta2 = real ( test, kind = rk ) * 2.0D+00 * pi & / real ( test_num, kind = rk ) call circle_triangle_area_2d ( r, pc, theta1, theta2, area ) write ( *, '(2x,4f12.6)' ) r, theta1, theta2, area end do return end subroutine circle_triple_angles_2d_test ( ) !*****************************************************************************80 ! !! circle_triple_angles_2d_test tests circle_triple_angles_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 September 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) angle1 real ( kind = rk ) angle2 real ( kind = rk ) angle3 integer i4_uniform_ab real ( kind = rk ) r1 real ( kind = rk ) r2 real ( kind = rk ) r3 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'circle_triple_angles_2d_test' write ( *, '(a)' ) ' circle_triple_angles_2d() computes the angles' write ( *, '(a)' ) ' in the triangle formed by the centers of 3' write ( *, '(a)' ) ' cotangent circles of radius r1, r2, r3.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' R1 R2 R3 A1 A2 A3' write ( *, '(a)' ) '' do test = 1, 10 r1 = real ( i4_uniform_ab ( 1, 5 ), kind = rk ) r2 = real ( i4_uniform_ab ( 1, 5 ), kind = rk ) r3 = real ( i4_uniform_ab ( 1, 5 ), kind = rk ) call circle_triple_angles_2d ( r1, r2, r3, angle1, angle2, angle3 ) write ( *, '(2x,6f8.4)' ) r1, r2, r3, angle1, angle2, angle3 end do return end subroutine circles_intersect_points_2d_test ( ) !*****************************************************************************80 ! !! CIRCLES_INTERSECT_POINTS_2D_TEST tests CIRCLES_INTERSECT_POINTS_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 5 integer int_num real ( kind = rk ), dimension(2) :: pc1 = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ) pc2(2) real ( kind = rk ), parameter, dimension (2,test_num) :: & pc2_test = reshape ( (/ & 5.0D+00, 5.0D+00, & 7.0710678D+00, 7.0710678D+00, & 4.0D+00, 0.0D+00, & 6.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ 2, test_num /) ) real ( kind = rk ) pint(2,2) real ( kind = rk ), parameter :: r1 = 5.0D+00 real ( kind = rk ) r2 real ( kind = rk ), parameter, dimension ( test_num ) :: r2_test = & (/ 0.5D+00, 5.0D+00, 3.0D+00, 3.0D+00, 5.0D+00 /) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'CIRCLES_INTERSECT_POINTS_2D_TEST' write ( *, '(a)' ) ' CIRCLE_INTERSECT_POINTS_2D determines intersection' write ( *, '(a)' ) ' points of two circles in 2D.' call circle_imp_print_2d ( r1, pc1, ' The first circle:' ) do test = 1, test_num r2 = r2_test(test) pc2(1:2) = pc2_test(1:2,test) call circle_imp_print_2d ( r2, pc2, ' The second circle:' ) call circles_intersect_points_2d ( r1, pc1, r2, pc2, int_num, pint ) if ( int_num == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The circles do not intersect.' else if ( int_num == 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The circles intersect at one point:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P' write ( *, '(a)' ) '' write ( *, '(2x,2f8.4)' ) pint(1:2,1) else if ( int_num == 2 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The circles intersect at two points:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P' write ( *, '(a)' ) '' write ( *, '(2x,4f8.4)' ) pint(1:2,1) write ( *, '(2x,2f8.4)' ) pint(1:2,2) else if ( int_num == 3 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The circles coincide (infinite intersection).' end if end do return end subroutine test020 ( ) !*****************************************************************************80 ! !! TEST020 tests CUBE_SIZE_3D and CUBE_SHAPE_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer edge_num integer face_num integer, allocatable, dimension ( : ) :: face_order integer face_order_max integer, allocatable, dimension ( :, : ) :: face_point integer point_num real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST020' write ( *, '(a)' ) ' CUBE_SIZE_3D returns dimension information for a cube;' write ( *, '(a)' ) ' CUBE_SHAPE_3D returns face and order information.' write ( *, '(a)' ) ' SHAPE_PRINT_3D prints this information.' ! ! Get the data sizes. ! call cube_size_3d ( point_num, edge_num, face_num, face_order_max ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num write ( *, '(a,i8)' ) ' Number of edges = ', edge_num write ( *, '(a,i8)' ) ' Number of faces = ', face_num write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max ! ! Make room for the data. ! allocate ( face_order(1:face_num) ) allocate ( face_point(1:face_order_max,1:face_num) ) allocate ( point_coord(1:3,1:point_num) ) ! ! Get the data. ! call cube_shape_3d ( point_num, face_num, face_order_max, point_coord, & face_order, face_point ) ! ! Print the data. ! call shape_print_3d ( point_num, face_num, face_order_max, & point_coord, face_order, face_point ) deallocate ( face_order ) deallocate ( face_point ) deallocate ( point_coord ) return end subroutine cube01_volume_test ( ) !*****************************************************************************80 ! !! CUBE01_VOLUME_TEST tests CUBE01_VOLUME. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) cube01_volume real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'CUBE01_VOLUME_TEST' write ( *, '(a)' ) ' CUBE01_VOLUME returns the volume of the unit cube.' volume = cube01_volume ( ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Volume = ', volume return end subroutine cylinder_point_dist_3d_test ( ) !*****************************************************************************80 ! !! cylinder_point_dist_3d_test tests cylinder_point_dist_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) :: dist real ( kind = rk ), dimension ( test_num ) :: dist_test = (/ & 3.0D+00, 0.5D+00, 5.0D+00, 8.0D+00, 1.0D+00, 0.25D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 4.0D+00, 0.5D+00, 0.0D+00, & -0.5D+00, -1.0D+00, 0.0D+00, & 4.0D+00, 6.0D+00, 0.0D+00, & 0.75D+00, -10.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.25D+00, 1.75D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, -2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ) :: r = 1.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_point_dist_3d_test' write ( *, '(a)' ) ' cylinder_point_dist_3d() computes the distance' write ( *, '(a)' ) ' to a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P = ', p(1:dim_num) call cylinder_point_dist_3d ( p1, p2, r, p, dist ) write ( *, '(a,g14.6)' ) ' DIST (computed) = ', dist write ( *, '(a,g14.6)' ) ' DIST (exact) = ', dist_test(test) end do return end subroutine cylinder_point_dist_signed_3d_test ( ) !*****************************************************************************80 ! !! cylinder_point_dist_signed_3d_test tests cylinder_point_dist_signed_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) :: dist real ( kind = rk ), dimension ( test_num ) :: dist_test = (/ & 3.0D+00, -0.5D+00, 5.0D+00, 8.0D+00, -1.0D+00, -0.25D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 4.0D+00, 0.5D+00, 0.0D+00, & -0.5D+00, -1.0D+00, 0.0D+00, & 4.0D+00, 6.0D+00, 0.0D+00, & 0.75D+00, -10.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.25D+00, 1.75D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, -2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ) :: r = 1.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_point_dist_signed_3d_test' write ( *, '(a)' ) ' cylinder_point_dist_signed_3d() computes the signed' write ( *, '(a)' ) ' distance to a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P = ', p(1:dim_num) call cylinder_point_dist_signed_3d ( p1, p2, r, p, dist ) write ( *, '(a,g14.6)' ) ' Signed distance (computed) = ', dist write ( *, '(a,g14.6)' ) ' Signed distance (exact) = ', dist_test(test) end do return end subroutine cylinder_point_inside_3d_test ( ) !*****************************************************************************80 ! !! cylinder_point_inside_3d_test tests cylinder_point_inside_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 logical :: inside logical, dimension ( test_num ) :: inside_test = (/ & .false., .true., .false., .false., .true., .true. /) real ( kind = rk ), dimension ( dim_num ) :: p real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 4.0D+00, 0.5D+00, 0.0D+00, & -0.5D+00, -1.0D+00, 0.0D+00, & 4.0D+00, 6.0D+00, 0.0D+00, & 0.75D+00, -10.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.25D+00, 1.75D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, -2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ) :: r = 1.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_point_inside_3d_test' write ( *, '(a)' ) ' cylinder_point_inside_3d() determines if a point is' write ( *, '(a)' ) ' inside a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P = ', p(1:dim_num) call cylinder_point_inside_3d ( p1, p2, r, p, inside ) write ( *, '(a,l1)' ) ' INSIDE (computed) = ', inside write ( *, '(a,l1)' ) ' INSIDE (exact) = ', inside_test(test) end do return end subroutine cylinder_point_near_3d_test ( ) !*****************************************************************************80 ! !! cylinder_point_near_3d_test tests cylinder_point_near_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ), dimension ( dim_num ) :: p real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 4.0D+00, 0.5D+00, 0.0D+00, & -0.5D+00, -1.0D+00, 0.0D+00, & 4.0D+00, 6.0D+00, 0.0D+00, & 0.75D+00, -10.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.25D+00, 1.75D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, -2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: pn real ( kind = rk ), dimension ( dim_num, test_num ) :: pn_test = reshape ( (/ & 1.0D+00, 0.5D+00, 0.0D+00, & -1.0D+00, -1.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 0.0D+00, & 0.75D+00, -2.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.25D+00, 2.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) :: r = 1.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_point_near_3d_test' write ( *, '(a)' ) ' cylinder_point_near_3d() computes the nearest point' write ( *, '(a)' ) ' on a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P = ', p(1:dim_num) call cylinder_point_near_3d ( p1, p2, r, p, pn ) write ( *, '(a,3g14.6)' ) ' PN (computed) = ', pn(1:dim_num) write ( *, '(a,3g14.6)' ) ' PN (exact) = ', pn_test(1:dim_num,test) end do write ( *, '(a)' ) '' write ( *, '(a)' ) ' (Note that case 5 is ambiguous. The set of nearest' write ( *, '(a)' ) ' points forms a circle, any of which will do.)' return end subroutine cylinder_sample_3d_test ( ) !*****************************************************************************80 ! !! cylinder_sample_3d_test tests cylinder_sample_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: n = 20 real ( kind = rk ), dimension ( dim_num, n ) :: p real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, -2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ) :: r = 1.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_sample_3d_test' write ( *, '(a)' ) ' cylinder_sample_3d() samples points in a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) call cylinder_sample_3d ( p1, p2, r, n, p ) call r8mat_transpose_print ( dim_num, n, p, ' Sample points:' ) return end subroutine cylinder_volume_3d_test ( ) !*****************************************************************************80 ! !! cylinder_volume_3d_test tests cylinder_volume_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) r8_pi real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 1.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 5.0D+00, 6.0D+00, 5.0D+00 /) real ( kind = rk ) :: r = 5.0D+00 real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'cylinder_volume_3d_test' write ( *, '(a)' ) ' cylinder_volume_3d() computes the volume of a cylinder.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius R = ', r write ( *, '(a,3g14.6)' ) ' Center of bottom disk = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Center of top disk = ', p2(1:dim_num) call cylinder_volume_3d ( p1, p2, r, volume ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Volume (computed) = ', volume write ( *, '(a,g14.6)' ) ' Volume (exact) = ', r8_pi ( ) * 150.0D+00 return end subroutine degrees_to_radians_test ( ) !*****************************************************************************80 ! !! degrees_to_radians_test tests degrees_to_radians. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) angle_degrees real ( kind = rk ) angle_degrees_2 real ( kind = rk ) angle_rad real ( kind = rk ) degrees_to_radians integer i real ( kind = rk ) radians_to_degrees write ( *, '(a)' ) '' write ( *, '(a)' ) 'degrees_to_radians_test' write ( *, '(a)' ) ' degrees_to_radians() converts an angle from degrees' write ( *, '(a)' ) ' to radians;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Degrees Radians Degrees' write ( *, '(a)' ) '' do i = -2, 14 angle_degrees = real ( 30 * i, kind = rk ) angle_rad = degrees_to_radians ( angle_degrees ) angle_degrees_2 = radians_to_degrees ( angle_rad ) write ( *, '(2x,f10.6,2x,f10.6,2x,f10.6)' ) & angle_degrees, angle_rad, angle_degrees_2 end do return end subroutine test021 ( ) !*****************************************************************************80 ! !! TEST021 tests DIRECTION_PERT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 integer i real ( kind = rk ) sigma(test_num) integer test real ( kind = rk ) vbase(dim_num) real ( kind = rk ) vran(dim_num) vbase(1:dim_num) = (/ 1.0D+00, 0.0D+00, 0.0D+00 /) sigma(1:test_num) = (/ 0.99D+00, 0.5D+00, 0.1D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST021' write ( *, '(a)' ) ' DIRECTION_PERT_3D perturbs a direction vector.' call r8vec_print ( dim_num, vbase, ' The base vector:' ) do test = 1, test_num write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Using Sigma = ', sigma(test) write ( *, '(a)' ) '' do i = 1, 20 call direction_pert_3d ( sigma(test), vbase, vran ) write ( *, '(2x,3f8.4)' ) vran(1:dim_num) end do end do return end subroutine disk_point_dist_3d_test ( ) !*****************************************************************************80 ! !! disk_point_dist_3d_test tests disk_point_dist_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 real ( kind = rk ), dimension(dim_num) :: axis = (/ & 0.0D+00, 1.0D+00, 1.0D+00 /) real ( kind = rk ) dist real ( kind = rk ), dimension(test_num) :: dist_test = (/ & 2.0D+00, 0.0D+00, 0.0D+00, 8.0D+00, 10.0D+00 /) real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: pc = (/ & 0.0D+00, 1.4142135D+00, 1.4142135D+00 /) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = & reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.70710677D+00, 2.1213202D+00, & 2.0D+00, 1.4142135D+00, 1.4142135D+00, & 10.0D+00, 1.4142135D+00, 1.4142135D+00, & 10.0D+00, 5.6568542D+00, 5.6568542D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) :: r = 2.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'disk_point_dist_3d_test' write ( *, '(a)' ) ' disk_point_dist_3d() finds the distance from' write ( *, '(a)' ) ' a disk to a point in 3D.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Disk radius = ', r call r8vec_print ( dim_num, pc, ' Disk center: ' ) call r8vec_print ( dim_num, axis, ' Disk axis: ' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' Point: ' ) call disk_point_dist_3d ( pc, r, axis, p, dist ) write ( *, '(a)' ) '' write ( *, '(a,g14.6,a,g14.6)' ) ' Distance = ', dist, & ' Expected = ', dist_test(test) end do return end subroutine dms_to_radians_test ( ) !*****************************************************************************80 ! !! dms_to_radians_test tests dms_to_radians. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer angle_degrees integer angle_min real ( kind = rk ) angle_rad real ( kind = rk ) angle_rad2 integer angle_sec integer i real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'dms_to_radians_test' write ( *, '(a)' ) ' dms_to_radians() converts an angle from ' write ( *, '(a)' ) ' degrees/minutes/seconds to radians;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Radians DMS Radians' write ( *, '(a)' ) '' do i = -2, 15 angle_rad = pi * real ( i, kind = rk ) / 7.0D+00 call radians_to_dms ( angle_rad, angle_degrees, angle_min, angle_sec ) call dms_to_radians ( angle_degrees, angle_min, angle_sec, angle_rad2 ) write ( *, '(2x,f10.6,2x,i4,2x,i3,2x,i3,2x,f10.6)' ) & angle_rad, angle_degrees, angle_min, angle_sec, angle_rad2 end do return end subroutine test0236 ( ) !*****************************************************************************80 ! !! TEST0236 tests DODEC_SIZE_3D and DODEC_SHAPE_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer edge_num integer face_num integer, allocatable, dimension ( : ) :: face_order integer face_order_max integer, allocatable, dimension ( :, : ) :: face_point integer point_num real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0236' write ( *, '(a)' ) ' For the dodecahedron,' write ( *, '(a)' ) ' DODEC_SIZE_3D returns dimension information;' write ( *, '(a)' ) ' DODEC_SHAPE_3D returns face and order information.' write ( *, '(a)' ) ' SHAPE_PRINT_3D prints this information.' call dodec_size_3d ( point_num, edge_num, face_num, face_order_max ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num write ( *, '(a,i8)' ) ' Number of edges = ', edge_num write ( *, '(a,i8)' ) ' Number of faces = ', face_num write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max allocate ( face_order(1:face_num) ) allocate ( face_point(1:face_order_max,1:face_num) ) allocate ( point_coord(1:3,1:point_num) ) call dodec_shape_3d ( point_num, face_num, face_order_max, point_coord, & face_order, face_point ) call shape_print_3d ( point_num, face_num, face_order_max, & point_coord, face_order, face_point ) deallocate ( face_order ) deallocate ( face_point ) deallocate ( point_coord ) return end subroutine dual_size_3d_test ( ) !*****************************************************************************80 ! !! dual_size_3d_test tests dual_size_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer edge_num1 integer edge_num2 integer, allocatable, dimension ( :, : ) :: edge_point1 integer face_num1 integer face_num2 integer, allocatable, dimension ( : ) :: face_order1 integer face_order_max1 integer face_order_max2 integer, allocatable, dimension ( :, : ) :: face_point1 integer point_num1 integer point_num2 real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'dual_size_3d_test' write ( *, '(a)' ) ' dual_size_3d() finds the "sizes" of the dual of a' write ( *, '(a)' ) ' polyhedron;' ! ! Get the CUBE shape. ! call cube_size_3d ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The cube:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num1 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces: ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max1 allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call cube_shape_3d ( point_num1, face_num1, face_order_max1, point_coord1, & face_order1, face_point1 ) call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, & face_num2, face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the cube:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num2 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces: ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max2 deallocate ( face_order1 ) deallocate ( face_point1 ) deallocate ( point_coord1 ) ! ! Get the DODECAHEDRON shape. ! call dodec_size_3d ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dodecahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num1 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces: ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max1 allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call dodec_shape_3d ( point_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1 ) call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, & face_num2, face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the dodecahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num2 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces: ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max2 deallocate ( face_order1 ) deallocate ( face_point1 ) deallocate ( point_coord1 ) ! ! Get the ICOSAHEDRON shape. ! call icos_size ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The icosahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num1 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces: ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max1 allocate ( edge_point1(1:2,1:edge_num1) ) allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call icos_shape ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, edge_point1, face_order1, face_point1 ) call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, & face_num2, face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the icosahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num2 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces: ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max2 deallocate ( edge_point1 ) deallocate ( face_order1 ) deallocate ( face_point1 ) deallocate ( point_coord1 ) ! ! Get the OCTAHEDRON shape. ! call octahedron_size_3d ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The octahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num1 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces: ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max1 allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call octahedron_shape_3d ( point_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1 ) call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, & face_num2, face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the octahedron:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num2 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces: ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max2 deallocate ( face_order1 ) deallocate ( face_point1 ) deallocate ( point_coord1 ) ! ! Get the SOCCER BALL shape. ! call soccer_size_3d ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The soccer ball:' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num1 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces: ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max1 allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call soccer_shape_3d ( point_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1 ) call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, face_num2, & face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the "soccer ball":' write ( *, '(a,i8)' ) ' Number of vertices: ', point_num2 write ( *, '(a,i8)' ) ' Number of edges: ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces: ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order: ', face_order_max2 deallocate ( face_order1 ) deallocate ( face_point1 ) deallocate ( point_coord1 ) return end subroutine dual_shape_3d_test ( ) !*****************************************************************************80 ! !! dual_shape_3d_test tests dual_shape_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer edge_num1 integer edge_num2 integer face_num1 integer face_num2 integer, allocatable, dimension ( : ) :: face_order1 integer, allocatable, dimension ( : ) :: face_order2 integer face_order_max1 integer face_order_max2 integer, allocatable, dimension ( :, : ) :: face_point1 integer, allocatable, dimension ( :, : ) :: face_point2 integer point_num1 integer point_num2 real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord1 real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'dual_shape_3d_test' write ( *, '(a)' ) ' dual_shape_3d() finds the dual of a polyhedron.' ! ! Get the dodecahedron shape. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dodecahedron:' call dodec_size_3d ( point_num1, edge_num1, face_num1, face_order_max1 ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num1 write ( *, '(a,i8)' ) ' Number of edges = ', edge_num1 write ( *, '(a,i8)' ) ' Number of faces = ', face_num1 write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max1 allocate ( face_order1(1:face_num1) ) allocate ( face_point1(1:face_order_max1,1:face_num1) ) allocate ( point_coord1(1:dim_num,1:point_num1) ) call dodec_shape_3d ( point_num1, face_num1, face_order_max1, point_coord1, & face_order1, face_point1 ) ! ! Get the dual. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' The dual of the dodecahedron:' call dual_size_3d ( point_num1, edge_num1, face_num1, face_order_max1, & point_coord1, face_order1, face_point1, point_num2, edge_num2, & face_num2, face_order_max2 ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num2 write ( *, '(a,i8)' ) ' Number of edges = ', edge_num2 write ( *, '(a,i8)' ) ' Number of faces = ', face_num2 write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max2 allocate ( face_order2(1:face_num2) ) allocate ( face_point2(1:face_order_max2,1:face_num2) ) allocate ( point_coord2(1:dim_num,1:point_num2) ) call dual_shape_3d ( point_num1, face_num1, face_order_max1, point_coord1, & face_order1, face_point1, point_num2, face_num2, face_order_max2, & point_coord2, face_order2, face_point2 ) call shape_print_3d ( point_num2, face_num2, face_order_max2, & point_coord2, face_order2, face_point2 ) deallocate ( face_order1 ) deallocate ( face_order2 ) deallocate ( face_point1 ) deallocate ( face_point2 ) deallocate ( point_coord1 ) deallocate ( point_coord2 ) return end subroutine test028 ( ) !*****************************************************************************80 ! !! test028 tests halfplane_contains_point_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 logical, dimension ( test_num ) :: expected = (/ & .true., .false., .true., .false. /) logical halfplane_contains_point_2d real ( kind = rk ), dimension ( dim_num, test_num ) :: p = reshape ( (/ & 1.0D+00, 1.0D+00, & 1.0D+00, -1.0D+00, & -1.0D+00, 1.0D+00, & 2.0D+00, 200.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1 = reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & -5.0D+00, -5.0D+00, & 3.0D+00, 150.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2 = reshape ( (/ & 2.0D+00, 0.0D+00, & 2.0D+00, 0.0D+00, & 10.0D+00, 10.0D+00, & 1.0D+00, 50.0D+00 /), (/ dim_num, test_num /) ) logical temp integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST028' write ( *, '(a)' ) ' HALFPLANE_CONTAINS_POINT_2D determines whether a' write ( *, '(a)' ) ' halfplane bounded by PA:PB contains the' write ( *, '(a)' ) ' point P.' write ( *, '(a)' ) '' do test = 1, test_num temp = halfplane_contains_point_2d ( p1(1:dim_num,test), & p2(1:dim_num,test), p(1:dim_num,test) ) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1 = ', p1(1:dim_num,test) write ( *, '(a,2g14.6)' ) ' P2 = ', p2(1:dim_num,test) write ( *, '(a,2g14.6)' ) ' P = ', p(1:dim_num,test) write ( *, '(a,l1,a,l1)' ) ' Contains? = ', temp, & ' Correct = ', expected(test) end do return end subroutine test029 ( ) !*****************************************************************************80 ! !! test029 tests halfspace_imp_triangle_int_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d integer int_num real ( kind = rk ) pint(dim_num,4) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 3.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 2.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 4.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 3.0D+00, & -8.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 4.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 4.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST029' write ( *, '(a)' ) ' HALFSPACE_IMP_TRIANGLE_INT_3D finds' write ( *, '(a)' ) ' intersection points of an implicit' write ( *, '(a)' ) ' halfspace and a triangle.' a = 1.0D+00 b = - 2.0D+00 c = - 3.0D+00 d = 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' The implicitly defined bounding plane' write ( *, '(a)' ) ' has the form: A*X + B*Y + C*Z + D = 0.' write ( *, '(a,4g14.6)' ) ' A,B,C,D = ', a, b, c, d do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Case ', test write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices' ) call halfspace_imp_triangle_int_3d ( a, b, c, d, t, int_num, pint ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of intersection points is ', int_num write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, int_num, pint, ' Intersections:' ) end do return end subroutine test030 ( ) !*****************************************************************************80 ! !! TEST030 tests HALFSPACE_NORMAL_TRIANGLE_INT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 integer int_num real ( kind = rk ), dimension(dim_num) :: normal = (/ & 2.0D+00, -4.0D+00, -6.0D+00 /) real ( kind = rk ) p(dim_num) real ( kind = rk ) pint(dim_num,4) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 3.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 2.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 4.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 3.0D+00, & -8.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 4.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 4.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST030' write ( *, '(a)' ) ' HALFSPACE_NORMAL_TRIANGLE_INT_3D finds' write ( *, '(a)' ) ' intersection points of a normal form' write ( *, '(a)' ) ' halfspace and a triangle.' p(1:dim_num) = (/ -6.0D+00, 0.0D+00, 0.0D+00 /) call r8vec_print ( dim_num, p, ' Plane point P:' ) call r8vec_print ( dim_num, normal, ' Plane normal:' ) do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Case ', test write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call halfspace_normal_triangle_int_3d ( p, normal, t, int_num, pint ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of intersection points is ', int_num write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, int_num, pint, ' Intersections:' ) end do return end subroutine test031 ( ) !*****************************************************************************80 ! !! TEST031 tests HAVERSINE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) d real ( kind = rk ) haversine real ( kind = rk ) hx real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) radians_to_degrees integer test integer, parameter :: test_num = 12 real ( kind = rk ) x write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST031' write ( *, '(a)' ) ' HAVERSINE computes the haversine of an angle.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Degrees Radians Haversine' write ( *, '(a)' ) '' do test = 0, test_num x = real ( test, kind = rk ) * 2.0D+00 * r8_pi / real ( test_num, kind = rk ) d = radians_to_degrees ( x ) hx = haversine ( x ) write ( *, '(2x,2f8.4,g14.6)' ) d, x, hx end do return end subroutine test0315 ( ) !*****************************************************************************80 ! !! TEST0315 tests HEXAGON_CONTAINS_POINT_2D ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 40 integer, parameter :: dim_num = 2 character dot(n) real ( kind = rk ), dimension(dim_num,6) :: h = reshape ( (/ & 0.2D+00, 0.4D+00, & 0.4D+00, 0.2D+00, & 0.8D+00, 0.0D+00, & 1.0D+00, 0.6D+00, & 0.4D+00, 1.0D+00, & 0.2D+00, 0.8D+00 /), (/ dim_num, 6 /) ) logical hexagon_contains_point_2d integer i integer j real ( kind = rk ) p(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0315' write ( *, '(a)' ) ' HEXAGON_CONTAINS_POINT_2D reports if a hexagon' write ( *, '(a)' ) ' contains a point.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will call the function repeatedly, and draw' write ( *, '(a)' ) ' a sketch of an irregular hexagon in the unit square.' write ( *, '(a)' ) '' do i = 1, n p(2) = real ( n - i, kind = rk ) & / real ( n - 1, kind = rk ) do j = 1, n p(1) = real ( j - 1, kind = rk ) & / real ( n - 1, kind = rk ) if ( hexagon_contains_point_2d ( h, p ) ) then dot(j) = '*' else dot(j) = '-' end if end do write ( *, '(2x,40a1)' ) dot(1:n) end do return end subroutine test032 ( ) !*****************************************************************************80 ! !! TEST032 tests HEXAGON_SHAPE_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) angle integer i real ( kind = rk ) p(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST032' write ( *, '(a)' ) ' HEXAGON_SHAPE_2D: points on a unit hexagon.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Angle X Y ' write ( *, '(a)' ) '' do i = -10, 370, 10 angle = real ( i, kind = rk ) call hexagon_shape_2d ( angle, p ) write ( *, '(2x,3g14.6)' ) angle, p(1:dim_num) end do return end subroutine test0321 ( ) !*****************************************************************************80 ! !! TEST0321 tests HEXAGON_VERTICES_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) p(dim_num,6) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0321' write ( *, '(a)' ) ' HEXAGON_VERTICES_2D: the vertices of the unit hexagon.' call hexagon_vertices_2d ( p ) call r8mat_transpose_print ( dim_num, 6, p, ' Vertices:' ) return end subroutine i4col_find_item_test ( ) !*****************************************************************************80 ! !! i4col_find_item_test tests i4col_find_item. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 5 integer, parameter :: n = 4 integer, parameter :: test_num = 3 integer a(m,n) integer col integer i integer item integer, dimension ( test_num ) :: item_test = (/ & 34, 12, 90 /) integer j integer row integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'i4col_find_item_test' write ( *, '(a)' ) ' i4col_find_item() finds the first occurrence of' write ( *, '(a)' ) ' an item in an integer array of columns.' do i = 1, m do j = 1, n a(i,j) = 10 * i + j end do end do call i4mat_print ( m, n, a, ' The matrix of columns:' ) do test = 1, test_num item = item_test(test) call i4col_find_item ( m, n, a, item, row, col ) write ( *, '(a,i8,a,i8,a,i8)' ) ' Item ', item, ' occurs in row ', & row, ' and column ', col end do return end subroutine test0323 ( ) !*****************************************************************************80 ! !! TEST0323 tests I4COL_FIND_PAIR_WRAP. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 5 integer, parameter :: n = 4 integer, parameter :: test_num = 5 integer a(m,n) integer col integer i integer item1 integer, dimension ( test_num ) :: item1_test = (/ & 22, 32, 22, 54, 54 /) integer item2 integer, dimension ( test_num ) :: item2_test = (/ & 32, 22, 23, 14, 11 /) integer j integer row integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0323' write ( *, '(a)' ) ' I4COL_FIND_PAIR_WRAP finds the first occurrence of' write ( *, '(a)' ) ' a pair of item in an integer array of columns.' write ( *, '(a)' ) ' Items in the array are ordered by column, and' write ( *, '(a)' ) ' wraparound is allowed.' do i = 1, m do j = 1, n a(i,j) = 10 * i + j end do end do call i4mat_print ( m, n, a, ' The matrix of columns:' ) do test = 1, test_num item1 = item1_test(test) item2 = item2_test(test) call i4col_find_pair_wrap ( m, n, a, item1, item2, row, col ) write ( *, '(a,i8,a,i8,a,i8,a,i8)' ) ' Item ', item1, & ' followed by item ', item2, ' occurs in row ', & row, ' and column ', col end do return end subroutine test0325 ( ) !*****************************************************************************80 ! !! TEST0325 tests ICOS_SIZE and ICOS_SHAPE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer edge_num integer, allocatable, dimension ( :, : ) :: edge_point integer face_num integer, allocatable, dimension ( : ) :: face_order integer face_order_max integer, allocatable, dimension ( :, : ) :: face_point integer point_num real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0325' write ( *, '(a)' ) ' For the icosahedron,' write ( *, '(a)' ) ' ICOS_SIZE returns dimension information;' write ( *, '(a)' ) ' ICOS_SHAPE returns face and order information.' write ( *, '(a)' ) ' SHAPE_PRINT_3D prints this information.' call icos_size ( point_num, edge_num, face_num, face_order_max ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num write ( *, '(a,i8)' ) ' Number of edges = ', edge_num write ( *, '(a,i8)' ) ' Number of faces = ', face_num write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max allocate ( edge_point(1:2,1:edge_num) ) allocate ( face_order(1:face_num) ) allocate ( face_point(1:face_order_max,1:face_num) ) allocate ( point_coord(1:3,1:point_num) ) call icos_shape ( point_num, edge_num, face_num, face_order_max, & point_coord, edge_point, face_order, face_point ) call shape_print_3d ( point_num, face_num, face_order_max, & point_coord, face_order, face_point ) deallocate ( edge_point ) deallocate ( face_order ) deallocate ( face_point ) deallocate ( point_coord ) return end subroutine line_exp_normal_2d_test ( ) !*****************************************************************************80 ! !! line_exp_normal_2d_test tests line_exp_normal_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) normal(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'line_exp_normal_2d_test' write ( *, '(a)' ) ' line_exp_normal_2d() determines a unit normal vector' write ( *, '(a)' ) ' to a given explicit line.' p1(1:dim_num) = (/ 1.0D+00, 3.0D+00 /) p2(1:dim_num) = (/ 4.0D+00, 0.0D+00 /) call r8vec_print ( dim_num, p1, ' Point 1: ' ) call r8vec_print ( dim_num, p2, ' Point 2: ' ) call line_exp_normal_2d ( p1, p2, normal ) call r8vec_print ( dim_num, normal, ' Normal vector N:' ) return end subroutine test033 ( ) !*****************************************************************************80 ! !! TEST033 tests LINE_EXP_PERP_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 logical flag real ( kind = rk ), dimension(dim_num) :: p1 = (/ 1.0D+00, 3.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 4.0D+00, 0.0D+00 /) real ( kind = rk ) p3(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p3_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 5.0D+00, -1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p4(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST033' write ( *, '(a)' ) ' LINE_EXP_PERP_2D is given an explicit line (P1,P2),' write ( *, '(a)' ) ' and another point P3. It then finds a point' write ( *, '(a)' ) ' P4 on (P1,P2) so that (P1,P2) is perpendicular' write ( *, '(a)' ) ' to (P3,P4).' call line_exp_print_2d ( p1, p2, ' The explicit line:' ) do test = 1, test_num p3(1:dim_num) = p3_test(1:dim_num,test) call r8vec_print ( dim_num, p3, ' Point P3:' ) call line_exp_perp_2d ( p1, p2, p3, p4, flag ) call r8vec_print ( dim_num, p4, ' Point P4:' ) end do return end subroutine test0335 ( ) !*****************************************************************************80 ! !! TEST0335 tests LINE_EXP_POINT_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 1.0D+00, 3.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 4.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = & reshape ( (/ & 0.0D+00, 0.0D+00, & 5.0D+00, -1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0335' write ( *, '(a)' ) ' LINE_EXP_POINT_DIST_2D finds the distance from' write ( *, '(a)' ) ' an explicit line to a point in 2D.' call line_exp_print_2d ( p1, p2, ' The explicit line:' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' Point: ' ) call line_exp_point_dist_2d ( p1, p2, p, dist ) write ( *, '(a,g14.6)' ) ' Distance = ', dist end do return end subroutine test0336 ( ) !*****************************************************************************80 ! !! TEST0336 tests LINE_EXP_POINT_DIST_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 1.0D+00, 3.0D+00, 2.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 4.0D+00, 0.0D+00, 1.0D+00 /) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, 2.0D+00, & 5.0D+00, -1.0D+00, 1.0D+00, & 5.0D+00, 3.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0336' write ( *, '(a)' ) ' LINE_EXP_POINT_DIST_3D finds the distance' write ( *, '(a)' ) ' from an explicit line to a point in 3D.' call line_exp_print_2d ( p1, p2, ' The explicit line:' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' Point: ' ) call line_exp_point_dist_3d ( p1, p2, p, dist ) write ( *, '(a,g14.6)' ) ' Distance = ', dist end do return end subroutine test0337 ( ) !*****************************************************************************80 ! !! TEST0337 tests LINE_EXP_POINT_DIST_SIGNED_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 1.0D+00, 3.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 4.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 5.0D+00, -1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0337' write ( *, '(a)' ) ' LINE_EXP_POINT_DIST_SIGNED_2D finds the signed' write ( *, '(a)' ) ' distance to a point from an explicit line.' call line_exp_print_2d ( p1, p2, ' The explicit line:' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' Point: ' ) call line_exp_point_dist_signed_2d ( p1, p2, p, dist ) write ( *, '(a,g14.6)' ) ' Signed distance = ', dist end do return end subroutine test034 ( ) !*****************************************************************************80 ! !! TEST034 tests LINE_EXP_POINT_NEAR_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 1.0D+00, 3.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 4.0D+00, 0.0D+00 /) real ( kind = rk ) pn(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 5.0D+00, -1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) t integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST034' write ( *, '(a)' ) ' LINE_EXP_POINT_NEAR_2D finds the point on' write ( *, '(a)' ) ' a line nearest in point in 2D.' call line_exp_print_2d ( p1, p2, ' The explicit line:' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' The point P:' ) call line_exp_point_near_2d ( p1, p2, p, pn, dist, t ) call r8vec_print ( dim_num, pn, ' Nearest point PN:' ) write ( *, '(a,g14.6)' ) ' Distance = ', dist write ( *, '(a,g14.6)' ) ' Relative line position T = ', t end do return end subroutine test0345 ( ) !*****************************************************************************80 ! !! TEST0345 tests LINE_EXP2IMP_2D and LINE_IMP2EXP_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) :: a1 = 1.0D+00 real ( kind = rk ) a2 real ( kind = rk ) :: b1 = 2.0D+00 real ( kind = rk ) b2 real ( kind = rk ) :: c1 = 3.0D+00 real ( kind = rk ) c2 real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0345' write ( *, '(a)' ) ' LINE_EXP2IMP_2D converts explicit to implicit lines.' write ( *, '(a)' ) ' LINE_IMP2EXP_2D converts implicit to explicit lines.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Implicit line A, B, C = ', a1, b1, c1 call line_imp2exp_2d ( a1, b1, c1, p1, p2 ) call line_exp_print_2d ( p1, p2, ' The explicit line:' ) call line_exp2imp_2d ( p1, p2, a2, b2, c2 ) write ( *, '(a,3f8.4)' ) ' Recovered implicit line A, B, C = ', a2, b2, c2 return end subroutine test0346 ( ) !*****************************************************************************80 ! !! TEST0346 tests LINE_EXP2PAR_2D and LINE_PAR2EXP_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2020 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) :: f1 = 1.0D+00 real ( kind = rk ) f2 real ( kind = rk ) :: g1 = 2.0D+00 real ( kind = rk ) g2 real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) :: x1 = 3.0D+00 real ( kind = rk ) x2 real ( kind = rk ) :: y1 = 4.0D+00 real ( kind = rk ) y2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0346' write ( *, '(a)' ) ' LINE_EXP2PAR_2D converts explicit to parametric lines.' write ( *, '(a)' ) ' LINE_PAR2EXP_2D converts parametric to explicit lines.' call line_par_print_2d ( f1, g1, x1, y1, ' Parametric line:' ) call line_par2exp_2d ( f1, g1, x1, y1, p1, p2 ) call line_exp_print_2d ( p1, p2, ' The explicit line:' ) call line_exp2par_2d ( p1, p2, f2, g2, x2, y2 ) call line_par_print_2d ( f2, g2, x2, y2, ' Recovered parametric line:' ) return end subroutine test035 ( ) !*****************************************************************************80 ! !! TEST035 tests LINE_IMP_POINT_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 August 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) a real ( kind = rk ), parameter, dimension ( test_num ) :: a_test = (/ & 2.0D+00, 2.0D+00, 2.0D+00 /) real ( kind = rk ) b real ( kind = rk ), parameter, dimension ( test_num ) :: b_test = (/ & 5.0D+00, 5.0D+00, 5.0D+00 /) real ( kind = rk ) c real ( kind = rk ), parameter, dimension ( test_num ) :: c_test = (/ & 3.0D+00, 3.0D+00, 3.0D+00 /) real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), parameter, dimension ( dim_num, test_num ) :: & p_test = reshape ( (/ & 0.0D+00, 6.0D+00, & 0.0D+00, 5.0D+00, & 0.0D+00, 4.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST035' write ( *, '(a)' ) ' LINE_IMP_POINT_DIST_2D finds the distance from' write ( *, '(a)' ) ' a point P to a line A * X + B * Y + C = 0.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y A B C DIST' write ( *, '(a)' ) '' do test = 1, test_num a = a_test(test) b = b_test(test) c = c_test(test) p(1:dim_num) = p_test(1:dim_num,test) call line_imp_point_dist_2d ( a, b, c, p, dist ) write ( *, '(2x,6f8.4)' ) p(1:dim_num), a, b, c, dist end do return end subroutine test0351 ( ) !*****************************************************************************80 ! !! TEST0351 tests LINE_PAR_POINT_NEAR_2D and LINE_PAR_POINT_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 April 2013 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) f real ( kind = rk ) g real ( kind = rk ) p(dim_num) real ( kind = rk ) pn(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 5.0D+00, -1.0D+00, & 5.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) r8vec_norm_affine integer test real ( kind = rk ) x0 real ( kind = rk ) y0 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0351' write ( *, '(a)' ) ' LINE_PAR_POINT_NEAR_2D finds the point on' write ( *, '(a)' ) ' a parametric line (X0,Y0,F,G) nearest a point P in 2D.' x0 = 1.0D+00 y0 = 3.0D+00 f = +1.0D+00 g = -1.0D+00 call line_par_print_2d ( f, g, x0, y0, ' Parametric line:' ) do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' The point P:' ) call line_par_point_dist_2d ( f, g, x0, y0, p, dist ) write ( *, '(a,g14.6)' ) ' Distance = ', dist call line_par_point_near_2d ( f, g, x0, y0, p, pn ) call r8vec_print ( dim_num, pn, ' Nearest point PN:' ) dist = r8vec_norm_affine ( dim_num, p, pn ) write ( *, '(a,g14.6)' ) ' Distance recomputed = ', dist end do return end subroutine test0352 ( ) !*****************************************************************************80 ! !! TEST0352 tests LINE_PAR_POINT_DIST_3D and LINE_PAR_POINT_NEAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 April 2013 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) f real ( kind = rk ) g real ( kind = rk ) h real ( kind = rk ) p(dim_num) real ( kind = rk ) pn(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, 2.0D+00, & 5.0D+00, -1.0D+00, 1.0D+00, & 5.0D+00, 3.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) r8vec_norm_affine integer test real ( kind = rk ) x0 real ( kind = rk ) y0 real ( kind = rk ) z0 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0352' write ( *, '(a)' ) ' LINE_PAR_POINT_DIST_3D finds the distance' write ( *, '(a)' ) ' from a parametric line to a point in 3D.' x0 = 1.0D+00 y0 = 3.0D+00 z0 = 2.0D+00 f = +3.0D+00 g = -3.0D+00 h = -1.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' Parametric line:' write ( *, '(a,g14.6,a,g14.6,a)' ) ' X(t) = ', x0, ' + ', f, ' * t' write ( *, '(a,g14.6,a,g14.6,a)' ) ' Y(t) = ', y0, ' + ', g, ' * t' write ( *, '(a,g14.6,a,g14.6,a)' ) ' Z(t) = ', z0, ' + ', h, ' * t' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call r8vec_print ( dim_num, p, ' The point P:' ) call line_par_point_dist_3d ( f, g, h, x0, y0, z0, p, dist ) write ( *, '(a,g14.6)' ) ' Distance = ', dist call line_par_point_near_3d ( f, g, h, x0, y0, z0, p, pn ) call r8vec_print ( dim_num, pn, ' Nearest point PN:' ) dist = r8vec_norm_affine ( dim_num, p, pn ) write ( *, '(a,g14.6)' ) ' Distance recomputed = ', dist end do return end subroutine test038 ( ) !*****************************************************************************80 ! !! TEST038 tests LINES_EXP_ANGLE_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) angle real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 1.0D+00, 2.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 0.0D+00, 3.0D+00, 3.0D+00, & 1.0D+00, 2.0D+00, -1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 3.0D+00, 0.0D+00, 3.0D+00, & 1.0D+00, 2.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST038' write ( *, '(a)' ) ' LINES_EXP_ANGLE_3D finds the angle between' write ( *, '(a)' ) ' two explicit lines in 3D;' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) call lines_exp_angle_3d ( p1, p2, q1, q2, angle ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Angle between lines is ', angle end do return end subroutine test0385 ( ) !*****************************************************************************80 ! !! TEST0385 tests LINES_EXP_DIST_3D and LINES_EXP_DIST_3D_2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) dist real ( kind = rk ) dist2 real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 4.0D+00, -3.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 1.0D+00, 2.0D+00, 0.0D+00, & -8.0D+00, 6.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 0.0D+00, 3.0D+00, 3.0D+00, & 3.0D+00, 4.0D+00, -1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 3.0D+00, 0.0D+00, 3.0D+00, & 3.0D+00, 4.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0385' write ( *, '(a)' ) ' LINES_EXP_DIST_3D finds the distance between' write ( *, '(a)' ) ' two explicit lines in 3D.' write ( *, '(a)' ) ' LINES_EXP_DIST_3D_2 finds the distance between' write ( *, '(a)' ) ' two explicit lines in 3D.' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) call lines_exp_dist_3d ( p1, p2, q1, q2, dist ) call lines_exp_dist_3d_2 ( p1, p2, q1, q2, dist2 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1:', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2:', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' Q1:', q1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Q2:', q2(1:dim_num) write ( *, '(a,g14.6)' ) ' LINES_EXP_DIST_3D = ', dist write ( *, '(a,g14.6)' ) ' LINES_EXP_DIST_3D_2 = ', dist2 end do return end subroutine test03855 ( ) !*****************************************************************************80 ! !! TEST03855 tests LINES_EXP_NEAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 4.0D+00, -3.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 1.0D+00, 2.0D+00, 0.0D+00, & -8.0D+00, 6.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pn(dim_num) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 0.0D+00, 3.0D+00, 3.0D+00, & 3.0D+00, 4.0D+00, -1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 3.0D+00, 0.0D+00, 3.0D+00, & 3.0D+00, 4.0D+00, 3.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) qn(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST03855' write ( *, '(a)' ) ' LINES_EXP_NEAR_3D finds nearest points on' write ( *, '(a)' ) ' two explicit lines in 3D.' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1:', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2:', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' Q1:', q1(1:dim_num) write ( *, '(a,3g14.6)' ) ' Q2:', q2(1:dim_num) call lines_exp_near_3d ( p1, p2, q1, q2, pn, qn ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' PN:', pn(1:dim_num) write ( *, '(a,3g14.6)' ) ' QN:', qn(1:dim_num) end do return end subroutine test0386 ( ) !*****************************************************************************80 ! !! TEST0386 tests LINES_EXP_EQUAL_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 6 logical equal logical lines_exp_equal_2d real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 1.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, & 7.0D+00, 14.0D+00, & 1.0D+00, 2.0D+00, & 0.0D+00, 10.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 1.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, & 2.0D+00, 4.0D+00, & 5.5D+00, 11.0D+00, & 3.0D+00, 5.0D+00, & 1.0D+00, 12.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0386' write ( *, '(a)' ) ' LINES_EXP_EQUAL_2D tries to determine if two ' write ( *, '(a)' ) ' explicit lines in 2D are equal.' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2', p2(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' Q1', q1(1:dim_num) write ( *, '(a,2g14.6)' ) ' Q2', q2(1:dim_num) equal = lines_exp_equal_2d ( p1, p2, q1, q2 ) if ( equal ) then write ( *, '(a)' ) ' The lines are equal.' else write ( *, '(a)' ) ' The lines are distinct.' end if end do return end subroutine test039 ( ) !*****************************************************************************80 ! !! TEST039 tests LINES_EXP_INT_2D. ! ! Discussion: ! ! Test #1: ! ! x + 2y - 4 = 0 ! x - y - 1 = 0 ! ! Test #2: ! ! x + 2y - 4 = 0 ! 2x + 4y - 1 = 0 ! ! Test #3: ! ! x + 2y - 4 = 0 ! -3x - 6y + 12 = 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 integer ival real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 2.0D+00, & 0.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 4.0D+00, 0.0D+00, & 4.0D+00, 0.0D+00, & 4.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 0.0D+00, -1.0D+00, & 0.0D+00, 0.25D+00, & 0.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 1.0D+00, 0.0D+00, & 0.5D+00, 0.0D+00, & 4.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST039' write ( *, '(a)' ) ' LINES_EXP_INT_2D finds intersections of ' write ( *, '(a)' ) ' two explicit lines in 2D.' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2', p2(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' Q1', q1(1:dim_num) write ( *, '(a,2g14.6)' ) ' Q2', q2(1:dim_num) call lines_exp_int_2d ( p1, p2, q1, q2, ival, p ) if ( ival == 1 ) then write ( *, '(a,2g14.6)' ) ' Intersection at ', p(1:dim_num) else if ( ival == 0 ) then write ( *, '(a)' ) ' Lines are parallel, no intersection.' else if ( ival == 2 ) then write ( *, '(a)' ) ' Lines are coincident.' else write ( *, '(a,i8)' ) ' Unknown return value of IVAL = ', ival end if end do return end subroutine test040 ( ) !*****************************************************************************80 ! !! TEST040 tests LINES_IMP_ANGLE_2D. ! ! Discussion: ! ! Test 1: ! ! x + 2y - 4 = 0 ! x - y - 1 = 0 ! ! Test 2: ! ! x + 2y - 4 = 0 ! 2x + 4y - 1 = 0 ! ! Test 3: ! ! x + 2y - 4 = 0 ! -3x - 6y +12 = 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) a1 real ( kind = rk ) a2 real ( kind = rk ), dimension ( test_num ) :: a2_test = (/ & 1.0D+00, 2.0D+00, -3.0D+00 /) real ( kind = rk ) angle real ( kind = rk ) b1 real ( kind = rk ) b2 real ( kind = rk ), dimension ( test_num ) :: b2_test = (/ & -1.0D+00, 4.0D+00, -6.0D+00 /) real ( kind = rk ) c1 real ( kind = rk ) c2 real ( kind = rk ), dimension ( test_num ) :: c2_test = (/ & -1.0D+00, -1.0D+00, 12.0D+00 /) real ( kind = rk ) radians_to_degrees integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST040' write ( *, '(a)' ) ' LINES_IMP_ANGLE_2D finds the angle between' write ( *, '(a)' ) ' two lines written in implicit form.' write ( *, '(a)' ) '' a1 = 1.0D+00 b1 = 2.0D+00 c1 = -4.0D+00 do test = 1, test_num write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Line 1 coefficients:', a1, b1, c1 a2 = a2_test(test) b2 = b2_test(test) c2 = c2_test(test) write ( *, '(a,3g14.6)' ) ' Line 2 coefficients:', a2, b2, c2 call lines_imp_angle_2d ( a1, b1, c1, a2, b2, c2, angle ) angle = radians_to_degrees ( angle ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Angle between lines is ', angle end do return end subroutine test041 ( ) !*****************************************************************************80 ! !! TEST041 tests LINES_IMP_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) a1 real ( kind = rk ), parameter, dimension ( test_num ) :: a1_test = & (/ 4.0D+00, 2.0D+00, 1.0D+00 /) real ( kind = rk ) a2 real ( kind = rk ), parameter, dimension ( test_num ) :: a2_test = & (/ 4.0D+00, 4.0D+00, 2.0D+00 /) real ( kind = rk ) b1 real ( kind = rk ), parameter, dimension ( test_num ) :: b1_test = & (/ -1.0D+00, -1.0D+00, 2.0D+00 /) real ( kind = rk ) b2 real ( kind = rk ), parameter, dimension ( test_num ) :: b2_test = & (/ -1.0D+00, -2.0D+00, 3.0D+00 /) real ( kind = rk ) c1 real ( kind = rk ), parameter, dimension ( test_num ) :: c1_test = & (/ 3.0D+00, 0.0D+00, 2.0D+00 /) real ( kind = rk ) c2 real ( kind = rk ), parameter, dimension ( test_num ) :: c2_test = & (/ 12.0D+00, 6.0D+00, 1.0D+00 /) real ( kind = rk ) dist integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST041' write ( *, '(a)' ) ' LINES_IMP_DIST_3D finds the distance between' write ( *, '(a)' ) ' two implicit lines in 2D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A1 B1 C1 A2 B2 C2 DIST' write ( *, '(a)' ) '' do test = 1, test_num a1 = a1_test(test) b1 = b1_test(test) c1 = c1_test(test) a2 = a2_test(test) b2 = b2_test(test) c2 = c2_test(test) call lines_imp_dist_2d ( a1, b1, c1, a2, b2, c2, dist ) write ( *, '(2x,7f8.4)' ) a1, b1, c1, a2, b2, c2, dist end do return end subroutine test0415 ( ) !*****************************************************************************80 ! !! TEST0415 tests LINES_IMP_INT_2D. ! ! Discussion: ! ! Test 1: ! ! x + 2y - 4 = 0 ! x - y - 1 = 0 ! ! Test 2: ! ! x + 2y - 4 = 0 ! 2x + 4y - 1 = 0 ! ! Test 3: ! ! x + 2y - 4 = 0 ! -3x - 6y +12 = 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) a1 real ( kind = rk ) a2 real ( kind = rk ), dimension ( test_num ) :: a2_test = (/ & 1.0D+00, 2.0D+00, -3.0D+00 /) real ( kind = rk ) b1 real ( kind = rk ) b2 real ( kind = rk ), dimension ( test_num ) :: b2_test = (/ & -1.0D+00, 4.0D+00, -6.0D+00 /) real ( kind = rk ) c1 real ( kind = rk ) c2 real ( kind = rk ), dimension ( test_num ) :: c2_test = (/ & -1.0D+00, -1.0D+00, 12.0D+00 /) integer ival real ( kind = rk ) p(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0415' write ( *, '(a)' ) ' LINES_IMP_INT_2D finds the intersection of' write ( *, '(a)' ) ' two lines written in implicit form.' write ( *, '(a)' ) '' a1 = 1.0D+00 b1 = 2.0D+00 c1 = -4.0D+00 do test = 1, test_num write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Line 1 coefficients:', a1, b1, c1 a2 = a2_test(test) b2 = b2_test(test) c2 = c2_test(test) write ( *, '(a,3g14.6)' ) ' Line 2 coefficients:', a2, b2, c2 call lines_imp_int_2d ( a1, b1, c1, a2, b2, c2, ival, p ) if ( ival == 1 ) then write ( *, '(a,2g14.6)' ) ' Intersection at ', p(1:dim_num) else if ( ival == 0 ) then write ( *, '(a)' ) ' Lines are parallel, no intersection.' else if ( ival == 2 ) then write ( *, '(a)' ) ' Lines are coincident.' else write ( *, '(a,i8)' ) ' Unknown return value of ival = ', ival end if end do return end subroutine test0416 ( ) !*****************************************************************************80 ! !! TEST0416 tests LINES_PAR_INT_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) f1 real ( kind = rk ) f2 real ( kind = rk ) g1 real ( kind = rk ) g2 real ( kind = rk ) pint(dim_num) real ( kind = rk ) t1 real ( kind = rk ) t2 real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) y1 real ( kind = rk ) y2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0416' write ( *, '(a)' ) ' LINES_PAR_INT_2D finds the intersection of' write ( *, '(a)' ) ' two lines written in parametric form.' write ( *, '(a)' ) '' ! ! x - 2y = -1 ! x1 = 0.0D+00 y1 = 1.0D+00 f1 = 2.0D+00 g1 = 1.0D+00 write ( *, '(a)' ) '' write ( *, '(a,4g14.6)' ) ' Line 1 parameters:', x1, y1, f1, g1 ! ! x + y - 8 = 0 ! x2 = 10.0D+00 y2 = -2.0D+00 f2 = 1.0D+00 g2 = 1.0D+00 write ( *, '(a)' ) '' write ( *, '(a,4g14.6)' ) ' Line 2 parameters:', x2, y2, f2, g2 call lines_par_int_2d ( f1, g1, x1, y1, f2, g2, x2, y2, t1, t2, pint ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Line 1 evaluated at T1:' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' T1 = ', t1 write ( *, '(a,g14.6)' ) ' X(T1)= ', x1 + f1 * t1 write ( *, '(a,g14.6)' ) ' Y(T1)= ', y1 + g1 * t1 write ( *, '(a)' ) '' write ( *, '(a)' ) ' Line 2 evaluated at T2:' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' T2 = ', t2 write ( *, '(a,g14.6)' ) ' X(T2)= ', x2 + f2 * t2 write ( *, '(a,g14.6)' ) ' Y(T2)= ', y2 + g2 * t2 write ( *, '(a)' ) '' write ( *, '(a)' ) ' Reported intersection PINT:' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' ', pint(1) write ( *, '(a,g14.6)' ) ' ', pint(2) return end subroutine minabs_test ( ) !*****************************************************************************80 ! !! minabs_test tests minabs. ! ! Discussion: ! ! Case 1: the three points lie on a straight line. ! (XMIN=9,YMIN=2). ! ! Case 2: the three points straddle a minimum. ! (XMIN=7, YMIN=2). ! ! Case 3: the three points straddle a maximum. ! (XMIN=2, YMIN=5). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 3 integer test real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) x3 real ( kind = rk ) xmin real ( kind = rk ) y1 real ( kind = rk ) y2 real ( kind = rk ) y3 real ( kind = rk ) ymin write ( *, '(a)' ) '' write ( *, '(a)' ) 'minabs_test' write ( *, '(a)' ) ' minabs() finds the minimum of a function' write ( *, '(a)' ) ' F(X) = a * ABS ( X ) + B' write ( *, '(a)' ) ' within an interval, given three data points.' do test = 1, test_num if ( test == 1 ) then x1 = 14.0D+00 y1 = 7.0D+00 x2 = 9.0D+00 y2 = 2.0D+00 x3 = 12.0D+00 y3 = 5.0D+00 else if ( test == 2 ) then x1 = 3.0D+00 y1 = 6.0D+00 x2 = 12.0D+00 y2 = 7.0D+00 x3 = 9.0D+00 y3 = 4.0D+00 else if ( test == 3 ) then x1 = 11.0D+00 y1 = 6.0D+00 x2 = 6.0D+00 y2 = 9.0D+00 x3 = 2.0D+00 y3 = 5.0D+00 end if call minabs ( x1, y1, x2, y2, x3, y3, xmin, ymin ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The points lie on a straight line.' write ( *, '(a,2g14.6)' ) ' XMIN, YMIN = ', xmin, ymin end do return end subroutine test047 ( ) !*****************************************************************************80 ! !! TEST047 tests MINQUAD. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) x3 real ( kind = rk ) xmin real ( kind = rk ) y1 real ( kind = rk ) y2 real ( kind = rk ) y3 real ( kind = rk ) ymin write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST047' write ( *, '(a)' ) ' MINQUAD finds the minimum of a function' write ( *, '(a)' ) ' F(X) = A * X * X + B * X + C' write ( *, '(a)' ) ' within an interval, given three data points.' ! ! Case 1: a minimum is in the interval. ! y = ( x - 1 )**2 + 4 ! x1 = 0.0D+00 y1 = ( x1 - 1.0D+00 )**2 + 4.0D+00 x2 = 2.0D+00 y2 = ( x2 - 1.0D+00 )**2 + 4.0D+00 x3 = 3.0D+00 y3 = ( x3 - 1.0D+00 )**2 + 4.0D+00 call minquad ( x1, y1, x2, y2, x3, y3, xmin, ymin ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The minimum lies in the interval.' write ( *, '(a,2g14.6)' ) ' X1, Y1 = ', x1, y1 write ( *, '(a,2g14.6)' ) ' X2, Y2 = ', x2, y2 write ( *, '(a,2g14.6)' ) ' X3, Y3 = ', x3, y3 write ( *, '(a,2g14.6)' ) ' XMIN, YMIN = ', xmin, ymin ! ! Case 2: the minimum is to the left of the interval. ! y = ( x - 1 )**2 + 4 ! x1 = 2.0D+00 y1 = ( x1 - 1.0D+00 )**2 + 4.0D+00 x2 = 4.0D+00 y2 = ( x2 - 1.0D+00 )**2 + 4.0D+00 x3 = 5.0D+00 y3 = ( x3 - 1.0D+00 )**2 + 4.0D+00 call minquad ( x1, y1, x2, y2, x3, y3, xmin, ymin ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The minimum is to the left of the interval' write ( *, '(a,2g14.6)' ) ' X1, Y1 = ', x1, y1 write ( *, '(a,2g14.6)' ) ' X2, Y2 = ', x2, y2 write ( *, '(a,2g14.6)' ) ' X3, Y3 = ', x3, y3 write ( *, '(a,2g14.6)' ) ' XMIN, YMIN = ', xmin, ymin ! ! Case 3: the function is flat. ! x1 = 11.0D+00 y1 = 6.0D+00 x2 = 6.0D+00 y2 = 6.0D+00 x3 = 2.0D+00 y3 = 6.0D+00 call minquad ( x1, y1, x2, y2, x3, y3, xmin, ymin ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The function is flat.' write ( *, '(a,2g14.6)' ) ' X1, Y1 = ', x1, y1 write ( *, '(a,2g14.6)' ) ' X2, Y2 = ', x2, y2 write ( *, '(a,2g14.6)' ) ' X3, Y3 = ', x3, y3 write ( *, '(a,2g14.6)' ) ' XMIN, YMIN = ', xmin, ymin ! ! Case 4: the function has a maximum. ! y = - ( x - 1 )**2 + 4 ! x1 = 0.0D+00 y1 = - ( x1 - 1.0D+00 )**2 + 4.0D+00 x2 = 2.0D+00 y2 = - ( x2 - 1.0D+00 )**2 + 4.0D+00 x3 = 3.0D+00 y3 = - ( x3 - 1.0D+00 )**2 + 4.0D+00 call minquad ( x1, y1, x2, y2, x3, y3, xmin, ymin ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The function has a maximum.' write ( *, '(a,2g14.6)' ) ' X1, Y1 = ', x1, y1 write ( *, '(a,2g14.6)' ) ' X2, Y2 = ', x2, y2 write ( *, '(a,2g14.6)' ) ' X3, Y3 = ', x3, y3 write ( *, '(a,2g14.6)' ) ' XMIN, YMIN = ', xmin, ymin return end subroutine test0475 ( ) !*****************************************************************************80 ! !! TEST0475 tests OCTAHEDRON_SIZE_3D and OCTAHEDRON_SHAPE_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) area integer edge_num integer face_num integer, allocatable, dimension ( : ) :: face_order integer face_order_max integer, allocatable, dimension ( :, : ) :: face_point integer i integer j integer k real ( kind = rk ) normal(dim_num) integer point_num real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord real ( kind = rk ), allocatable, dimension ( :, : ) :: v real ( kind = rk ) vave(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0475' write ( *, '(a)' ) ' For the octahedron:' write ( *, '(a)' ) ' OCTAHEDRON_SIZE_3D returns dimension information;' write ( *, '(a)' ) ' OCTAHEDRON_SHAPE_3D returns face and order information.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will use this information to compute the' write ( *, '(a)' ) ' areas and centers of each face.' call octahedron_size_3d ( point_num, edge_num, face_num, face_order_max ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num write ( *, '(a,i8)' ) ' Number of edges = ', edge_num write ( *, '(a,i8)' ) ' Number of faces = ', face_num write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max allocate ( face_order(1:face_num) ) allocate ( face_point(1:face_order_max,1:face_num) ) allocate ( point_coord(1:dim_num,1:point_num) ) allocate ( v(1:3,1:face_order_max) ) call octahedron_shape_3d ( point_num, face_num, face_order_max, point_coord, & face_order, face_point ) ! ! Compute the area of each face. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' Face Order Area' write ( *, '(a)' ) '' do i = 1, face_num do j = 1, face_order(i) k = face_point(j,i) v(1:3,j) = point_coord(1:dim_num,k) end do call polygon_area_3d ( face_order(i), v, area, normal ) write ( *, '(2x,i8,i7,f8.4)' ) i, face_order(i), area end do ! ! Find the center of each face. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' Face Center' write ( *, '(a)' ) '' do i = 1, face_num vave(1:dim_num) = 0.0D+00 do j = 1, face_order(i) k = face_point(j,i) vave(1:dim_num) = vave(1:dim_num) + point_coord(1:dim_num,k) end do vave(1:dim_num) = vave(1:dim_num) / real ( face_order(i), kind = rk ) write ( *, '(2x,i8,3f8.4)' ) i, vave(1:dim_num) end do deallocate ( face_order ) deallocate ( face_point ) deallocate ( point_coord ) deallocate ( v ) return end subroutine test0477 ( ) !*****************************************************************************80 ! !! TEST0477 tests PARALLELOGRAM_AREA_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ) :: p(2,4) = reshape ( (/ & 2.0D+00, 7.0D+00, & 5.0D+00, 7.0D+00, & 6.0D+00, 9.0D+00, & 3.0D+00, 9.0D+00 & /), (/ 2, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0477' write ( *, '(a)' ) ' PARALLELOGRAM_AREA_2D finds the area of a' write ( *, '(a)' ) ' parallelogram in 2D.' call r8mat_transpose_print ( 2, 4, p, ' Vertices:' ) call parallelogram_area_2d ( p, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' AREA = ', area return end subroutine test0478 ( ) !*****************************************************************************80 ! !! TEST0478 tests PARALLELOGRAM_AREA_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ) :: p(3,4) = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 2.4142137D+00, 3.4142137D+00, 3.0D+00, & 1.7071068D+00, 2.7071068D+00, 4.0D+00, & 0.2928931D+00, 0.2928931D+00, 4.0D+00 & /), (/ 3, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0478' write ( *, '(a)' ) ' PARALLELOGRAM_AREA_3D finds the area of a' write ( *, '(a)' ) ' parallelogram in 3D.' call r8mat_transpose_print ( 3, 4, p, ' Vertices:' ) call parallelogram_area_3d ( p, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' AREA = ', area return end subroutine test048 ( ) !*****************************************************************************80 ! !! TEST048 tests PARALLELOGRAM_CONTAINS_POINT_2D. ! ! Discussion: ! ! The four points are In, Out, Out, and Out. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 logical inside real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = & reshape ( (/ & 1.0D+00, 0.5D+00, & 2.0D+00, 0.0D+00, & 0.5D+00, -0.1D+00, & 0.1D+00, 0.5D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 1.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p3 = (/ 1.0D+00, 1.0D+00 /) logical parallelogram_contains_point_2d integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST048' write ( *, '(a)' ) ' PARALLELOGRAM_CONTAINS_POINT_2D determines if a point ' write ( *, '(a)' ) ' is within a parallelogram in 2D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Parallelogram defined by P2-P1, P3-P1:' write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,2g14.6)' ) ' P3 = ', p3(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P Inside?' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) inside = parallelogram_contains_point_2d ( p1, p2, p3, p ) write ( *, '(2x,2g14.6,2x,l1)' ) p(1:dim_num), inside end do return end subroutine test0485 ( ) !*****************************************************************************80 ! !! TEST0485 tests PARALLELOGRAM_CONTAINS_POINT_2D ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 51 integer, parameter :: dim_num = 2 logical parallelogram_contains_point_2d character dot(n) integer i integer j real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 0.2D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 0.4D+00, 0.6D+00 /) real ( kind = rk ), dimension(dim_num) :: p3 = (/ 0.6D+00, 0.4D+00 /) real ( kind = rk ), parameter :: xhi = 1.0D+00 real ( kind = rk ), parameter :: xlo = 0.0D+00 real ( kind = rk ), parameter :: yhi = 1.0D+00 real ( kind = rk ), parameter :: ylo = 0.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0485' write ( *, '(a)' ) ' PARALLELOGRAM_CONTAINS_POINT_2D reports if a' write ( *, '(a)' ) ' parallelogram contains a point.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will call the function repeatedly, and draw' write ( *, '(a)' ) ' a sketch of the unit square.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Parallelogram defined by P2-P1, P3-P1:' write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,2g14.6)' ) ' P3 = ', p3(1:dim_num) write ( *, '(a)' ) '' do i = 1, n p(2) = ( real ( n - i, kind = rk ) * yhi & + real ( i - 1, kind = rk ) * ylo ) & / real ( n - 1, kind = rk ) do j = 1, n p(1) = ( real ( n - j, kind = rk ) * xlo & + real ( j - 1, kind = rk ) * xhi ) & / real ( n - 1, kind = rk ) if ( parallelogram_contains_point_2d ( p1, p2, p3, p ) ) then dot(j) = '*' else dot(j) = '-' end if end do write ( *, '(2x,51a1)' ) dot(1:n) end do return end subroutine test049 ( ) !*****************************************************************************80 ! !! TEST049 tests PARALLELOGRAM_CONTAINS_POINT_3D. ! ! Discussion: ! ! The points are In, Out, Out, Out, Out ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 logical inside real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = & reshape ( (/ & 1.0D+00, 1.0D+00, 0.5D+00, & 3.0D+00, 3.0D+00, 0.0D+00, & 0.5D+00, 0.5D+00, -0.1D+00, & 0.1D+00, 0.1D+00, 0.5D+00, & 1.5D+00, 1.6D+00, 0.5D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: p1 = (/ & 0.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ & 2.0D+00, 2.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p3 = (/ & 1.0D+00, 1.0D+00, 1.0D+00 /) logical parallelogram_contains_point_3d integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST049' write ( *, '(a)' ) ' PARALLELOGRAM_CONTAINS_POINT_3D determines if a point ' write ( *, '(a)' ) ' is within a parallelogram in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Parallelogram defined by P2-P1, P3-P1:' write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3 = ', p3(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P Inside?' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) inside = parallelogram_contains_point_3d ( p1, p2, p3, p ) write ( *, '(2x,3g14.6,2x,l1)' ) p(1:dim_num), inside end do return end subroutine test0493 ( ) !*****************************************************************************80 ! !! TEST0493 tests PARABOLA_EX and PARABOLA_EX2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c integer ierror real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) x3 real ( kind = rk ) xmin real ( kind = rk ) y1 real ( kind = rk ) y2 real ( kind = rk ) y3 real ( kind = rk ) ymin write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0493' write ( *, '(a)' ) ' PARABOLA_EX finds the extreme value of a parabola' write ( *, '(a)' ) ' determined by three points.' write ( *, '(a)' ) ' PARABOLA_EX2 finds the extreme value of a parabola' write ( *, '(a)' ) ' determined by three points.' a = 2.0D+00 b = -4.0D+00 c = 10.0D+00 x1 = 1.0D+00 y1 = a * x1 * x1 + b * x1 + c x2 = 2.0D+00 y2 = a * x2 * x2 + b * x2 + c x3 = 3.0D+00 y3 = a * x3 * x3 + b * x3 + c write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Parabolic coefficients (A,B,C) = ', a, b, c write ( *, '(a)' ) '' write ( *, '(a)' ) ' X, Y data' write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' X1, Y1 = ', x1, y1 write ( *, '(a,2g14.6)' ) ' X2, Y2 = ', x2, y2 write ( *, '(a,2g14.6)' ) ' X3, Y3 = ', x3, y3 a = 0.0D+00 b = 0.0D+00 c = 0.0D+00 call parabola_ex ( x1, y1, x2, y2, x3, y3, xmin, ymin, ierror ) if ( ierror == 0 ) then write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' PARABOLA_EX returns (XMIN,YMIN) = ', xmin, ymin else write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' PARABOLA_EX returns error code ', ierror end if call parabola_ex2 ( x1, y1, x2, y2, x3, y3, xmin, ymin, a, b, c, ierror ) if ( ierror == 0 ) then write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' PARABOLA_EX2 returns (XMIN,YMIN) = ', xmin, ymin write ( *, '(a,3g14.6)' ) ' and (A,B,C) = ', a, b, c else write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' PARABOLA_EX2 returns error code ', ierror end if return end subroutine test0495 ( ) !*****************************************************************************80 ! !! TEST0495 tests PARALLELEPIPED_POINT_DIST_3D. ! ! Discussion: ! ! The points tested are: ! ! 1: Center of box. ! 2: The middle of a face. ! 3: The middle of an edge. ! 4: A corner. ! 5: Close to a face. ! 6: Close to an edge. ! 7: Close to a corner. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 7 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = & reshape ( (/ & 1.0D+00, 4.0D+00, 0.5D+00, & 1.0D+00, 0.0D+00, 0.5D+00, & 0.0D+00, 4.0D+00, 1.0D+00, & 2.0D+00, 8.0D+00, 1.0D+00, & -0.5D+00, 4.0D+00, 0.5D+00, & 1.0D+00, -1.0D+00, -1.0D+00, & 3.0D+00, 9.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 0.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 2.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 0.0D+00, 8.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p4 = (/ & 0.0D+00, 0.0D+00, 1.0D+00 /) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0495' write ( *, '(a)' ) ' PARALLELEPIPED_POINT_DIST_3D computes the distance ' write ( *, '(a)' ) ' from a point to a box (parallelipiped) in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The 4 box corners that are specified:' write ( *, '(a)' ) '' write ( *, '(2x,3f10.2)' ) p1(1:dim_num) write ( *, '(2x,3f10.2)' ) p2(1:dim_num) write ( *, '(2x,3f10.2)' ) p3(1:dim_num) write ( *, '(2x,3f10.2)' ) p4(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test P Distance to box' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call parallelepiped_point_dist_3d ( p1, p2, p3, p4, p, dist ) write ( *, '(2x,i3,2x,3f10.2,2x,g14.6)' ) test, p(1:dim_num), dist end do return end subroutine test050 ( ) !*****************************************************************************80 ! !! TEST050 tests PLANE_EXP_NORMAL_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) normal(dim_num) real ( kind = rk ), dimension ( dim_num) :: p1 = (/ & -10.56D+00, -10.56D+00, 78.09D+00 /) real ( kind = rk ), dimension ( dim_num) :: p2 = (/ & 44.66D+00, -65.77D+00, 0.00D+00 /) real ( kind = rk ), dimension ( dim_num) :: p3 = (/ & 44.66D+00, 44.66D+00, 0.00D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST050' write ( *, '(a)' ) ' PLANE_EXP_NORMAL_3D finds the normal ' write ( *, '(a)' ) ' to a plane.' write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) call plane_exp_normal_3d ( p1, p2, p3, normal ) call r8vec_print ( dim_num, normal, ' The normal vector:' ) return end subroutine plane_exp2imp_3d_test ( ) !*****************************************************************************80 ! !! PLANE_EXP2IMP_3D_TEST tests PLANE_EXP2IMP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ), dimension ( dim_num ) :: p1 real ( kind = rk ), dimension ( dim_num,test_num ) :: p1_test = reshape ( (/ & -1.0D+00, 0.0D+00, -1.0D+00, & -16.0D+00, 2.0D+00, 4.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p2 real ( kind = rk ), dimension ( dim_num,test_num ) :: p2_test = reshape ( (/ & -4.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p3 real ( kind = rk ), dimension ( dim_num,test_num ) :: p3_test = reshape ( (/ & -20.0D+00, 2.0D+00, 4.0D+00, & 4.0D+00, -2.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'PLANE_EXP2IMP_3D_TEST' write ( *, '(a)' ) ' PLANE_EXP2IMP_3D puts a plane defined by ' write ( *, '(a)' ) ' 3 points into A*X+B*Y+C*Z+D = 0 form.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test 1: Correct answer is a multiple of 1, 2, 3, 4.' write ( *, '(a)' ) ' Test 2: Correct answer is a multiple of 1, 2, 3, 0.' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) p3(1:dim_num) = p3_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) call plane_exp2imp_3d ( p1, p2, p3, a, b, c, d ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' (A,B,C,D)= ' write ( *, '(2x,4g14.6)' ) a, b, c, d write ( *, '(a)' ) '' end do return end subroutine plane_exp2normal_3d_test ( ) !*****************************************************************************80 ! !! PLANE_EXP2NORMAL_3D_TEST tests PLANE_EXP2NORMAL_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) normal(dim_num) real ( kind = rk ), dimension ( dim_num ) :: p1 real ( kind = rk ), dimension ( dim_num,test_num ) :: p1_test = reshape ( (/ & -1.0D+00, 0.0D+00, -1.0D+00, & -16.0D+00, 2.0D+00, 4.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p2 real ( kind = rk ), dimension ( dim_num,test_num ) :: p2_test = reshape ( (/ & -4.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p3 real ( kind = rk ), dimension ( dim_num,test_num ) :: p3_test = reshape ( (/ & -20.0D+00, 2.0D+00, 4.0D+00, & 4.0D+00, -2.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pp(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'PLANE_EXP2NORMAL_3D_TEST' write ( *, '(a)' ) ' PLANE_EXP2NORMAL_3D puts a plane defined by ' write ( *, '(a)' ) ' 3 points into point, normal form.' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) p3(1:dim_num) = p3_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) call plane_exp2normal_3d ( p1, p2, p3, pp, normal ) call r8vec_print ( dim_num, pp, ' The point PP:' ) call r8vec_print ( dim_num, normal, ' Normal vector:' ) end do return end subroutine test053 ( ) !*****************************************************************************80 ! !! TEST053 tests PLANE_EXP_PROJECT_3D. ! ! Discussion: ! ! 1: Projection is ( 0, 0.5, 0.5 ), IVIS is 3. ! 2: Projection is ( 4, 5, -8 ), IVIS is 2. ! 3: Projection is ( 0.33, 0.33, 0.33), IVIS is 1. ! 4: "Projection" is ( 0, 0, 0 ), IVIS is 0. ! 5: Projection is ( 1, 0, 0 ), IVIS is -1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 integer ivis(test_num) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 1.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 1.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 0.0D+00, 0.0D+00, 1.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: pf = (/ & 0.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num,test_num) :: po = reshape ( (/ & 0.00D+00, 2.00D+00, 2.00D+00, & 4.00D+00, 5.00D+00, -8.00D+00, & 0.25D+00, 0.25D+00, 0.25D+00, & 5.00D+00, -2.00D+00, -3.00D+00, & -2.00D+00, 0.00D+00, 0.00D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pp(dim_num,test_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST053' write ( *, '(a)' ) ' PLANE_EXP_PROJECT_3D projects a point through' write ( *, '(a)' ) ' a focus point into a plane.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' PO PP IVIS' write ( *, '(a)' ) '' call plane_exp_project_3d ( p1, p2, p3, pf, test_num, po, pp, ivis ) do test = 1, test_num write ( *, '(2x,6g12.4,i4)' ) po(1:dim_num,test), & pp(1:dim_num,test), ivis(test_num) end do return end subroutine test054 ( ) !*****************************************************************************80 ! !! TEST054 tests PLANE_IMP2EXP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST054' write ( *, '(a)' ) ' PLANE_IMP2EXP_3D converts a plane in implicit' write ( *, '(a)' ) ' (A,B,C,D) form to explicit form.' a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' (A,B,C,D) = ' write ( *, '(2x,4g14.6)' ) a, b, c, d call plane_imp2exp_3d ( a, b, c, d, p1, p2, p3 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) return end subroutine test055 ( ) !*****************************************************************************80 ! !! TEST055 tests PLANE_IMP2NORMAL_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) normal(dim_num) real ( kind = rk ) pp(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST055' write ( *, '(a)' ) ' PLANE_IMP2NORMAL_3D converts a plane in implicit' write ( *, '(a)' ) ' (A,B,C,D) form to point, normal form.' a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' Input:' write ( *, '(a)' ) '' write ( *, '(a,4g14.6)' ) ' (A,B,C,D) = ', a, b, c, d call plane_imp2normal_3d ( a, b, c, d, pp, normal ) call r8vec_print ( dim_num, pp, ' The point PP:' ) call r8vec_print ( dim_num, normal, ' Normal vector:' ) return end subroutine test056 ( ) !*****************************************************************************80 ! !! TEST056 tests PLANE_IMP_LINE_PAR_INT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) f real ( kind = rk ) g real ( kind = rk ) h logical intersect real ( kind = rk ) p(dim_num) real ( kind = rk ) x0 real ( kind = rk ) y0 real ( kind = rk ) z0 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST056' write ( *, '(a)' ) ' PLANE_IMP_LINE_PAR_INT_3D finds the ' write ( *, '(a)' ) ' intersection of an implicit plane and' write ( *, '(a)' ) ' a parametric line, in 3D.' a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 f = 2.0D+00 g = 1.0D+00 h = 5.0D+00 x0 = 3.0D+00 y0 = 0.0D+00 z0 = -7.0D+00 call plane_imp_line_par_int_3d ( a, b, c, d, x0, y0, z0, f, g, h, & intersect, p ) if ( intersect ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The plane and line intersect at ' write ( *, '(2x,3g14.6)' ) p(1:dim_num) else write ( *, '(a)' ) '' write ( *, '(a)' ) ' The plane and the line do not intersect.' end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' Expected answer:' write ( *, '(a)' ) ' The plane and line intersect at ' write ( *, '(a)' ) ' 7, 2, 3.' return end subroutine test057 ( ) !*****************************************************************************80 ! !! TEST057 tests PLANE_IMP_SEGMENT_NEAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) dist real ( kind = rk ) p(1:dim_num) real ( kind = rk ) p1(1:dim_num) real ( kind = rk ) p2(1:dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p2_test = reshape ( (/ & 9.0D+00, 3.0D+00, 8.0D+00, & 5.0D+00, 1.0D+00, -2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pn(1:dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST057' write ( *, '(a)' ) ' PLANE_IMP_SEGMENT_NEAR_3D finds the point' write ( *, '(a)' ) ' on a line segment nearest a plane.' do test = 1, test_num p1(1:dim_num) = (/ 3.0D+00, 0.0D+00, -7.0D+00 /) p2(1:dim_num) = p2_test(1:dim_num,test) a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 call plane_imp_segment_near_3d ( p1, p2, a, b, c, d, dist, p, pn ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' The distance between the plane and the' write ( *, '(a,g14.6)' ) ' line segment is ', dist write ( *, '(a)' ) '' write ( *, '(a)' ) ' A nearest point on the line segment is ' write ( *, '(2x,3g14.6)' ) pn(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' A nearest point on the plane is ' write ( *, '(2x,3g14.6)' ) p(1:dim_num) end do return end subroutine test058 ( ) !*****************************************************************************80 ! !! TEST058 tests PLANE_IMP_POINT_DIST_3D and PLANE_IMP_POINT_DIST_SIGNED_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) dist real ( kind = rk ) dist_signed real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = & reshape ( (/ & -12.0D+00, 14.0D+00, 0.0D+00, & 7.0D+00, 8.0D+00, 9.0D+00, & 1.0D+00, 2.0D+00, 10.0D+00, & 0.0D+00, 0.0D+00, 12.0D+00 /), (/ dim_num, test_num /) ) integer test ! ! This is the plane Z = 10. ! a = 0.0D+00 b = 0.0D+00 c = 1.0D+00 d = - 10.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST058' write ( *, '(a)' ) ' PLANE_IMP_POINT_DIST_3D computes the distance' write ( *, '(a)' ) ' between an implicit plane and a point in 3D;' write ( *, '(a)' ) ' PLANE_IMP_POINT_DIST_SIGNED 3D computes the ' write ( *, '(a)' ) ' signed distance between an implicit plane ' write ( *, '(a)' ) ' and a point in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' For all tests, we use the implicit plane with' write ( *, '(a,4g14.6)' ) ' (A,B,C,D) = ', a, b, c, d write ( *, '(a)' ) '' write ( *, '(a)' ) ' (X,Y,Z) DISTANCE SIGNED_DISTANCE' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call plane_imp_point_dist_3d ( a, b, c, d, p, dist ) call plane_imp_point_dist_signed_3d ( a, b, c, d, p, dist_signed ) write ( *, '(2x,5g14.6)' ) p(1:dim_num), dist, dist_signed end do return end subroutine test059 ( ) !*****************************************************************************80 ! !! TEST059 tests PLANE_IMP_TRIANGLE_NEAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ) dist integer near_num real ( kind = rk ) pn(dim_num,6) real ( kind = rk ), dimension(dim_num,3) :: t real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 5.0D+00, 1.0D+00, -2.0D+00, & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 9.0D+00, 3.0D+00, 8.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST059' write ( *, '(a)' ) ' PLANE_IMP_TRIANGLE_NEAR_3D finds the nearest' write ( *, '(a)' ) ' points on an implicit plane and a triangle.' a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' Implicit plane: A*X + B*Y + C*Z + D = 0.' write ( *, '(a)' ) ' A,B,C,D = ' write ( *, '(2x,4g14.6)' ) a, b, c, d do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call plane_imp_triangle_near_3d ( t, a, b, c, d, dist, near_num, pn ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Triangle to plane distance is ', dist call r8mat_transpose_print ( dim_num, near_num, pn, ' Nearest points:' ) end do return end subroutine test060 ( ) !*****************************************************************************80 ! !! TEST060 tests PLANE_IMP_TRIANGLE_INT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d integer int_num real ( kind = rk ) pint(dim_num,3) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 5.0D+00, 1.0D+00, -2.0D+00, & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 9.0D+00, 3.0D+00, 8.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 3.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 2.0D+00, & -4.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 6.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST060' write ( *, '(a)' ) ' PLANE_IMP_TRIANGLE_INT_3D finds the' write ( *, '(a)' ) ' intersection points of an implicit plane' write ( *, '(a)' ) ' and a triangle.' a = 1.0D+00 b = -2.0D+00 c = -3.0D+00 d = 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) ' The implicit plane: A*X + B*Y + C*Z + D = 0.' write ( *, '(a,4g14.6)' ) ' A,B,C,D = ', a, b, c, d do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Case ', test write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call plane_imp_triangle_int_3d ( a, b, c, d, t, int_num, pint ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of intersection points is ', int_num write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, int_num, pint, & ' Intersection points:' ) end do return end subroutine test061 ( ) !*****************************************************************************80 ! !! TEST061 tests PLANE_NORMAL_BASIS_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 real ( kind = rk ) b(dim_num,dim_num) real ( kind = rk ), dimension(dim_num) :: normal real ( kind = rk ), dimension(dim_num) :: pp real ( kind = rk ), dimension(dim_num) :: pq real ( kind = rk ), dimension(dim_num) :: pr integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST061' write ( *, '(a)' ) ' PLANE_NORMAL_BASIS_3D, given a plane in' write ( *, '(a)' ) ' point, normal form (P,N), finds two unit' write ( *, '(a)' ) ' vectors Q and R that "lie" in the plane' write ( *, '(a)' ) ' and are mutually orthogonal.' do test = 1, test_num call random_number ( harvest = normal(1:dim_num) ) call random_number ( harvest = pp(1:dim_num) ) call plane_normal_basis_3d ( pp, normal, pq, pr ) if ( test == 1 ) then call r8vec_print ( dim_num, pp, ' Point PP:' ) call r8vec_print ( dim_num, normal, ' Normal vector N:' ) call r8vec_print ( dim_num, pq, ' Vector PQ:' ) call r8vec_print ( dim_num, pr, ' Vector PR:' ) end if b(1,1) = dot_product ( normal(1:dim_num), normal(1:dim_num) ) b(1,2) = dot_product ( normal(1:dim_num), pq(1:dim_num) ) b(1,3) = dot_product ( normal(1:dim_num), pr(1:dim_num) ) b(2,1) = dot_product ( pq(1:dim_num), normal(1:dim_num) ) b(2,2) = dot_product ( pq(1:dim_num), pq(1:dim_num) ) b(2,3) = dot_product ( pq(1:dim_num), pr(1:dim_num) ) b(3,1) = dot_product ( pr(1:dim_num), normal(1:dim_num) ) b(3,2) = dot_product ( pr(1:dim_num), pq(1:dim_num) ) b(3,3) = dot_product ( pr(1:dim_num), pr(1:dim_num) ) call r8mat_print ( dim_num, dim_num, b, ' Dot product matrix:' ) end do return end subroutine test0615 ( ) !*****************************************************************************80 ! !! TEST0615 tests PLANE_NORMAL_LINE_EXP_INT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer ival real ( kind = rk ), dimension(dim_num) :: normal = (/ & 1.0D+00, -2.0D+00, -3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 3.0D+00, 0.0D+00, -7.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 5.0D+00, 1.0D+00, -2.0D+00 /) real ( kind = rk ) pint(dim_num) real ( kind = rk ), dimension ( dim_num ) :: pp = (/ & -1.0D+00, +1.0D+00, +1.0D+00 /) real ( kind = rk ) temp write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0615' write ( *, '(a)' ) ' PLANE_NORMAL_LINE_EXP_INT_3D finds the ' write ( *, '(a)' ) ' intersection of a normal plane and' write ( *, '(a)' ) ' an explicit line, in 3D.' temp = sqrt ( sum ( normal(1:dim_num)**2 ) ) normal(1:dim_num) = normal(1:dim_num) / temp call r8vec_print ( dim_num, pp, ' Plane point PP:' ) call r8vec_print ( dim_num, normal, ' Plane Normal:' ) call line_exp_print_2d ( p1, p2, ' The explicit line:' ) call plane_normal_line_exp_int_3d ( pp, normal, p1, p2, ival, pint ) write ( *, '(a)' ) '' if ( ival == 0 ) then write ( *, '(a)' ) ' The plane and line do not intersect.' else if ( ival == 1 ) then write ( *, '(a)' ) ' The plane and line intersect at ' write ( *, '(2x,3g14.6)' ) pint(1:dim_num) else if ( ival == 2 ) then write ( *, '(a)' ) ' The plane and line are coincident.' write ( *, '(a)' ) ' One of the infinitely many points of intersection:' write ( *, '(2x,3g14.6)' ) pint(1:dim_num) else write ( *, '(a)' ) ' The plane and the line do not intersect.' end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' Expected answer:' write ( *, '(a)' ) ' The plane and line intersect at ' write ( *, '(a)' ) ' 7, 2, 3.' return end subroutine test0616 ( ) !*****************************************************************************80 ! !! TEST0616 tests PLANE_NORMAL_QR_TO_XYZ and PLANE_NORMAL_XYZ_TO_QR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 November 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 3 integer, parameter :: n = 5 real ( kind = rk ) dif integer j real ( kind = rk ) normal(m) real ( kind = rk ) pp(m) real ( kind = rk ) pq(m) real ( kind = rk ) pr(m) real ( kind = rk ) qr1(m-1,n) real ( kind = rk ) qr2(m-1,n) real ( kind = rk ) xyz(m,n) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0616' write ( *, '(a)' ) ' For a normal plane, with point PP and NORMAL vector,' write ( *, '(a)' ) ' and in-plane basis vectors PQ and PR,' write ( *, '(a)' ) ' PLANE_NORMAL_QR_TO_XYZ converts QR to XYZ coordinates;' write ( *, '(a)' ) ' PLANE_NORMAL_XYZ_TO_QR converts XYZ to QR coordinates.' ! ! Choose PP and NORMAL at random. ! call random_number ( harvest = pp(1:m) ) call random_number ( harvest = normal(1:m) ) ! ! Compute in-plane basis vectors PQ and PR. ! call plane_normal_basis_3d ( pp, normal, pq, pr ) ! ! Choose random Q, R coordinates. ! call random_number ( harvest = qr1(1:m-1,1:n) ) call r8mat_transpose_print ( m - 1, n, qr1, ' QR1' ) ! ! Convert to XYZ. ! call plane_normal_qr_to_xyz ( pp, normal, pq, pr, n, qr1, xyz ) call r8mat_transpose_print ( m, n, xyz, ' XYZ' ) ! ! Convert XYZ to QR. ! call plane_normal_xyz_to_qr ( pp, normal, pq, pr, n, xyz, qr2 ) call r8mat_transpose_print ( m - 1, n, qr2, ' QR2' ) dif = 0.0D+00 do j = 1, n dif = max ( dif, sqrt ( sum ( ( qr1(1:m-1,j) - qr2(1:m-1,j) )**2 ) ) ) end do write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Maximum difference was ', dif return end subroutine test0617 ( ) !*****************************************************************************80 ! !! TEST0617 tests PLANE_NORMAL_TETRAHEDRON_INTERSECT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 June 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer j integer k integer int_num real ( kind = rk ) normal(3) real ( kind = rk ) pint(3,4) real ( kind = rk ) pp(3) real ( kind = rk ), dimension ( 3, 4 ) :: t = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 & /), (/ 3, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0617' write ( *, '(a)' ) ' PLANE_NORMAL_TETRAHEDRON_INTERSECT determines' write ( *, '(a)' ) ' the intersection of a plane and tetrahedron.' do k = 1, 2 if ( k == 1 ) then normal(1:3) = (/ 0.0D+00, 0.0D+00, 1.0D+00 /) else normal(1:3) = (/ 1.0D+00, 1.0D+00, 0.0D+00 /) / sqrt ( 2.0D+00 ) end if write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' Plane normal vector number ', k write ( *, '(a)' ) '' write ( *, '(2x,g14.6,2x,g14.6,2x,g14.6)' ) normal(1:3) do i = 0, 6 pp(1:3) = normal(1:3) * real ( i, kind = rk ) / 5.0D+00 call plane_normal_tetrahedron_intersect ( pp, normal, t, int_num, pint ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Point on plane:' write ( *, '(a)' ) '' write ( *, '(2x,g14.6,2x,g14.6,2x,g14.6)' ) pp(1:3) write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' Number of intersection points = ', int_num write ( *, '(a)' ) '' do j = 1, int_num write ( *, '(2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) j, pint(1:3,j) end do end do end do return end subroutine test062 ( ) !*****************************************************************************80 ! !! TEST062 tests PLANE_NORMAL_TRIANGLE_INT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 integer int_num real ( kind = rk ), dimension(dim_num) :: normal = (/ & 1.0D+00, -2.0D+00, -3.0D+00 /) real ( kind = rk ) pint(dim_num,3) real ( kind = rk ), dimension(dim_num) :: pp = (/ & 0.0D+00, 0.0D+00, 2.0D+00 /) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 5.0D+00, 1.0D+00, -2.0D+00, & 3.0D+00, 0.0D+00, -7.0D+00, & 13.0D+00, -4.0D+00, -1.0D+00, & 9.0D+00, 3.0D+00, 8.0D+00, & -6.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 3.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 2.0D+00, & -4.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 6.0D+00, -2.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST062' write ( *, '(a)' ) ' PLANE_NORMAL_TRIANGLE_INT_3D finds the' write ( *, '(a)' ) ' intersection points of a normal form plane' write ( *, '(a)' ) ' and a triangle.' call r8vec_print ( dim_num, pp, ' The point PP:' ) call r8vec_print ( dim_num, normal, ' The normal vector N:' ) do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call plane_normal_triangle_int_3d ( pp, normal, t, int_num, pint ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of intersection points is ', int_num write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, int_num, pint, & ' Intersection points:' ) end do return end subroutine test063 ( ) !*****************************************************************************80 ! !! TEST063 tests PLANE_NORMAL2EXP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ), dimension(dim_num) :: normal = (/ & -0.2672612D+00, -0.5345225D+00, -0.8017837D+00 /) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) p3(dim_num) real ( kind = rk ), dimension(dim_num) :: pp = (/ & -1.0D+00, 0.0D+00, -1.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST063' write ( *, '(a)' ) ' PLANE_NORMAL2EXP_3D puts a plane defined by ' write ( *, '(a)' ) ' point, normal form into explicit form.' call r8vec_print ( dim_num, pp, ' The point PP:' ) call r8vec_print ( dim_num, normal, ' Normal vector:' ) call plane_normal2exp_3d ( pp, normal, p1, p2, p3 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) return end subroutine test064 ( ) ! !*****************************************************************************80 ! !! TEST064 tests PLANE_NORMAL2IMP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d real ( kind = rk ), dimension(dim_num) :: normal real ( kind = rk ), dimension(dim_num,test_num) :: normal_test = reshape ( (/ & -0.2672612D+00, -0.5345225D+00, -0.8017837D+00, & -0.2672612D+00, -0.5345225D+00, -0.8017837D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: pp real ( kind = rk ), dimension(dim_num,test_num) :: pp_test = reshape ( (/ & -1.0D+00, 0.0D+00, -1.0D+00, & -16.0D+00, 2.0D+00, 4.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST064' write ( *, '(a)' ) ' PLANE_NORMAL2IMP_3D puts a plane defined by ' write ( *, '(a)' ) ' point, normal form into implicit ABCD form.' do test = 1, test_num pp(1:dim_num) = pp_test(1:dim_num,test) normal(1:dim_num) = normal_test(1:dim_num,test) call r8vec_print ( dim_num, pp, ' The point PP:' ) call r8vec_print ( dim_num, normal, ' Normal vector:' ) call plane_normal2imp_3d ( pp, normal, a, b, c, d ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Output:' write ( *, '(a)' ) '' write ( *, '(a,4g14.6)' ) ' (A,B,C,D)= ', a, b, c, d end do return end subroutine points_centroid_2d_test ( ) !*****************************************************************************80 ! !! points_centroid_2d_test tests points_centroid_2d. ! ! Diagram: ! ! !....3&11.... ! !............ ! !............ ! X..9......... ! !.....5...... ! !...........6 ! !.4.2...10... ! !.....8...12. ! V............ ! !..7......... ! !......1..... ! !............ ! !............ ! !----V----X-- ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 12 integer, parameter :: dim_num = 2 integer centroid_index real ( kind = rk ), dimension ( dim_num, n ) :: p = reshape ( (/ & 7.0D+00, 3.0D+00, & 4.0D+00, 7.0D+00, & 5.0D+00, 13.0D+00, & 2.0D+00, 7.0D+00, & 6.0D+00, 9.0D+00, & 12.0D+00, 8.0D+00, & 3.0D+00, 4.0D+00, & 6.0D+00, 6.0D+00, & 3.0D+00, 10.0D+00, & 8.0D+00, 7.0D+00, & 5.0D+00, 13.0D+00, & 10.0D+00, 6.0D+00 /), (/ dim_num, n /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'points_centroid_2d_test' write ( *, '(a)' ) ' points_centroid_2d() computes the centroid of a' write ( *, '(a)' ) ' discrete set of points.' call r8mat_transpose_print ( dim_num, n, p, ' The points:' ) call points_centroid_2d ( n, p, centroid_index ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' The centroid is point #:', centroid_index return end subroutine test066 ( ) !*****************************************************************************80 ! !! TEST066 tests POINTS_COLIN_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) colin real ( kind = rk ), dimension(dim_num) :: p1 real ( kind = rk ), dimension(dim_num,test_num) :: p1_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: p2 real ( kind = rk ), dimension(dim_num,test_num) :: p2_test = reshape ( (/ & 10.0D+00, 10.0D+00, & 0.0D+00, 1.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: p3 real ( kind = rk ), dimension(dim_num,test_num) :: p3_test = reshape ( (/ & 5.0D+00, 4.99D+00, & 100.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST066' write ( *, '(a)' ) ' POINTS_COLIN_2D estimates the colinearity' write ( *, '(a)' ) ' of three points.' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) p3(1:dim_num) = p3_test(1:dim_num,test) write ( *, '(a)' ) '' if ( test == 1 ) then write ( *, '(a)' ) ' Points almost on a line: Expect tiny COLIN.' else if ( test == 2 ) then write ( *, '(a)' ) ' Two points close, one far: Expect tiny COLIN.' else if ( test == 3 ) then write ( *, '(a)' ) ' Points on an equilateral triangle: Expect COLIN = 1.' end if call points_colin_2d ( p1, p2, p3, colin ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' P1: ', p1(1:dim_num) write ( *, '(a,3g14.6)' ) ' P2: ', p2(1:dim_num) write ( *, '(a,3g14.6)' ) ' P3: ', p3(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Colinearity index = ', colin end do return end subroutine points_hull_2d_test ( ) !*****************************************************************************80 ! !! points_hull_2d_test tests points_hull_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: node_num = 7 integer hull_num real ( kind = rk ) node_xy(2,node_num) integer hull(node_num) real ( kind = rk ) hull_xy(2,node_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'points_hull_2d_test' write ( *, '(a)' ) ' points_hull_2d() computes the convex hull' write ( *, '(a)' ) ' of a set of N 2D points using an algorithm' write ( *, '(a)' ) ' that is order NlogH.' write ( *, '(a)' ) ' (H is the number of points on the convex hull.)' node_xy(1:2,1:node_num) = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, & 2.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, & 0.0D+00, 2.0D+00, & 1.0D+00, 3.0D+00, & 2.0D+00, 2.0D+00 /), (/ 2, node_num /) ) call r8mat_transpose_print ( 2, node_num, node_xy, & ' Coordinates of the points:' ) call points_hull_2d ( node_num, node_xy, hull_num, hull ) hull_xy(1:2,1:hull_num) = node_xy(1:2,hull(1:hull_num)) call r8mat_transpose_print ( 2, hull_num, hull_xy, & ' Coordinates of the convex hull:' ) return end subroutine polar_to_xy_test ( ) !*****************************************************************************80 ! !! polar_to_xy_test tests polar_to_xy. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) r real ( kind = rk ) r8_uniform_ab real ( kind = rk ) t integer test integer, parameter :: test_num = 10 real ( kind = rk ) xy1(2) real ( kind = rk ) xy2(2) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polar_to_xy_test' write ( *, '(a)' ) ' polar_to_xy() converts (R,Theta) to (X,Y);' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' X Y ===> R T => X Y' write ( *, '(a)' ) '' b = -1.0D+00 c = +1.0D+00 do test = 1, test_num xy1(1) = r8_uniform_ab ( b, c ) xy1(2) = r8_uniform_ab ( b, c ) call xy_to_polar ( xy1, r, t ) call polar_to_xy ( r, t, xy2 ) write ( *, '(2x,6f12.5)' ) xy1(1:2), r, t, xy2(1:2) end do return end subroutine polygon_area_2d_test ( ) !*****************************************************************************80 ! !! polygon_area_2d_test() tests polygon_area_2d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 2 real ( kind = rk ) area real ( kind = rk ) area_exact real ( kind = rk ), dimension ( test_num ) :: area_exact_test = (/ & 2.0D+00, 6.0D+00 /) integer n integer, dimension ( test_num ) :: n_test = (/ 4, 8 /) integer test real ( kind = rk ), allocatable, dimension ( :, : ) :: v write ( *, '(a)' ) '' write ( *, '(a)' ) 'polygon_area_2d_test():' write ( *, '(a)' ) ' polygon_area_2d() computes the area.' do test = 1, test_num n = n_test(test) area_exact = area_exact_test(test) allocate ( v(1:dim_num,1:n) ) if ( test == 1 ) then v(1:dim_num,1:n) = reshape ( (/ & 1.0D+00, 0.0D+00, & 2.0D+00, 1.0D+00, & 1.0D+00, 2.0D+00, & 0.0D+00, 1.0D+00 /), (/ dim_num, n /) ) else if ( test == 2 ) then v(1:dim_num,1:n) = reshape ( (/ & 0.0D+00, 0.0D+00, & 3.0D+00, 0.0D+00, & 3.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 2.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, & 1.0D+00, 2.0D+00, & 0.0D+00, 2.0D+00 /), (/ dim_num, n /) ) end if write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of polygonal vertices = ', n call r8mat_transpose_print ( dim_num, n, v, ' The polygon vertices:' ) call polygon_area_2d ( n, v, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Exact area is ', area_exact write ( *, '(a,g14.6)' ) ' The computed area is ', area deallocate ( v ) end do return end subroutine polygon_area_3d_test ( ) !*****************************************************************************80 ! !! polygon_area_3d_test() tests polygon_area_3d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 October 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 2 real ( kind = rk ) area real ( kind = rk ) :: area_exact real ( kind = rk ), dimension ( test_num ) :: area_exact_test = (/ & 2.4494898D+00, 6.0D+00 /) integer n integer, dimension ( test_num ) :: n_test = (/ 4, 8 /) real ( kind = rk ), dimension ( dim_num ) :: normal integer test real ( kind = rk ), allocatable, dimension (:,:) :: v write ( *, '(a)' ) '' write ( *, '(a)' ) 'polygon_area_3d_test():' write ( *, '(a)' ) ' polygon_area_3d() computes the area of a polygon in 3D;' do test = 1, test_num area_exact = area_exact_test(test) n = n_test(test) allocate ( v(1:dim_num,1:n) ) if ( test == 1 ) then v = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 2.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 2.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00 /), (/ dim_num, n /) ) else if ( test == 2 ) then v = reshape ( (/ & 0.00000D+00, 0.00000D+00, 0.00000D+00, & 2.62679D+00, 1.26009D+00, -0.715657D+00, & 1.48153D+00, 3.97300D+00, -0.142512D+00, & 0.605932D+00, 3.55297D+00, 0.960401D-01, & 1.36944D+00, 1.74437D+00, -0.286056D+00, & 0.493842D+00, 1.32433D+00, -0.475041D-01, & 0.112090D+00, 2.22864D+00, 0.143544D+00, & -0.763505D+00, 1.80861D+00, 0.382097D+00 /), (/ dim_num, n /) ) end if call r8mat_transpose_print ( dim_num, n, v, ' The polygon vertices:' ) call polygon_area_3d ( n, v, area, normal ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Exact area is ', area_exact write ( *, '(a,g14.6)' ) ' The computed area is ', area deallocate ( v ) end do return end subroutine polygon_centroid_3d_test ( ) !*****************************************************************************80 ! !! polygon_centroid_3d_test() tests polygon_centroid_3d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 4 integer, parameter :: dim_num = 3 real ( kind = rk ) centroid(dim_num) real ( kind = rk ), dimension (dim_num,n) :: v = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 2.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 2.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00 /), (/ dim_num, n /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polygon_centroid_3d_test():' write ( *, '(a)' ) ' polygon_centroid_3d() computes the centroid.' call r8mat_transpose_print ( dim_num, n, v, ' The polygon vertices:' ) call polygon_centroid_3d ( n, v, centroid ) call r8vec_print ( dim_num, centroid, ' The centroid:' ) return end subroutine polygon_solid_angle_3d_test ( ) !*****************************************************************************80 ! !! polygon_solid_angle_3d_test() tests polygon_solid_angle_3d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2015 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 integer n real ( kind = rk ), dimension ( dim_num ) :: p real ( kind = rk ) solid_angle integer test real ( kind = rk ), allocatable, dimension (:,:) :: v write ( *, '(a)' ) '' write ( *, '(a)' ) 'polygon_solid_angle_3d_test():' write ( *, '(a)' ) ' polygon_solid_angle_3d() computes the solid angle' write ( *, '(a)' ) ' subtended by a planar polygon as viewed from' write ( *, '(a)' ) ' a point P.' do test = 1, test_num ! ! One eighth of sphere surface, on the unit sphere surface. ! if ( test == 1 ) then n = 3 allocate ( v(1:dim_num,1:n) ) v = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, n /) ) p(1:3) = (/ 0.0D+00, 0.0D+00, 0.0D+00 /) ! ! Reverse order of vertices. ! else if ( test == 2 ) then n = 3 allocate ( v(1:dim_num,1:n) ) v = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00 /), (/ dim_num, n /) ) p(1:3) = (/ 0.0D+00, 0.0D+00, 0.0D+00 /) ! ! One eighth of sphere surface, on the unit sphere surface, ! translated by (1,2,3). ! else if ( test == 3 ) then n = 3 allocate ( v(1:dim_num,1:n) ) v = reshape ( (/ & 2.0D+00, 2.0D+00, 3.0D+00, & 1.0D+00, 3.0D+00, 3.0D+00, & 1.0D+00, 2.0D+00, 4.0D+00 /), (/ dim_num, n /) ) p(1:3) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) ! ! One eighth of sphere surface, but on sphere of radius 2. ! else if ( test == 4 ) then n = 3 allocate ( v(1:dim_num,1:n) ) v = reshape ( (/ & 2.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 2.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 2.0D+00 /), (/ dim_num, n /) ) p(1:3) = (/ 0.0D+00, 0.0D+00, 0.0D+00 /) end if write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' TEST # ', test write ( *, '(a)' ) '' call r8vec_print ( dim_num, p, ' The viewing point P:' ) call r8mat_transpose_print ( dim_num, n, v, ' The polygon vertices V:' ) call polygon_solid_angle_3d ( n, v, p, solid_angle ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Solid angle subtended: ', solid_angle deallocate ( v ) end do return end subroutine polyhedron_area_3d_test ( ) !*****************************************************************************80 ! !! polyhedron_area_3d_test tests polyhedron_area_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: order_max = 3 integer, parameter :: face_num = 4 integer, parameter :: dim_num = 3 integer, parameter :: node_num = 4 real ( kind = rk ) area real ( kind = rk ), parameter :: area_exact = 2.366025D+00 real ( kind = rk ), dimension ( dim_num, node_num ) :: coord = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, node_num /) ) integer i integer j integer, dimension(face_num,order_max) :: node = reshape ( (/ & 3, 1, 1, 2, & 2, 2, 4, 3, & 1, 4, 3, 4 /), (/ face_num,order_max /) ) integer, dimension ( face_num ) :: order = (/ 3, 3, 3, 3 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polyhedron_area_3d_test' write ( *, '(a)' ) ' polyhedron_area_3d() computes surface area of a' write ( *, '(a)' ) ' polyhedron in 3D.' write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of faces is ', face_num call i4vec_print ( face_num, order, ' Order of each face:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Nodes per face:' write ( *, '(a)' ) '' do i = 1, face_num write ( *, '(5i8)' ) i, ( node(i,j), j = 1, order(i) ) end do call r8mat_transpose_print ( dim_num, node_num, coord, ' Polyhedron nodes' ) call polyhedron_area_3d ( coord, order_max, face_num, node, node_num, & order, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Surface area = ', area write ( *, '(a,g14.6)' ) ' Exact area = ', area_exact return end subroutine polyhedron_centroid_3d_test ( ) !*****************************************************************************80 ! !! POLYHEDRON_CENTROID_3D_TEST tests POLYHEDRON_CENTROID_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: order_max = 3 integer, parameter :: face_num = 4 integer, parameter :: dim_num = 3 integer, parameter :: node_num = 4 real ( kind = rk ) centroid(dim_num) real ( kind = rk ), dimension ( dim_num ) :: centroid_exact = (/ & 0.25D+00, 0.25D+00, 0.25D+00 /) real ( kind = rk ), dimension ( dim_num, node_num ) :: coord = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, node_num /) ) integer i integer j integer, dimension(face_num,order_max) :: node = reshape ( (/ & 3, 1, 1, 2, & 2, 2, 4, 3, & 1, 4, 3, 4 /), (/ face_num,order_max /) ) integer, dimension ( face_num ) :: order = (/ 3, 3, 3, 3 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'POLYHEDRON_CENTROID_3D_TEST' write ( *, '(a)' ) ' POLYHEDRON_CENTROID_3D computes the centroid of a' write ( *, '(a)' ) ' polyhedron in 3D.' write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of faces is ', face_num call i4vec_print ( face_num, order, ' Order of each face:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Nodes per face:' write ( *, '(a)' ) '' do i = 1, face_num write ( *, '(5i8)' ) i, ( node(i,j), j = 1, order(i) ) end do call r8mat_transpose_print ( dim_num, node_num, coord, ' Polyhedron nodes:' ) call polyhedron_centroid_3d ( coord, order_max, face_num, node, node_num, & order, centroid ) call r8vec_print ( dim_num, centroid, ' Computed centroid:' ) call r8vec_print ( dim_num, centroid_exact, ' Exact centroid:' ) return end subroutine polyhedron_contains_point_3d_test ( ) !*****************************************************************************80 ! !! polyhedron_contains_point_3d_test() tests polyhedron_contains_point_3d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: face_num = 4 integer, parameter :: face_order_max = 3 integer, parameter :: node_num = 4 integer, parameter :: test_num = 100 real ( kind = rk ) c(dim_num+1) integer, dimension(face_num) :: face_order = (/ 3, 3, 3, 3 /) integer, dimension (face_order_max,face_num) :: face_point = reshape ( (/ & 1, 2, 4, & 1, 3, 2, & 1, 4, 3, & 2, 3, 4 /), (/ face_order_max, face_num /) ) logical inside1 logical inside2 real ( kind = rk ) p(dim_num) integer test real ( kind = rk ), dimension ( dim_num, node_num ) :: v = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, node_num /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polyhedron_contains_point_3d_test' write ( *, '(a)' ) ' polyhedron_contains_point_3d() determines if a point' write ( *, '(a)' ) ' is inside a polyhedron.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We test this routine by using a tetrahedron as ' write ( *, '(a)' ) ' the polyhedron.' write ( *, '(a)' ) ' For this shape, an independent check can be made,' write ( *, '(a)' ) ' using barycentric coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We label these checks IN1 and IN2, and ' write ( *, '(a)' ) ' we expect them to agree.' call r8mat_transpose_print ( dim_num, node_num, v, ' The vertices:' ) call i4vec_print ( face_num, face_order, ' The face orders:' ) call i4mat_transpose_print ( face_order_max, face_num, face_point, & ' The nodes making each face:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y Z IN1 IN2' write ( *, '(a)' ) '' do test = 1, test_num call random_number ( harvest = p(1:dim_num) ) call polyhedron_contains_point_3d ( node_num, face_num, & face_order_max, v, face_order, face_point, p, inside1 ) call tetrahedron_barycentric_3d ( v, p, c ) inside2 = ( 0.0D+00 <= c(1) ) .and. ( c(1) <= 1.0D+00 ) .and. & ( 0.0D+00 <= c(2) ) .and. ( c(2) <= 1.0D+00 ) .and. & ( 0.0D+00 <= c(3) ) .and. ( c(3) <= 1.0D+00 ) .and. & ( 0.0D+00 <= c(4) ) .and. ( c(4) <= 1.0D+00 ) .and. & ( c(1) + c(2) + c(3) + c(4) <= 1.0D+00 ) write ( *, '(2x,g14.6,2x,g14.6,2x,g14.6,2x,l1,2x,l1)' ) & p(1:3), inside1, inside2 if ( inside1 .neqv. inside2 ) then write ( *, '(a)' ) '??? Disagreement! Barycentric coordinates:' write ( *, '(2x,g14.6,2x,g14.6,2x,g14.6,2x,g14.6)' ) c(1:4) end if end do return end subroutine test083 ( ) !*****************************************************************************80 ! !! TEST083 tests POLYHEDRON_VOLUME_3D and POLYHEDRON_VOLUME_3D_2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: order_max = 3 integer, parameter :: face_num = 4 integer, parameter :: dim_num = 3 integer, parameter :: node_num = 4 real ( kind = rk ), dimension ( dim_num, node_num ) :: coord = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, node_num /) ) integer i integer j integer, dimension(face_num,order_max) :: node = reshape ( (/ & 3, 1, 1, 2, & 2, 2, 4, 3, & 1, 4, 3, 4 /), (/ face_num,order_max /) ) integer, dimension ( face_num ) :: order = (/ 3, 3, 3, 3 /) real ( kind = rk ) :: volume_exact = 1.0D+00 / 6.0D+00 real ( kind = rk ) volume1 real ( kind = rk ) volume2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST083' write ( *, '(a)' ) ' For a polyhedron in 3D:' write ( *, '(a)' ) ' POLYHEDRON_VOLUME_3D computes volume.' write ( *, '(a)' ) ' POLYHEDRON_VOLUME_3D_2 computes volume.' write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of faces is ', face_num call i4vec_print ( face_num, order, ' Order of each face:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Nodes per face:' write ( *, '(a)' ) '' do i = 1, face_num write ( *, '(5i8)' ) i, ( node(i,j), j = 1, order(i) ) end do call r8mat_transpose_print ( dim_num, node_num, coord, ' Polyhedron nodes' ) call polyhedron_volume_3d ( coord, order_max, face_num, node, node_num, & order, volume1 ) call polyhedron_volume_3d_2 ( coord, order_max, face_num, node, node_num, & order, volume2 ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Volume ( method 1 ) = ', volume1 write ( *, '(a,g14.6)' ) ' Volume ( method 2 ) = ', volume2 write ( *, '(a,g14.6)' ) ' Volume ( exact ) = ', volume_exact return end subroutine test084 ( ) !*****************************************************************************80 ! !! TEST084 tests POLYLINE_ARCLENGTH_ND and POLYLINE_INDEX_POINT_ND; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 4 integer, parameter :: dim_num = 2 integer i real ( kind = rk ), dimension(dim_num,n) :: p = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, & 2.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, n /) ) real ( kind = rk ) pt(dim_num) real ( kind = rk ) s(n) real ( kind = rk ) t t = 2.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST084' write ( *, '(a)' ) ' POLYLINE_INDEX_POINT_ND finds a point on a ' write ( *, '(a)' ) ' polyline with given arclength.' write ( *, '(a)' ) ' POLYLINE_ARCLENGTH_ND computes the arclength ' write ( *, '(a)' ) ' of the polyline, and its nodes.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The line we examine is defined by these points:' ! ! The call to POLYLINE_ARCLENGTH_ND is just to help us believe ! the final result. ! call polyline_arclength_nd ( dim_num, n, p, s ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P Arclength(X,Y)' write ( *, '(a)' ) '' do i = 1, n write ( *, '(2x,3g14.6)' ) p(1:dim_num,i), s(i) end do write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' We search for the point with coordinate ', t call polyline_index_point_nd ( dim_num, n, p, t, pt ) call r8vec_print ( dim_num, pt, ' The computed point:' ) return end subroutine polyline_points_nd_test ( ) !*****************************************************************************80 ! !! polyline_points_nd_test tests polyline_points_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: nk = 4 integer, parameter :: nt = 13 real ( kind = rk ), dimension(dim_num,nk) :: pk = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00 /), (/ dim_num, nk /) ) real ( kind = rk ) pt(dim_num,nt) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polyline_points_nd_test' write ( *, '(a)' ) ' polyline_points_nd() computes points on a polyline.' call r8mat_transpose_print ( dim_num, nk, pk, ' The defining points:' ) call polyline_points_nd ( dim_num, nk, pk, nt, pt ) call r8mat_transpose_print ( dim_num, nt, pt, ' The computed points:' ) return end subroutine polyloop_arclength_nd_test ( ) !*****************************************************************************80 ! !! polyloop_arclength_nd_test tests polyloop_arclength_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 4 integer, parameter :: dim_num = 2 integer i4_wrap integer j integer j2 real ( kind = rk ), dimension(dim_num,n) :: p = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, & 2.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, n /) ) real ( kind = rk ) s(n+1) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polyloop_arclength_nd_test' write ( *, '(a)' ) ' polyloop_arclength_nd() computes the arclength ' write ( *, '(a)' ) ' of the nodes of a polyloop.' call polyloop_arclength_nd ( dim_num, n, p, s ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P Arclength(P)' write ( *, '(a)' ) '' do j = 1, n + 1 j2 = i4_wrap ( j, 1, n ) write ( *, '(2x,3g14.6)' ) p(1:dim_num,j2), s(j) end do return end subroutine polyloop_points_nd_test ( ) !*****************************************************************************80 ! !! polyloop_points_nd_test tests polyloop_points_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: nk = 4 integer, parameter :: nt = 12 real ( kind = rk ), dimension(dim_num,nk) :: pk = reshape ( (/ & 0.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00 /), (/ dim_num, nk /) ) real ( kind = rk ) pt(dim_num,nt) write ( *, '(a)' ) '' write ( *, '(a)' ) 'polyloop_points_nd_test' write ( *, '(a)' ) ' polyloop_points_nd() computes points on a polyloop.' call r8mat_transpose_print ( dim_num, nk, pk, ' The defining points:' ) call polyloop_points_nd ( dim_num, nk, pk, nt, pt ) call r8mat_transpose_print ( dim_num, nt, pt, ' The computed points:' ) return end subroutine test085 ( ) !*****************************************************************************80 ! !! TEST085 tests PLANE_EXP_PRO3. ! ! Discussion: ! ! Projection is ( -1, 1, 1 ). ! Projection is ( 4, 5, -8 ). ! Projection is ( 0.33, 0.33, 0.33). ! Projection is ( 5.33, -1.66, -2.66 ). ! Projection is ( -1, 1, 1 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 1.0D+00, 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 0.0D+00, 1.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 0.0D+00, 0.0D+00, 1.0D+00 /) real ( kind = rk ), dimension (dim_num,test_num) :: po = reshape ( (/ & 0.0D+00, 2.0D+00, 2.0D+00, & 4.0D+00, 5.0D+00, -8.0D+00, & 0.25D+00, 0.25D+00, 0.25D+00, & 5.0D+00, -2.0D+00, -3.0D+00, & -2.0D+00, 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pp(dim_num,test_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST085' write ( *, '(a)' ) ' PLANE_EXP_PRO3 projects an object point ' write ( *, '(a)' ) ' orthographically into a plane.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' PO PP' write ( *, '(a)' ) '' call plane_exp_pro3 ( p1, p2, p3, test_num, po, pp ) do test = 1, test_num write ( *, '(2x,6g12.4)' ) po(1:dim_num,test), pp(1:dim_num,test) end do return end subroutine test170 ( ) !*****************************************************************************80 ! !! TEST170 tests PROVEC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 4 integer, parameter :: n = 2 real ( kind = rk ), dimension(m,n) :: base = reshape ( (/ & 4.0D+00, 3.0D+00, 2.0D+00, 1.0D+00, & 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00 /), (/ m, n /) ) real ( kind = rk ), dimension ( m ) :: vecm = (/ & 1.0D+00, 1.0D+00, 1.0D+00, 2.0D+00 /) real ( kind = rk ) vecn(n) real ( kind = rk ) vecnm(m) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST170' write ( *, '(a)' ) ' PROVEC projects a vector onto a subspace.' call r8mat_transpose_print ( m, n, base, ' Base vectors' ) call r8vec_print ( m, vecm, ' Vector to be projected:' ) call provec ( m, n, base, vecm, vecn, vecnm ) call r8vec_print ( n, vecn, ' Projected vector in BASE coordinates:' ) call r8vec_print ( m, vecnm, ' Projected vector in original coordinates:' ) return end subroutine test171 ( ) !*****************************************************************************80 ! !! TEST171 tests QUAD_AREA_2D, QUAD_AREA2_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ), dimension(2,4) :: q = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00 /), (/ 2, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST171' write ( *, '(a)' ) ' For a quadrilateral in 2D:' write ( *, '(a)' ) ' QUAD_AREA_2D finds the area;' write ( *, '(a)' ) ' QUAD_AREA2_2D finds the area;' call r8mat_transpose_print ( 2, 4, q, ' The vertices:' ) call quad_area_2d ( q, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' QUAD_AREA_2D area is ', area call quad_area2_2d ( q, area ) write ( *, '(a,g14.6)' ) ' QUAD_AREA2_2D area is ', area return end subroutine test1712 ( ) !*****************************************************************************80 ! !! TEST1712 tests QUAD_AREA_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ) area1 real ( kind = rk ) area2 real ( kind = rk ), dimension(3,4) :: q = reshape ( (/ & 2.0D+00, 2.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00, & 3.0D+00, 3.0D+00, 1.0D+00 & /), (/ 3, 4 /) ) real ( kind = rk ) t(3,3) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1712' write ( *, '(a)' ) ' For a quadrilateral in 3D:' write ( *, '(a)' ) ' QUAD_AREA_3D finds the area.' call r8mat_transpose_print ( 3, 4, q, ' The vertices:' ) call quad_area_3d ( q, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' QUAD_AREA_3D area is ', area t(1:3,1:3) = q(1:3,1:3) call triangle_area_3d ( t, area1 ) t(1:3,1:2) = q(1:3,3:4) t(1:3, 3) = q(1:3,1 ) call triangle_area_3d ( t, area2 ) write ( *, '(a,g14.6)' ) ' Sum of TRIANGLE_AREA_3D: ', area1 + area2 return end subroutine test1715 ( ) !*****************************************************************************80 ! !! TEST1715 tests QUAD_CONTAINS_POINT_2D, QUAD_POINT_DIST_2D, QUAD_POINT_DIST_SIGNED_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 real ( kind = rk ) dist real ( kind = rk ) dist_signed logical inside real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 0.50D+00, & 0.50D+00, -10.00D+00, & 2.00D+00, 2.00D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num,4) :: q = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 1.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00 /), (/ dim_num, 4 /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1715' write ( *, '(a)' ) ' For a quadrilateral in 2D:' write ( *, '(a)' ) ' QUAD_AREA_2D finds the area;' write ( *, '(a)' ) ' QUAD_CONTAINS_POINT_2D tells if a point is inside;' write ( *, '(a)' ) ' QUAD_POINT_DIST_2D computes the distance.' write ( *, '(a)' ) ' QUAD_POINT_DIST_SIGNED_2D computes signed distance.' call r8mat_transpose_print ( dim_num, 4, q, ' The vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P Contains Dist Dist' write ( *, '(a)' ) ' Signed Unsigned' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call quad_contains_point_2d ( q, p, inside ) call quad_point_dist_signed_2d ( q, p, dist_signed ) call quad_point_dist_2d ( q, p, dist ) write ( *, '(2x,2g14.6,2x,l1,2x,2f12.4)' ) & p(1:dim_num), inside, dist_signed, dist end do return end subroutine r8_acos_test ( ) !*****************************************************************************80 ! !! r8_acos_test tests R8_ACOS; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 9 real ( kind = rk ) r8_acos real ( kind = rk ) radians_to_degrees real ( kind = rk ) temp1 real ( kind = rk ) temp2 integer test real ( kind = rk ) x real ( kind = rk ), dimension ( test_num ) :: x_test = (/ & 5.0D+00, 1.2D+00, 1.0D+00, 0.9D+00, 0.5D+00, & 0.0D+00, -0.9D+00, -1.0D+00, -1.01D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8_ACOS_TEST' write ( *, '(a)' ) ' R8_ACOS computes an angle with a given cosine;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X R8_ACOS(X) (Degrees)' write ( *, '(a)' ) '' do test = 1, test_num x = x_test(test) temp1 = r8_acos ( x ) temp2 = radians_to_degrees ( temp1 ) write ( *, '(2x,6g12.4)') x, temp1, temp2 end do return end subroutine r8_asin_test ( ) !*****************************************************************************80 ! !! r8_asin_test tests R8_ASIN; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 9 real ( kind = rk ) r8_asin real ( kind = rk ) radians_to_degrees real ( kind = rk ) temp1 real ( kind = rk ) temp2 integer test real ( kind = rk ) x real ( kind = rk ), dimension ( test_num ) :: x_test = (/ & 5.0D+00, 1.2D+00, 1.0D+00, 0.9D+00, 0.5D+00, & 0.0D+00, -0.9D+00, -1.0D+00, -1.01D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8_asin_test' write ( *, '(a)' ) ' R8_ASIN computes an angle with a given sine;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X R8_ASIN(X) (Degrees)' write ( *, '(a)' ) '' do test = 1, test_num x = x_test(test) temp1 = r8_asin ( x ) temp2 = radians_to_degrees ( temp1 ) write ( *, '(2x,6g12.4)') x, temp1, temp2 end do return end subroutine r8_atan_test ( ) !*****************************************************************************80 ! !! R8_ATAN_TEST tests R8_ATAN; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 8 real ( kind = rk ) r8_atan real ( kind = rk ) radians_to_degrees real ( kind = rk ) temp1 real ( kind = rk ) temp2 real ( kind = rk ) temp3 integer test real ( kind = rk ) x real ( kind = rk ), dimension ( test_num ) :: x_test = (/ & 1.0D+00, 1.0D+00, 1.0D+00, 1.0D+00, 1.0D+00, & -1.0D+00, -1.0D+00, 0.0D+00 /) real ( kind = rk ) y real ( kind = rk ), dimension ( test_num ) :: y_test = (/ & 0.0D+00, 1.0D+00, 2.0D+00, 0.0D+00, -1.0D+00, & -1.0D+00, -1.0D+00, -1.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8_ATAN_TEST' write ( *, '(a)' ) ' R8_ATAN computes an angle with a given tangent.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y ATAN(Y/X) ATAN2(Y,X) R8_ATAN(Y,X)' write ( *, '(a)' ) '' do test = 1, test_num x = x_test(test) y = y_test(test) if ( x /= 0.0D+00 ) then temp1 = atan ( y / x ) else temp1 = huge ( y ) end if temp2 = atan2 ( y, x ) temp3 = r8_atan ( y, x ) write ( *, '(2x,6g12.4)') x, y, temp1, temp2, temp3 end do write ( *, '(a)' ) '' write ( *, '(a)' ) ' Repeat, but display answers in degrees.' write ( *, '(a)' ) '' do test = 1, test_num x = x_test(test) y = y_test(test) if ( x /= 0.0D+00 ) then temp1 = radians_to_degrees ( atan ( y / x ) ) else temp1 = huge ( y ) end if temp2 = radians_to_degrees ( atan2 ( y, x ) ) temp3 = radians_to_degrees ( r8_atan ( y, x ) ) write ( *, '(2x,6g12.4)') x, y, temp1, temp2, temp3 end do return end subroutine test1787 ( ) !*****************************************************************************80 ! !! TEST1787 tests R8GE_FA and R8GE_SL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 5 real ( kind = rk ) a(n,n) real ( kind = rk ) alu(n,n) real ( kind = rk ) b(n) integer i integer info integer job integer pivot(n) real ( kind = rk ) x(n) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1787' write ( *, '(a)' ) ' R8GE_FA factors a general linear system,' write ( *, '(a)' ) ' R8GE_SL solves a factored system.' write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Matrix order N = ', n ! ! Set the matrix. ! call random_number ( harvest = a(1:n,1:n) ) call r8mat_print ( n, n, a, ' Matrix A.' ) ! ! Set the desired solution. ! do i = 1, n x(i) = real ( i, kind = rk ) end do ! ! Compute the corresponding right hand side. ! b(1:n) = matmul ( a(1:n,1:n), x(1:n) ) ! ! Make a copy of the matrix. ! alu(1:n,1:n) = a(1:n,1:n) ! ! Factor the matrix. ! call r8ge_fa ( n, alu, pivot, info ) call r8mat_print ( n, n, alu, ' Factored ALU matrix.' ) if ( info /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Fatal error!' write ( *, '(a)' ) ' r8ge_fa declares the matrix is singular!' write ( *, '(a,i8)' ) ' The value of INFO is ', info return end if ! ! Solve the linear system. ! job = 0 call r8ge_sl ( n, alu, pivot, b, job ) call r8vec_print ( n, b, ' Solution: (Should be 1, 2, 3,...)' ) ! ! Set another the desired solution. ! x(1:n) = 1.0D+00 ! ! Compute the corresponding right hand side. ! b(1:n) = matmul ( a(1:n,1:n), x(1:n) ) ! ! Solve the system ! job = 0 call r8ge_sl ( n, alu, pivot, b, job ) call r8vec_print ( n, b, ' Solution: (Should be 1, 1, 1,...)' ) ! ! Set the desired solution. ! do i = 1, n x(i) = real ( i, kind = rk ) end do ! ! Compute the corresponding right hand side. ! b(1:n) = matmul ( transpose ( a(1:n,1:n) ), x(1:n) ) ! ! Solve the system. ! job = 1 call r8ge_sl ( n, alu, pivot, b, job ) call r8vec_print ( n, b, & ' Solution of transposed system: (Should be 1, 2, 3,...)' ) return end subroutine r8mat_inverse_3d_test ( ) !*****************************************************************************80 ! !! r8mat_inverse_3d_test tests r8mat_inverse_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 3 real ( kind = rk ), dimension ( n, n ) :: a = reshape ( (/ & 3.0D+00, 2.0D+00, 0.0D+00, & 2.0D+00, 2.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00 /), (/ n, n /) ) real ( kind = rk ) b(n,n) real ( kind = rk ) det write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8mat_inverse_3d_test' write ( *, '(a)' ) ' r8mat_inverse_3d() inverts a 3 by 3 matrix.' call r8mat_print ( n, n, a, ' Matrix A:' ) call r8mat_inverse_3d ( a, b, det ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Determinant of A is ', det call r8mat_print ( n, n, b, ' Inverse matrix B:' ) return end subroutine r8mat_solve_test ( ) !*****************************************************************************80 ! !! r8mat_solve_test tests r8mat_solve. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 3 integer, parameter :: rhs_num = 2 real ( kind = rk ), dimension (n,n+rhs_num) :: a = reshape ( (/ & 1.0D+00, 4.0D+00, 7.0D+00, & 2.0D+00, 5.0D+00, 8.0D+00, & 3.0D+00, 6.0D+00, 0.0D+00, & 14.0D+00, 32.0D+00, 23.0D+00, & 7.0D+00, 16.0D+00, 7.0D+00 /), (/ n, n+rhs_num /) ) integer i integer info write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8mat_solve_test' write ( *, '(a)' ) ' r8mat_solve() solves linear systems.' write ( *, '(a)' ) '' ! ! Print out the matrix to be inverted. ! call r8mat_print ( n, n+rhs_num, a, ' The linear system:' ) ! ! Solve the systems. ! call r8mat_solve ( n, rhs_num, a, info ) if ( info /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The input matrix was singular.' write ( *, '(a)' ) ' The solutions could not be computed.' write ( *, '(a)' ) '' return end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' The computed solutions:' write ( *, '(a)' ) '' do i = 1, n write ( *, '(2x,2g14.6)' ) a(i,n+1:n+rhs_num) end do return end subroutine r8mat_solve_2d_test ( ) !*****************************************************************************80 ! !! r8mat_solve_2d_test tests r8mat_solve_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 November 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 2 real ( kind = rk ), dimension (n,n) :: a real ( kind = rk ), dimension ( n ) :: b real ( kind = rk ) det integer i integer test integer, parameter :: test_num = 5 real ( kind = rk ), dimension ( n ) :: x real ( kind = rk ), dimension ( n ) :: x2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8mat_solve_2d_test' write ( *, '(a)' ) ' r8mat_solve_2d() solves 2D linear systems.' do test = 1, test_num call random_number ( harvest = a(1:n,1:n) ) call random_number ( harvest = x(1:n) ) b(1:n) = matmul ( a(1:n,1:n), x(1:n) ) call r8mat_solve_2d ( a, b, det, x2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Solution / Computed:' write ( *, '(a)' ) '' do i = 1, n write ( *, '(2x,g14.6,2x,g14.6)' ) x(i), x2(i) end do end do return end subroutine r8vec_any_normal_test ( ) !*****************************************************************************80 ! !! r8vec_any_normal_test tests r8vec_any_normal_test. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 10 integer, parameter :: test_num = 5 real ( kind = rk ) r8vec_norm integer test real ( kind = rk ) v1(dim_num) real ( kind = rk ) v1_length real ( kind = rk ) v1v2_dot real ( kind = rk ) v2(dim_num) real ( kind = rk ) v2_length write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8vec_any_normal_test' write ( *, '(a)' ) ' r8vec_any_normal() computes a vector V2 that is normal' write ( *, '(a)' ) ' to a given vector V1.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test ||V1|| ||V2|| V1.V2' write ( *, '(a)' ) '' do test = 1, test_num call random_number ( harvest = v1(1:dim_num) ) v1_length = r8vec_norm ( dim_num, v1 ) call r8vec_any_normal ( dim_num, v1, v2 ) v2_length = r8vec_norm ( dim_num, v2 ) v1v2_dot = dot_product ( v1(1:dim_num), v2(1:dim_num) ) write ( *, '(2x,i8,2x,f10.6,2x,f10.6,2x,f10.6)' ) & test, v1_length, v2_length, v1v2_dot end do return end subroutine r8vec_uniform_unit_test ( ) !*****************************************************************************80 ! !! r8vec_uniform_unit_test tests R8VEC_UNIFORM_UNIT; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 4 integer, parameter :: test_num = 10 integer test real ( kind = rk ) vran(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'r8vec_uniform_unit_test' write ( *, '(a)' ) ' R8VEC_UNIFORM_UNIT picks a random direction vector.' write ( *, '(a)' ) '' do test = 1, test_num call r8vec_uniform_unit ( dim_num, vran ) write ( *, '(2x,4f8.4)' ) vran(1:dim_num) end do return end subroutine radec_distance_3d_test ( ) !*****************************************************************************80 ! !! radec_distance_3d_test tests radec_distance_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) dec1 real ( kind = rk ) dec2 real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00, & 5.0D+00, -2.0D+00, -1.0D+00, & -2.0D+00, -2.0D+00, -2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) ra1 real ( kind = rk ) ra2 real ( kind = rk ) radians_to_degrees integer test1 integer test2 real ( kind = rk ) theta real ( kind = rk ) theta_deg write ( *, '(a)' ) '' write ( *, '(a)' ) 'radec_distance_3d_test' write ( *, '(a)' ) ' radec_distance_3d() computes the angular separation' write ( *, '(a)' ) ' between two points on a sphere described in terms of' write ( *, '(a)' ) ' right ascension and declination.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' RA1 DEC1 RA2 DEC2 Radians Degrees' write ( *, '(a)' ) '' do test1 = 1, test_num p1(1:dim_num) = p_test(1:dim_num,test1) call xyz_to_radec ( p1, ra1, dec1 ) do test2 = test1+1, test_num p2(1:dim_num) = p_test(1:dim_num,test2) call xyz_to_radec ( p2, ra2, dec2 ) call radec_distance_3d ( ra1, dec1, ra2, dec2, theta ) theta_deg = radians_to_degrees ( theta ) write ( *, '(2x,6f10.4)' ) ra1, dec1, ra2, dec2, theta, theta_deg end do end do return end subroutine radec_to_xyz_test ( ) !*****************************************************************************80 ! !! radec_to_xyz_test tests radec_to_xyz. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) dec real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00, & 5.0D+00, -2.0D+00, -1.0D+00, & -2.0D+00, -2.0D+00, -2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) ra integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'radec_to_xyz_test' write ( *, '(a)' ) ' radec_to_xyz() converts RADEC to XYZ coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 RA DEC P2' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p_test(1:dim_num,test) call xyz_to_radec ( p1, ra, dec ) call radec_to_xyz ( ra, dec, p2 ) write ( *, '(2x,8f7.3)' ) p1(1:dim_num), ra, dec, p2(1:dim_num) end do return end subroutine radians_to_degrees_test ( ) !*****************************************************************************80 ! !! radians_to_degrees_test tests radians_to_degrees. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer angle_degrees integer angle_min real ( kind = rk ) angle_rad real ( kind = rk ) angle_rad2 integer angle_sec integer i real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'radians_to_degrees_test' write ( *, '(a)' ) ' radians_to_degrees() converts an angle from radians' write ( *, '(a)' ) ' to degrees/minutes/seconds;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Radians DMS Radians' write ( *, '(a)' ) '' do i = -2, 15 angle_rad = pi * real ( i, kind = rk ) / 7.0D+00 call radians_to_dms ( angle_rad, angle_degrees, angle_min, angle_sec ) call dms_to_radians ( angle_degrees, angle_min, angle_sec, angle_rad2 ) write ( *, '(2x,f10.6,2x,i4,2x,i3,2x,i3,2x,f10.6)' ) & angle_rad, angle_degrees, angle_min, angle_sec, angle_rad2 end do return end subroutine radians_to_dms_test ( ) !*****************************************************************************80 ! !! radians_to_dms_test tests radians_to_dms(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer angle_degrees integer angle_min real ( kind = rk ) angle_rad real ( kind = rk ) angle_rad2 integer angle_sec integer i real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'radians_to_dms_test' write ( *, '(a)' ) ' radians_to_dms() converts an angle from radians' write ( *, '(a)' ) ' to degrees/minutes/seconds;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Radians DMS Radians' write ( *, '(a)' ) '' do i = -2, 15 angle_rad = pi * real ( i, kind = rk ) / 7.0D+00 call radians_to_dms ( angle_rad, angle_degrees, angle_min, angle_sec ) call dms_to_radians ( angle_degrees, angle_min, angle_sec, angle_rad2 ) write ( *, '(2x,f10.6,2x,i4,2x,i3,2x,i3,2x,f10.6)' ) & angle_rad, angle_degrees, angle_min, angle_sec, angle_rad2 end do return end subroutine rtp_to_xyz_test ( ) !*****************************************************************************80 ! !! rtp_to_xyz_test tests rtp_to_xyz. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) :: a = -2.0D+00 real ( kind = rk ) :: b = 3.0D+00 real ( kind = rk ) phi real ( kind = rk ) r integer test integer, parameter :: test_num = 5 real ( kind = rk ) theta real ( kind = rk ) xyz1(3) real ( kind = rk ) xyz2(3) write ( *, '(a)' ) '' write ( *, '(a)' ) 'rtp_to_xyz_test' write ( *, '(a)' ) ' rtp_to_xyz() converts XYZ to (R,Theta,Phi) coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' X1 Y1 Z1 R THETA PHI X2 Y2 Z2' write ( *, '(a)' ) '' do test = 1, test_num call r8vec_uniform_ab ( 3, a, b, xyz1 ) call xyz_to_rtp ( xyz1, r, theta, phi ) call rtp_to_xyz ( r, theta, phi, xyz2 ) write ( *, '(2x,9f7.3)' ) xyz1(1:3), r, theta, phi, xyz2(1:3) end do return end subroutine segment_contains_point_1d_test ( ) !*****************************************************************************80 ! !! segment_contains_point_1d_test tests segment_contains_point_1d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 4 real ( kind = rk ) p real ( kind = rk ), dimension ( test_num ) :: p_test = (/ & 3.0D+00, 7.5D+00, 20.0D+00, 5.0D+00 /) real ( kind = rk ) p1 real ( kind = rk ), dimension ( test_num ) :: p1_test = (/ & 2.0D+00, 10.0D+00, 8.0D+00, 88.0D+00 /) real ( kind = rk ) p2 real ( kind = rk ), dimension ( test_num ) :: p2_test = (/ & 6.0D+00, -10.0D+00, 10.0D+00, 88.0D+00 /) real ( kind = rk ) t integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_contains_point_1d_test' write ( *, '(a)' ) ' segment_contains_point_1d() determines if a point' write ( *, '(a)' ) ' lies within a line segment in 1D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 P T' write ( *, '(a)' ) '' do test = 1, test_num p1 = p1_test(test) p2 = p2_test(test) p = p_test(test) call segment_contains_point_1d ( p1, p2, p, t ) write ( *, '(2x,3f7.2,g14.6)' ) p1, p2, p, t end do return end subroutine segment_point_coords_2d_test ( ) !*****************************************************************************80 ! !! segment_point_coords_2d_test tests segment_point_coords_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 6 real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 3.0D+00, 1.0D+00, & 4.0D+00, 1.0D+00, & 100.0D+00, 1.0D+00, & 5.0D+00, 100.0D+00, & 7.0D+00, -1.0D+00, & 0.0D+00, 5.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) s real ( kind = rk ), dimension ( test_num ) :: s_test = (/ & 0.0D+00, 0.0D+00, 0.0D+00, 99.0D+00, 2.0D+00, 4.0D+00 /) real ( kind = rk ) t real ( kind = rk ), dimension ( test_num ) :: t_test = (/ & 0.0D+00, 0.25D+00, 24.250D+00, 0.50D+00, 1.0D+00, -0.75D+00 /) integer test p1(1:dim_num) = (/ 3.0D+00, 1.0D+00 /) p2(1:dim_num) = (/ 7.0D+00, 1.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_point_coords_2d_test' write ( *, '(a)' ) ' segment_point_coords_2d() computes coordinates' write ( *, '(a)' ) ' (S,T) for a point relative to a line segment in 2D.' write ( *, '(a)' ) '' write ( *, '(a,2f9.4)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2f9.4)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 S T' write ( *, '(a)' ) ' ----------------- ------ ------' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call segment_point_coords_2d ( p1, p2, p, s, t ) write ( *, '(a)' ) '' write ( *, '(2x,2f9.4,2x,2f9.4,2x,a)' ) p(1:dim_num), s, t, 'Computed' write ( *, '(2x,18x,2x,2f9.4,2x,a)' ) s_test(test), t_test(test), 'Expected' end do return end subroutine segment_point_dist_2d_test ( ) !*****************************************************************************80 ! !! segment_point_dist_2d_test tests segment_point_dist_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_point_dist_2d_test' write ( *, '(a)' ) ' segment_point_dist_2d() computes the distance' write ( *, '(a)' ) ' between a line segment and point in 2D.' do test = 1, test_num call random_number ( harvest = p1(1:dim_num) ) call random_number ( harvest = p2(1:dim_num) ) call random_number ( harvest = p(1:dim_num) ) call segment_point_dist_2d ( p1, p2, p, dist ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' TEST = ', test write ( *, '(a,2f9.4)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2f9.4)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,2f9.4)' ) ' P = ', p(1:dim_num) write ( *, '(a, f9.4)' ) ' DIST = ', dist end do return end subroutine segment_point_dist_3d_test ( ) !*****************************************************************************80 ! !! segment_point_dist_3d_test tests segment_point_dist_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_point_dist_3d_test' write ( *, '(a)' ) ' segment_point_dist_3d() computes the distance' write ( *, '(a)' ) ' between a line segment and point in 3D.' do test = 1, test_num call random_number ( harvest = p1(1:dim_num) ) call random_number ( harvest = p2(1:dim_num) ) call random_number ( harvest = p(1:dim_num) ) call segment_point_dist_3d ( p1, p2, p, dist ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' TEST = ', test write ( *, '(a,3f9.4)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,3f9.4)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,3f9.4)' ) ' P = ', p(1:dim_num) write ( *, '(a, f9.4)' ) ' DIST = ', dist end do return end subroutine segment_point_near_2d_test ( ) !*****************************************************************************80 ! !! segment_point_near_2d_test tests segment_point_near_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 May 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) pn(dim_num) real ( kind = rk ) t integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_point_near_2d_test' write ( *, '(a)' ) ' segment_point_near_2d() computes the nearest point' write ( *, '(a)' ) ' on a line segment to a point in 2D.' do test = 1, test_num call random_number ( harvest = p1(1:dim_num) ) call random_number ( harvest = p2(1:dim_num) ) call random_number ( harvest = p(1:dim_num) ) call segment_point_near_2d ( p1, p2, p, pn, dist, t ) write ( *, '(a)' ) '' write ( *, '(a,i2)' ) ' TEST = ', test write ( *, '(a,2f9.4)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2f9.4)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,2f9.4)' ) ' P = ', p(1:dim_num) write ( *, '(a,2f9.4)' ) ' PN = ', pn(1:dim_num) write ( *, '(a, f9.4)' ) ' DIST = ', dist write ( *, '(a, f9.4)' ) ' T = ', t end do return end subroutine segment_point_near_3d_test ( ) !*****************************************************************************80 ! !! segment_point_near_3d_test tests segment_point_near_3d. ! ! Discussion: ! ! Case 1, point is nearest end of segment. ! ! LS: (2,3,0) + t * (2,1,0) for t = 0 to 3. ! P (11,6,4) ! Distance is 5. ! ! Case 2, point is nearest interior point of segment. ! ! LS: (2,3,0) + t * (2,1,0) for t = 0 to 3. ! P (4,4,1) ! Distance is 1. ! ! Case 3, point is on the line. ! ! LS: (2,3,0) + t * (2,1,0) for t = 0 to 3. ! P (6,5,0) ! Distance is 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 11.0D+00, 6.0D+00, 4.0D+00, & 4.0D+00, 4.0D+00, 1.0D+00, & 6.0D+00, 5.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 2.0D+00, 3.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 8.0D+00, 6.0D+00, 0.0D+00 /) real ( kind = rk ) pn(dim_num) real ( kind = rk ) t integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segment_point_near_3d_test' write ( *, '(a)' ) ' segment_point_near_3d() computes the nearest' write ( *, '(a)' ) ' point on a line segment, to a given point,' write ( *, '(a)' ) ' in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test T Distance PN.' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call segment_point_near_3d ( p1, p2, p, pn, dist, t ) write ( *, '(2x,i2,5f9.4)' ) test, t, dist, pn(1:dim_num) end do return end subroutine segments_curvature_2d_test ( ) !*****************************************************************************80 ! !! segments_curvature_2d_test tests segments_curvature_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 13 real ( kind = rk ) curvature real ( kind = rk ), dimension(dim_num) :: p1 = (/ 0.0D+00, 0.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ 1.0D+00, 0.0D+00 /) real ( kind = rk ) p3(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) theta real ( kind = rk ) theta_degrees integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segments_curvature_2d_test' write ( *, '(a)' ) ' segments_curvature_2d() computes the local curvature ' write ( *, '(a)' ) ' defined by the line segments [P1,P2] and [P2,P3].' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Our three points are:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 = (0,0)' write ( *, '(a)' ) ' P2 = (1,0)' write ( *, '(a)' ) ' P3 = (C,S)' write ( *, '(a)' ) '' write ( *, '(a)' ) ' C = cosine ( theta), S = sine ( theta ).' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Test Theta Curvature' write ( *, '(a)' ) '' do test = 1, test_num theta = 2.0D+00 * pi * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) theta_degrees = 360.0D+00 * real ( test - 1, kind = rk ) & / real ( test_num - 1, kind = rk ) p3(1:dim_num) = (/ cos ( theta ), sin ( theta ) /) call segments_curvature_2d ( p1, p2, p3, curvature ) write ( *, '(2x,i4,2x,f5.0,2x,g14.6)' ) test, theta_degrees, curvature end do return end subroutine segments_dist_2d_test ( ) !*****************************************************************************80 ! !! segments_dist_2d_test tests segments_dist_2d. ! ! Discussion: ! ! Case 1, parallel, not coincident. ! Case 2, parallel, coincident, overlapping. ! Case 3, parallel, coincident, disjoint. ! Case 4, nonparallel, intersecting. ! Case 5, nonparallel, disjoint. ! Case 6 and 7, should be same, because simply a translation by 50; ! Case 8 and 9, answers should be same. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 9 real ( kind = rk ) dist real ( kind = rk ) p1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p1_test = & reshape ( (/ & 2.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 57.0D+00, 53.0D+00, & 7.0D+00, 3.0D+00, & 0.0D+00, 0.0D+00, & -10.0D+00, -10.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p2_test = & reshape ( (/ & 8.0D+00, 6.0D+00, & 8.0D+00, 6.0D+00, & 8.0D+00, 6.0D+00, & 8.0D+00, 6.0D+00, & 8.0D+00, 6.0D+00, & 58.0D+00, 53.0D+00, & 8.0D+00, 3.0D+00, & 100.0D+00, 100.0D+00, & 100.0D+00, 100.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = & reshape ( (/ & 8.0D+00, 3.0D+00, & 4.0D+00, 4.0D+00, & 14.0D+00, 9.0D+00, & 0.0D+00, 8.0D+00, & 7.0D+00, 3.0D+00, & 65.0D+00, 45.0D+00, & 15.0D+00, -5.0D+00, & 50.0D+00, 0.0D+00, & 50.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = & reshape ( (/ & 14.0D+00, 6.0D+00, & 14.0D+00, 9.0D+00, & 16.0D+00, 10.0D+00, & 5.0D+00, 3.0D+00, & 9.0D+00, -1.0D+00, & 57.0D+00, 53.0D+00, & 7.0D+00, 3.0D+00, & 60.0D+00, 0.0D+00, & 60.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segments_dist_2d_test' write ( *, '(a)' ) ' segments_dist_2d() computes the distance between' write ( *, '(a)' ) ' line segments in 2D.' do test = 1, test_num p1(1:dim_num) = p1_test(1:dim_num,test) p2(1:dim_num) = p2_test(1:dim_num,test) q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) call segments_dist_2d ( p1, p2, q1, q2, dist ) if ( test == 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Same slope, different intercepts.' else if ( test == 2 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Same slope, same intercepts, overlapping.' write ( *, '(a)' ) ' Distance should be 0.' else if ( test == 3 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Same slope, same intercepts, disjoint.' write ( *, '(a)' ) ' Distance should be sqrt(45)=6.7082038' else if ( test == 4 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Different slopes, intersecting.' write ( *, '(a)' ) ' Distance should be 0.' else if ( test == 5 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Different slopes, not intersecting.' else if ( test == 6 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Simple problem.' write ( *, '(a)' ) ' Distance should be 0' else if ( test == 7 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Same data, translated by 50.' write ( *, '(a)' ) ' Distance should be 0' else if ( test == 8 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Diagonal and horizontal.' write ( *, '(a)' ) ' Distance should be sqrt(2500/2)=35.355339' else if ( test == 9 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' Same data, except first segment extended.' write ( *, '(a)' ) ' Distance should be sqrt(2500/2)=35.355339' end if write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2 = ', p2(1:dim_num) write ( *, '(a,2g14.6)' ) ' Q1 = ', q1(1:dim_num) write ( *, '(a,2g14.6)' ) ' Q2 = ', q2(1:dim_num) write ( *, '(a,g14.6)' ) ' Distance([P1,P2],[Q1,Q2]) = ', dist end do return end subroutine segments_dist_3d_test ( ) !*****************************************************************************80 ! !! segments_dist_3d_test tests segments_dist_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 August 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) dist real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ) q1(dim_num) real ( kind = rk ) q2(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'segments_dist_3d_test' write ( *, '(a)' ) ' segments_dist_3d() computes the distance between' write ( *, '(a)' ) ' line segments in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Case Computed True' write ( *, '(a)' ) '' ! ! Case 1, parallel, not coincident. ! ! LS1: (2,3,0) + t * (2,1,0) for t = 0 to 3. ! LS2: (11,6,4) + t * (2,1,0) for t = 0 to 3. ! Distance is 5. ! p1(1:dim_num) = (/ 2.0D+00, 3.0D+00, 0.0D+00 /) p2(1:dim_num) = (/ 8.0D+00, 6.0D+00, 0.0D+00 /) q1(1:dim_num) = (/ 11.0D+00, 6.0D+00, 4.0D+00 /) q2(1:dim_num) = (/ 17.0D+00, 9.0D+00, 4.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 1, dist, 5.0D+00 ! ! Case 2, parallel, coincident, overlapping. ! ! (1,2,3) + t * ( 1,-1,2) ! LS1: t = 0 to t = 3. ! Distance is 0. ! p1(1:dim_num) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) p2(1:dim_num) = (/ 4.0D+00, -1.0D+00, 9.0D+00 /) q1(1:dim_num) = (/ 3.0D+00, 0.0D+00, 7.0D+00 /) q2(1:dim_num) = (/ 6.0D+00, -3.0D+00, 13.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 2, dist, 0.0D+00 ! ! Case 3, parallel, coincident, disjoint. ! ! LS1: (3,4,5) + t * ( 2,2,1) for 0 <= t <= 2. ! LS2: (3,4,5) + t * ( 2,2,1) for 3 <= t <= 5. ! Distance = 3. ! p1(1:dim_num) = (/ 3.0D+00, 4.0D+00, 5.0D+00 /) p2(1:dim_num) = (/ 7.0D+00, 8.0D+00, 7.0D+00 /) q1(1:dim_num) = (/ 9.0D+00, 10.0D+00, 8.0D+00 /) q2(1:dim_num) = (/ 13.0D+00, 14.0D+00, 10.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 3, dist, 3.0D+00 ! ! Case 4, nonparallel, could intersect, and does intersect. ! ! L1: (1,1,1) + t * (0,1,2) ! L2: (0,2,3) + t * (1,0,0) ! intersect at (1,2,3) ! Distance is 0. ! p1(1:dim_num) = (/ 1.0D+00, 1.0D+00, 1.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 4.0D+00, 7.0D+00 /) q1(1:dim_num) = (/ 0.0D+00, 2.0D+00, 3.0D+00 /) q2(1:dim_num) = (/ 5.0D+00, 2.0D+00, 3.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 4, dist, 0.0D+00 ! ! Case 5, nonparallel, could intersect, and does not intersect. ! ! L1: (1,1,1) + t * (0,1,2) ! L2: (0,2,3) + t * (1,0,0) ! lines intersect at (1,2,3), line segments do not intersect. ! Distance is 1.0D+00 ! p1(1:dim_num) = (/ 1.0D+00, 1.0D+00, 1.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 4.0D+00, 7.0D+00 /) q1(1:dim_num) = (/ 0.0D+00, 2.0D+00, 3.0D+00 /) q2(1:dim_num) = (/ -5.0D+00, 2.0D+00, 3.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 5, dist, 1.0D+00 ! ! Case 6, nonparallel, can not intersect, "end-to-end". ! ! L1: (2,2,1) + t * (0,1,2) 0 <= t <= 5 ! L2: (0,0,0) + t * (-1,-1,-1) 0 <= t <= 5 ! Distance is 3. ! p1(1:dim_num) = (/ 2.0D+00, 2.0D+00, 1.0D+00 /) p2(1:dim_num) = (/ 2.0D+00, 7.0D+00, 11.0D+00 /) q1(1:dim_num) = (/ 0.0D+00, 0.0D+00, 0.0D+00 /) q2(1:dim_num) = (/ -5.0D+00, -5.0D+00, -5.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 6, dist, 3.0D+00 ! ! Case 7, nonparallel, can not intersect, "end-to-mid". ! ! L1: (1,1,1) + t * (0,1,2) 0 <= t <= 5 ! L2: (0,4,7) + t * (-1,0,0) 0 <= t <= 5 ! Distance is 1. ! p1(1:dim_num) = (/ 1.0D+00, 1.0D+00, 1.0D+00 /) p2(1:dim_num) = (/ 1.0D+00, 6.0D+00, 11.0D+00 /) q1(1:dim_num) = (/ 0.0D+00, 4.0D+00, 7.0D+00 /) q2(1:dim_num) = (/ -5.0D+00, 4.0D+00, 7.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 7, dist, 1.0D+00 ! ! Case 8, nonparallel, can not intersect, "mid-to-mid". ! ! L1: (0,5,10) + t * (1,-1,0) 0 <= t <= 5 ! L2: (0,0,0) + t * (1,1,0) 0 <= t <= 6 ! Distance = 10. ! p1(1:dim_num) = (/ 0.0D+00, 5.0D+00, 10.0D+00 /) p2(1:dim_num) = (/ 5.0D+00, 0.0D+00, 10.0D+00 /) q1(1:dim_num) = (/ 0.0D+00, 0.0D+00, 0.0D+00 /) q2(1:dim_num) = (/ 6.0D+00, 6.0D+00, 0.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 8, dist, 10.0D+00 ! ! Case 9, nonparallel, can not intersect, "mid-to-end". ! ! L1: (-2,0,0) + t * (1,0,0) 0 <= t <= 12 ! L2: (-2,8,1) + t * (9,-4,-1) 0 <= t <= 1 ! Distance = 4. ! p1(1:dim_num) = (/ -2.0D+00, 0.0D+00, 0.0D+00 /) p2(1:dim_num) = (/ 10.0D+00, 0.0D+00, 0.0D+00 /) q1(1:dim_num) = (/ -2.0D+00, 8.0D+00, 1.0D+00 /) q2(1:dim_num) = (/ 7.0D+00, 4.0D+00, 0.0D+00 /) call segments_dist_3d ( p1, p2, q1, q2, dist ) write ( *, '(2x,i8,2g14.6)' ) 9, dist, 4.0D+00 return end subroutine segments_int_1d_test ( ) !*****************************************************************************80 ! !! segments_int_1d_test tests segments_int_1d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 7 real ( kind = rk ) dist integer test real ( kind = rk ) p1 real ( kind = rk ) p2 real ( kind = rk ) q1 real ( kind = rk ), dimension ( test_num ) :: q1_test = & (/ -1.0D+00, 3.0D+00, 1.0D+00, 0.5D+00, 0.25D+00, 0.5D+00, 2.0D+00 /) real ( kind = rk ) q2 real ( kind = rk ), dimension ( test_num ) :: q2_test = & (/ 1.0D+00, 2.0D+00, 2.0D+00, -3.0D+00, 0.50D+00, 0.5D+00, 2.0D+00 /) real ( kind = rk ) r1 real ( kind = rk ) r2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'segments_int_1d_test' write ( *, '(a)' ) ' segments_int_1d() determines the intersection [R1,R2]' write ( *, '(a)' ) ' of line segments [P1,P2] and [Q1,Q2] in 1D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' DIST is negative for overlap,' write ( *, '(a)' ) ' 0 for point intersection,' write ( *, '(a)' ) ' positive if there is no overlap.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' Test P1 P2 Q1 Q2 R1 R2 DIST' write ( *, '(a)' ) '' do test = 1, test_num p1 = -1.0D+00 p2 = 1.0D+00 q1 = q1_test(test) q2 = q2_test(test) call segments_int_1d ( p1, p2, q1, q2, dist, r1, r2 ) write ( *, '(2x,i4,3(2x,f8.4,2x,f8.4),2x,f8.4)' ) & test, p1, p2, q1, q2, r1, r2, dist end do return end subroutine segments_int_2d_test ( ) !*****************************************************************************80 ! !! segments_int_2d_test tests segments_int_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 integer flag real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ -1.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ 1.0D+00, 1.0D+00 /) real ( kind = rk ) q1(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q1_test = reshape ( (/ & -1.0D+00, 1.0D+00, & 3.0D+00, -1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) q2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: q2_test = reshape ( (/ & 1.0D+00, -1.0D+00, & 2.0D+00, 0.0D+00, & 0.0D+00, 9.0D+00, & 3.0D+00, 2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) r(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'segments_int_2d_test' write ( *, '(a)' ) ' segments_int_2d() searches for an intersection of two' write ( *, '(a)' ) ' line segments in 2D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' All tests use the same line segment 1:' write ( *, '(a,2g14.6)' ) ' P1 = ', p1(1:dim_num) write ( *, '(a,2g14.6)' ) ' P2 = ', p2(1:dim_num) do test = 1, test_num q1(1:dim_num) = q1_test(1:dim_num,test) q2(1:dim_num) = q2_test(1:dim_num,test) write ( *, '(a)' ) '' write ( *, '(a,2g14.6)' ) ' Q1 = ', q1(1:dim_num) write ( *, '(a,2g14.6)' ) ' Q2 = ', q2(1:dim_num) call segments_int_2d ( p1, p2, q1, q2, flag, r ) if ( flag == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The line segments do not intersect.' else if ( flag == 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The line segments intersect at:' write ( *, '(2x,2g14.6)' ) r(1:dim_num) end if end do return end subroutine test1788 ( ) !*****************************************************************************80 ! !! TEST17888 tests SIMPLEX_LATTICE_LAYER_POINT_NEXT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 4 integer, allocatable :: c(:) integer i integer layer logical more integer n integer :: n_test(test_num) = (/ 1, 2, 3, 4 /) integer test integer, allocatable :: v(:) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1788' write ( *, '(a)' ) ' SIMPLEX_LATTICE_LAYER_POINT_NEXT returns the next' write ( *, '(a)' ) ' point in an N-dimensional simplex lattice layer defined by:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' C(N+1) - 1 <= X(1)/C(1) + X(2)/C(2) + ... + X(N)/C(N) <= C(N+1).' do test = 1, test_num n = n_test(test) allocate ( c(1:n+1) ) allocate ( v(1:n) ) do i = 1, n c(i) = i + 1 end do v(1:n) = 0 write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' N = ', n write ( *, '(a)', advance = 'NO' ) ' C = ' do i = 1, n write ( *, '(2x,i4)', advance = 'NO' ) c(i) end do write ( *, '(a)', advance = 'YES' ) write ( *, '(a)' ) '' do layer = 0, 2 write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' Layer ', layer write ( *, '(a)' ) '' c(n+1) = layer more = .false. i = 0 do call simplex_lattice_layer_point_next ( n, c, v, more ) if ( .not. more ) then write ( *, '(a)' ) ' No more.' exit end if i = i + 1 write ( *, '(2x,i4,6x,10(2x,i4))' ) i, v(1:n) end do end do deallocate ( c ) deallocate ( v ) end do return end subroutine simplex_lattice_point_next_test ( ) !*****************************************************************************80 ! !! simplex_lattice_point_next_test tests simplex_lattice_point_next. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 4 integer, allocatable :: c(:) integer i logical more integer n integer :: n_test(test_num) = (/ 1, 2, 3, 4 /) integer test integer, allocatable :: v(:) write ( *, '(a)' ) '' write ( *, '(a)' ) 'simplex_lattice_point_next_test' write ( *, '(a)' ) ' simplex_lattice_point_next() returns the next lattice' write ( *, '(a)' ) ' point in an N-dimensional simplex defined by:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' 0 <= X(1)/C(1) + X(2)/C(2) + ... + X(N)/C(N) <= C(N+1).' do test = 1, test_num n = n_test(test) allocate ( c(1:n+1) ) allocate ( v(1:n) ) do i = 1, n + 1 c(i) = n + 2 - i end do v(1:n) = 0 more = .false. write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' N = ', n write ( *, '(a)', ADVANCE = 'NO' ) ' C = ' do i = 1, n + 1 write ( *, '(2x,i4)', ADVANCE = 'NO' ) c(i) end do write ( *, '(a)', ADVANCE = 'YES' ) write ( *, '(a)' ) '' i = 0 do call simplex_lattice_point_next ( n, c, v, more ) if ( .not. more ) then write ( *, '(a)' ) ' No more.' exit end if i = i + 1 write ( *, '(2x,i4,6x,10(2x,i4))' ) i, v(1:n) end do deallocate ( c ) deallocate ( v ) end do return end subroutine test179 ( ) !*****************************************************************************80 ! !! TEST179 tests SOCCER_SIZE_3D and SOCCER_SHAPE_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) area integer edge_num integer face_num integer, allocatable, dimension ( : ) :: face_order integer face_order_max integer, allocatable, dimension ( :, : ) :: face_point integer i integer j integer k real ( kind = rk ) normal(dim_num) integer point_num real ( kind = rk ), allocatable, dimension ( :, : ) :: point_coord real ( kind = rk ), allocatable, dimension ( :, : ) :: v real ( kind = rk ) vave(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST179' write ( *, '(a)' ) ' For the truncated icosahedron, or soccer ball,' write ( *, '(a)' ) ' SOCCER_SIZE_3D returns dimension information;' write ( *, '(a)' ) ' SOCCER_SHAPE_3D returns face and order information.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We will use this information to compute the' write ( *, '(a)' ) ' areas and centers of each face.' call soccer_size_3d ( point_num, edge_num, face_num, face_order_max ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of vertices = ', point_num write ( *, '(a,i8)' ) ' Number of edges = ', edge_num write ( *, '(a,i8)' ) ' Number of faces = ', face_num write ( *, '(a,i8)' ) ' Maximum face order = ', face_order_max allocate ( face_order(1:face_num) ) allocate ( face_point(1:face_order_max,1:face_num) ) allocate ( point_coord(1:dim_num,1:point_num) ) allocate ( v(1:dim_num,1:face_order_max) ) call soccer_shape_3d ( point_num, face_num, face_order_max, point_coord, & face_order, face_point ) ! ! Compute the area of each face. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' Face Order Area' write ( *, '(a)' ) '' do i = 1, face_num do j = 1, face_order(i) k = face_point(j,i) v(1:dim_num,j) = point_coord(1:dim_num,k) end do call polygon_area_3d ( face_order(i), v, area, normal ) write ( *, '(2x,i8,i7,f8.4)' ) i, face_order(i), area end do ! ! Find the center of each face. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' Face Center' write ( *, '(a)' ) '' do i = 1, face_num vave(1:dim_num) = 0.0D+00 do j = 1, face_order(i) k = face_point(j,i) vave(1:dim_num) = vave(1:dim_num) + point_coord(1:dim_num,k) end do vave(1:dim_num) = vave(1:dim_num) / real ( face_order(i), kind = rk ) write ( *, '(2x,i8,3f8.4)' ) i, vave(1:dim_num) end do deallocate ( face_order ) deallocate ( face_point ) deallocate ( point_coord ) deallocate ( v ) return end subroutine test180 ( ) !*****************************************************************************80 ! !! TEST180 tests SORT_HEAP_EXTERNAL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 20 integer a(n) integer i integer indx integer isgn integer j write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST180' write ( *, '(a)' ) ' SORT_HEAP_EXTERNAL sorts objects externally.' write ( *, '(a)' ) '' indx = 0 i = 0 j = 0 isgn = 0 call i4vec_uniform_ab ( n, 1, n, a ) call i4vec_print ( n, a, ' Unsorted array' ) do call sort_heap_external ( n, indx, i, j, isgn ) if ( indx < 0 ) then if ( a(i) <= a(j) ) then isgn = -1 else isgn = +1 end if else if ( 0 < indx ) then call i4_swap ( a(i), a(j) ) else exit end if end do call i4vec_print ( n, a, ' Sorted array' ) return end subroutine test1804 ( ) !*****************************************************************************80 ! !! TEST1804 tests SIMPLEX01_LATTICE_POINT_NUM_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 11 integer dim_num integer, dimension ( test_num ) :: dim_num_test = (/ & 2, 2, 2, 2, 3, 3, 3, 3, 4, 5, 6 /) integer t integer, dimension ( test_num ) :: t_test = (/ & 1, 2, 3, 4, 1, 2, 3, 10, 3, 3, 3 /) integer test integer volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1804' write ( *, '(a)' ) ' For an N-dimensional unit simplex' write ( *, '(a)' ) ' 0 <= X(1:N),' write ( *, '(a)' ) ' sum X(1:N) <= T' write ( *, '(a)' ) ' where T is an integer,' write ( *, '(a)' ) ' SIMPLEX01_LATTICE_POINT_NUM_ND computes the lattice volume,' write ( *, '(a)' ) ' that is, the number of lattice points it contains.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' N T Volume' write ( *, '(a)' ) '' do test = 1, test_num dim_num = dim_num_test(test) t = t_test(test) call simplex01_lattice_point_num_nd ( dim_num, t, volume ) write ( *, '(2x,i8,2x,i8,2x,i8)' ) dim_num, t, volume end do return end subroutine test1805 ( ) !*****************************************************************************80 ! !! TEST1805 tests SIMPLEX_VOLUME_ND and TETRAHEDRON_VOLUME_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ), dimension(dim_num,4) :: tetra = reshape ( (/& 0.000000D+00, 0.942809D+00, -0.333333D+00, & -0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.000000D+00, 0.000000D+00, 1.000000D+00 /), (/ dim_num, 4 /) ) real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1805' write ( *, '(a)' ) ' For an N-dimensional simplex,' write ( *, '(a)' ) ' SIMPLEX_VOLUME_ND computes the volume.' write ( *, '(a)' ) ' Here, we check the routine by comparing it' write ( *, '(a)' ) ' with TETRAHEDRON_VOLUME_3D.' call r8mat_transpose_print ( dim_num, 4, tetra, ' Simplex vertices:' ) call tetrahedron_volume_3d ( tetra, volume ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Volume computed by TETRAHEDRON_VOLUME_3D:' write ( *, '(2x,g14.6)' ) volume call simplex_volume_nd ( dim_num, tetra, volume ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Volume computed by SIMPLEX_VOLUME_ND:' write ( *, '(2x,g14.6)' ) volume return end subroutine test0126 ( ) !*****************************************************************************80 ! !! TEST0126 tests SPHERE_CAP_VOLUME_3D and SPHERE_CAP_VOLUME_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) h real ( kind = rk ) :: r = 1.0D+00 integer test integer, parameter :: test_num = 12 real ( kind = rk ) volume1 real ( kind = rk ) volume2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0126' write ( *, '(a)' ) ' SPHERE_CAP_VOLUME_3D computes the volume of a' write ( *, '(a)' ) ' spherical cap, defined by a plane that cuts the' write ( *, '(a)' ) ' sphere to a thickness of H units.' write ( *, '(a)' ) ' SPHERE_CAP_VOLUME_ND does the same operation,' write ( *, '(a)' ) ' but in N dimensions.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Using a radius R = ', r write ( *, '(a)' ) '' write ( *, '(a)' ) ' H Cap Cap' write ( *, '(a)' ) ' volume_3d volume_nd' write ( *, '(a)' ) '' do test = 0, test_num h = 2.0D+00 * r * real ( test, kind = rk ) / real ( test_num, kind = rk ) call sphere_cap_volume_3d ( r, h, volume1 ) call sphere_cap_volume_nd ( dim_num, r, h, volume2 ) write ( *, '(2x,3f12.6)' ) h, volume1, volume2 end do return end subroutine sphere_cap_volume_2d_test ( ) !*****************************************************************************80 ! !! sphere_cap_volume_2d_test tests SPHERE_CAP_VOLUME_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) h real ( kind = rk ) haver_sine real ( kind = rk ) pc(dim_num) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r real ( kind = rk ) r8_asin integer test integer, parameter :: test_num = 12 real ( kind = rk ) theta1 real ( kind = rk ) theta2 real ( kind = rk ) volume1 real ( kind = rk ) volume2 pc(1:2) = (/ 0.0D+00, 0.0D+00 /) r = 1.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere_cap_volume_2d_test' write ( *, '(a)' ) ' SPHERE_CAP_VOLUME_2D computes the volume (area) of a' write ( *, '(a)' ) ' spherical cap, defined by a plane that cuts the' write ( *, '(a)' ) ' sphere to a thickness of H units.' write ( *, '(a)' ) ' SPHERE_CAP_VOLUME_ND does the same operation,' write ( *, '(a)' ) ' but in N dimensions.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The two routines should get the same results' write ( *, '(a)' ) ' if THETA1, THETA2 and H correspond.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Using a radius R = ', r write ( *, '(a)' ) '' write ( *, '(a)' ) & ' Theta1 Theta2 H Cap Cap' write ( *, '(a)' ) & ' vol_2d vol_nd' write ( *, '(a)' ) '' do test = 0, test_num h = 2.0D+00 * r * real ( test, kind = rk ) / real ( test_num, kind = rk ) haver_sine = sqrt ( r * r - ( r - h )**2 ) if ( h <= r ) then theta2 = r8_asin ( haver_sine / r ) else theta2 = ( pi - r8_asin ( haver_sine / r ) ) end if theta1 = -theta2 call sphere_cap_volume_2d ( r, h, volume1 ) call sphere_cap_volume_nd ( dim_num, r, h, volume2 ) write ( *, '(2x,6f12.6)' ) theta1, theta2, h, volume1, volume2 end do return end subroutine test0127 ( ) !*****************************************************************************80 ! !! TEST0127 tests SPHERE_CAP_AREA_3D and SPHERE_CAP_AREA_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) area1 real ( kind = rk ) area2 real ( kind = rk ) h integer test integer, parameter :: test_num = 12 real ( kind = rk ) r r = 1.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST0127' write ( *, '(a)' ) ' SPHERE_CAP_AREA_3D computes the volume of a' write ( *, '(a)' ) ' 3D spherical cap, defined by a plane that cuts the' write ( *, '(a)' ) ' sphere to a thickness of H units.' write ( *, '(a)' ) ' SPHERE_CAP_AREA_ND computes the volume of an' write ( *, '(a)' ) ' ND spherical cap, defined by a plane that cuts the' write ( *, '(a)' ) ' sphere to a thickness of H units.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' R H Cap Cap' write ( *, '(a)' ) ' area_3d area_nd' write ( *, '(a)' ) '' do test = 0, test_num h = 2.0D+00 * r * real ( test, kind = rk ) / real ( test_num, kind = rk ) call sphere_cap_area_3d ( r, h, area1 ) call sphere_cap_area_nd ( dim_num, r, h, area2 ) write ( *, '(2x,5f12.6)' ) r, h, area1, area2 end do return end subroutine test068 ( ) !*****************************************************************************80 ! !! TEST068 tests the SPHERE_DISTANCE routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: test_num = 6 real ( kind = rk ) dist1 real ( kind = rk ) dist2 real ( kind = rk ) dist3 character ( len = 18 ), dimension ( test_num ) :: name = (/ & 'Atlanta, Georgia ', & 'North Pole ', & 'South Pole ', & 'Timbuktu ', & 'San Antonio, Texas', & 'Savannah, Georgia ' /) integer, dimension ( test_num ) :: lat_d = (/ 33, 90, -90, 16, 29, 32 /) integer, dimension ( test_num ) :: lat_m = (/ 11, 0, 0, 49, 25, 5 /) integer, dimension ( test_num ) :: long_d = (/ 82, 0, 0, 3, 98, 81 /) integer, dimension ( test_num ) :: long_m = (/ 34, 0, 0, 0, 30, 6 /) real ( kind = rk ) lat1 real ( kind = rk ) lat2 real ( kind = rk ) long1 real ( kind = rk ) long2 real ( kind = rk ), parameter :: radius = 3957.0D+00 integer test1 integer test2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST068' write ( *, '(a)' ) ' SPHERE_DISTANCE1, SPHERE_DISTANCE2 and SPHERE_DISTANCE3' write ( *, '(a)' ) ' measure the distance between two points on a sphere.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' All tests uses RADIUS = ', radius write ( *, '(a)' ) ' which is the radius of the earth in miles.' write ( *, '(a)' ) '' do test1 = 1, test_num-1 call dms_to_radians ( lat_d(test1), lat_m(test1), 0, lat1 ) call dms_to_radians ( long_d(test1), long_m(test1), 0, long1 ) write ( *, '(a)' ) '' write ( *, '(a,a)' ) ' Distance from ', name(test1) do test2 = test1+1, test_num call dms_to_radians ( lat_d(test2), lat_m(test2), 0, lat2 ) call dms_to_radians ( long_d(test2), long_m(test2), 0, long2 ) call sphere_distance1 ( lat1, long1, lat2, long2, radius, dist1 ) call sphere_distance2 ( lat1, long1, lat2, long2, radius, dist2 ) call sphere_distance3 ( lat1, long1, lat2, long2, radius, dist3 ) write ( *, '(a,a,3g14.6)' ) ' to ', & name(test2), dist1, dist2, dist3 end do end do return end subroutine sphere_dia2imp_3d_test ( ) !*****************************************************************************80 ! !! sphere_dia2imp_3d_test tests sphere_dia2imp_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) pc(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ & -1.0D+00, -1.0D+00, 4.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ & 5.0D+00, 7.0D+00, 4.0D+00 /) real ( kind = rk ) r write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere_dia2imp_3d_test' write ( *, '(a)' ) ' sphere_dia2imp_3d() converts a sphere from' write ( *, '(a)' ) ' diameter to implicit form.' call r8vec_print ( dim_num, p1, ' Point P1:' ) call r8vec_print ( dim_num, p2, ' Point P2:' ) call sphere_dia2imp_3d ( p1, p2, r, pc ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Radius: ', r call r8vec_print ( dim_num, pc, ' The center:' ) return end subroutine test182 ( ) !*****************************************************************************80 ! !! TEST182 tests SPHERE_EXP_CONTAINS_POINT_3D and SPHERE_IMP_CONTAINS_POINT_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 logical inside real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 7.0D+00, 2.0D+00, 3.0D+00, & 1.0D+00, 5.0D+00, 3.0D+00, & 2.5D+00, 3.5D+00, 4.5D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 1.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 4.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 1.0D+00, 5.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 1.0D+00, 2.0D+00, 6.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p4 = (/ & -2.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ) :: r = 3.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST182' write ( *, '(a)' ) ' SPHERE_EXP_CONTAINS_POINT_3D determines if a' write ( *, '(a)' ) ' point is within an explicit sphere;' write ( *, '(a)' ) ' SPHERE_IMP_CONTAINS_POINT_3D determines if a' write ( *, '(a)' ) ' point is within an implicit sphere;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' SPHERE_EXP_CONTAINS_POINT_3D:' write ( *, '(a)' ) ' Inside, P' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call sphere_exp_contains_point_3d ( p1, p2, p3, p4, p, inside ) write ( *, '(2x,l1,3g14.6)' ) inside, p(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a)' ) ' SPHERE_IMP_CONTAINS_POINT_3D:' write ( *, '(a)' ) ' Inside, P' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call sphere_imp_contains_point_3d ( r, pc, p, inside ) write ( *, '(2x,l1,3g14.6)' ) inside, p(1:dim_num) end do return end subroutine test183 ( ) !*****************************************************************************80 ! !! TEST183 tests SPHERE_EXP_POINT_NEAR_3D and SPHERE_IMP_POINT_NEAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 7.0D+00, 2.0D+00, 3.0D+00, & 1.0D+00, 5.0D+00, 3.0D+00, & 2.5D+00, 3.5D+00, 4.5D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 4.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 1.0D+00, 5.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 1.0D+00, 2.0D+00, 6.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p4 = (/ & -2.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 1.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ) pn(dim_num) real ( kind = rk ) :: r = 3.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST183' write ( *, '(a)' ) ' SPHERE_EXP_POINT_NEAR_3D determines if a' write ( *, '(a)' ) ' point is within an explicit sphere;' write ( *, '(a)' ) ' SPHERE_IMP_POINT_NEAR_3D determines if a' write ( *, '(a)' ) ' point is within an implicit sphere;' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Sphere radius ', r call r8vec_print ( dim_num, pc, ' Sphere center:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' SPHERE_EXP_POINT_NEAR_3D:' write ( *, '(a)' ) ' P PN' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call sphere_exp_point_near_3d ( p1, p2, p3, p4, p, pn ) write ( *, '(2x,6f10.4)' ) p(1:dim_num), pn(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a)' ) ' SPHERE_IMP_POINT_NEAR_3D:' write ( *, '(a)' ) ' P PN' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call sphere_imp_point_near_3d ( r, pc, p, pn ) write ( *, '(2x,6f10.4)' ) p(1:dim_num), pn(1:dim_num) end do return end subroutine test1835 ( ) !*****************************************************************************80 ! !! TEST1835 tests SPHERE_EXP2IMP_3D and SPHERE_IMP2EXP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 1.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 4.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p2 = (/ & 1.0D+00, 5.0D+00, 3.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p3 = (/ & 1.0D+00, 2.0D+00, 6.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: p4 = (/ & -2.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ) :: r = 3.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1835' write ( *, '(a)' ) ' SPHERE_EXP2IMP_3D: explicit sphere => implicit form;' write ( *, '(a)' ) ' SPHERE_IMP2EXP_3D: implicit sphere => explicit form.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Initial form of explicit sphere:' write ( *, '(a)' ) '' write ( *, '(2x,3g14.6)' ) p1(1:dim_num) write ( *, '(2x,3g14.6)' ) p2(1:dim_num) write ( *, '(2x,3g14.6)' ) p3(1:dim_num) write ( *, '(2x,3g14.6)' ) p4(1:dim_num) call sphere_exp2imp_3d ( p1, p2, p3, p4, r, pc ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Computed form of implicit sphere:' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Imputed radius = ', r call r8vec_print ( dim_num, pc, ' Imputed center' ) call sphere_imp2exp_3d ( r, pc, p1, p2, p3, p4 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Computed form of explicit sphere:' write ( *, '(a)' ) '' write ( *, '(2x,3g14.6)' ) p1(1:dim_num) write ( *, '(2x,3g14.6)' ) p2(1:dim_num) write ( *, '(2x,3g14.6)' ) p3(1:dim_num) write ( *, '(2x,3g14.6)' ) p4(1:dim_num) return end subroutine sphere_exp2imp_nd_test ( ) !*****************************************************************************80 ! !! sphere_exp2imp_nd_test tests sphere_exp2imp_nd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 July 2011 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 3 real ( kind = rk ), dimension (n,n+1) :: p = reshape ( (/ & 4.0D+00, 2.0D+00, 3.0D+00, & 1.0D+00, 5.0D+00, 3.0D+00, & 1.0D+00, 2.0D+00, 6.0D+00, & -2.0D+00, 2.0D+00, 3.0D+00 /), (/ n, n + 1 /) ) real ( kind = rk ) pc(n) real ( kind = rk ), dimension ( n ) :: pc_true = (/ & 1.0D+00, 2.0D+00, 3.0D+00 /) real ( kind = rk ) r real ( kind = rk ) :: r_true = 3.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere_exp2imp_nd_test' write ( *, '(a)' ) ' sphere_exp2imp_nd(): explicit sphere => implicit form;' call r8mat_transpose_print ( n, n + 1, p, ' Initial form of explicit sphere:' ) call sphere_exp2imp_nd ( n, p, r, pc ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Computed form of implicit sphere:' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Imputed radius = ', r write ( *, '(a,g14.6)' ) ' True radius = ', r_true call r8vec_print ( n, pc, ' Imputed center' ) call r8vec_print ( n, pc_true, ' True center' ) return end subroutine sphere_imp_point_project_3d_test ( ) !*****************************************************************************80 ! !! sphere_imp_point_project_3d_test tests sphere_imp_point_project_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 July 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 4 real ( kind = rk ), dimension ( dim_num,test_num) :: p_test = reshape ( (/ & 2.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 4.0D+00, 0.0D+00, & 2.0D+00, 4.0D+00, 10.0D+00, & 3.0D+00, 5.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num) :: pc = (/ & 2.0D+00, 4.0D+00, 0.0D+00 /) real ( kind = rk ) :: r = 2.0D+00 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere_imp_point_project_3d_test' write ( *, '(a)' ) ' sphere_imp_point_project_3d() projects a 3D point' write ( *, '(a)' ) ' onto a sphere.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 projection P2' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p_test(1:dim_num,test) call sphere_imp_point_project_3d ( r, pc, p1, p2 ) write ( *, '(6g12.4)' ) p1(1:dim_num), p2(1:dim_num) end do return end subroutine test189 ( ) !*****************************************************************************80 ! !! TEST189 tests SPHERE_IMP_AREA_ND and SPHERE_IMP_VOLUME_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area integer dim_num real ( kind = rk ), parameter :: r = 1.0D+00 real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST189' write ( *, '(a)' ) ' SPHERE_IMP_AREA_ND computes the area of a sphere in ND;' write ( *, '(a)' ) ' SPHERE_IMP_VOLUME_ND computes the volume of a sphere in ND.' write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' We use a radius of R = ', r write ( *, '(a)' ) '' write ( *, '(a)' ) ' DIM_NUM Area Volume' write ( *, '(a)' ) '' do dim_num = 2, 10 call sphere_imp_area_nd ( dim_num, r, area ) call sphere_imp_volume_nd ( dim_num, r, volume ) write ( *, '(2x,i3,2g14.6)' ) dim_num, area, volume end do return end subroutine test1895 ( ) !*****************************************************************************80 ! !! TEST1895 tests SPHERE01_AREA_ND and SPHERE01_AREA_VALUES. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) area real ( kind = rk ) area2 integer dim_num integer n_data real ( kind = rk ) sphere01_area_nd write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1895:' write ( *, '(a)' ) ' SPHERE01_AREA_ND evaluates the area of the unit' write ( *, '(a)' ) ' sphere in N dimensions.' write ( *, '(a)' ) ' SPHERE01_AREA_VALUES returns some test values.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' DIM_NUM Exact Computed' write ( *, '(a)' ) ' Area Area' write ( *, '(a)' ) '' n_data = 0 do call sphere01_area_values ( n_data, dim_num, area ) if ( n_data == 0 ) then exit end if area2 = sphere01_area_nd ( dim_num ) write ( *, '(2x,i8,2x,f10.6,2x,f10.6)' ) dim_num, area, area2 end do return end subroutine sphere01_sample_2d_test ( ) !*****************************************************************************80 ! !! sphere01_sample_2d_test tests sphere01_sample_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere01_sample_2d_test' write ( *, '(a)' ) ' sphere01_sample_2d() samples the unit sphere' write ( *, '(a)' ) ' in 2D (the circle);' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_2d ( x ) write ( *, '(2x,2f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_2d ( x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,2f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We expect a value near 2 / PI = 0.6366...' do j = 1, 5 call sphere01_sample_2d ( v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_2d ( x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,2f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine sphere01_sample_3d_test ( ) !*****************************************************************************80 ! !! sphere01_sample_3d_test tests sphere01_sample_3d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'sphere01_sample_3d_test' write ( *, '(a)' ) ' sphere01_sample_3d() samples the unit sphere in 3D.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_3d ( x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_3d ( x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' do j = 1, 5 call sphere01_sample_3d ( v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_3d ( x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine test192 ( ) !*****************************************************************************80 ! !! TEST192 tests SPHERE01_SAMPLE_3D_2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST192' write ( *, '(a)' ) ' For the unit sphere in 3 dimensions:' write ( *, '(a)' ) ' SPHERE01_SAMPLE_3D_2 samples;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Warning: SPHERE01_SAMPLE_3D_2 is NOT a good code!' write ( *, '(a)' ) ' I only implemented it for comparison.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_3d_2 ( x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_3d_2 ( x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' do j = 1, 5 call sphere01_sample_3d_2 ( v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_3d_2 ( x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine test193 ( ) !*****************************************************************************80 ! !! TEST193 tests SPHERE01_SAMPLE_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST193' write ( *, '(a)' ) ' For the unit sphere in N dimensions:' write ( *, '(a)' ) ' SPHERE01_SAMPLE_ND samples;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_nd ( dim_num, x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Spatial dimension = ', dim_num write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd ( dim_num, x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as N increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' do j = 1, 5 call sphere01_sample_nd ( dim_num, v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd ( dim_num, x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine test194 ( ) !*****************************************************************************80 ! !! TEST194 tests SPHERE01_SAMPLE_ND_2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST194' write ( *, '(a)' ) ' For the unit sphere in N dimensions:' write ( *, '(a)' ) ' SPHERE01_SAMPLE_ND_2 samples;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_nd_2 ( dim_num, x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Spatial dimension = ', dim_num write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd_2 ( dim_num, x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' do j = 1, 5 call sphere01_sample_nd_2 ( dim_num, v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd_2 ( dim_num, x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine test195 ( ) !*****************************************************************************80 ! !! TEST195 tests SPHERE01_SAMPLE_ND_3. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) average(dim_num) real ( kind = rk ) dot_average integer i integer j integer, parameter :: sample_num = 1000 real ( kind = rk ) v(dim_num) real ( kind = rk ) x(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST195' write ( *, '(a)' ) ' For the unit sphere in N dimensions:' write ( *, '(a)' ) ' SPHERE01_SAMPLE_ND_3 samples;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' A few sample values:' write ( *, '(a)' ) '' do i = 1, 5 call sphere01_sample_nd_3 ( dim_num, x ) write ( *, '(2x,3f8.4)' ) x(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Spatial dimension = ', dim_num write ( *, '(a,i8)' ) ' Number of sample points = ', sample_num average(1:dim_num) = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd_3 ( dim_num, x ) average(1:dim_num) = average(1:dim_num) + x(1:dim_num) end do average(1:dim_num) = average(1:dim_num) / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now average the points, which should get a value' write ( *, '(a)' ) ' close to zero, and closer as sample_num increases.' write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' Average: ', average(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now choose a random direction, sample the same' write ( *, '(a)' ) ' number of points, and compute the dot product with' write ( *, '(a)' ) ' the direction.' write ( *, '(a)' ) ' Take the absolute value of each dot product ' write ( *, '(a)' ) ' and sum and average.' do j = 1, 5 call sphere01_sample_nd_3 ( dim_num, v ) dot_average = 0.0D+00 do i = 1, sample_num call sphere01_sample_nd_3 ( dim_num, x ) dot_average = dot_average & + abs ( dot_product ( x(1:dim_num), v(1:dim_num) ) ) end do dot_average = dot_average / real ( sample_num, kind = rk ) write ( *, '(a)' ) '' write ( *, '(a,3f8.4)' ) ' V: ', v(1:dim_num) write ( *, '(a, f8.4)' ) ' Average |(XdotV)| ', dot_average end do return end subroutine test1955 ( ) !*****************************************************************************80 ! !! TEST1955 tests SPHERE01_VOLUME_ND and SPHERE01_VOLUME_VALUES. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dim_num integer n_data real ( kind = rk ) sphere01_volume_nd real ( kind = rk ) volume real ( kind = rk ) volume2 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST1955:' write ( *, '(a)' ) ' SPHERE01_VOLUME_ND evaluates the area of the unit' write ( *, '(a)' ) ' sphere in N dimensions.' write ( *, '(a)' ) ' SPHERE01_VOLUME_VALUES returns some test values.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' DIM_NUM Exact Computed' write ( *, '(a)' ) ' Volume Volume' write ( *, '(a)' ) '' n_data = 0 do call sphere01_volume_values ( n_data, dim_num, volume ) if ( n_data == 0 ) then exit end if volume2 = sphere01_volume_nd ( dim_num ) write ( *, '(2x,i8,2x,f10.6,2x,f10.6)' ) dim_num, volume, volume2 end do return end subroutine test196 ( ) !*****************************************************************************80 ! !! TEST196 tests SHAPE_POINT_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: side_num = 4 integer, parameter :: test_num = 9 real ( kind = rk ) dist real ( kind = rk ) p(1:dim_num) real ( kind = rk ),dimension ( dim_num ) :: p1 = (/ 5.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: pc = (/ 3.0D+00, 0.0D+00 /) real ( kind = rk ), dimension (dim_num,test_num) :: p_test = reshape ( (/ & 3.0D+00, 0.0D+00, & 5.0D+00, 0.0D+00, & 4.0D+00, 0.0D+00, & 10.0D+00, 0.0D+00, & 8.0D+00, 5.0D+00, & 6.0D+00, 6.0D+00, & 1.0D+00, 2.0D+00, & 2.5D+00, -0.5D+00, & 4.0D+00, -1.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST196' write ( *, '(a)' ) ' For a shape in 2D,' write ( *, '(a)' ) ' SHAPE_POINT_DIST_2D computes the distance' write ( *, '(a)' ) ' to a point;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Number of sides:' write ( *, '(a)' ) '' write ( *, '(2x,i8)' ) side_num call r8vec_print ( dim_num, pc, ' Center of square:' ) call r8vec_print ( dim_num, p1, ' Square vertex #1' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' TEST X Y DIST' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call shape_point_dist_2d ( pc, p1, side_num, p, dist ) write ( *, '(2x,i8,3g14.6)' ) test, p(1:dim_num), dist end do return end subroutine test197 ( ) !*****************************************************************************80 ! !! TEST197 tests SHAPE_POINT_DIST_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: side_num = 6 integer, parameter :: test_num = 8 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num) :: p1 = (/ 5.0D+00, 0.0D+00 /) real ( kind = rk ), dimension (dim_num) :: pc = (/ 3.0D+00, 0.0D+00 /) real ( kind = rk ), dimension (dim_num,test_num) :: p_test = reshape ( (/ & 3.0D+00, 0.0D+00, & 5.0D+00, 0.0D+00, & 4.0D+00, 0.0D+00, & 10.0D+00, 0.0D+00, & 4.0D+00, 1.7320508D+00, & 5.0D+00, 3.4641016D+00,& 3.0D+00, 1.7320508D+00, & 3.0D+00, 0.86602539D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST197' write ( *, '(a)' ) ' For a shape in 2D,' write ( *, '(a)' ) ' SHAPE_POINT_DIST_2D computes the distance' write ( *, '(a)' ) ' to a point;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Number of sides:' write ( *, '(a)' ) '' write ( *, '(2x,i8)' ) side_num call r8vec_print ( dim_num, pc, ' Center of hexagon:' ) call r8vec_print ( dim_num, p1, ' Hexagon vertex #1' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' TEST X Y DIST' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call shape_point_dist_2d ( pc, p1, side_num, p, dist ) write ( *, '(2x,i8,3g14.6)' ) test, p(1:dim_num), dist end do return end subroutine test198 ( ) !*****************************************************************************80 ! !! TEST198 tests SHAPE_POINT_NEAR_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: side_num = 6 integer, parameter :: test_num = 8 real ( kind = rk ) dist real ( kind = rk ) p(1:dim_num) real ( kind = rk ), dimension(1:dim_num,test_num) :: p_test = & reshape ( (/ & 3.0D+00, 0.0D+00, & 5.0D+00, 0.0D+00, & 4.0D+00, 0.0D+00, & 10.0D+00, 0.0D+00, & 4.0D+00, 1.7320508D+00, & 5.0D+00, 3.4641016D+00, & 3.0D+00, 1.7320508D+00, & 3.0D+00, 0.86602539D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ & 5.0D+00, 0.0D+00 /) real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 3.0D+00, 0.0D+00 /) real ( kind = rk ) pn(1:dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST198' write ( *, '(a)' ) ' For a shape in 2D,' write ( *, '(a)' ) ' SHAPE_POINT_NEAR_2D computes the nearest' write ( *, '(a)' ) ' point to a point;' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Number of sides:' write ( *, '(a)' ) '' write ( *, '(2x,i8)' ) side_num call r8vec_print ( dim_num, pc, ' Hexagon center:' ) call r8vec_print ( dim_num, p1, ' Hexagon vertex #1' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' TEST X Y ' // & ' PN Dist' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call shape_point_near_2d ( pc, p1, side_num, p, pn, dist ) write ( *, '(2x,i8,5f12.4)' ) test, p(1:dim_num), pn(1:dim_num), dist end do return end subroutine test199 ( ) !*****************************************************************************80 ! !! TEST199 tests SHAPE_RAY_INT_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: side_num = 6 integer, parameter :: test_num = 4 real ( kind = rk ), dimension ( dim_num ) :: p1 = (/ 5.0D+00, 0.0D+00 /) real ( kind = rk ) pa(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: pa_test = reshape ( (/ & 3.0D+00, 0.0D+00, & 3.0D+00, 0.0D+00, & 3.0D+00, -1.0D+00, & 3.0D+00, -1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pb(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: pb_test = reshape ( (/ & 4.0D+00, 0.0D+00, & 3.0D+00, 1.0D+00, & 3.0D+00, 1.0D+00, & 7.0D+00, 5.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num ) :: pc = (/ 3.0D+00, 0.0D+00 /) real ( kind = rk ) pint(dim_num) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST199' write ( *, '(a)' ) ' For a shape in 2D,' write ( *, '(a)' ) ' SHAPE_RAY_INT_2D computes the intersection of' write ( *, '(a)' ) ' a shape and a ray whose origin is within' write ( *, '(a)' ) ' the shape.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Number of sides:' write ( *, '(a)' ) '' write ( *, '(2x,i8)' ) side_num call r8vec_print ( dim_num, pc, ' Hexagon center:' ) call r8vec_print ( dim_num, p1, ' Hexagon vertex #1' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' TEST XA YA XB' // & ' YB XI YI' write ( *, '(a)' ) '' do test = 1, test_num pa(1:dim_num) = pa_test(1:dim_num,test) pb(1:dim_num) = pb_test(1:dim_num,test) call shape_ray_int_2d ( pc, p1, side_num, pa, pb, pint ) write ( *, '(2x,i8,6f12.4)' ) & test, pa(1:dim_num), pb(1:dim_num), pint(1:dim_num) end do return end subroutine sphere_triangle_sides_to_angles_test ( ) !*****************************************************************************80 ! !! SPHERE_TRIANGLE_SIDES_TO_ANGLES_TEST tests SPHERE_TRIANGLE_SIDES_TO_ANGLES. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) as real ( kind = rk ) b real ( kind = rk ) bs real ( kind = rk ) c real ( kind = rk ) cs real ( kind = rk ) degrees_to_radians real ( kind = rk ), parameter :: r = 10.0D+00 real ( kind = rk ) radians_to_degrees write ( *, '(a)' ) '' write ( *, '(a)' ) 'SPHERE_TRIANGLE_SIDES_TO_ANGLES_TEST' write ( *, '(a)' ) ' SPHERE_TRIANGLE_SIDES_TO_ANGLES takes the sides of a' write ( *, '(a)' ) ' spherical triangle and determines the angles.' as = 121.0D+00 + ( 15.4D+00 / 60.0D+00 ) bs = 104.0D+00 + ( 54.7D+00 / 60.0D+00 ) cs = 65.0D+00 + ( 42.5D+00 / 60.0D+00 ) as = degrees_to_radians ( as ) bs = degrees_to_radians ( bs ) cs = degrees_to_radians ( cs ) as = r * as bs = r * bs cs = r * cs ! ! Get the spherical angles. ! call sphere_triangle_sides_to_angles ( r, as, bs, cs, a, b, c ) write ( *, '(a)' ) '' write ( *, '(a,f8.4,a)' ) ' A = ', a, ' (radians)' a = radians_to_degrees ( a ) write ( *, '(a,f8.4,a)' ) ' = ', a, ' ( degrees )' a = 117.0D+00 + ( 58.0D+00 / 60.0D+00 ) write ( *, '(a,f8.4,a)' ) ' Correct = ', a, ' (degrees)' write ( *, '(a)' ) '' write ( *, '(a,f8.4,a)' ) ' B = ', b, ' (radians)' b = radians_to_degrees ( b ) write ( *, '(a,f8.4,a)' ) ' = ', b, ' ( degrees )' b = 93.0D+00 + ( 13.8D+00 / 60.0D+00 ) write ( *, '(a,f8.4,a)' ) ' Correct = ', b, ' (degrees)' write ( *, '(a)' ) '' write ( *, '(a,f8.4,a)' ) ' C = ', c, ' (radians)' c = radians_to_degrees ( c ) write ( *, '(a,f8.4,a)' ) ' = ', c, ' ( degrees )' c = 70.0D+00 + ( 20.6D+00 / 60.0D+00 ) write ( *, '(a,f8.4,a)' ) ' Correct = ', c, ' (degrees)' return end subroutine test201 ( ) !*****************************************************************************80 ! !! TEST201 tests STRING_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: vec_num = 15 integer i integer jstrng integer order(vec_num) real ( kind = rk ), dimension ( dim_num, vec_num ) :: p1 = reshape ( (/ & 0.0D+00, 0.0D+00, & 3.0D+00, 4.0D+00, & 2.0D+00, 2.0D+00, & 3.0D+00, 2.0D+00, & 2.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, & 0.0D+00, 5.0D+00, & 1.0D+00, 2.0D+00, & 3.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, & 5.0D+00, 5.0D+00, & 3.0D+00, 3.0D+00, & 2.0D+00, 4.0D+00, & 7.0D+00, 4.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, vec_num /) ) real ( kind = rk ), dimension ( dim_num, vec_num ) :: p2 = reshape ( (/ & 1.0D+00, 1.0D+00, & 2.0D+00, 4.0D+00, & 1.0D+00, 3.0D+00, & 2.0D+00, 3.0D+00, & 2.0D+00, 2.0D+00, & 1.0D+00, 2.0D+00, & 1.0D+00, 6.0D+00, & 1.0D+00, 3.0D+00, & 3.0D+00, 3.0D+00, & 1.0D+00, 0.0D+00, & 6.0D+00, 6.0D+00, & 3.0D+00, 4.0D+00, & 2.0D+00, 3.0D+00, & 5.0D+00, 5.0D+00, & 2.0D+00, 1.0D+00 /), (/ dim_num, vec_num /) ) integer string(vec_num) integer string_num write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST201' write ( *, '(a)' ) ' STRING_2D takes a set of line segments, and' write ( *, '(a)' ) ' "strings" them together.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' I P1 P2' write ( *, '(a)' ) '' do i = 1, vec_num write ( *, '(2x,i8,4g14.6)' ) i, p1(1:2,i), p2(1:2,i) end do call string_2d ( vec_num, p1, p2, string_num, order, string ) write ( *, '(a)' ) '' write ( *, '(a,i8,a)' ) ' Found ', string_num, ' groups of segments.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' STRING ORDER P1 P2' write ( *, '(a)' ) '' jstrng = 1 do i = 1, vec_num if ( jstrng < string(i) ) then write ( *, '(a)' ) '' jstrng = jstrng + 1 end if write ( *, '(2x,i3,1x,i3,4f10.4)' ) string(i), order(i), p1(1:2,i), & p2(1:2,i) end do return end subroutine test202 ( ) !*****************************************************************************80 ! !! TEST202 tests SUPER_ELLIPSE_POINTS_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 24 integer, parameter :: dim_num = 2 real ( kind = rk ), dimension ( dim_num ) :: pc = (/ & 5.0D+00, -2.0D+00 /) real ( kind = rk ) expo real ( kind = rk ) p(dim_num,n) real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) psi real ( kind = rk ) r1 real ( kind = rk ) r2 r1 = 3.0D+00 r2 = 1.0D+00 expo = 1.5D+00 psi = pi / 6.0D+00 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST202' write ( *, '(a)' ) & ' SUPER_ELLIPSE_POINTS_2D returns points on a super ellipse;' call r8vec_print ( dim_num, pc, ' Superellipse center:' ) write ( *, '(a)' ) '' write ( *, '(a,g14.6,a,g14.6)' ) ' radii R1 = ', r1, ' R2 = ', r2 write ( *, '(a,g14.6)' ) ' exponent EXPO = ', expo write ( *, '(a,g14.6)' ) ' and angle PSI = ', psi call super_ellipse_points_2d ( pc, r1, r2, expo, psi, n, p ) call r8mat_transpose_print ( dim_num, n, p, ' Sample points:' ) return end subroutine tetrahedron_centroid_3d_test ( ) !*****************************************************************************80 ! !! tetrahedron_centroid_3d_test tests tetrahedron_centroid_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) centroid(dim_num) real ( kind = rk ), dimension (dim_num,4) :: tetra = reshape ( (/& 0.000000D+00, 0.942809D+00, -0.333333D+00, & -0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.000000D+00, 0.000000D+00, 1.000000D+00 /), (/ dim_num, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'tetrahedron_centroid_3d_test' write ( *, '(a)' ) ' tetrahedron_centroid_3d() computes the centroid' write ( *, '(a)' ) ' of a tetrahedron in 3D.' call r8mat_transpose_print ( dim_num, 4, tetra, ' Tetrahedron vertices:' ) call tetrahedron_centroid_3d ( tetra, centroid ) call r8vec_print ( dim_num, centroid, ' Centroid:' ) return end subroutine tetrahedron_circumsphere_3d_test ( ) !*****************************************************************************80 ! !! tetrahedron_circumsphere_3d_test tests tetrahedron_circumsphere_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 August 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) pc(dim_num) real ( kind = rk ) r real ( kind = rk ), dimension(dim_num,4) :: tetra = reshape ( (/& 0.577350269189626D+00, 0.0D+00, 0.0D+00, & -0.288675134594813D+00, 0.5D+00, 0.0D+00, & -0.288675134594813D+00, -0.5D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.816496580927726D+00 /), & (/ dim_num, 4 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'tetrahedron_circumsphere_3d_test' write ( *, '(a)' ) ' tetrahedron_circumsphere_3d() computes the circumsphere' write ( *, '(a)' ) ' of a tetrahedron in 3D.' call r8mat_transpose_print ( dim_num, 4, tetra, ' Tetrahedron vertices:' ) call tetrahedron_circumsphere_3d ( tetra, r, pc ) call r8vec_print ( dim_num, pc, ' Circumsphere center:' ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Circumsphere radius is ', r return end subroutine tetrahedron_volume_3d_test ( ) !*****************************************************************************80 ! !! tetrahedron_volume_3d_test() tests tetrahedron_volume_3d(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ), dimension(dim_num,4) :: tetra = reshape ( (/& 0.000000D+00, 0.942809D+00, -0.333333D+00, & -0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.816496D+00, -0.816496D+00, -0.333333D+00, & 0.000000D+00, 0.000000D+00, 1.000000D+00 /), (/ dim_num, 4 /) ) real ( kind = rk ) volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'tetrahedron_volume_3d_test():' write ( *, '(a)' ) ' tetrahedron_volume_3d() computes the volume' write ( *, '(a)' ) ' of a tetrahedron in 3D.' call r8mat_transpose_print ( dim_num, 4, tetra, ' Tetrahedron vertices' ) call tetrahedron_volume_3d ( tetra, volume ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Volume = ', volume return end subroutine test204 ( ) !*****************************************************************************80 ! !! TEST204 tests TMAT_INIT, TMAT_ROT_AXIS, TMAT_ROT_VECTOR, TMAT_SCALE, TMAT_SHEAR, TMAT_TRANS. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) a(4,4) real ( kind = rk ) angle real ( kind = rk ) axis(dim_num) character axis1 character ( len = 2 ) axis2 real ( kind = rk ) b(4,4) real ( kind = rk ) s real ( kind = rk ) v(3) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST204' write ( *, '(a)' ) ' TMAT geometric transformation matrix routines:' write ( *, '(a)' ) ' TMAT_INIT initializes,' write ( *, '(a)' ) ' TMAT_ROT_AXIS for rotation about an axis,' write ( *, '(a)' ) ' TMAT_ROT_VECTOR for rotation about a vector,' write ( *, '(a)' ) ' TMAT_SCALE for scaling,' write ( *, '(a)' ) ' TMAT_SHEAR for shear,' write ( *, '(a)' ) ' TMAT_TRANS for translation' ! ! Initialization. ! call tmat_init ( a ) call r8mat_print ( 4, 4, a, ' Initial transformation matrix:' ) ! ! Rotation about an axis. ! angle = 30.0D+00 axis1 = 'x' call tmat_rot_axis ( a, angle, axis1, b ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Transformation matrix for' write ( *, '(a)' ) ' rotation about ' // axis1 write ( *, '(a,g14.6)' ) ' by ' , angle call r8mat_print ( 4, 4, b, '' ) ! ! Rotation about a vector. ! angle = 30.0D+00 axis(1:dim_num) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) call tmat_rot_vector ( a, angle, axis, b ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Transformation matrix for' write ( *, '(a,3g14.6)' ) ' rotation about ', axis(1:dim_num) write ( *, '(a,g14.6)' ) ' of ', angle call r8mat_print ( 4, 4, b, '' ) ! ! Scaling. ! v(1:3) = (/ 2.0D+00, 0.5D+00, 10.0D+00 /) call tmat_scale ( a, v, b ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Transformation matrix for' write ( *, '(a,3g14.6)' ) ' scaling by ', v(1:3) call r8mat_print ( 4, 4, b, '' ) ! ! Shear. ! axis2 = 'xy' s = 0.5D+00 call tmat_shear ( a, axis2, s, b ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Transformation matrix for' write ( *, '(2x,a)' ) axis2 write ( *, '(a,g14.6)' ) ' shear coefficient of ', s call r8mat_print ( 4, 4, b, '' ) ! ! Translation. ! v(1:3) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) call tmat_trans ( a, v, b ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Transformation matrix for' write ( *, '(a,3g14.6)' ) ' translation by ', v(1:3) call r8mat_print ( 4, 4, b, '' ) return end subroutine test205 ( ) !*****************************************************************************80 ! !! TEST205 tests TMAT_MXP2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 4 integer, parameter :: dim_num = 3 real ( kind = rk ) a(4,4) real ( kind = rk ) angle real ( kind = rk ) axis(dim_num) character axis1 character ( len = 2 ) axis2 real ( kind = rk ) b(4,4) real ( kind = rk ), dimension ( dim_num, n ) :: point = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00 /), (/ dim_num, n /) ) real ( kind = rk ) point2(dim_num,n) real ( kind = rk ) s real ( kind = rk ) v(1:3) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST205' write ( *, '(a)' ) ' TMAT_MXP2 applies a geometric transformation' write ( *, '(a)' ) ' matrix to a set of points.' call r8mat_transpose_print ( 3, n, point, ' Points:' ) ! ! Initialization of transformation matrix. ! call tmat_init ( a ) call r8mat_print ( 4, 4, a, ' Initial transformation matrix:' ) ! ! Rotation about an axis. ! angle = 30.0D+00 axis1 = 'x' call tmat_rot_axis ( a, angle, axis1, b ) call tmat_mxp2 ( b, n, point, point2 ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Rotation about ' // axis1 write ( *, '(a,g14.6)' ) ' by ' , angle call r8mat_transpose_print ( 3, n, point2, '' ) ! ! Rotation about a vector. ! angle = 30.0D+00 axis(1:3) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) call tmat_rot_vector ( a, angle, axis, b ) call tmat_mxp2 ( b, n, point, point2 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Rotation about ', axis(1:3) write ( *, '(a,g14.6)' ) ' of ', angle call r8mat_transpose_print ( 3, n, point2, '' ) ! ! Scaling. ! v(1:3) = (/ 2.0D+00, 0.5D+00, 10.0D+00 /) call tmat_scale ( a, v, b ) call tmat_mxp2 ( b, n, point, point2 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Scaling by ', v(1:3) call r8mat_transpose_print ( 3, n, point2, '' ) ! ! Shear. ! axis2 = 'xy' s = 0.5D+00 call tmat_shear ( a, axis2, s, b ) call tmat_mxp2 ( b, n, point, point2 ) write ( *, '(a)' ) '' write ( *, '(2x,a)' ) axis2 write ( *, '(a,g14.6)' ) ' shear coefficient of ', s call r8mat_transpose_print ( 3, n, point2, '' ) ! ! Translation. ! v(1:3) = (/ 1.0D+00, 2.0D+00, 3.0D+00 /) call tmat_trans ( a, v, b ) call tmat_mxp2 ( b, n, point, point2 ) write ( *, '(a)' ) '' write ( *, '(a,3g14.6)' ) ' Translation by ', v(1:3) call r8mat_transpose_print ( 3, n, point2, '' ) return end subroutine test206 ( ) !*****************************************************************************80 ! !! TEST206 tests TRIANGLE_ANGLES_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) angle(3) integer i real ( kind = rk ) radians_to_degrees real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST206' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_ANGLES_2D computes the angles;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_angles_2d ( t, angle ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Radians Degrees' write ( *, '(a)' ) '' do i = 1, 3 write ( *, '(2x,g14.6,2x,g14.6)' ) angle(i), radians_to_degrees ( angle(i) ) end do return end subroutine test20605 ( ) !*****************************************************************************80 ! !! TEST20605 tests TRIANGLE_ANGLES_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) angle(3) integer i real ( kind = rk ) radians_to_degrees real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 2.4142137D+00, 3.4142137D+00, 3.0D+00, & 1.7071068D+00, 2.7071068D+00, 4.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST20605' write ( *, '(a)' ) ' For a triangle in 3D:' write ( *, '(a)' ) ' TRIANGLE_ANGLES_3D computes the angles;' write ( *, '(a)' ) '' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices: ' ) call triangle_angles_3d ( t, angle ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Radians Degrees' write ( *, '(a)' ) '' do i = 1, 3 write ( *, '(2x,g14.6,2x,g14.6)' ) angle(i), radians_to_degrees ( angle(i) ) end do return end subroutine test2061 ( ) !*****************************************************************************80 ! !! TEST2061 tests TRIANGLE_AREA_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) area real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2061' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_AREA_2D computes the area;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_area_2d ( t, area ) write ( *, '(a,g14.6)' ) ' Triangle area is ', area return end subroutine test2062 ( ) !*****************************************************************************80 ! !! TEST2062 tests TRIANGLE_AREA_HERON; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) area integer i integer j integer jp1 real ( kind = rk ) s(3) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2062' write ( *, '(a)' ) ' For a triangle in any dimension,' write ( *, '(a)' ) ' TRIANGLE_AREA_HERON computes the area;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) do j = 1, 3 s(j) = 0.0D+00 jp1 = mod ( j, 3 ) + 1 do i = 1, dim_num s(j) = s(j) + ( t(i,j) - t(i,jp1) )**2 end do s(j) = sqrt ( s(j) ) end do call r8vec_print ( 3, s, ' Side lengths:' ) call triangle_area_heron ( s, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' The area is ', area return end subroutine test209 ( ) !*****************************************************************************80 ! !! TEST209 tests TRIANGLE_AREA_3D, TRIANGLE_AREA_3D_2, TRIANGLE_AREA_3D_3; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) area real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 2.4142137D+00, 3.4142137D+00, 3.0D+00, & 1.7071068D+00, 2.7071068D+00, 4.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST209' write ( *, '(a)' ) ' For a triangle in 3D:' write ( *, '(a)' ) ' TRIANGLE_AREA_3D computes the area;' write ( *, '(a)' ) ' TRIANGLE_AREA_3D_2 computes the area;' write ( *, '(a)' ) ' TRIANGLE_AREA_3D_3 computes the area;' call r8mat_print ( dim_num, 3, t, ' Triangle (vertices are columns)' ) call triangle_area_3d ( t, area ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Area #1 ', area call triangle_area_3d_2 ( t, area ) write ( *, '(a,g14.6)' ) ' Area #2 ', area call triangle_area_3d_3 ( t, area ) write ( *, '(a,g14.6)' ) ' Area #3 ', area return end subroutine test20655 ( ) !*****************************************************************************80 ! !! TEST20655 tests TRIANGLE_BARYCENTRIC_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 1.00D+00, & 0.50D+00, -10.00D+00, & 0.60D+00, 0.60D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) integer test real ( kind = rk ) xsi(dim_num+1) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST20655' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_BARYCENTRIC_2D converts XY coordinates' write ( *, '(a)' ) ' to barycentric XSI coordinates;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P XSI' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_barycentric_2d ( t, p, xsi ) write ( *, '(2x,2f8.3,2x,3f8.3)' ) p(1:dim_num), xsi(1:dim_num+1) end do return end subroutine test2066 ( ) !*****************************************************************************80 ! !! TEST2066 tests TRIANGLE_CENTROID_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) centroid(dim_num) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2066' write ( *, '(a)' ) ' For a triangle in 2D:' write ( *, '(a)' ) ' TRIANGLE_CENTROID_2D computes the centroid.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_centroid_2d ( t, centroid ) call r8vec_print ( dim_num, centroid, ' Centroid:' ) end do return end subroutine test2094 ( ) !*****************************************************************************80 ! !! TEST2094 tests TRIANGLE_CENTROID_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 real ( kind = rk ) centroid(dim_num) real ( kind = rk ), dimension (dim_num,3) :: t = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 2.4142137D+00, 3.4142137D+00, 3.0D+00, & 1.7071068D+00, 2.7071068D+00, 4.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2094' write ( *, '(a)' ) ' For a triangle in 3D:' write ( *, '(a)' ) ' TRIANGLE_CENTROID_3D computes the centroid.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_centroid_3d ( t, centroid ) call r8vec_print ( dim_num, centroid, ' Centroid:' ) return end subroutine test2101 ( ) !*****************************************************************************80 ! !! TEST2101 tests TRIANGLE_CIRCUMCENTER_2D and others. ! ! Discussion: ! ! The functions tested include ! * TRIANGLE_CIRCUMCENTER_2D; ! * TRIANGLE_CIRCUMCENTER_2D_2; ! * TRIANGLE_CIRCUMCENTER. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 2 integer, parameter :: test_num = 4 real ( kind = rk ) pc(m) real ( kind = rk ) t(m,3) real ( kind = rk ), dimension(m,3,test_num) :: t_test = reshape ( (/ & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.0D+00, 6.0D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.5D+00, 5.86602539D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.5D+00, 15.0D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 20.0D+00, 7.0D+00 /), (/ m, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2101' write ( *, '(a)' ) & ' For a triangle in 2D, the circumenter can be computed by:' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCENTER_2D;' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCENTER_2D_2;' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCENTER (any dimension);' do test = 1, test_num t(1:m,1:3) = t_test(1:m,1:3,test) call r8mat_transpose_print ( m, 3, t, ' Triangle vertices:' ) call triangle_circumcenter_2d ( t, pc ) call r8vec_print ( m, pc, ' Circumcenter by TRIANGLE_CIRCUMCENTER_2D:' ) call triangle_circumcenter_2d_2 ( t, pc ) call r8vec_print ( m, pc, ' Circumcenter by TRIANGLE_CIRCUMCENTER_2D_2:' ) call triangle_circumcenter ( m, t, pc ) call r8vec_print ( m, pc, ' Circumcenter by TRIANGLE_CIRCUMCENTER:' ) end do return end subroutine test21011 ( ) !*****************************************************************************80 ! !! TEST21011 tests TRIANGLE_CIRCUMCENTER. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2010 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m1 = 2 integer, parameter :: test_num = 4 real ( kind = rk ), allocatable :: a12(:,:) integer j integer m2 real ( kind = rk ), allocatable :: o1(:) real ( kind = rk ), allocatable :: o2(:) real ( kind = rk ), allocatable :: pc2(:) real ( kind = rk ) r8vec_norm_affine real ( kind = rk ) t1(m1,3) real ( kind = rk ), allocatable :: t2(:,:) real ( kind = rk ), dimension(m1,3,test_num) :: t_test = reshape ( (/ & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.0D+00, 6.0D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.5D+00, 5.86602539D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 10.5D+00, 15.0D+00, & 10.0D+00, 5.0D+00, & 11.0D+00, 5.0D+00, & 20.0D+00, 7.0D+00 /), (/ m1, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST21011' write ( *, '(a)' ) & ' For a triangle in M dimensions, the circumenter can be computed by:' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCENTER;' ! ! Vary the dimension. ! do m2 = 2, 5 write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' M2 = ', m2 allocate ( a12(1:m2,1:m1) ) allocate ( o1(1:m1) ) allocate ( o2(1:m2) ) allocate ( pc2(1:m2) ) allocate ( t2(1:m2,1:3) ) ! ! Randomly choose a mapping P2 = O2 + A12 * ( P1 - O1 ) ! call random_number ( harvest = a12(1:m2,1:m1) ) call random_number ( harvest = o1(1:m1) ) call random_number ( harvest = o2(1:m2) ) ! ! Map each M1-dimensional triangle into M2 space. ! do test = 1, test_num t1(1:m1,1:3) = t_test(1:m1,1:3,test) do j = 1, 3 t1(1:m1,j) = t1(1:m1,j) - o1(1:m1) end do t2(1:m2,1:3) = matmul ( a12(1:m2,1:m1), t1(1:m1,1:3) ) do j = 1, 3 t2(1:m2,j) = t2(1:m2,j) + o2(1:m2) end do call triangle_circumcenter ( m2, t2, pc2 ) call r8vec_print ( m2, pc2, ' Circumcenter by TRIANGLE_CIRCUMCENTER:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Distances from circumcenter to vertices:' write ( *, '(a)' ) '' do j = 1, 3 write ( *, '(2x,g14.6)' ) r8vec_norm_affine ( m2, pc2, t2(1:m2,j) ) end do end do deallocate ( a12 ) deallocate ( o1 ) deallocate ( o2 ) deallocate ( pc2 ) deallocate ( t2 ) end do return end subroutine test2067 ( ) !*****************************************************************************80 ! !! TEST2067 tests TRIANGLE_CIRCUMCIRCLE_2D and TRIANGLE_CIRCUMCIRCLE_2D_2; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) pc(dim_num) real ( kind = rk ) r real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2067' write ( *, '(a)' ) ' For a triangle in 2D:' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCIRCLE_2D computes the circumcenter.' write ( *, '(a)' ) ' TRIANGLE_CIRCUMCIRCLE_2D_2 computes the circumcenter.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_circumcircle_2d ( t, r, pc ) call r8vec_print ( dim_num, pc, ' Circumcenter' ) write ( *, '(a,g14.6)' ) ' Circumradius: ', r call triangle_circumcircle_2d_2 ( t, r, pc ) call r8vec_print ( dim_num, pc, ' Circumcenter2' ) write ( *, '(a,g14.6)' ) ' Circumradius2: ', r end do return end subroutine test21015 ( ) !*****************************************************************************80 ! !! TEST21015 tests TRIANGLE_CIRCUMRADIUS_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) r real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST21015' write ( *, '(a)' ) ' For a triangle in 2D:' write ( *, '(a)' ) ' TRIANGLE_CIRCUMRADIUS_2D computes the circumradius.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_circumradius_2d ( t, r ) write ( *, '(a,g14.6)' ) ' Circumradius: ', r end do return end subroutine test2068 ( ) !*****************************************************************************80 ! !! TEST2068 tests TRIANGLE_CONTAINS_LINE_EXP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 logical inside real ( kind = rk ), dimension(dim_num) :: p1 = (/ & 3.0D+00, 0.0D+00, -7.0D+00 /) real ( kind = rk ), dimension(dim_num) :: p2 = (/ & 5.0D+00, 1.0D+00, -2.0D+00 /) real ( kind = rk ) pint(dim_num) real ( kind = rk ), dimension(dim_num,3) :: t = reshape ( (/ & 8.0D+00, 4.0D+00, 2.0D+00, & 9.0D+00, 0.0D+00, 5.0D+00, & 2.0D+00, 1.0D+00, 2.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2068' write ( *, '(a)' ) ' TRIANGLE_CONTAINS_LINE_EXP_3D determines whether ' write ( *, '(a)' ) ' a triangle "contains" an explicit line in 3D.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call r8vec_print ( dim_num, p1, ' Line point P1:' ) call r8vec_print ( dim_num, p2, ' Line point P2:' ) call triangle_contains_line_exp_3d ( t, p1, p2, inside, pint ) if ( inside ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle contains the line.' call r8vec_print ( dim_num, pint, ' Intersection point:' ) else write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle does not contain the line.' call r8vec_print ( dim_num, pint, ' The intersection point:' ) end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' Expected answer:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle contains the line, and' write ( *, '(a)' ) ' the intersection point is at:' write ( *, '(a)' ) ' ( 7, 2, 3 ).' return end subroutine test2069 ( ) !*****************************************************************************80 ! !! TEST2069 tests TRIANGLE_CONTAINS_LINE_PAR_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 February 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 logical inside real ( kind = rk ) norm real ( kind = rk ), dimension(dim_num) :: p0 = (/ & 3.0D+00, 0.0D+00, -7.0D+00 /) real ( kind = rk ), dimension(dim_num) :: pd = (/ & 2.0D+00, 1.0D+00, 5.0D+00 /) real ( kind = rk ) pint(dim_num) real ( kind = rk ), dimension(dim_num,3) :: t = reshape ( (/ & 8.0D+00, 4.0D+00, 2.0D+00, & 9.0D+00, 0.0D+00, 5.0D+00, & 2.0D+00, 1.0D+00, 2.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2069' write ( *, '(a)' ) ' TRIANGLE_CONTAINS_LINE_PAR_3D determines whether ' write ( *, '(a)' ) ' a triangle "contains" a parametric line in 3D.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) norm = sqrt ( sum ( pd(1:dim_num)**2 ) ) ! pd(1:dim_num) = pd(1:dim_num) / norm call r8vec_print ( dim_num, p0, ' Parametric base point P0:' ) call r8vec_print ( dim_num, pd, ' Parametric direction PD:' ) call triangle_contains_line_par_3d ( t, p0, pd, inside, pint ) if ( inside ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle contains the line.' call r8vec_print ( dim_num, pint, ' Intersection point:' ) else write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle does not contain the line.' call r8vec_print ( dim_num, pint, ' The intersection point:' ) end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' Expected answer:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' The triangle contains the line, and' write ( *, '(a)' ) ' the intersection point is at:' write ( *, '(a)' ) ' ( 7, 2, 3 ).' return end subroutine test207 ( ) !*****************************************************************************80 ! !! TEST207 tests TRIANGLE_CONTAINS_POINT_2D_*. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 logical inside1 logical inside2 logical inside3 integer j real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 1.00D+00, & 0.50D+00, -10.00D+00, & 0.60D+00, 0.60D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) real ( kind = rk ), dimension ( dim_num, 3 ) :: t2 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST207' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_CONTAINS_POINT_2D_1 reports if a point ' write ( *, '(a)' ) ' is inside a triangle (and doesn''t care about' write ( *, '(a)' ) ' the ordering of the vertices);' write ( *, '(a)' ) ' TRIANGLE_CONTAINS_POINT_2D_2 reports if a point ' write ( *, '(a)' ) ' is inside a triangle (and DOES care about' write ( *, '(a)' ) ' the ordering of the vertices);' write ( *, '(a)' ) ' TRIANGLE_CONTAINS_POINT_2D_3 reports if a point ' write ( *, '(a)' ) ' is inside a triangle (and doesn''t care about' write ( *, '(a)' ) ' the ordering of the vertices);' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y In1 In2 In3' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_contains_point_2d_1 ( t, p, inside1 ) call triangle_contains_point_2d_2 ( t, p, inside2 ) call triangle_contains_point_2d_3 ( t, p, inside3 ) write ( *, '(2x,2f8.3,5x,l1,4x,l1,4x,l1)' ) & p(1:dim_num), inside1, inside2, inside3 end do ! ! Make a copy of the triangle with vertices in reverse order. ! write ( *, '(a)' ) '' write ( *, '(a)' ) ' Repeat the test, but reverse the triangle vertex' write ( *, '(a)' ) ' ordering.' do j = 1, 3 t2(1:2,j) = t(1:2,4-j) end do call r8mat_transpose_print ( dim_num, 3, t2, & ' Triangle vertices (reversed):' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y In1 In2 In3' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_contains_point_2d_1 ( t2, p, inside1 ) call triangle_contains_point_2d_2 ( t2, p, inside2 ) call triangle_contains_point_2d_3 ( t2, p, inside3 ) write ( *, '(2x,2f8.3,5x,l1,4x,l1,4x,l1)' ) & p(1:dim_num), inside1, inside2, inside3 end do return end subroutine test2075 ( ) !*****************************************************************************80 ! !! TEST2075 tests TRIANGLE_DIAMETER_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) diameter real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & -2.0D+00, 2.0D+00, & 4.0D+00, 2.0D+00, & 5.0D+00, 4.0D+00, & 6.0D+00, 6.0D+00, & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & 4.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2075' write ( *, '(a)' ) ' TRIANGLE_DIAMETER_2D computes the diameter of ' write ( *, '(a)' ) ' the SMALLEST circle around the triangle.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_diameter_2d ( t, diameter ) write ( *, '(a,g14.6)' ) ' Diameter = ', diameter end do return end subroutine test208 ( ) !*****************************************************************************80 ! !! TEST208 tests TRIANGLE_GRIDPOINTS_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: grid_max = 50 real ( kind = rk ) g(dim_num,grid_max) integer grid_num integer sub_num real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) sub_num = 3 write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST208' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_GRIDPOINTS_2D produces a set of' write ( *, '(a)' ) ' gridpoints in or on the triangle.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_gridpoints_2d ( t, sub_num, grid_max, grid_num, g ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of grid points is ', grid_num call r8mat_print ( dim_num, grid_num, g, ' Grid points: ' ) return end subroutine test2102 ( ) !*****************************************************************************80 ! !! TEST2102 tests TRIANGLE_INCENTER_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) pc(dim_num) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2102' write ( *, '(a)' ) ' For a triangle in 2D:' write ( *, '(a)' ) ' TRIANGLE_INCENTER_2D computes the incenter.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_incenter_2d ( t, pc ) call r8vec_print ( dim_num, pc, ' Incenter' ) end do return end subroutine test2070 ( ) !*****************************************************************************80 ! !! TEST2070 tests TRIANGLE_INCIRCLE_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) pc(dim_num) real ( kind = rk ) r real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2070' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_INCIRCLE_2D computes the incircle.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_incircle_2d ( t, r, pc ) call r8vec_print ( dim_num, pc, ' Incenter' ) write ( *, '(a,g14.6)' ) ' Incircle radius is ', r return end subroutine test20701 ( ) !*****************************************************************************80 ! !! TEST20701 tests TRIANGLE_INRADIUS_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 real ( kind = rk ) r real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST20701' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_INRADIUS_2D computes the inradius.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_inradius_2d ( t, r ) write ( *, '(a,g14.6)' ) ' Incircle radius is ', r return end subroutine test2104 ( ) !*****************************************************************************80 ! !! TEST2104 tests TRIANGLE_LATTICE_LAYER_POINT_NEXT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 2 integer c(n+1) integer i integer layer logical more integer v(n) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2104' write ( *, '(a)' ) ' TRIANGLE_LATTICE_LAYER_POINT_NEXT returns the next' write ( *, '(a)' ) ' point in a triangle lattice layer defined by:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' C(3) - 1 < X(1)/C(1) + X(2)/C(2) <= C(3).' c(1) = 2 c(2) = 3 v(1:n) = 0 write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' N = ', n write ( *, '(a)', ADVANCE = 'NO' ) ' C = ' do i = 1, n write ( *, '(2x,i4)', ADVANCE = 'NO' ) c(i) end do write ( *, '(a)', ADVANCE = 'YES' ) do layer = 0, 4 write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' Layer ', layer write ( *, '(a)' ) '' c(3) = layer more = .false. i = 0 do call triangle_lattice_layer_point_next ( c, v, more ) if ( .not. more ) then write ( *, '(a)' ) ' No more.' exit end if i = i + 1 write ( *, '(2x,i4,6x,10(2x,i4))' ) i, v(1:n) end do end do return end subroutine test2105 ( ) !*****************************************************************************80 ! !! TEST2105 tests TRIANGLE_LATTICE_POINT_NEXT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 2 integer c(n+1) integer i logical more integer v(n) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2105' write ( *, '(a)' ) ' TRIANGLE_LATTICE_POINT_NEXT returns the next lattice' write ( *, '(a)' ) ' point in a triangle defined by:' write ( *, '(a)' ) '' write ( *, '(a)' ) ' 0 <= X(1)/C(1) + X(2)/C(2) <= C(3).' do i = 1, n + 1 c(i) = n + 2 - i end do v(1:n) = 0 more = .false. write ( *, '(a)' ) '' write ( *, '(a,i4)' ) ' N = ', n write ( *, '(a)', ADVANCE = 'NO' ) ' C = ' do i = 1, n + 1 write ( *, '(2x,i4)', ADVANCE = 'NO' ) c(i) end do write ( *, '(a)', ADVANCE = 'YES' ) write ( *, '(a)' ) '' i = 0 do call triangle_lattice_point_next ( c, v, more ) if ( .not. more ) then write ( *, '(a)' ) ' No more.' exit end if i = i + 1 write ( *, '(2x,i4,6x,10(2x,i4))' ) i, v(1:n) end do return end subroutine test211 ( ) !*****************************************************************************80 ! !! TEST211 tests TRIANGLE_ORIENTATION_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 integer triangle_orientation_2d integer i real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & -2.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & 4.0D+00, 2.0D+00, & 1.0D+00, -1.0D+00, & 1.0D+00, 5.0D+00, & 2.0D+00, 7.0D+00, & 3.0D+00, 9.0D+00, & 1.0D+00, 5.0D+00, & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST211' write ( *, '(a)' ) ' TRIANGLE_ORIENTATION_2D determines orientation' write ( *, '(a)' ) ' of a triangle.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) i = triangle_orientation_2d ( t ) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) if ( i == 0 ) then write ( *, '(a)' ) ' The points are counterclockwise.' else if ( i == 1 ) then write ( *, '(a)' ) ' The points are clockwise.' else if ( i == 2 ) then write ( *, '(a)' ) ' The points are colinear.' else if ( i == 3 ) then write ( *, '(a)' ) ' The points are not distinct.' else write ( *, '(a)' ) ' The return value makes no sense.' end if end do return end subroutine test2103 ( ) !*****************************************************************************80 ! !! TEST2103 tests TRIANGLE_ORTHOCENTER_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2009 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 logical flag real ( kind = rk ) pc(dim_num) real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension(dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2103' write ( *, '(a)' ) ' TRIANGLE_ORTHOCENTER_2D computes the orthocenter' write ( *, '(a)' ) ' of a triangle in 2D.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_orthocenter_2d ( t, pc, flag ) call r8vec_print ( dim_num, pc, ' Orthocenter' ) end do return end subroutine test2071 ( ) !*****************************************************************************80 ! !! TEST2071 tests TRIANGLE_POINT_DIST_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 1.00D+00, & 0.50D+00, -10.00D+00, & 0.60D+00, 0.60D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2071' write ( *, '(a)' ) ' TRIANGLE_POINT_DIST_2D computes the distance' write ( *, '(a)' ) ' from a point to a triangle in 2D;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P DIST' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_point_dist_2d ( t, p, dist ) write ( *, '(2x,2f8.3,2x,f8.3)' ) p(1:dim_num), dist end do return end subroutine test20715 ( ) !*****************************************************************************80 ! !! TEST20715 tests TRIANGLE_POINT_DIST_SIGNED_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 real ( kind = rk ) dist_signed real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 1.00D+00, & 0.50D+00, -10.00D+00, & 0.60D+00, 0.60D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST20715' write ( *, '(a)' ) ' TRIANGLE_POINT_DIST_SIGNED_2D computes signed' write ( *, '(a)' ) ' distance from a point to a triangle in 2D;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P DIST_SIGNED' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_point_dist_signed_2d ( t, p, dist_signed ) write ( *, '(2x,2f8.3,2x,f8.3)' ) p(1:dim_num), dist_signed end do return end subroutine test2095 ( ) !*****************************************************************************80 ! !! TEST2095 tests TRIANGLE_POINT_DIST_3D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 1.3535534D+00, 2.3535534D+00, 3.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) , dimension ( dim_num, 3 ) :: t = reshape ( (/ & 1.0D+00, 2.0D+00, 3.0D+00, & 2.4142137D+00, 3.4142137D+00, 3.0D+00, & 1.7071068D+00, 2.7071068D+00, 4.0D+00 /), (/ dim_num, 3 /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2095' write ( *, '(a)' ) ' TRIANGLE_POINT_DIST_3D computes the distance' write ( *, '(a)' ) ' from a point to a triangle in 3D;' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P DIST' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_point_dist_3d ( t, p, dist ) write ( *, '(2x,3g12.4,2x,g14.6)' ) p(1:dim_num), dist end do return end subroutine test2072 ( ) !*****************************************************************************80 ! !! TEST2072 tests TRIANGLE_POINT_NEAR_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 7 real ( kind = rk ) dist real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 0.25D+00, 0.25D+00, & 0.75D+00, 0.25D+00, & 1.00D+00, 1.00D+00, & 11.00D+00, 0.50D+00, & 0.00D+00, 1.00D+00, & 0.50D+00, -10.00D+00, & 0.60D+00, 0.60D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) pn(dim_num) real ( kind = rk ), dimension ( dim_num, 3 ) :: t = reshape ( (/ & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00 /), (/ dim_num, 3 /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2072' write ( *, '(a)' ) ' For a triangle in 2D,' write ( *, '(a)' ) ' TRIANGLE_POINT_NEAR_2D computes the nearest' write ( *, '(a)' ) ' point to a point.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P PN' write ( *, '(a)' ) '' do test = 1, test_num p(1:dim_num) = p_test(1:dim_num,test) call triangle_point_near_2d ( t, p, pn, dist ) write ( *, '(2x,2f8.3,2x,2f8.3)' ) p(1:dim_num), pn(1:dim_num) end do return end subroutine test2115 ( ) !*****************************************************************************80 ! !! TEST2115 tests TRIANGLE_QUALITY_2D; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) quality real ( kind = rk ) t(dim_num,3) real ( kind = rk ), dimension (dim_num,3,test_num) :: t_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 0.86602539D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 0.5D+00, 10.0D+00, & 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, & 10.0D+00, 2.0D+00 /), (/ dim_num, 3, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST2115' write ( *, '(a)' ) ' TRIANGLE_QUALITY_2D computes the quality of a triangle.' do test = 1, test_num t(1:dim_num,1:3) = t_test(1:dim_num,1:3,test) call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) call triangle_quality_2d ( t, quality ) write ( *, '(a,g14.6)' ) ' Quality = ', quality end do return end subroutine test212 ( ) !*****************************************************************************80 ! !! TEST212 tests TRIANGLE_SAMPLE, TRIANGLE_XY_TO_XSI_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 April 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 10 real ( kind = rk ) p(dim_num) real ( kind = rk ), dimension(dim_num,3) :: t = reshape ( (/ & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & -2.0D+00, 2.0D+00 /), (/ dim_num, 3 /) ) integer test real ( kind = rk ) xsi(dim_num+1) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST212' write ( *, '(a)' ) ' TRIANGLE_SAMPLE samples a triangle.' write ( *, '(a)' ) ' TRIANGLE_XY_TO_XSI_2D converts XY to XSI coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We are computing the XSI coordinates just to verify' write ( *, '(a)' ) ' that the points are inside the triangle.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Sample points (X,Y) and (XSI1,XSI2,XSI3) coordinates:' write ( *, '(a)' ) '' do test = 1, test_num call triangle_sample ( t, 1, p ) call triangle_xy_to_xsi_2d ( t, p, xsi ) write ( *, '(2x,2f8.4,4x,3f8.4)' ) p(1:dim_num), xsi(1:dim_num+1) end do return end subroutine test213 ( ) !*****************************************************************************80 ! !! TEST213 tests TRIANGLE_SAMPLE, TRIANGLE_XY_TO_XSI_2D, TRIANGLE_XSI_TO_XY_2D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 April 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 10 integer i real ( kind = rk ) p(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num,3) :: t = reshape ( (/ & 4.0D+00, 2.0D+00, & 1.0D+00, 5.0D+00, & -2.0D+00, 2.0D+00 /), (/ dim_num, 3 /) ) integer test real ( kind = rk ) xsi(dim_num+1) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST213' write ( *, '(a)' ) ' TRIANGLE_SAMPLE samples a triangle.' write ( *, '(a)' ) ' TRIANGLE_XY_TO_XSI_2D converts XY to XSI coordinates.' write ( *, '(a)' ) ' TRIANGLE_XSI_TO_XY_2D converts XSI to XY coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' We verify that (X,Y) -> (XSI1,XSI2,XSI3) -> (X,Y)' write ( *, '(a)' ) ' works properly.' call r8mat_transpose_print ( dim_num, 3, t, ' Triangle vertices:' ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Sample points:' write ( *, '(a)' ) '' do test = 1, test_num if ( test == 1 ) then do i = 1, dim_num p(i) = sum ( t(i,1:3) ) / 3.0D+00 end do else if ( test == 2 ) then p(1) = 3.0D+00 p(2) = 0.0D+00 else call triangle_sample ( t, 1, p ) end if call triangle_xy_to_xsi_2d ( t, p, xsi ) call triangle_xsi_to_xy_2d ( t, xsi, p2 ) write ( *, '(a)' ) '' write ( *, '(2x,2f8.4,4x,3f8.4)' ) p(1:dim_num), xsi(1:dim_num+1) write ( *, '(2x,2f8.4)' ) p2(1:dim_num) end do return end subroutine tube_2d_test ( ) !*****************************************************************************80 ! !! tube_2d_test tests tube_2d. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) dist real ( kind = rk ), dimension ( test_num ) :: dist_test = (/ & 0.5D+00, 0.5D+00, 1.0D+00, 1.0D+00 /) integer n integer nhi integer nlo integer, dimension ( test_num ) :: n_test = (/ 4, 5, 5, 5 /) real ( kind = rk ), allocatable, dimension(:,:) :: p real ( kind = rk ), dimension ( dim_num, 19 ) :: p_test = reshape ( (/ & 0.0D+00, 0.0D+00, & 4.0D+00, 3.0D+00, & 4.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 2.0D+00, 0.0D+00, & 2.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, & 10.0D+00, 20.0D+00, & 20.0D+00, 20.0D+00, & 10.0D+00, 10.0D+00, & 20.0D+00, 10.0D+00, & 10.0D+00, 20.0D+00, & 0.0D+00, 0.0D+00, & 10.0D+00, 0.0D+00, & 10.0D+00, 10.0D+00, & 10.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00 /), (/ dim_num, 19 /) ) real ( kind = rk ), allocatable, dimension(:,:) :: p1 real ( kind = rk ), allocatable, dimension(:,:) :: p2 integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'tube_2d_test' write ( *, '(a)' ) ' tube_2d() computes corners of a tube of radius' write ( *, '(a)' ) ' DIST surrounding a sequence of points.' do test = 1, test_num n = n_test ( test ) dist = dist_test(test) allocate ( p(1:dim_num,1:n) ) nlo = sum ( n_test(1:test-1) ) + 1 nhi = nlo + n - 1 p(1:dim_num,1:n) = p_test(1:dim_num,nlo:nhi) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Test ', test write ( *, '(a,i8)' ) ' Number of points N = ', n write ( *, '(a,g14.6)' ) ' Tube radius DIST = ', dist call r8mat_transpose_print ( dim_num, n, p, ' Points to surround:' ) allocate ( p1(1:dim_num,1:n) ) allocate ( p2(1:dim_num,1:n) ) call tube_2d ( dist, n, p, p1, p2 ) call r8mat_transpose_print ( dim_num, n, p1, ' P1:' ) call r8mat_transpose_print ( dim_num, n, p2, ' P2:' ) deallocate ( p ) deallocate ( p1 ) deallocate ( p2 ) end do return end subroutine test220 ( ) !*****************************************************************************80 ! !! TEST220 tests VECTOR_DIRECTIONS_ND; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 5 real ( kind = rk ) angle(dim_num) real ( kind = rk ) angle_degrees(dim_num) integer j real ( kind = rk ) radians_to_degrees integer test real ( kind = rk ) v(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: v_test = reshape ( (/ & 1.0D+00, 0.0D+00, & 1.7320508D+00, 1.0D+00, & -1.7320508D+00, 1.0D+00, & -1.7320508D+00, -1.0D+00, & 1.7320508D+00, -1.0D+00 /), (/ dim_num, test_num /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST220' write ( *, '(a)' ) ' VECTOR_DIRECTIONS_ND computes the angles' write ( *, '(a)' ) ' that a vector makes with the axes.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y AX AY ' // & ' AX AY' write ( *, '(a)' ) ' (__Radians___)' // & ' (___Degrees___)' write ( *, '(a)' ) '' do test = 1, test_num v(1:dim_num) = v_test(1:dim_num,test) call vector_directions_nd ( dim_num, v, angle ) do j = 1, dim_num angle_degrees(j) = radians_to_degrees ( angle(j) ) end do write ( *, '(2x,6f9.3)' ) & v(1:dim_num), angle(1:dim_num), angle_degrees(1:dim_num) end do return end subroutine vector_directions_nd_test ( ) !*****************************************************************************80 ! !! vector_directions_nd_test tests vector_directions_nd; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 3 real ( kind = rk ) angle(dim_num) real ( kind = rk ) angle_degrees(dim_num) integer j real ( kind = rk ) radians_to_degrees integer test real ( kind = rk ) v(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: v_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 3.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00 /), (/ dim_num, test_num /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_directions_nd_test' write ( *, '(a)' ) ' vector_directions_nd() computes the angles' write ( *, '(a)' ) ' that a vector makes with the axes.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X Y Z AX AY AZ ' // & ' AX AY AZ ' write ( *, '(a)' ) ' (_____Radians_______)' // & ' (_______Degrees_______)' write ( *, '(a)' ) '' do test = 1, test_num v(1:dim_num) = v_test(1:dim_num,test) call vector_directions_nd ( dim_num, v, angle ) do j = 1, dim_num angle_degrees(j) = radians_to_degrees ( angle(j) ) end do write ( *, '(2x,9f8.3)' ) & v(1:dim_num), angle(1:dim_num), angle_degrees(1:dim_num) end do return end subroutine vector_rotate_2d_test ( ) !*****************************************************************************80 ! !! vector_rotate_2d_test tests vector_rotate_2d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 3 real ( kind = rk ) angle real ( kind = rk ), dimension(test_num) :: a_test = (/ & 30.0D+00, -45.0D+00, 270.0D+00 /) real ( kind = rk ) degrees_to_radians integer test real ( kind = rk ) v(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: v_test = reshape ( (/ & 1.0D+00, 0.0D+00, & 0.0D+00, 2.0D+00, & 1.0D+00, 1.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) w(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_rotate_2d_test' write ( *, '(a)' ) ' vector_rotate_2d() rotates a vector through' write ( *, '(a)' ) ' a given angle around the origin.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' X1 Y1 Angle X2 Y2' write ( *, '(a)' ) '' do test = 1, test_num v(1:dim_num) = v_test(1:dim_num,test) angle = degrees_to_radians ( a_test(test) ) call vector_rotate_2d ( v, angle, w ) write ( *, '(2x,5f8.3)') v(1:dim_num), a_test(test), w(1:dim_num) end do return end subroutine vector_rotate_3d_test ( ) !*****************************************************************************80 ! !! vector_rotate_3d_test tests vector_rotate_3d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 real ( kind = rk ), dimension(dim_num) :: axis = (/ & 1.0D+00, 1.0D+00, 1.0D+00 /) real ( kind = rk ) angle real ( kind = rk ), dimension ( test_num ) :: a_test = (/ & 30.0D+00, -45.0D+00, 90.0D+00, 270.0D+00, 30.0D+00 /) real ( kind = rk ) degrees_to_radians integer test real ( kind = rk ) v1(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: v1_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 2.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 3.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, -2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) v2(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_rotate_3d_test' write ( *, '(a)' ) ' vector_rotate_3d() rotates a vector through' write ( *, '(a)' ) ' a given angle around the origin.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Rotations will be about the following axis:' write ( *, '(a)' ) '' write ( *, '(2x,3f8.3)' ) axis(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' V1 Angle V2' write ( *, '(a)' ) & ' ---------------------- ------ ----------------------' write ( *, '(a)' ) '' do test = 1, test_num v1(1:dim_num) = v1_test(1:dim_num,test) angle = degrees_to_radians ( a_test(test) ) call vector_rotate_3d ( v1, axis, angle, v2 ) write ( *, '(2x,7f8.3)') v1(1:dim_num), a_test(test), v2(1:dim_num) end do ! ! Test using an axis that is not of unit length! ! axis(1:3) = (/ 0.0D+00, 0.0D+00, 2.0D+00 /) write ( *, '(a)' ) '' write ( *, '(a)' ) ' Rotations will be about the following axis:' write ( *, '(a)' ) '' write ( *, '(2x,3f8.3)' ) axis(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' V1 Angle V2' write ( *, '(a)' ) & ' ---------------------- ------ ----------------------' write ( *, '(a)' ) '' v1(1:3) = (/ 1.0D+00, 1.0D+00, 1.0D+00 /) angle = 90.0D+00 angle = degrees_to_radians ( angle ) call vector_rotate_3d ( v1, axis, angle, v2 ) write ( *, '(2x,7f8.3)') v1(1:dim_num), 90.0, v2(1:dim_num) return end subroutine vector_rotate_base_2d_test ( ) !*****************************************************************************80 ! !! vector_rotate_base_2d_test tests vector_rotate_base_2d; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 2 integer, parameter :: test_num = 4 real ( kind = rk ) angle real ( kind = rk ), dimension ( test_num ) :: a_test = (/ & 30.0D+00, -45.0D+00, 270.0D+00, 20.0D+00 /) real ( kind = rk ) degrees_to_radians real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num) :: pb = (/ 10.0D+00, 5.0D+00 /) real ( kind = rk ), dimension ( dim_num, test_num ) :: p_test = reshape ( (/ & 11.0D+00, 5.0D+00, & 10.0D+00, 7.0D+00, & 11.0D+00, 6.0D+00, & 10.0D+00, 5.0D+00 /), (/ dim_num, test_num /) ) integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_rotate_base_2d_test' write ( *, '(a)' ) ' vector_rotate_base_2d() rotates a vector (X1,Y1)' write ( *, '(a)' ) ' through an angle around a base point (XB,YB).' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 PB Angle P2' write ( *, '(a)' ) '' do test = 1, test_num p1 = p_test(1:dim_num,test) angle = degrees_to_radians ( a_test(test) ) call vector_rotate_base_2d ( p1, pb, angle, p2 ) write ( *, '(2x,7f8.3)' ) & p1(1:dim_num), pb(1:dim_num), a_test(test), p2(1:dim_num) end do return end subroutine vector_separation_nd_test ( ) !*****************************************************************************80 ! !! vector_separation_nd_test tests vector_separation_nd; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 5 real ( kind = rk ) radians_to_degrees integer test1 integer test2 real ( kind = rk ) theta real ( kind = rk ) theta_deg real ( kind = rk ) v1(dim_num) real ( kind = rk ) v2(dim_num) real ( kind = rk ), dimension ( dim_num, test_num ) :: v_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 3.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & -3.0D+00, 2.0D+00, -1.0D+00, & -2.0D+00, -4.0D+00, -6.0D+00 /), (/ dim_num, test_num /) ) write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_separation_nd_test' write ( *, '(a)' ) ' vector_separation_nd() computes the separation angle' write ( *, '(a)' ) ' between two vectors.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' -----Vector 1----- -----Vector 2----- ' // & ' Radians Degrees' write ( *, '(a)' ) '' do test1 = 1, test_num v1(1:dim_num) = v_test(1:dim_num,test1) do test2 = test1 + 1, test_num v2(1:dim_num) = v_test(1:dim_num,test2) call vector_separation_nd ( dim_num, v1, v2, theta ) theta_deg = radians_to_degrees ( theta ) write ( *, '(2x,6f8.3,f8.3,5x,f8.3)') & v1(1:dim_num), v2(1:dim_num), theta, theta_deg end do end do return end subroutine voxels_dist_l1_nd_test ( ) !*****************************************************************************80 ! !! VOXELS_DIST_L1_ND_TEST tests VOXELS_DIST_L1_ND. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer dist integer, dimension(dim_num) :: p1 = (/ 1, 1, 5 /) integer, dimension(dim_num) :: p2 = (/ 9, 4, 4 /) integer voxels_dist_l1_nd write ( *, '(a)' ) '' write ( *, '(a)' ) 'VOXELS_DIST_L1_ND_TEST' write ( *, '(a)' ) ' VOXELS_DIST_L1_ND prints the voxels on a line in ND.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1:' write ( *, '(4x,3i8)' ) p1(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' P2:' write ( *, '(4x,3i8)' ) p2(1:dim_num) dist = voxels_dist_l1_nd ( dim_num, p1, p2 ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' L1 distance = ', dist return end subroutine voxels_line_3d_test ( ) !*****************************************************************************80 ! !! VOXELS_LINE_3D_TEST tests VOXELS_LINE_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2005 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer n integer, allocatable, dimension ( :, : ) :: v integer voxels_dist_l1_nd integer, dimension ( dim_num ) :: p1 = (/ 1, 1, 5 /) integer, dimension ( dim_num ) :: p2 = (/ 9, 4, 4 /) write ( *, '(a)' ) '' write ( *, '(a)' ) 'VOXELS_LINE_3D_TEST' write ( *, '(a)' ) ' VOXELS_LINE_3D computes the voxels on a line in 3D' write ( *, '(a)' ) ' starting at the first voxel, and heading towards' write ( *, '(a)' ) ' the second one.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Starting voxel:' write ( *, '(4x,3i8)' ) p1(1:dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) ' "Heading" voxel:' write ( *, '(4x,3i8)' ) p2(1:dim_num) n = voxels_dist_l1_nd ( dim_num, p1, p2 ) + 1 write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of voxels we will compute is ', n allocate ( v(1:3,n) ) call voxels_line_3d ( p1, p2, n, v ) call i4mat_transpose_print ( 3, n, v, ' The voxels:' ) deallocate ( v ) return end subroutine voxels_region_3d_test ( ) !*****************************************************************************80 ! !! VOXELS_REGION_3D_TEST tests VOXELS_REGION_3D. ! ! Discussion: ! ! The test region is 8 by 9 by 1 voxels: ! ! 123456789 ! 1 ......... ! 2 ...11.1.. ! 3 ..11111.. ! 4 ...11.1.. ! 5 ......1.. ! 6 .11..11.. ! 7 ..1...... ! 8 .......1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: list_max = 100 integer, parameter :: dim_num = 3 integer, parameter :: nx = 8 integer, parameter :: ny = 9 integer, parameter :: nz = 1 integer i integer ishow(nx,ny,nz) integer j integer k integer l integer list(list_max) integer list_num integer nelements integer region integer region_num write ( *, '(a)' ) '' write ( *, '(a)' ) 'VOXELS_REGION_3D_TEST' write ( *, '(a)' ) ' VOXELS_REGION_3D groups voxels into regions.' ishow(1:nx,1:ny,1:nz) = 0 ishow(2,4,1) = 1 ishow(2,5,1) = 1 ishow(2,7,1) = 1 ishow(3,3,1) = 1 ishow(3,4,1) = 1 ishow(3,5,1) = 1 ishow(3,6,1) = 1 ishow(3,7,1) = 1 ishow(4,4,1) = 1 ishow(4,5,1) = 1 ishow(4,7,1) = 1 ishow(5,7,1) = 1 ishow(6,2,1) = 1 ishow(6,3,1) = 1 ishow(6,6,1) = 1 ishow(6,7,1) = 1 ishow(7,3,1) = 1 ishow(8,8,1) = 1 call voxels_region_3d ( list_max, nx, ny, nz, ishow, list_num, list, & region_num ) write ( *, '(a)' ) '' write ( *, '(a,i8)' ) ' Number of regions found = ', region_num write ( *, '(a)' ) '' write ( *, '(a)' ) ' The nonzero ISHOW array elements are:' write ( *, '(a)' ) '' do i = 1, nx do j = 1, ny do k = 1, nz l = ishow(i,j,k) if ( l /= 0 ) then write ( *, '(2x,4i8)' ) i, j, k, l end if end do end do end do if ( list_max < list_num ) then write ( *, '(a)' ) '' write ( *, '(a)' ) ' The stack-based list of regions is unusable.' else write ( *, '(a)' ) '' write ( *, '(a)' ) ' The stack-based list of regions is:' write ( *, '(a)' ) '' region = region_num do while ( 0 < list_num ) nelements = list(list_num) list_num = list_num - 1 write ( *, '(a)' ) '' write ( *, '(a,i8,a,i8,a)' ) & ' Region ', region, ' includes ', nelements, ' voxels:' write ( *, '(a)' ) '' do l = 1, nelements k = list(list_num) list_num = list_num - 1 j = list(list_num) list_num = list_num - 1 i = list(list_num) list_num = list_num - 1 write ( *, '(2x,3i8)' ) i, j, k end do region = region - 1 end do end if return end subroutine voxels_step_3d_test ( ) !*****************************************************************************80 ! !! VOXELS_STEP_3D_TEST tests VOXELS_STEP_3D. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer i integer inc integer jnc integer knc integer v1(dim_num) integer v2(dim_num) integer v3(dim_num) write ( *, '(a)' ) '' write ( *, '(a)' ) 'VOXELS_STEP_3D_TEST' write ( *, '(a)' ) ' VOXELS_STEP_3D steps along a line from' write ( *, '(a)' ) ' one voxel to another.' v1(1:dim_num) = (/ 1, 1, 5 /) v2(1:dim_num) = v1(1:dim_num) inc = 7 jnc = 3 knc = -1 write ( *, '(a)' ) '' write ( *, '(2x,i4,2x,3i8)' ) 0, v2(1:dim_num) do i = 1, 10 call voxels_step_3d ( v1, v2, inc, jnc, knc, v3 ) write ( *, '(2x,i4,2x,3i8)' ) i, v3(1:dim_num) v2(1:dim_num) = v3(1:dim_num) end do write ( *, '(a)' ) '' write ( *, '(a)' ) ' Now, as a check, reverse direction and return.' write ( *, '(a)' ) '' v1(1:dim_num) = v2(1:dim_num) inc = -inc jnc = -jnc knc = -knc v2(1:dim_num) = v1(1:dim_num) write ( *, '(2x,i4,2x,3i8)' ) 0, v2(1:dim_num) do i = 1, 10 call voxels_step_3d ( v1, v2, inc, jnc, knc, v3 ) write ( *, '(2x,i4,2x,3i8)' ) i, v3(1:dim_num) v2(1:dim_num) = v3(1:dim_num) end do return end subroutine wedge01_volume_test ( ) !*****************************************************************************80 ! !! WEDGE01_VOLUME_TEST tests WEDGE01_VOLUME. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 2018 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) volume real ( kind = rk ) wedge01_volume write ( *, '(a)' ) '' write ( *, '(a)' ) 'WEDGE01_VOLUME_TEST' write ( *, '(a)' ) ' WEDGE01_VOLUME returns the volume of the unit wedge.' volume = wedge01_volume ( ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Unit wedge volume = ', volume return end subroutine xy_to_polar_test ( ) !*****************************************************************************80 ! !! xy_to_polar_test tests xy_to_polar. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 January 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) r real ( kind = rk ) r8_uniform_ab real ( kind = rk ) t integer test integer, parameter :: test_num = 10 real ( kind = rk ) xy1(2) real ( kind = rk ) xy2(2) write ( *, '(a)' ) '' write ( *, '(a)' ) 'xy_to_polar_test' write ( *, '(a)' ) ' xy_to_polar() converts (X,Y) to (R,Theta).' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' X Y ===> R T => X Y' write ( *, '(a)' ) '' b = -1.0D+00 c = +1.0D+00 do test = 1, test_num xy1(1) = r8_uniform_ab ( b, c ) xy1(2) = r8_uniform_ab ( b, c ) call xy_to_polar ( xy1, r, t ) call polar_to_xy ( r, t, xy2 ) write ( *, '(2x,6f12.5)' ) xy1(1:2), r, t, xy2(1:2) end do return end subroutine xyz_to_radec_test ( ) !*****************************************************************************80 ! !! xyz_to_radec_test tests xyz_to_radec. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2006 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: dim_num = 3 integer, parameter :: test_num = 6 real ( kind = rk ) dec real ( kind = rk ) p1(dim_num) real ( kind = rk ) p2(dim_num) real ( kind = rk ), dimension(dim_num,test_num) :: p_test = reshape ( (/ & 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00, & 5.0D+00, -2.0D+00, -1.0D+00, & -2.0D+00, -2.0D+00, -2.0D+00 /), (/ dim_num, test_num /) ) real ( kind = rk ) ra integer test write ( *, '(a)' ) '' write ( *, '(a)' ) 'xyz_to_radec_test' write ( *, '(a)' ) ' xyz_to_radec() converts XYZ to RADEC coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' P1 RA DEC P2' write ( *, '(a)' ) '' do test = 1, test_num p1(1:dim_num) = p_test(1:dim_num,test) call xyz_to_radec ( p1, ra, dec ) call radec_to_xyz ( ra, dec, p2 ) write ( *, '(2x,8f7.3)' ) p1(1:dim_num), ra, dec, p2(1:dim_num) end do return end subroutine xyz_to_rtp_test ( ) !*****************************************************************************80 ! !! xyz_to_rtp_test tests xyz_to_rtp. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 July 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) :: a = -2.0D+00 real ( kind = rk ) :: b = 3.0D+00 real ( kind = rk ) phi real ( kind = rk ) r integer test integer, parameter :: test_num = 5 real ( kind = rk ) theta real ( kind = rk ) xyz1(3) real ( kind = rk ) xyz2(3) write ( *, '(a)' ) '' write ( *, '(a)' ) 'xyz_to_rtp_test' write ( *, '(a)' ) ' xyz_to_rtp() converts (R,Theta,Phi) to XYZ coordinates.' write ( *, '(a)' ) '' write ( *, '(a)' ) & ' X1 Y1 Z1 R THETA PHI X2 Y2 Z2' write ( *, '(a)' ) '' do test = 1, test_num call r8vec_uniform_ab ( 3, a, b, xyz1 ) call xyz_to_rtp ( xyz1, r, theta, phi ) call rtp_to_xyz ( r, theta, phi, xyz2 ) write ( *, '(2x,9f7.3)' ) xyz1(1:3), r, theta, phi, xyz2(1:3) end do return end