C INTERNATIONAL AVS CENTER C (This disclaimer must remain at the top of all files) C C WARRANTY DISCLAIMER C C This module and the files associated with it are distributed free of charge. C It is placed in the public domain and permission is granted for anyone to use, C duplicate, modify, and redistribute it unless otherwise noted. Some modules C may be copyrighted. You agree to abide by the conditions also included in C the AVS Licensing Agreement, version 1.0, located in the main module C directory located at the International AVS Center ftp site and to include C the AVS Licensing Agreement when you distribute any files downloaded from C that site. C C The International AVS Center, MCNC, the AVS Consortium and the individual C submitting the module and files associated with said module provide absolutely C NO WARRANTY OF ANY KIND with respect to this software. The entire risk as to C the quality and performance of this software is with the user. IN NO EVENT C WILL The International AVS Center, MCNC, the AVS Consortium and the individual C submitting the module and files associated with said module BE LIABLE TO C ANYONE FOR ANY DAMAGES ARISING FROM THE USE OF THIS SOFTWARE, INCLUDING, C WITHOUT LIMITATION, DAMAGES RESULTING FROM LOST DATA OR LOST PROFITS, OR ANY C SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES. C C This AVS module and associated files are public domain software unless C otherwise noted. Permission is hereby granted to do whatever you like with C it, subject to the conditions that may exist in copyrighted materials. Should C you wish to make a contribution toward the improvement, modification, or C general performance of this module, please send us your comments: why you C liked or disliked it, how you use it, and most important, how it helps your C work. We will receive your comments at avs@ncsc.org. C C Please send AVS module bug reports to avs@ncsc.org. C C "@(#)csg.f 1.1 Stardent 90/03/23" C Copyright (c) 1989 by C Stardent Computer Inc. C All Rights Reserved C C This software comprises unpublished confidential information of C Stardent Computer Inc. and may not be used, copied or made C available to anyone, except in accordance with the license C under which it is furnished. C C This file is under sccs control at Stardent in: C /sccs/avs/user_modules/data/read_dyna3d/src/s.csg.f C C c *--------------------------------------------------------* c * * c * **** create_shrink_geom **** * c * * c * referenced by: cobj.f * c * * c * csg.f * c *--------------------------------------------------------* subroutine create_shrink_geom (avs_obj1, avs_obj2, num_nodes, & num_node_data, nodes, num_1d_elems, & elem_1d, num_2d_elems, elem_2d, & num_3d_elems, elem_3d, num_states, & node_data, contour_flag, state, & vert_colors, verts, shrink_fact, & material_table, group_flag, group_list) include 'read_dyna3d.h' include '/usr/avs/include/geom.inc' integer num_nodes, num_node_data, num_1d_elems, num_2d_elems, 1 num_3d_elems, contour_flag, elem_1d(num_1d_elems, n1d), 2 elem_2d(num_2d_elems, n2d), elem_3d(num_3d_elems, n3d), avs_obj1, 3 avs_obj2, num_states, shrink_fact, group_flag, 4 group_list(max_groups),state real nodes(3, num_nodes), node_data(num_nodes, num_node_data, & num_states), model_extent(6), def_fact, vert_colors(3, & 10000), verts(3, 10000),material_table(3, max_material_types) integer elem, node, i, node1, node2, num_verts, & elem_topo(4, 6), j, 2 index, data_index(20), anode, material_code logical in_group, elem_in_group real pverts(3, 10000), red, green, blue, pcolors(3, 10000), 1 scale, comp_def_scale, shrink_val, x, y, z, ecx, ecy, ecz data elem_topo/1, 2, 6, 5, 2, 3, 7, 6, 5, 6, 7, 8, 4, 1, 5, 8, 1 3, 4, 8, 7, 4, 3, 2, 1/ data data_index/DISP, VELOCITY, ACC, 17*0/ c ************** c *** body *** c ************** shrink_val = float(shrink_fact) / 100.0 write (0, *) 'csg: shrink val:', shrink_val avs_obj1 = geom_create_obj (GEOM_POLYTRI, GEOM_NULL) c call geom_add_vertices (avs_obj, verts, num_nodes, GEOM_COPY_DATA) red = 1.0 green = 0.8 blue = 0.0 num_verts = 0 if (contour_flag .ne. 1) then do i = 1, num_nodes vert_colors(1, i) = red vert_colors(1, i) = green vert_colors(1, i) = blue end do end if do elem = 1, num_1d_elems node1 = elem_1d(elem, 1) node2 = elem_1d(elem, 2) num_verts = num_verts + 1 pverts(1, num_verts) = verts(1, node1) pverts(2, num_verts) = verts(2, node1) pverts(3, num_verts) = verts(3, node1) pcolors(1, num_verts) = vert_colors(1, node1) pcolors(2, num_verts) = vert_colors(2, node1) pcolors(3, num_verts) = vert_colors(3, node1) num_verts = num_verts + 1 pverts(1, num_verts) = verts(1, node2) pverts(2, num_verts) = verts(2, node2) pverts(3, num_verts) = verts(3, node2) pcolors(1, num_verts) = vert_colors(1, node2) pcolors(2, num_verts) = vert_colors(2, node2) pcolors(3, num_verts) = vert_colors(3, node2) end do call geom_add_disjoint_line (avs_obj1, pverts, pcolors, num_verts, & GEOM_COPY_DATA) c create object for 2d and 3d elements. avs_obj2 = geom_create_obj (GEOM_POLYHEDRON, GEOM_NULL) c add 2d elements. do elem = 1, num_2d_elems num_verts = 0 x = 0.0 y = 0.0 z = 0.0 node = elem_2d(elem, 1) material_code = elem_2d(elem, 5) in_group = elem_in_group(group_flag, group_list, material_code) do i = 1, 4 node = elem_2d(elem, i) anode = abs(node) if (anode .gt. 0) then num_verts = num_verts + 1 x = x + verts(1, anode) y = y + verts(2, anode) z = z + verts(3, anode) end if end do ecx = x / float(num_verts) ecy = y / float(num_verts) ecz = z / float(num_verts) do i = 1, 4 node = elem_2d(elem, i) x = verts(1, node) y = verts(2, node) z = verts(3, node) pverts(1, i) = (ecx - x) * shrink_val + x pverts(2, i) = (ecy - y) * shrink_val + y pverts(3, i) = (ecz - z) * shrink_val + z if (contour_flag .ne. 1) then pcolors(1, i) = material_table(1, material_code) pcolors(2, i) = material_table(2, material_code) pcolors(3, i) = material_table(3, material_code) else if (in_group) then pcolors(1, i) = vert_colors(1, node) pcolors(2, i) = vert_colors(2, node) pcolors(3, i) = vert_colors(3, node) else pcolors(1, i) = material_table(1, material_code) pcolors(2, i) = material_table(2, material_code) pcolors(3, i) = material_table(3, material_code) end if end do call geom_add_disjoint_polygon (avs_obj2, pverts, & GEOM_NULL, pcolors, 4, ior(GEOM_NOT_SHARED, & GEOM_CONVEX), GEOM_COPY_DATA) end do c add 3d elements. do elem = 1, num_3d_elems num_verts = 0 x = 0.0 y = 0.0 z = 0.0 node = elem_3d(elem, 1) material_code = elem_3d(elem, 9) in_group = elem_in_group(group_flag, group_list, material_code) do i = 1, 8 node = elem_3d(elem, i) anode = abs(node) if (anode .gt. 0) then num_verts = num_verts + 1 x = x + verts(1, anode) y = y + verts(2, anode) z = z + verts(3, anode) end if end do ecx = x / float(num_verts) ecy = y / float(num_verts) ecz = z / float(num_verts) do i = 1, 6 do j = 1, 4 node = elem_3d(elem, elem_topo(j, i)) x = verts(1, node) y = verts(2, node) z = verts(3, node) pverts(1, j) = (ecx - x) * shrink_val + x pverts(2, j) = (ecy - y) * shrink_val + y pverts(3, j) = (ecz - z) * shrink_val + z if (contour_flag .ne. 1) then pcolors(1, j) = material_table(1, material_code) pcolors(2, j) = material_table(2, material_code) pcolors(3, j) = material_table(3, material_code) else if (in_group) then pcolors(1, j) = vert_colors(1, node) pcolors(2, j) = vert_colors(2, node) pcolors(3, j) = vert_colors(3, node) else pcolors(1, j) = material_table(1, material_code) pcolors(2, j) = material_table(2, material_code) pcolors(3, j) = material_table(3, material_code) end if end do call geom_add_disjoint_polygon (avs_obj2, pverts, & GEOM_NULL, pcolors, 4, ior(GEOM_NOT_SHARED, GEOM_CONVEX), & GEOM_COPY_DATA) end do end do call geom_gen_normals (avs_obj2, 0) call geom_cvt_polyh_to_polytri (avs_obj2, ior(GEOM_SURFACE, & GEOM_WIREFRAME)) return end