program ivread ! !******************************************************************************* ! !! IVREAD is the main program for converting a graphics file. ! ! ! Introduction: ! ! This program was written for the Studio for Creative Inquiry. ! ! This program was originally intended to read an Inventor 3D graphics ! file, and write a corresponding VLA graphics file. ! ! However, it can also try to read files of several different types, ! convert the data internally to line data, and write out files ! of various types. ! ! DXF and Inventor file formats are sophisticated and extensive. ! This program was only designed to work on a few simple cases, and ! may easily be confused by unexpected (though legal) data. ! ! A sketch of the file formats and data structures is included ! in most of the READ and WRITE routines. ! ! The sizes of COR3_MAX, FACE_MAX and LINE_MAX control how much ! information this program can handle. ! ! The "head.25.iv" file has 240146 faces and 119,736 points. ! The "fish.iv" file has about 76000 faces. ! The "brain.iv" file has between 40000 and 75000 faces. ! ! Development: ! ! 18 October 2001: TS_READ and TS_WRITE handle ambientlight by assigning ! it to color of default material #1. IV_READ and IV_WRITE go along ! with this. See if other formats have a single ambient light setting. ! ! Also, trying to get line colors to work. I see that IV_READ doesn't ! even read line colors in...trying to fix that. Then I can read in ! MATERIALS.IV and output MATERIALS.TS. ! ! 16 October 2001: Added draft TS_READ. ! ! 14 October 2001: Added POINT data. ! ! 13 October 2001: Added TS_WRITE. ! ! 05 June 2001: Restored XYZ_WRITE. ! ! 26 May 1999: Added LINE_PRUNE switch, which will try to cut down ! (by about half) the number of superfluous lines created when ! faces are turned into lines by FACE_TO_LINE for VLA_WRITE output. ! ! 22 May 1999: For VLA output files, the program now will automatically ! try to temporarily convert all face information to line information. No ! sophisticated attempt is made to delete superfluous lines (the ! way FACE_TO_EDGE tries.) ! ! The "<<" merge command: ! ! On 20 April 1999, the "<<" command was added, to allow data ! from two or more files to be merged. It works, on a simple example, ! for OBJ files. However, some tuning of OBJ_READ was necessary. ! Similar testing and tuning must be done to the other READ routines ! before they will work with this option. ! On 21 April 1999, the "<<" command worked on a simple example ! using two IV files as input. SMF_READ was also updated for the "<<" ! command, but not tested. ASE_READ, DXF_READ, HRC_READ, ! STLA_READ and VLA_READ may already be OK. ! On 22 April 1999, "<<" command works with ASE_READ, HRC_READ, ! SMF_READ and STLA_READ. ! ! The "MatrixTransform" field in IV_READ/IV_WRITE. ! I'm having problems because I am reading in an IV file that has ! a matrix transform that is not the identity. I just ignore it, ! and so my data is not rotated and scaled, when it should be. ! As a start toward addressing this issue, I have IV_WRITE ! writing out the current transform matrix. One problem with ! Inventor is that the transform matrix can be specified on ! every level, and the actual transform matrix that applies ! has to be deduced from where you are in the tree. ! Right now, all I've done is have IV_READ read the matrix, ! and IV_WRITE write it out. No concatenation is possible right now, ! but my kludgy code will at least apply ONE transformation matrix ! to the data, in IV_READ, anyway... ! ! Adding material/normal/texture binding stubs, because ! A) new SMF format allows it; ! B) Inventor uses it; ! C) SCI wants to do textures eventually. ! ! SMF_READ and SMF_WRITE can now read and write face and vertex colors ! of SMF2.0 files. ! ! Modified: ! ! 26 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Parameter, integer COR3_MAX, the maximum number of points. ! ! Parameter, integer EDGE_MAX, the maximum number of edges. ! ! Parameter, integer FACE_MAX, the maximum number of faces. ! ! Parameter, integer LINE_MAX, the maximum number of line definition items. ! ! Parameter, integer MATERIAL_MAX, the maximum number of materials. ! ! Parameter, integer ORDER_MAX, the maximum number of vertices per face. ! ! Parameter, integer POINT_MAX, the maximum number of points to display. ! ! Parameter, integer TEXTURE_MAX, the maximum number of textures. ! implicit none ! integer, parameter :: cor3_max = 50000 integer, parameter :: edge_max = 100 integer, parameter :: face_max = 50000 integer, parameter :: line_max = 50000 integer, parameter :: material_max = 200 integer, parameter :: order_max = 6 integer, parameter :: point_max = 1000 integer, parameter :: texture_max = 10 ! integer arg_num logical byte_swap real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_new(3,cor3_max) real cor3_normal(3,cor3_max) real cor3_tex_uv(2,cor3_max) logical debug integer edge(4,edge_max) integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_object(face_max) integer face_order(face_max) integer face_rank(face_max) real face_tex_uv(2,face_max) integer face_tier(face_max) character ( len = 100 ) filein_name character ( len = 100 ) fileout_name integer iarg integer iargc integer ierror integer ipxfargc integer line_dex(line_max) integer line_material(line_max) integer line_prune integer list(cor3_max) character ( len = 100 ) material_name(material_max) real material_rgba(4,material_max) character ( len = 100 ) object_name integer point(point_max) integer point_num character ( len = 100 ) texture_name(texture_max) real texture_temp(2,order_max*face_max) real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! call timestamp ( ) ! ! Initialize a few program variables. ! byte_swap = .true. debug = .false. filein_name = ' ' fileout_name = ' ' ierror = 0 line_prune = 1 ! ! Get the number of command line arguments. ! ! Old style: ! arg_num = iargc ( ) ! ! New style: ! ! arg_num = ipxfargc ( ) if ( arg_num >= 2 ) then call command_line ( arg_num, cor3, cor3_material, cor3_max, cor3_normal, & cor3_tex_uv, debug, face, face_area, face_material, face_max, & face_normal, face_order, face_tex_uv, filein_name, fileout_name, & ierror, line_dex, line_material, line_prune, material_name, & material_rgba, line_max, material_max, order_max, texture_max, & object_name, point, point_max, point_num, & texture_name, texture_temp, & transform_matrix, vertex_material, vertex_normal, vertex_tex_uv ) else call interact ( byte_swap, cor3, cor3_material, cor3_max, cor3_new, & cor3_normal, cor3_tex_uv, debug, edge, edge_max, face, face_area, & face_material, face_max, face_normal, face_object, face_order, & face_rank, face_tex_uv, face_tier, filein_name, fileout_name, ierror, & line_dex, line_material, line_max, line_prune, list, material_max, & material_name, material_rgba, order_max, object_name, & point, point_max, point_num, texture_max, texture_name, texture_temp, & transform_matrix, vertex_material, vertex_normal, vertex_tex_uv ) end if if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVREAD - Error exit.' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVREAD - Normal exit.' end if stop end function angle_rad_3d ( x1, y1, z1, x2, y2, z2, x3, y3, z3 ) ! !******************************************************************************* ! !! ANGLE_RAD_3D returns the angle in radians between two vectors in 3D. ! ! ! Discussion: ! ! The routine always computes the SMALLER of the two angles between ! two vectors. Thus, if the vectors make an (exterior) angle of ! 1.5 radians, the (interior) angle of 0.5 radians will be reported. ! ! Formula: ! ! X dot Y = Norm(X) * Norm(Y) * Cos ( Angle(X,Y) ) ! ! Modified: ! ! 19 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, are three points ! which define the vectors. The vectors are: ! ( X1-X2, Y1-Y2, Z1-Z2 ) and ( X3-X2, Y3-Y2, Z3-Z2 ). ! ! Output, real ANGLE_RAD_3D, the angle between the two vectors, in radians. ! This value will always be between 0 and PI. If either vector has ! zero length, then the angle is returned as zero. ! implicit none ! real angle_rad_3d real dot real dot0_3d real enorm0_3d real v1norm real v2norm real x1 real x2 real x3 real y1 real y2 real y3 real z1 real z2 real z3 ! dot = dot0_3d ( x2, y2, y2, x1, y1, z1, x3, y3, z3 ) v1norm = enorm0_3d ( x1, y1, z1, x2, y2, z2 ) v2norm = enorm0_3d ( x3, y3, z3, x2, y2, z2 ) if ( v1norm == 0.0E+00 .or. v2norm == 0.0E+00 ) then angle_rad_3d = 0.0E+00 else angle_rad_3d = acos ( dot / ( v1norm * v2norm ) ) end if return end subroutine ase_read ( bad_num, cor3, cor3_material, cor3_max, cor3_num, & face, face_material, face_max, face_normal, face_num, face_order, & filein_name, ierror, iunit, material_max, material_name, & material_num, material_rgba, order_max, text_num, & vertex_material, vertex_normal ) ! !******************************************************************************* ! !! ASE_READ reads graphics information from an ASE file. ! ! ! Problems: ! ! Processing of the MESH_FACELIST assumes faces are always triangles ! or quadrilaterals. ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Modified: ! ! 09 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input/output, integer COR3_MATERIAL(COR3_MAX), the material index ! of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Output, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Input/output, integer VERTEX_MATERIAL(ORDER_MAX,FACE_MAX), ! vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! implicit none ! logical, parameter :: debug = .false. integer, parameter :: level_max = 10 integer, parameter :: OFFSET = 1 ! integer cor3_max integer face_max integer material_max integer order_max ! integer bad_num real bval character ( len = 4 ) char4 real cor3(3,cor3_max) integer cor3_material(cor3_max) integer cor3_num integer cor3_num_old logical done integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_num_old integer face_order(face_max) character ( len = * ) filein_name real gval integer i integer ierror integer iface integer imat integer ios integer iunit integer ivert integer iword integer k integer lchar integer level character ( len = 256 ) level_name(0:level_max) character ( len = 256 ) line character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer nlbrack integer node integer nrbrack real rgba(4) real rval logical s_eqi real temp integer text_num real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) character ( len = 256 ) word character ( len = 256 ) word1 character ( len = 256 ) wordm1 real x real y real z ! ierror = 0 level = 0 level_name(0) = 'Top' cor3_num_old = cor3_num face_num_old = face_num nlbrack = 0 nrbrack = 0 call tmat_init ( transform_matrix ) word = ' ' wordm1 = ' ' ! ! Read a line of text from the file. ! do read ( iunit, '(a)', iostat = ios ) line if ( ios /= 0 ) then exit end if text_num = text_num + 1 ! ! Replace any control characters (in particular, TAB's) by blanks. ! call s_control_blank ( line ) done = .true. iword = 0 ! ! Read a word from the line. ! 20 continue if ( word /= ' ' ) then wordm1 = word end if call word_next_read ( line, word, done ) ! ! If no more words in this line, read a new line. ! if ( done ) then cycle end if iword = iword + 1 if ( iword == 1 ) then word1 = word end if ! ! In cases where the word is a left bracket, record the level name, ! and for right brackets, do a parity check. ! if ( word == '{' ) then nlbrack = nlbrack + 1 level = nlbrack - nrbrack if ( level < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ASE_READ - Error!' write ( *, '(a)' ) ' Too many right brackets!' level = 0 else if ( level > level_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ASE_READ - Error!' write ( *, '(a)' ) ' Too many left brackets!' level = level_max end if level_name(level) = wordm1 if ( debug ) then do i = 0, level write ( *, '(i6,2x,a)' ) i, trim ( level_name(i) ) end do end if else if ( word == '}' ) then nrbrack = nrbrack + 1 if ( nlbrack < nrbrack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ASE_READ - Fatal error!' write ( *, '(a,i6)' ) ' Extraneous right bracket on line ', text_num write ( *, '(a)' ) trim ( line ) write ( *, '(a)' ) ' Currently processing field:' write ( *, '(a)' ) trim ( level_name(level) ) ierror = 1 return end if end if ! ! *3DSMAX_ASCIIEXPORT 200 ! if ( word1 == '*3DSMAX_ASCIIEXPORT' ) then cycle ! ! *COMMENT ! else if ( word1 == '*COMMENT' ) then cycle ! ! *GEOMOBJECT ! else if ( level_name(level) == '*GEOMOBJECT' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*NODE_NAME' ) then cycle else if ( word == '*NODE_TM' ) then go to 20 else if ( word == '*MESH' ) then go to 20 else if ( word == '*PROP_CASTSHADOW' ) then cycle else if ( word == '*PROP_MOTIONBLUR' ) then cycle else if ( word == '*PROP_RECVSHADOW' ) then cycle else go to 99 end if ! ! *MESH ! else if ( level_name(level) == '*MESH' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*MESH_CFACELIST' ) then go to 20 else if ( word == '*MESH_CVERTLIST' ) then go to 20 else if ( word == '*MESH_FACE_LIST' ) then go to 20 else if ( word == '*MESH_NORMALS' ) then go to 20 else if ( word == '*MESH_NUMCVERTEX' ) then cycle else if ( word == '*MESH_NUMCVFACES' ) then cycle else if ( word == '*MESH_NUMFACES' ) then cycle else if ( word == '*MESH_NUMTVERTEX' ) then cycle else if ( word == '*MESH_NUMTVFACES' ) then cycle else if ( word == '*MESH_NUMVERTEX' ) then cycle else if ( word == '*MESH_TFACELIST' ) then go to 20 else if ( word == '*MESH_TVERTLIST' ) then go to 20 else if ( word == '*MESH_VERTEX_LIST' ) then go to 20 else if ( word == '*TIMEVALUE' ) then cycle else bad_num = bad_num + 1 if ( bad_num < 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ASE_READ - Error!' write ( *, '(a)' ) ' Bad data while reading *MESH.' write ( *, '(a)' ) trim ( line ) end if cycle end if ! ! *MESH_CFACELIST ! else if ( level_name(level) == '*MESH_CFACELIST' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*MESH_CFACE' ) then cycle else go to 99 end if ! ! *MESH_CVERTLIST ! ! Mesh vertex indices must be incremented by COR3_NUM_OLD before ! being stored in the internal array. ! else if ( level_name(level) == '*MESH_CVERTLIST' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*MESH_VERTCOL' ) then call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) i = i + cor3_num_old + OFFSET call word_next_read ( line, word, done ) call s_to_r ( word, rval, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, gval, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, bval, ierror, lchar ) rgba(1) = rval rgba(2) = gval rgba(3) = bval rgba(4) = 1.0E+00 if ( material_num <= 1000 ) then call rcol_find ( 4, 4, material_num, material_rgba, rgba, imat ) else imat = 0 end if if ( imat == 0 ) then material_num = material_num + 1 if ( material_num <= material_max ) then call i_to_s_zero ( material_num, char4 ) material_name(material_num) = 'Material_' // char4 material_rgba(1:4,material_num) = rgba(1:4) imat = material_num else imat = 0 end if end if cor3_material(i) = imat else go to 99 end if ! ! *MESH_FACE_LIST ! ! WARNING: ! The following coding assumes that the faces are always triangles ! or quadrilaterals, but not higher order. ! else if ( level_name(level) == '*MESH_FACE_LIST' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*MESH_FACE' ) then face_num = face_num + 1 if ( face_num <= face_max ) then call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) face_material(face_num) = material_num face_order(face_num) = 0 call word_next_read ( line, word, done ) call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) face(1,face_num) = i + cor3_num_old + OFFSET vertex_material(1,face_num) = material_num face_order(face_num) = face_order(face_num) + 1 call word_next_read ( line, word, done ) call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) face(2,face_num) = i + cor3_num_old + OFFSET vertex_material(2,face_num) = material_num face_order(face_num) = face_order(face_num) + 1 call word_next_read ( line, word, done ) call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) face(3,face_num) = i + cor3_num_old + OFFSET vertex_material(3,face_num) = material_num face_order(face_num) = face_order(face_num) + 1 call word_next_read ( line, word, done ) if ( s_eqi ( word, 'D:' ) ) then call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) face(4,face_num) = i + cor3_num_old + OFFSET vertex_material(4,face_num) = material_num face_order(face_num) = face_order(face_num) + 1 end if end if cycle else go to 99 end if ! ! *MESH_NORMALS ! else if ( level_name(level) == '*MESH_NORMALS' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*MESH_FACENORMAL' ) then call word_next_read ( line, word, done ) call s_to_i ( word, iface, ierror, lchar ) iface = iface + face_num_old + OFFSET ivert = 0 call word_next_read ( line, word, done ) call s_to_r ( word, x, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, y, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, z, ierror, lchar ) face_normal(1,iface) = x face_normal(2,iface) = y face_normal(3,iface) = z cycle else if ( word == '*MESH_VERTEXNORMAL' ) then call word_next_read ( line, word, done ) call s_to_i ( word, node, ierror, lchar ) ivert = ivert + 1 call word_next_read ( line, word, done ) call s_to_r ( word, x, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, y, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, z, ierror, lchar ) vertex_normal(1,ivert,iface) = x vertex_normal(2,ivert,iface) = y vertex_normal(3,ivert,iface) = z cycle else go to 99 end if ! ! *MESH_TFACELIST ! else if ( level_name(level) == '*MESH_TFACELIST' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word1 == '*MESH_TFACE' ) then cycle else go to 99 end if ! ! *MESH_TVERTLIST ! else if ( level_name(level) == '*MESH_TVERTLIST' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word1 == '*MESH_TVERT' ) then cycle else go to 99 end if ! ! *MESH_VERTEX_LIST ! else if ( level_name(level) == '*MESH_VERTEX_LIST' ) then if ( word == '{' ) then cor3_num_old = cor3_num go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word1 == '*MESH_VERTEX' ) then call word_next_read ( line, word, done ) call s_to_i ( word, i, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, x, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, y, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, z, ierror, lchar ) i = i + cor3_num_old + OFFSET cor3_num = max ( cor3_num, i ) if ( i <= cor3_max ) then cor3(1,i) = transform_matrix(1,1) * x + transform_matrix(1,2) * y & + transform_matrix(3,1) * z + transform_matrix(4,1) cor3(2,i) = transform_matrix(2,1) * x + transform_matrix(2,2) * y & + transform_matrix(2,3) * z + transform_matrix(2,4) cor3(3,i) = transform_matrix(3,1) * x + transform_matrix(3,2) * y & + transform_matrix(3,3) * z + transform_matrix(3,4) end if cycle else go to 99 end if ! ! *NODE_TM ! ! Each node should start out with a default transformation matrix. ! else if ( level_name(level) == '*NODE_TM' ) then if ( word == '{' ) then call tmat_init ( transform_matrix ) go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*INHERIT_POS' ) then cycle else if ( word == '*INHERIT_ROT' ) then cycle else if ( word == '*INHERIT_SCL' ) then cycle else if ( word == '*NODE_NAME' ) then cycle else if ( word == '*TM_POS' ) then cycle else if ( word == '*TM_ROTANGLE' ) then cycle else if ( word == '*TM_ROTAXIS' ) then cycle else if ( word == '*TM_ROW0' ) then call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(1,1) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(2,1) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(3,1) = temp cycle else if ( word == '*TM_ROW1' ) then call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(1,2) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(2,2) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(3,2) = temp cycle else if ( word == '*TM_ROW2' ) then call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(1,3) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(2,3) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(3,3) = temp cycle else if ( word == '*TM_ROW3' ) then call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(1,4) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(2,4) = temp call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) transform_matrix(3,4) = temp cycle else if ( word == '*TM_SCALE' ) then cycle else if ( word == '*TM_SCALEAXIS' ) then cycle else if ( word == '*TM_SCALEAXISANG' ) then cycle else go to 99 end if ! ! *SCENE ! else if ( level_name(level) == '*SCENE' ) then if ( word == '{' ) then go to 20 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '*SCENE_AMBIENT_STATIC' ) then cycle else if ( word == '*SCENE_BACKGROUND_STATIC' ) then cycle else if ( word == '*SCENE_FILENAME' ) then cycle else if ( word == '*SCENE_FIRSTFRAME' ) then cycle else if ( word == '*SCENE_FRAMESPEED' ) then cycle else if ( word == '*SCENE_LASTFRAME' ) then cycle else if ( word == '*SCENE_TICKSPERFRAME' ) then cycle else go to 99 end if end if go to 20 ! ! Bad data ! 99 continue bad_num = bad_num + 1 if ( bad_num <= 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ASE_READ - Warning!' write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( line ) end if end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'ASE_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine ase_write ( cor3, cor3_max, cor3_num, face, face_max, & face_normal, face_num, face_order, filein_name, fileout_name, & iunit, order_max, vertex_normal ) ! !******************************************************************************* ! !! ASE_WRITE writes graphics information to an ASE file. ! ! ! Modified: ! ! 22 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer, parameter :: OFFSET = 1 ! integer cor3_max integer face_max integer order_max ! character ( len = 10 ) chrtmp real cor3(3,cor3_max) integer cor3_num integer face(order_max,face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name integer i integer i1 integer i2 integer i3 integer i4 integer iface integer iunit integer ivert integer j integer text_num character ( len = 200 ) text real vertex_normal(3,order_max,face_max) real x real y real z ! text_num = 0 ! ! Write the header. ! write ( iunit, '(a)' ) '*3DSMAX_ASCIIEXPORT 200' write ( iunit, '(a)' ) '*COMMENT "' // trim ( fileout_name ) // & ', created by IVREAD."' write ( iunit, '(a)' ) '*COMMENT "Original data in ' // trim ( filein_name ) & // '."' text_num = text_num + 3 ! ! Write the scene block. ! write ( iunit, '(a)' ) '*SCENE {' write ( iunit, '(a)' ) ' *SCENE_FILENAME ""' write ( iunit, '(a)' ) ' *SCENE_FIRSTFRAME 0' write ( iunit, '(a)' ) ' *SCENE_LASTFRAME 100' write ( iunit, '(a)' ) ' *SCENE_FRAMESPEED 30' write ( iunit, '(a)' ) ' *SCENE_TICKSPERFRAME 160' write ( iunit, '(a)' ) ' *SCENE_BACKGROUND_STATIC 0.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *SCENE_AMBIENT_STATIC 0.0431 0.0431 0.0431' write ( iunit, '(a)' ) '}' text_num = text_num + 9 ! ! Begin the big geometry block. ! write ( iunit, '(a)' ) '*GEOMOBJECT {' write ( iunit, '(a)' ) ' *NODE_NAME "Object01"' text_num = text_num + 2 ! ! Sub block NODE_TM: ! write ( iunit, '(a)' ) ' *NODE_TM {' write ( iunit, '(a)' ) ' *NODE_NAME "Object01"' write ( iunit, '(a)' ) ' *INHERIT_POS 0 0 0' write ( iunit, '(a)' ) ' *INHERIT_ROT 0 0 0' write ( iunit, '(a)' ) ' *INHERIT_SCL 0 0 0' write ( iunit, '(a)' ) ' *TM_ROW0 1.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *TM_ROW1 0.0000 1.0000 0.0000' write ( iunit, '(a)' ) ' *TM_ROW2 0.0000 0.0000 1.0000' write ( iunit, '(a)' ) ' *TM_ROW3 0.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *TM_POS 0.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *TM_ROTAXIS 0.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *TM_ROTANGLE 0.0000' write ( iunit, '(a)' ) ' *TM_SCALE 1.0000 1.0000 1.0000' write ( iunit, '(a)' ) ' *TM_SCALEAXIS 0.0000 0.0000 0.0000' write ( iunit, '(a)' ) ' *TM_SCALEAXISANG 0.0000' write ( iunit, '(a)' ) ' }' text_num = text_num + 16 ! ! Sub block MESH: ! Items ! write ( iunit, '(a)' ) ' *MESH {' write ( iunit, '(a)' ) ' *TIMEVALUE 0' write ( chrtmp, '(i8)' ) cor3_num write ( iunit, '(a)' ) ' *MESH_NUMVERTEX ' // trim ( chrtmp ) write ( chrtmp, '(i8)' ) face_num write ( iunit, '(a)' ) ' *MESH_NUMFACES ' // trim ( chrtmp ) text_num = text_num + 4 ! ! Sub sub block MESH_VERTEX_LIST ! write ( iunit, '(a)' ) ' *MESH_VERTEX_LIST {' do j = 1, cor3_num write ( text, '(a,i8,3g12.4)' ) '*MESH_VERTEX ', j - OFFSET, cor3(1:3,j) call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) end do write ( iunit, '(a)' ) ' }' text_num = text_num + cor3_num + 2 ! ! Sub sub block MESH_FACE_LIST ! Items MESH_FACE ! ! ??? What do you do when the face has more than 4 vertices? ! write ( iunit, '(a)' ) ' *MESH_FACE_LIST {' do iface = 1, face_num i1 = face(1,iface) - OFFSET i2 = face(2,iface) - OFFSET i3 = face(3,iface) - OFFSET if ( face_order(iface) == 3 ) then write ( text, '(a,i8,a,i8,a,i8,a,i8,a)' ) '*MESH_FACE ', & iface - OFFSET, ': A: ', i1, ' B: ', i2, ' C: ', i3, & ' AB: 1 BC: 1 CA: 1 *MESH_SMOOTHING *MESH_MTLID 1' call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) else if ( face_order(iface) == 4 ) then i4 = face(4,iface) - OFFSET write ( text, '(a,i8,a,i8,a,i8,a,i8,a,i8,a)' ) '*MESH_FACE ', & iface - OFFSET, ': A: ', i1, ' B: ', i2, ' C: ', i3, ' D: ', i4, & ' AB: 1 BC: 1 CD: 1 DA: 1 *MESH_SMOOTHING *MESH_MTLID 1' call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) end if end do write ( iunit, '(a)' ) ' }' text_num = text_num + face_num + 2 ! ! Item MESH_NUMTVERTEX ! write ( iunit, '(a)' ) ' *MESH_NUMTVERTEX 0' text_num = text_num + 1 ! ! Item NUMCVERTEX ! write ( iunit, '(a)' ) ' *MESH_NUMCVERTEX 0' text_num = text_num + 1 ! ! Sub block MESH_NORMALS ! Items MESH_FACENORMAL, MESH_VERTEXNORMAL (repeated) ! write ( iunit, '(a)' ) ' *MESH_NORMALS {' text_num = text_num + 1 do iface = 1, face_num x = face_normal(1,iface) y = face_normal(2,iface) z = face_normal(3,iface) write ( text, '(a,i8,3g12.4)' ) '*MESH_FACENORMAL ', iface-OFFSET, x, y, z call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) text_num = text_num + 1 do ivert = 1, face_order(iface) x = vertex_normal(1,ivert,iface) y = vertex_normal(2,ivert,iface) z = vertex_normal(3,ivert,iface) write ( text, '(a,i8,3g12.4)' ) '*MESH_VERTEXNORMAL ', ivert-OFFSET, & x, y, z call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) text_num = text_num + 1 end do end do write ( iunit, '(a)' ) ' }' text_num = text_num + 1 ! ! Close the MESH object. ! write ( iunit, '(a)' ) ' }' ! ! A few closing parameters. ! write ( iunit, '(a)' ) ' *PROP_MOTIONBLUR 0' write ( iunit, '(a)' ) ' *PROP_CASTSHADOW 1' write ( iunit, '(a)' ) ' *PROP_RECVSHADOW 1' ! ! Close the GEOM object. ! write ( iunit, '(a)' ) '}' text_num = text_num + 5 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'ASE_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine byu_read ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, filein_name, ierror, iunit, order_max ) ! !******************************************************************************* ! !! BYU_READ reads graphics data from a Movie.BYU surface geometry file. ! ! ! Discussion: ! ! A Movie.BYU surface geometry file contains 4 groups of data. ! ! The first group of data is a single line, containing 4 integers, ! each one left justified in 8 columns. The integers are: ! ! PART_NUM, VERTEX_NUM, POLY_NUM, EDGE_NUM, ! ! that is, the number of parts or objects, the number of vertices or nodes, ! the number of polygons or faces, and the number of edges. ! ! The second group of data is a single line, containing 2 integers, ! each one left justified in 8 columnes. The integers are: ! ! POLY1, POLY2, ! ! the starting and ending polygon numbers. Presumably, this means ! that the polygons are labeled POLY1, POLY1+1, ..., POLY2, comprising ! a total of POLY_NUM polygons. ! ! The third group is the X, Y and Z coordinates of all the vertices. ! These may be written using a FORTRAN format of 6E12.5, which ! crams two sets of (X,Y,Z) data onto each line, with each real value ! written in an exponential format with 5 places after the decimal. ! However, it is generally possible to write the XYZ coordinate data ! for each vertex on a separate line. ! ! The fourth group defines the polygons in terms of the vertex indices. ! For each polygon, the vertices that make up the polygon are listed in ! counterclockwise order. The last vertex listed is given with a negative ! sign to indicate the end of the list. All the vertices for all the ! polygons are listed one after the other, using a format that puts ! up to 10 left-justified integers on a line, with each integer occupying ! 8 spaces. ! ! This code will certainly read a BYU file created by BYU_WRITE, but ! it will not handle more general files. In particular, an object ! can have several parts, the coordinate data can be grouped so ! that there are 2 sets of (x,y,z) data per line, and so on. ! ! Example: ! ! 1 8 6 24 ! 1 6 ! 0.00000E+00 0.00000E+00 0.00000E+00 ! 1.00000E+00 0.00000E+00 0.00000E+00 ! 1.00000E+00 2.00000E+00 0.00000E+00 ! 0.00000E+00 2.00000E+00 0.00000E+00 ! 0.00000E+00 0.00000E+00 1.00000E+00 ! 1.00000E+00 0.00000E+00 1.00000E+00 ! 1.00000E+00 2.00000E+00 1.00000E+00 ! 0.00000E+00 2.00000E+00 1.00000E+00 ! 4 3 2 -1 ! 5 6 7 -8 ! 1 5 8 -4 ! 4 8 7 -3 ! 3 7 6 -2 ! 2 6 5 -1 ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer FACE_NUM, the number of faces. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer cor3_num integer cor3_num_new logical done integer edge_num integer face(order_max,face_max) integer face_num integer face_num_new integer face_order(face_max) character ( len = * ) filein_name integer i integer ierror integer iface integer ios integer irow integer iunit integer ival integer ivert integer j integer np1 integer np2 integer part_num character ( len = 256 ) text integer text_num ! ierror = 0 text_num = 0 read ( iunit, *, iostat = ios ) part_num, cor3_num_new, face_num_new, edge_num if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BYU_READ - Fatal error!' write ( *, '(a)' ) ' Unexpected end of file.' return end if text_num = text_num + 1 read ( iunit, *, iostat = ios ) np1, np2 if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BYU_READ - Fatal error!' write ( *, '(a)' ) ' Unexpected end of file.' return end if text_num = text_num + 1 do j = cor3_num + 1, cor3_num + cor3_num_new read ( iunit, *, iostat = ios ) cor3(1:3,j) if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BYU_READ - Fatal error!' write ( *, '(a)' ) ' Unexpected end of file.' return end if text_num = text_num + 1 end do do iface = face_num + 1, face_num + face_num_new read ( iunit, '(a)', iostat = ios ) text text_num = text_num + 1 ivert = 0 done = .true. do call intnex ( text, ival, done ) if ( done ) then exit end if ivert = ivert + 1 face(ivert,iface) = abs ( ival ) + cor3_num if ( ival <= 0 ) then exit end if end do face_order(iface) = ivert end do cor3_num = cor3_num + cor3_num_new face_num = face_num + face_num_new ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'BYU_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine byu_write ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, fileout_name, iunit, order_max ) ! !******************************************************************************* ! !! BYU_WRITE writes out the graphics data as a Movie.BYU surface geometry file. ! ! ! Discussion: ! ! A Movie.BYU surface geometry file contains 4 groups of data. ! ! The first group of data is a single line, containing 4 integers, ! each one left justified in 8 columns. The integers are: ! ! PART_NUM, VERTEX_NUM, POLY_NUM, EDGE_NUM, ! ! that is, the number of parts or objects, the number of vertices or nodes, ! the number of polygons or faces, and the number of edges. ! ! The second group of data is a single line, containing 2 integers, ! each one left justified in 8 columnes. The integers are: ! ! POLY1, POLY2, ! ! the starting and ending polygon numbers. Presumably, this means ! that the polygons are labeled POLY1, POLY1+1, ..., POLY2, comprising ! a total of POLY_NUM polygons. ! ! The third group is the X, Y and Z coordinates of all the vertices. ! These may be written using a FORTRAN format of 6E12.5, which ! crams two sets of (X,Y,Z) data onto each line, with each real value ! written in an exponential format with 5 places after the decimal. ! However, it is generally possible to write the XYZ coordinate data ! for each vertex on a separate line. ! ! The fourth group defines the polygons in terms of the vertex indices. ! For each polygon, the vertices that make up the polygon are listed in ! counterclockwise order. The last vertex listed is given with a negative ! sign to indicate the end of the list. All the vertices for all the ! polygons are listed one after the other, using a format that puts ! up to 10 left-justified integers on a line, with each integer occupying ! 8 spaces. ! ! This code will certainly read a BYU file created by BYU_WRITE, but ! it will not handle more general files. In particular, an object ! can have several parts, the coordinate data can be grouped so ! that there are 2 sets of (x,y,z) data per line, and so on. ! ! Example: ! ! 1 8 6 24 ! 1 6 ! 0.00000E+00 0.00000E+00 0.00000E+00 ! 1.00000E+00 0.00000E+00 0.00000E+00 ! 1.00000E+00 2.00000E+00 0.00000E+00 ! 0.00000E+00 2.00000E+00 0.00000E+00 ! 0.00000E+00 0.00000E+00 1.00000E+00 ! 1.00000E+00 0.00000E+00 1.00000E+00 ! 1.00000E+00 2.00000E+00 1.00000E+00 ! 0.00000E+00 2.00000E+00 1.00000E+00 ! 4 3 2 -1 ! 5 6 7 -8 ! 1 5 8 -4 ! 4 8 7 -3 ! 3 7 6 -2 ! 2 6 5 -1 ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer cor3_num integer edge_num integer face(order_max,face_max) integer face_num integer face_order(face_max) character ( len = * ) fileout_name integer i integer iface integer ihi integer iunit integer ivert integer j integer jp(8) integer part_num integer text_num ! text_num = 0 ! ! EDGE_NUM is the total number of edges. ! edge_num = sum ( face_order(1:face_num) ) part_num = 1 write ( iunit, '(10i8)' ) part_num, cor3_num, face_num, edge_num text_num = text_num + 1 write ( iunit, '(10i8)' ) 1, face_num text_num = text_num + 1 do j = 1, cor3_num write ( iunit, '(1p6e12.5)' ) cor3(1:3,j) text_num = text_num + 1 end do ! ! It takes a little mangling in order to print out all the edges in a ! single list, one face at a time, with the last node in each face ! negative, and written in groups of 8. ! ihi = 0 do iface = 1, face_num do ivert = 1, face_order(iface) ihi = ihi + 1 jp(ihi) = face(ivert,iface) if ( ivert == face_order(iface) ) then jp(ihi) = - jp(ihi) end if if ( ihi == 8 .or. ivert == face_order(iface) ) then write ( iunit, '(10i8)' ) jp(1:ihi) text_num = text_num + 1 ihi = 0 end if end do end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'BYU_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine ch_cap ( c ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end function ch_eqi ( c1, c2 ) ! !******************************************************************************* ! !! CH_EQI is a case insensitive comparison of two characters for equality. ! ! ! Examples: ! ! CH_EQI ( 'A', 'a' ) is .TRUE. ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C1, C2, the characters to compare. ! ! Output, logical CH_EQI, the result of the comparison. ! implicit none ! logical ch_eqi character c1 character c2 character cc1 character cc2 ! cc1 = c1 cc2 = c2 call ch_cap ( cc1 ) call ch_cap ( cc2 ) if ( cc1 == cc2 ) then ch_eqi = .true. else ch_eqi = .false. end if return end function ch_is_control ( c ) ! !******************************************************************************* ! !! CH_IS_CONTROL reports whether a character is a control character or not. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the character to be tested. ! ! Output, logical CH_IS_CONTROL, TRUE if C is a control character, and ! FALSE otherwise. ! implicit none ! character c logical ch_is_control ! if ( ichar ( c ) <= 31 .or. ichar ( c ) >= 127 ) then ch_is_control = .true. else ch_is_control = .false. end if return end subroutine ch_to_digit ( c, digit ) ! !******************************************************************************* ! !! CH_TO_DIGIT returns the integer value of a base 10 digit. ! ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! ... ... ! '9' 9 ! ' ' 0 ! 'X' -1 ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the decimal digit, '0' through '9' or blank ! are legal. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none ! character c integer digit ! if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then digit = ichar ( c ) - 48 else if ( c == ' ' ) then digit = 0 else digit = -1 end if return end subroutine command_line ( arg_num, cor3, cor3_material, cor3_max, cor3_normal, & cor3_tex_uv, debug, face, face_area, face_material, face_max, face_normal, & face_order, face_tex_uv, filein_name, fileout_name, ierror, & line_dex, line_material, line_prune, material_name, material_rgba, & line_max, material_max, order_max, texture_max, & object_name, point, point_max, point_num, texture_name, & texture_temp, transform_matrix, vertex_material, vertex_normal, & vertex_tex_uv ) ! !******************************************************************************* ! !! COMMAND_LINE works with command line parameters. ! ! ! Discussion: ! ! This routine is invoked when the user command is something like ! ! ivread filein_name fileout_name ! ! or ! ! ivread -rn filein_name fileout_name ! ! where "-rn" signals the "reverse normals" option, or ! ! ivread -rf filein_name fileout_name ! ! where "-rf" signals the "reverse faces" option. ! ! Modified: ! ! 26 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ARG_NUM, the number of command-line arguments. ! ! Workspace, real COR3(3,COR3_MAX), the coordinates of points. ! ! Workspace, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Workspace, real COR3_NORMAL(3,COR3_MAX), normals at nodes. ! ! Workspace, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Input, logical DEBUG, debugging switch. ! ! Workspace, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Workspace, real FACE_AREA(FACE_MAX), area of each face. ! ! Workspace, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Workspace, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Workspace, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Workspace, real FACE_TEX_UV(2,FACE_MAX), face texture coordinates. ! ! Workspace, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Workspace, character ( len = * ) FILEOUT_NAME, the name of the ! output file. ! ! Output, integer IERROR, error flag. ! ! Workspace, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated ! by -1. ! ! Workspace, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_PRUNE, pruning option. ! 0, no pruning, draw every line. ! nonzero, prune. Only draw the line from node I to node J if I < J. ! This should cut down on repeated drawing of lines in the common ! case of a face mesh where each line is drawn twice, once with positive ! and once with negative orientation. In other cases, pruning ! may omit some lines that only occur with negative orientation. ! ! Workspace, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Workspace, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and ! A values. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Workspace, character ( len = * ) OBJECT_NAME, object name. ! ! Workspace, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), ! texture names. ! ! Workspace, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Workspace, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Workspace, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Workspace, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! integer arg_num real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical debug integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) real face_tex_uv(2,face_max) character ( len = * ) filein_name character ( len = 10 ) filein_type character ( len = * ) fileout_name character ( len = 10 ) fileout_type integer group_num integer i integer iarg integer icor3 integer ierror integer iface integer ilen integer ivert integer line_dex(line_max) integer line_material(line_max) integer line_num integer line_prune character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) character ( len = * ) object_name integer object_num integer point(point_max) integer point_num logical reverse_faces logical reverse_normals logical s_eqi character ( len = * ) texture_name(texture_max) integer texture_num real texture_temp(2,order_max*face_max) real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! reverse_faces = .false. reverse_normals = .false. ! ! Initialize the graphics data. ! call data_init ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, cor3_tex_uv, face, face_area, face_material, face_max, & face_normal, face_num, face_order, face_tex_uv, group_num, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_name, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, transform_matrix, vertex_material, vertex_normal, & vertex_tex_uv ) ! ! Sort out the command line arguments. ! iarg = 1 ! ! Old style: ! call getarg ( iarg, filein_name ) ! ! New style: ! ! call pxfgetarg ( iarg, filein_name, ilen, ierror ) ! ! if ( ierror /= 0 ) then ! write ( *, '(a)' ) ' ' ! write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' ! write ( *, '(a)' ) ' Could not read command line argument.' ! stop ! end if if ( s_eqi ( filein_name, '-RN' ) ) then reverse_normals = .true. iarg = iarg + 1 ! ! Old style: ! call getarg ( iarg, filein_name ) ! ! New style: ! ! call pxfgetarg ( iarg, filein_name, ilen, ierror ) ! ! if ( ierror /= 0 ) then ! write ( *, '(a)' ) ' ' ! write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' ! write ( *, '(a)' ) ' Could not read command line argument.' ! stop ! end if else if ( s_eqi ( filein_name, '-RF' ) ) then reverse_faces = .true. iarg = iarg + 1 ! ! Old style: ! call getarg ( iarg, filein_name ) ! ! New style: ! ! call pxfgetarg ( iarg, filein_name, ilen, ierror ) ! ! if ( ierror /= 0 ) then ! write ( *, '(a)' ) ' ' ! write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' ! write ( *, '(a)' ) ' Could not read command line argument.' ! stop ! end if end if iarg = iarg + 1 if ( iarg <= arg_num ) then ! ! Old style: ! call getarg ( iarg, fileout_name ) ! ! New style: ! ! call pxfgetarg ( iarg, fileout_name, ilen, ierror ) ! ! if ( ierror /= 0 ) then ! write ( *, '(a)' ) ' ' ! write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' ! write ( *, '(a)' ) ' Could not read command line argument.' ! stop ! end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' write ( *, '(a)' ) ' Not enough arguments on the command line.' write ( *, '(a)' ) ' Could not find the output file name.' return end if ! ! Check the input file name. ! call infile ( filein_name, ierror, filein_type ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' write ( *, '(a)' ) ' Improper input file name.' return end if ! ! Read the input file. ! call data_read ( cor3, cor3_material, cor3_max, & cor3_normal, cor3_num, cor3_tex_uv, debug, face, face_area, & face_material, face_max, face_normal, face_num, face_order, & face_tex_uv, filein_name, filein_type, group_num, ierror, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, vertex_material, vertex_normal, vertex_tex_uv ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' write ( *, '(a)' ) ' The input file could not be opened or read properly.' return end if ! ! Check the output file name. ! call outfile ( filein_name, fileout_name, ierror, fileout_type ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMAND_LINE - Fatal error!' write ( *, '(a)' ) ' Improper output file name.' return end if ! ! -RN: Reverse the normal vectors at points, vertices, and faces. ! if ( reverse_normals ) then cor3_normal(1:3,1:cor3_num) = - cor3_normal(1:3,1:cor3_num) vertex_normal(1:3,1:order_max,1:face_num) = & - vertex_normal(1:3,1:order_max,1:face_num) face_normal(1:3,1:face_num) = - face_normal(1:3,1:face_num) ! ! -RF: Reverse the order of the nodes defining each face. ! else if ( reverse_faces ) then call face_reverse_order ( cor3_max, cor3_normal, cor3_num, face, & face_max, face_normal, face_num, face_order, order_max, & vertex_material, vertex_normal, vertex_tex_uv ) end if ! ! Write the output file. ! call data_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, debug, face, face_material, face_max, face_normal, & face_num, face_order, face_tex_uv, filein_name, fileout_name, & fileout_type, ierror, line_dex, line_material, line_max, line_num, & line_prune, material_name, material_max, material_num, material_rgba, & object_name, order_max, point, point_max, point_num, texture_max, & texture_name, texture_num, vertex_material, vertex_normal, & vertex_tex_uv ) return end subroutine cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) ! !******************************************************************************* ! !! COR3_NORMAL_SET recomputes zero node normal vectors. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, real COR3_NORMAL(3,COR3_MAX), normals at nodes. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3_normal(3,cor3_max) real cor3_temp(cor3_max) integer face(order_max,face_max) real face_area(face_max) integer face_num integer face_order(face_max) integer icor3 integer iface integer ivert integer j real norm real vertex_normal(3,order_max,face_max) ! ! Determine which nodes need to have their normals recomputed. ! do icor3 = 1, cor3_max cor3_temp(icor3) = sum ( cor3_normal(1:3,icor3)**2 ) end do ! ! Add up the vertex normals from all the faces to which the node belongs, ! weighted by area. ! do iface = 1, face_num do ivert = 1, face_order(iface) icor3 = face(ivert,iface) if ( cor3_temp(icor3) == 0.0E+00 ) then do j = 1, 3 cor3_normal(j,icor3) = cor3_normal(j,icor3) & + face_area(iface) * vertex_normal(j,ivert,iface) end do end if end do end do ! ! Renormalize. ! do icor3 = 1, cor3_max norm = sum ( cor3_normal(1:3,icor3)**2 ) if ( norm == 0.0E+00 ) then norm = 3.0E+00 cor3_normal(1:3,icor3) = 1.0E+00 end if norm = sqrt ( norm ) cor3_normal(1:3,icor3) = cor3_normal(1:3,icor3) / norm end do return end subroutine cor3_range ( cor3, cor3_max, cor3_num ) ! !******************************************************************************* ! !! COR3_RANGE computes and prints the coordinate minima and maxima. ! ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! implicit none ! integer cor3_max ! real cor3(3,cor3_max) integer cor3_num logical, parameter :: debug = .false. integer i real xave real xmax real xmin real yave real ymax real ymin real zave real zmax real zmin ! if ( cor3_num <= 0 ) then xave = 0.0E+00 xmax = 0.0E+00 xmin = 0.0E+00 yave = 0.0E+00 ymax = 0.0E+00 ymin = 0.0E+00 zave = 0.0E+00 zmax = 0.0E+00 zmin = 0.0E+00 else xave = cor3(1,1) xmax = cor3(1,1) xmin = cor3(1,1) yave = cor3(2,1) ymax = cor3(2,1) ymin = cor3(2,1) zave = cor3(3,1) zmax = cor3(3,1) zmin = cor3(3,1) do i = 2, cor3_num xave = xave + cor3(1,i) xmin = min ( xmin, cor3(1,i) ) xmax = max ( xmax, cor3(1,i) ) yave = yave + cor3(2,i) ymin = min ( ymin, cor3(2,i) ) ymax = max ( ymax, cor3(2,i) ) zave = zave + cor3(3,i) zmin = min ( zmin, cor3(3,i) ) zmax = max ( zmax, cor3(3,i) ) end do xave = xave / real ( cor3_num ) yave = yave / real ( cor3_num ) zave = zave / real ( cor3_num ) end if if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COR3_RANGE - Nodal coordinate range:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Minimum Average Maximum Range' write ( *, '(a)' ) ' ' write ( *, '(a1,4g12.4)' ) 'X', xmin, xave, xmax, xmax-xmin write ( *, '(a1,4g12.4)' ) 'Y', ymin, yave, ymax, ymax-ymin write ( *, '(a1,4g12.4)' ) 'Z', zmin, zave, zmax, zmax-zmin end if return end subroutine cross0_3d ( x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3 ) ! !******************************************************************************* ! !! CROSS0_3D computes the cross product of (P1-P0) and (P2-P0) in 3D. ! ! ! Discussion: ! ! The vectors are specified with respect to a basis point P0. ! We are computing the normal to the triangle (P0,P1,P2). ! ! Modified: ! ! 19 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X0, Y0, Z0, X1, Y1, Z1, X2, Y2, Z2, the coordinates of ! three points. The basis point is (X0,Y0,Z0). ! ! Output, real X3, Y3, Z3, the cross product (P1-P0) x (P2-P0), or ! (X1-X0,Y1-Y0,Z1-Z0) x (X2-X0,Y2-Y0,Z2-Z0). ! implicit none ! real x0 real x1 real x2 real x3 real y0 real y1 real y2 real y3 real z0 real z1 real z2 real z3 ! x3 = ( y1 - y0 ) * ( z2 - z0 ) - ( z1 - z0 ) * ( y2 - y0 ) y3 = ( z1 - z0 ) * ( x2 - x0 ) - ( x1 - x0 ) * ( z2 - z0 ) z3 = ( x1 - x0 ) * ( y2 - y0 ) - ( y1 - y0 ) * ( x2 - x0 ) return end subroutine data_check ( cor3_max, cor3_num, face_max, face_num, face_order, & line_max, line_num, material_max, material_name, material_num, order_max, & texture_max, texture_num, texture_name ) ! !******************************************************************************* ! !! DATA_CHECK checks the input data, and enforces limits. ! ! ! Modified: ! ! 05 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices per ! face. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer LINE_NUM, the number of line definition items. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Input/output, integer TEXTURE_NUM, the number of textures. ! ! Input/output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), ! texture names. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer texture_max ! character ( len = 4 ) char4 integer cor3_num integer face_num integer face_order(face_max) integer i integer iface integer line_num integer material_num character ( len = * ) material_name(material_max) integer nfix character ( len = * ) texture_name(texture_max) integer texture_num ! if ( cor3_num > cor3_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a)' ) ' The input data requires ', cor3_num, ' points.' write ( *, '(a,i6)' ) ' There was only room for ', cor3_max cor3_num = cor3_max else if ( cor3_num < 0 ) then cor3_num = 0 end if if ( face_num > face_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a)' ) ' The input data requires ', face_num, ' faces.' write ( *, '(a,i6)' ) ' There was only room for ', face_max face_num = face_max else if ( face_num <0 ) then face_num = 0 end if if ( line_num > line_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a)' ) ' The input data requires ', line_num, ' line items.' write ( *, '(a,i6)' ) ' There was only room for ', line_max line_num = line_max else if ( line_num < 0 ) then line_num = 0 end if if ( material_num > material_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a)' ) ' The input data requires ', material_num, ' materials.' write ( *, '(a,i6)' ) ' There was only room for ', material_max material_num = material_max else if ( material_num < 0 ) then material_num = 0 end if nfix = 0 do iface = 1, face_num if ( face_order(iface) < 3 ) then nfix = nfix + 1 face_order(iface) = 0 end if end do if ( nfix > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a)' ) ' Corrected ', nfix, & ' faces using less than 3 vertices per face.' end if nfix = 0 do iface = 1, face_num if ( face_order(iface) > order_max ) then nfix = nfix + 1 face_order(iface) = order_max end if end do if ( nfix > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_CHECK - Warning!' write ( *, '(a,i6,a,i6,a)' ) ' Corrected ', nfix, & ' faces using more than ', order_max, ' vertices per face.' end if do i = 1, material_num if ( material_name(i) == ' ' ) then call i_to_s_zero ( i, char4 ) texture_name(i) = 'Material_' // char4 end if end do do i = 1, texture_num if ( texture_name(i) == ' ' ) then call i_to_s_zero ( i, char4 ) texture_name(i) = 'Texture_' // char4 end if end do return end subroutine data_init ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, cor3_tex_uv, face, face_area, face_material, face_max, & face_normal, face_num, face_order, face_tex_uv, group_num, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_name, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, transform_matrix, vertex_material, vertex_normal, & vertex_tex_uv ) ! !******************************************************************************* ! !! DATA_INIT initializes internal graphics data. ! ! ! Modified: ! ! 14 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Output, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Output, integer COR3_NUM, the number of points. ! ! Output, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Output, integer FACE_NUM, the number of faces. ! ! Output, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Output, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Output, integer LINE_NUM, the number of line data items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Output, integer MATERIAL_NUM, the number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture names. ! ! Output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Output, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! character ( len = 4 ) char4 real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical, parameter :: debug = .false. integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) real face_tex_uv(2,face_max) integer group_num integer i integer iface integer ivert integer j integer line_dex(line_max) integer line_material(line_max) integer line_num character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) character ( len = * ) object_name integer object_num integer, parameter :: OFFSET = 1 integer point(point_max) integer point_num character ( len = * ) texture_name(texture_max) integer texture_num real texture_temp(2,order_max*face_max) real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! cor3(1:3,1:cor3_max) = 0.0E+00 cor3_material(1:cor3_max) = -1 cor3_normal(1:3,1:cor3_max) = 0.0E+00 cor3_num = 0 cor3_tex_uv(1:2,1:cor3_max) = 0.0E+00 face(1:order_max,1:face_max) = -1 + OFFSET face_area(1:face_max) = 0.0E+00 face_material(1:face_max) = 0 + OFFSET face_normal(1:3,1:face_max) = 0.0E+00 face_num = 0 face_order(1:face_max) = 0 face_tex_uv(1:2,1:face_max) = 0.0E+00 group_num = 0 line_dex(1:line_max) = -1 + OFFSET line_material(1:line_max) = 0 + OFFSET line_num = 0 ! ! There is one special default material, which is gray. ! material_name(1) = 'Material_Default' do i = 2, material_max call i_to_s_zero ( i, char4 ) material_name(i) = 'Material_' // char4 end do material_num = 1 material_rgba(1:4,1:material_max) = 0.5E+00 object_name = 'IVCON' object_num = 0 point(1:point_max) = 0 point_num = 0 do i = 1, texture_max call i_to_s_zero ( i, char4 ) texture_name(i) = 'Texture_' // char4 end do texture_num = 0 texture_temp(1:2,1:order_max*face_max) = 0.0E+00 call tmat_init ( transform_matrix ) vertex_material(1:order_max,1:face_max) = 0 + OFFSET vertex_normal(1:3,1:order_max,1:face_max) = 0.0E+00 vertex_tex_uv(1:2,1:order_max,1:face_max) = 0.0E+00 if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_INIT: Initialized graphics data.' end if return end subroutine data_read ( cor3, cor3_material, cor3_max, & cor3_normal, cor3_num, cor3_tex_uv, debug, face, face_area, & face_material, face_max, face_normal, face_num, face_order, & face_tex_uv, filein_name, filein_type, group_num, ierror, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! DATA_READ reads a file into internal graphics data. ! ! ! Modified: ! ! 04 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Output, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Output, integer COR3_NUM, the number of points. ! ! Output, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Output, integer FACE_NUM, the number of faces. ! ! Output, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input/output, character ( len = * ) FILEIN_NAME, the name of the ! input file. ! ! Output, integer IERROR, an error flag. ! ! Output, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), material ! names. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer LINE_NUM, the number of line definition items. ! ! Output, integer MATERIAL_NUM, the number of materials. ! ! Output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture names. ! ! Output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Output, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! integer bad_num real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical debug integer dup_num integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) real face_tex_uv(2,face_max) character ( len = * ) filein_name character ( len = 10 ) filein_type integer group_num integer i integer ierror integer iline integer ios integer, parameter :: iunit = 1 integer j integer line_dex(line_max) integer line_material(line_max) integer line_num character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer ncol_oogl integer nrow_oogl integer ntemp integer object_num integer, parameter :: OFFSET = 1 integer order_num integer point(point_max) integer point_num logical s_eqi integer text_num character ( len = * ) texture_name(texture_max) integer texture_num real texture_temp(2,order_max*face_max) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! ierror = 0 bad_num = 0 dup_num = 0 text_num = 0 ! ! Open the file. ! open ( unit = iunit, file = filein_name, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_READ - Error!' write ( *, '(a)' ) ' The input file "' // trim ( filein_name ) & // '" could not be opened!' ierror = ios return end if ! ! Read the information in the file. ! if ( s_eqi ( filein_type, 'ASE' ) ) then call ase_read ( bad_num, cor3, cor3_material, cor3_max, cor3_num, & face, face_material, face_max, face_normal, face_num, face_order, & filein_name, ierror, iunit, material_max, material_name, & material_num, material_rgba, order_max, text_num, & vertex_material, vertex_normal ) call node_to_vertex_material ( cor3_material, cor3_max, face, & face_max, face_num, face_order, order_max, vertex_material ) face_material(1:face_num) = vertex_material(1,1:face_num) else if ( s_eqi ( filein_type, 'BYU' ) ) then call byu_read ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, filein_name, ierror, iunit, order_max ) else if ( s_eqi ( filein_type, 'DXF' ) ) then call dxf_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, & ierror, iunit, line_dex, line_material, line_max, line_num, & material_num, order_max, text_num ) else if ( s_eqi ( filein_type, 'HRC' ) ) then call hrc_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, & ierror, iunit, line_dex, line_material, line_max, line_num, & material_max, material_name, material_num, material_rgba, & order_max, text_num, texture_max, texture_name, texture_num, & vertex_material, vertex_normal, vertex_tex_uv ) else if ( s_eqi ( filein_type, 'IV' ) ) then call iv_read ( bad_num, cor3, cor3_max, cor3_num, & debug, face, face_max, face_num, face_order, filein_name, ierror, & iunit, line_dex, line_material, line_max, line_num, material_max, & material_num, material_rgba, order_max, text_num, & texture_max, texture_name, texture_num, texture_temp, & vertex_material, vertex_normal, vertex_tex_uv ) else if ( s_eqi ( filein_type, 'OBJ' ) ) then call obj_read ( bad_num, cor3, cor3_max, cor3_num, face, & face_material, face_max, face_num, face_order, filein_name, & group_num, ierror, iunit, line_dex, line_material, line_max, & line_num, material_max, material_name, material_num, material_rgba, & object_num, order_max, text_num, vertex_material, vertex_normal ) else if ( s_eqi ( filein_type, 'OOGL' ) ) then call oogl_read ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & face, face_area, face_material, face_max, face_normal, face_num, & face_order, filein_name, ierror, iunit, material_max, material_name, & material_num, material_rgba, ncol_oogl, nrow_oogl, order_max, text_num, & vertex_material, vertex_normal ) else if ( s_eqi ( filein_type, 'SMF' ) ) then call smf_read ( bad_num, cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, cor3_tex_uv, debug, face, face_material, face_max, & face_normal, face_num, face_order, face_tex_uv, filein_name, & group_num, ierror, iunit, material_max, material_name, material_num, & material_rgba, order_max, text_num, texture_max, texture_num, & texture_name, vertex_material ) else if ( s_eqi ( filein_type, 'STL' ) .or. & s_eqi ( filein_type, 'STLA' ) ) then call stla_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_normal, face_num, face_order, & filein_name, ierror, iunit, material_num, object_num, order_max, & text_num, vertex_material, vertex_normal ) else if ( s_eqi ( filein_type, 'TRI' ) .or. & s_eqi ( filein_type, 'TRIA' ) ) then call tria_read ( cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, ierror, & iunit, order_max, text_num, vertex_material, vertex_normal ) else if ( s_eqi ( filein_type, 'TS' ) .or. & s_eqi ( filein_type, '3S' ) ) then call ts_read ( bad_num, cor3, cor3_max, cor3_num, face, face_material, & face_max, face_num, face_order, filein_name, ierror, iunit, line_dex, & line_material, line_max, line_num, material_max, material_num, & material_rgba, order_max, point, point_max, point_num ) else if ( s_eqi ( filein_type, 'VLA' ) ) then call vla_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, & filein_name, ierror, iunit, line_dex, line_material, line_max, & line_num, material_num, text_num ) else if ( s_eqi ( filein_type, 'WRL' ) ) then call vrml_read ( bad_num, cor3, cor3_material, cor3_max, cor3_num, & face, face_material, face_max, face_num, face_order, filein_name, & ierror, iunit, line_dex, line_material, line_max, line_num, & material_max, material_name, material_num, material_rgba, & order_max, text_num, texture_max, texture_name, texture_num, & vertex_material, vertex_normal, vertex_tex_uv ) else if ( s_eqi ( filein_type, 'XYZ' ) ) then call xyz_read ( cor3, cor3_max, cor3_num, filein_name, ierror, iunit, & line_dex, line_max, line_num, text_num ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_READ - Fatal error!' write ( *, '(a)' ) ' Unrecognized input file type:' write ( *, '(a)' ) trim ( filein_type ) ierror = 1 return end if close ( unit = iunit ) ! ! Make a report on what we saw in the file. ! ntemp = min ( face_num, face_max ) call ivec_max ( ntemp, face_order, order_num ) call data_report ( bad_num, cor3_num, dup_num, face_num, & group_num, line_num, material_num, object_num, order_num, text_num ) ! ! Warn about any errors that occurred during reading. ! if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_READ - Warning!' write ( *, '(a)' ) ' An error occurred reading the input file.' return end if ! ! Check the data. ! ! You MUST wait until after this check before doing other computations, ! since COR3_NUM, and the other variables could be much larger than ! the legal maximums, until corrected by this routine. ! call data_check ( cor3_max, cor3_num, face_max, face_num, face_order, & line_max, line_num, material_max, material_name, material_num, order_max, & texture_max, texture_num, texture_name ) ! ! MATERIALS FIXUPS: ! ! If there are no materials, define one. ! if ( material_num <= 0 ) then material_num = 1 material_name(material_num) = 'Default_Material' material_rgba(1,material_num) = 0.7E+00 material_rgba(2,material_num) = 0.7E+00 material_rgba(3,material_num) = 0.7E+00 material_rgba(4,material_num) = 1.0E+00 end if ! ! If a point hasn't been assigned a material, set it to material 1. ! do i = 1, cor3_num if ( cor3_material(i) < 1 .or. cor3_material(i) > material_num ) then cor3_material(i) = 1 end if end do ! ! If a vertex hasn't been assigned a material, set it to material 1. ! do i = 1, face_num do j = 1, face_order(i) if ( vertex_material(j,i) < 1 .or. & vertex_material(j,i) > material_num ) then vertex_material(j,i) = 1 end if end do end do ! ! If a face hasn't been assigned a material, set it to material 1. ! do i = 1, face_num if ( face_material(i) < 1 .or. face_material(i) > material_num ) then face_material(i) = 1 end if end do ! ! If a line item hasn't been assigned a material, set it to material 1. ! do iline = 1, line_num if ( line_dex(iline) == -1 + OFFSET ) then line_material(iline) = -1 + OFFSET else if ( line_material(iline) < 1 .or. & line_material(iline) > material_num ) then line_material(iline) = material_num end if end do ! ! NULL EDGE DELETION. ! call edge_null_delete ( cor3, cor3_max, face, face_max, face_num, & face_order, order_max, vertex_normal ) ! ! COMPUTE FACE AREAS. ! call face_area_set ( cor3, cor3_max, face, face_area, face_max, & face_num, face_order, order_max ) ! ! NULL FACE DELETION. ! call face_null_delete ( face, face_area, face_material, face_max, & face_num, face_order, order_max, vertex_material, vertex_normal ) ! ! NORMAL VECTOR FIXUPS: ! ! Recompute zero vertex normals from vertex positions. ! call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) ! ! Recompute zero node normals by averaging vertex normals. ! call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) ! ! Recompute zero face normals by averaging vertex normals. ! call face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) ! ! Report the range of the nodal coordinates. ! call cor3_range ( cor3, cor3_max, cor3_num ) return end subroutine data_report ( bad_num, cor3_num, dup_num, & face_num, group_num, line_num, material_num, object_num, order_num, text_num ) ! !******************************************************************************* ! !! DATA_REPORT gives a summary of the contents of the data file. ! ! ! Modified: ! ! 09 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_NUM, the number of materials. ! implicit none ! integer bad_num integer cor3_num integer dup_num integer face_num integer group_num integer line_num integer material_num integer object_num integer order_num integer text_num ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_REPORT - The input file contains:' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Bad data items ', bad_num write ( *, '(a,i6)' ) ' Text lines ', text_num write ( *, '(a,i6)' ) ' Duplicate points ', dup_num write ( *, '(a,i6)' ) ' Faces ', face_num write ( *, '(a,i6)' ) ' Groups ', group_num write ( *, '(a,i6)' ) ' Vertices per face, maximum ', order_num write ( *, '(a,i6)' ) ' Line items ', line_num write ( *, '(a,i6)' ) ' Materials ', material_num write ( *, '(a,i6)' ) ' Points ', cor3_num write ( *, '(a,i6)' ) ' Objects ', object_num return end subroutine data_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, debug, face, face_material, face_max, face_normal, face_num, & face_order, face_tex_uv, filein_name, fileout_name, fileout_type, ierror, & line_dex, line_material, line_max, line_num, line_prune, material_name, & material_max, material_num, material_rgba, object_name, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! DATA_WRITE writes the internal graphics data to a file. ! ! ! Modified: ! ! 14 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of 3D points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input/output, character ( len = * ) FILEOUT_NAME, the name of the ! output file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), material names. ! ! Input, integer MATERIAL_NUM, the number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Input, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture names. ! ! Input, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Input, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Input, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! real cor2(2,cor3_max) integer cor2_max integer cor2_num real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical debug integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) real face_tex_uv(2,face_max) character ( len = * ) filein_name character ( len = * ) fileout_name character ( len = 10 ) fileout_type integer ierror integer ios integer, parameter :: iunit = 1 integer line_dex(line_max) integer line_material(line_max) integer line_num integer line_num_save integer line_prune character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) character ( len = * ) object_name integer point(point_max) integer point_num logical s_eqi character ( len = * ) texture_name(texture_max) integer texture_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! ierror = 0 ! ! Open the file. ! open ( unit = iunit, file = fileout_name, status = 'replace', iostat = ios ) if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Warning!' write ( *, '(a)' ) ' Could not open the output file.' return end if ! ! Write an Autodesk file... ! if ( s_eqi ( fileout_type, 'ASE' ) ) then call ase_write ( cor3, cor3_max, cor3_num, face, face_max, & face_normal, face_num, face_order, filein_name, fileout_name, & iunit, order_max, vertex_normal ) ! ! ...or a BYU file... ! else if ( s_eqi ( fileout_type, 'BYU' ) ) then call byu_write ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, fileout_name, iunit, order_max ) ! ! ...or a DXF file... ! else if ( s_eqi ( fileout_type, 'DXF' ) ) then call dxf_write ( cor3, cor3_max, face, face_max, face_num, & face_order, filein_name, fileout_name, iunit, line_dex, & line_max, line_num, order_max ) ! ! ...or an HRC SoftImage file... ! else if ( s_eqi ( fileout_type, 'HRC' ) ) then call hrc_write ( cor3, cor3_max, cor3_num, face, face_material, & face_max, face_num, face_order, fileout_name, iunit, line_dex, & line_max, line_num, material_max, material_name, material_num, & material_rgba, order_max, texture_max, texture_name, texture_num, & vertex_normal, vertex_tex_uv ) ! ! ...or an IV Inventor file... ! else if ( s_eqi ( fileout_type, 'IV' ) ) then ! if ( face_num == 0 .and. line_num == 0 ) then if ( face_num == 0 ) then call iv_point_write ( cor3, cor3_max, cor3_num, filein_name, & fileout_name, line_dex, line_max, line_num, iunit ) else call iv_write ( cor3, cor3_max, cor3_normal, cor3_num, face, & face_max, face_num, face_order, filein_name, fileout_name, & iunit, line_dex, line_material, line_max, line_num, material_max, & material_num, material_rgba, order_max, texture_max, & texture_num, texture_name, vertex_material, vertex_tex_uv ) end if ! ! ...or a WaveFront OBJ file... ! else if ( s_eqi ( fileout_type, 'OBJ' ) ) then call obj_write ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, filein_name, fileout_name, iunit, line_dex, line_max, & line_num, order_max, vertex_normal ) ! ! ...or a POV file... ! else if ( s_eqi ( fileout_type, 'POV' ) ) then call pov_write ( cor3, cor3_max, face, face_material, face_max, & face_num, face_order, filein_name, fileout_name, iunit, & material_max, material_num, material_rgba, order_max, vertex_normal ) ! ! ...or a PS file... ! else if ( s_eqi ( fileout_type, 'PS' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WATCH OUT!' write ( *, '(a)' ) 'PS_WRITE not ready yet!' cor2_num = cor3_num cor2_max = cor3_max call project_2d ( cor2, cor3, ierror, cor2_max, cor3_max, cor2_num, & cor3_num ) if ( ierror == 0 ) then call ps_write ( cor2, cor2_max, cor2_num, face, face_material, & face_max, face_num, face_order, fileout_name, iunit, line_dex, & line_material, line_max, line_num, material_max, & material_rgba, order_max ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Error!' write ( *, '(a)' ) ' 2D projection canceled.' return end if ! ! ...or an SMF file... ! else if ( s_eqi ( fileout_type, 'SMF' ) ) then call smf_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, face, face_max, face_num, face_order, filein_name, & fileout_name, iunit, material_max, material_rgba, order_max, & texture_max, texture_name, texture_num ) ! ! ...or an ASCII STL file... ! else if ( s_eqi ( fileout_type, 'STL' ) .or. & s_eqi ( fileout_type, 'STLA' ) ) then call stla_write ( cor3, cor3_max, face, face_max, face_normal, & face_num, face_order, filein_name, fileout_name, iunit, order_max ) ! ! ...or a TEC file... ! else if ( s_eqi ( fileout_type, 'TEC' ) ) then call tec_write ( cor3, cor3_material, cor3_max, cor3_num, face, & face_max, face_num, face_order, fileout_name, iunit, material_max, & material_rgba, order_max ) ! ! ...or a TRI/TRIA file... ! else if ( s_eqi ( fileout_type, 'TRI' ) .or. & s_eqi ( fileout_type, 'TRIA' ) ) then call tria_write ( cor3, cor3_max, cor3_normal, face, face_max, face_num, & face_order, fileout_name, iunit, order_max ) ! ! ...or a Mathematics TS file... ! else if ( s_eqi ( fileout_type, 'TS' ) .or. & s_eqi ( fileout_type, '3S' ) ) then call ts_write ( cor3, cor3_max, cor3_num, face, face_material, & face_max, face_num, face_order, filein_name, fileout_name, iunit, & line_dex, line_material, line_max, line_num, material_max, & material_num, material_rgba, order_max, point, point_max, point_num ) ! ! ...or a TXT text file... ! else if ( s_eqi ( fileout_type, 'TXT' ) ) then call txt_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, face, face_material, face_max, face_normal, face_num, & face_order, face_tex_uv, filein_name, fileout_name, iunit, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_name, order_max, point, point_max, & point_num, texture_max, texture_name, texture_num, vertex_material, & vertex_normal, vertex_tex_uv ) ! ! ...or a UCD file... ! else if ( s_eqi ( fileout_type, 'UCD' ) ) then call ucd_write ( cor3, cor3_material, cor3_max, cor3_num, face, & face_material, face_max, face_num, face_order, fileout_name, iunit, & material_max, material_num, material_rgba, order_max ) ! ! ...or a VLA file... ! else if ( s_eqi ( fileout_type, 'VLA' ) ) then line_num_save = line_num if ( face_num > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Note:' write ( *, '(a)' ) ' Face information will be temporarily' write ( *, '(a)' ) ' converted to line information for ' write ( *, '(a)' ) ' the VLA output.' call face_to_line ( debug, face, face_max, face_num, face_order, & line_dex, line_material, line_max, line_num, line_prune, & order_max, vertex_material ) if ( line_num > line_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Note:' write ( *, '(a)' ) ' Some face information was lost.' write ( *, '(a,i6)' ) ' The maximum number of lines is ', line_max write ( *, '(a,i6)' ) ' but we would need at least ', line_num line_num = line_max end if end if call vla_write ( cor3, cor3_max, filein_name, fileout_name, iunit, & line_dex, line_max, line_num ) line_num = line_num_save ! ! ...or a VRML file... ! else if ( s_eqi ( fileout_type, 'WRL' ) ) then call vrml_write ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, filein_name, fileout_name, iunit, line_dex, line_material, & line_max, line_num, material_max, material_num, material_rgba, & order_max, vertex_material ) ! ! ...or an XGL file... ! else if ( s_eqi ( fileout_type, 'XGL' ) ) then call xgl_write ( cor3, cor3_max, cor3_normal, cor3_num, face, & face_material, face_max, face_num, face_order, fileout_name, iunit, & material_max, material_num, material_rgba, order_max ) ! ! ...or an XYZ file... ! else if ( s_eqi ( fileout_type, 'XYZ' ) ) then line_num_save = line_num if ( face_num > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Note:' write ( *, '(a)' ) ' Face information will be temporarily' write ( *, '(a)' ) ' converted to line information for ' write ( *, '(a)' ) ' the XYZ output.' call face_to_line ( debug, face, face_max, face_num, face_order, & line_dex, line_material, line_max, line_num, line_prune, & order_max, vertex_material ) if ( line_num > line_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Note:' write ( *, '(a)' ) ' Some face information was lost.' write ( *, '(a,i6)' ) ' The maximum number of lines is ', line_max write ( *, '(a,i6)' ) ' but we would need at least ', line_num line_num = line_max end if end if call xyz_write ( cor3, cor3_max, cor3_num, filein_name, fileout_name, & iunit, line_dex, line_max, line_num ) line_num = line_num_save ! ! ...or what the hell happened? ! else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DATA_WRITE - Warning!' write ( *, '(a)' ) ' Unrecognized output file type.' ierror = 1 end if ! ! Close the file. ! close ( unit = iunit ) return end function degrees_to_radians ( angle ) ! !******************************************************************************* ! !! DEGREES_TO_RADIANS converts an angle from degrees to radians. ! ! ! Modified: ! ! 10 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ANGLE, an angle in degrees. ! ! Output, real DEGREES_TO_RADIANS, the equivalent angle ! in radians. ! implicit none ! real angle real degrees_to_radians real, parameter :: pi = & 3.14159265358979323846264338327950288419716939937510E+00 ! degrees_to_radians = ( angle / 180.0E+00 ) * pi return end subroutine digit_to_ch ( digit, c ) ! !******************************************************************************* ! !! DIGIT_TO_CH returns the character representation of a decimal digit. ! ! ! Example: ! ! DIGIT C ! ----- --- ! 0 '0' ! 1 '1' ! ... ... ! 9 '9' ! 17 '*' ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIGIT, the digit value between 0 and 9. ! ! Output, character C, the corresponding character, or '*' if DIGIT ! was illegal. ! implicit none ! character c integer digit ! if ( 0 <= digit .and. digit <= 9 ) then c = char ( digit + 48 ) else c = '*' end if return end function dot0_3d ( x0, y0, z0, x1, y1, z1, x2, y2, z2 ) ! !******************************************************************************* ! !! DOT0_3D computes the dot product of (P1-P0) and (P2-P0) in 3D. ! ! ! Modified: ! ! 19 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X0, Y0, Z0, the coordinates of the point P0. ! ! Input, real X1, Y1, Z1, the coordinates of the point P1. ! ! Input, real X2, Y2, Z2, the coordinates of the point P2. ! ! Output, real DOT0_3D, the dot product of (P1-P0) and (P2-P0). ! implicit none ! real dot0_3d real x0 real x1 real x2 real y0 real y1 real y2 real z0 real z1 real z2 ! dot0_3d = ( x1 - x0 ) * ( x2 - x0 ) + ( y1 - y0 ) * ( y2 - y0 ) + & ( z1 - z0 ) * ( z2 - z0 ) return end subroutine dxf_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, & ierror, iunit, line_dex, line_material, line_max, line_num, & material_num, order_max, text_num ) ! !******************************************************************************* ! !! DXF_READ reads graphics information from an AutoCAD DXF file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! 0 ! SECTION ! 2 ! HEADER ! 999 ! diamond.dxf created by IVREAD. ! 999 ! Original data in diamond.obj. ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! TABLES ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! BLOCKS ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! ENTITIES ! 0 ! LINE ! 8 ! 0 ! 10 ! 0.00 (X coordinate of beginning of line.) ! 20 ! 0.00 (Y coordinate of beginning of line.) ! 30 ! 0.00 (Z coordinate of beginning of line.) ! 11 ! 1.32 (X coordinate of end of line.) ! 21 ! 1.73 (Y coordinate of end of line.) ! 31 ! 2.25 (Z coordinate of end of line.) ! 0 ! 3DFACE ! 8 ! Cube ! 10 ! -0.50 (X coordinate of vertex 1) ! 20 ! 0.50 (Y coordinate of vertex 1) ! 30 ! 1.0 (Z coordinate of vertex 1) ! 11 ! 0.50 (X coordinate of vertex 2) ! 21 ! 0.50 (Y coordinate of vertex 2) ! 31 ! 1.0 (Z coordinate of vertex 2) ! 12 ! 0.50 (X coordinate of vertex 3) ! 22 ! 0.50 (Y coordinate of vertex 3) ! 32 ! 0.00 (Z coordinate of vertex 3) ! 0 ! ENDSEC ! 0 ! EOF ! ! Modified: ! ! 02 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BAD_NUM, the number of "bad" lines of input text. ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Output, integer DUP_NUM, the number of duplicate nodes discovered. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, integer LINE_DEX(LINE_MAX), nodes forming a line, ! terminated by -1. ! ! Input/output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line items. ! ! Input/output, integer LINE_NUM, the number of line definition items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer TEXT_NUM, the number of lines of input text. ! implicit none ! integer cor3_max integer face_max integer line_max integer order_max ! integer bad_num real cor3(3,cor3_max) integer cor3_num real cvec(3) integer dup_num integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name integer i integer icode integer icor3 integer ierror integer ios integer iunit integer ival integer ivert integer ixyz integer lchar integer line_dex(line_max) integer line_material(line_max) integer line_num integer material_num character ( len = 256 ) mode integer, parameter :: OFFSET = 1 real rval logical s_eqi integer text_num character ( len = 256 ) text1 character ( len = 256 ) text2 ! ierror = 0 mode = ' ' ! ! Read the next pair of lines. ! TEXT1 is a numeric tag, TEXT2 contains data. ! do read ( iunit, '(a)', iostat = ios ) text1 if ( ios /= 0 ) then exit end if text_num = text_num + 1 call s_to_i ( text1, icode, ierror, lchar ) if ( ierror /= 0 ) then ierror = 1 bad_num = bad_num + 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DXF_READ - Fatal error!' write ( *, '(a)' ) ' Could not interpret line:' write ( *, '(a)' ) trim ( text1 ) return end if ! ! Read the second item, which might be a label or numeric value. ! read ( iunit, '(a)', iostat = ios ) text2 if ( ios /= 0 ) then if ( text1 /= ' ' ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DXF_READ - Warning!' write ( *, '(a)' ) ' The last code was not followed by data:' write ( *, '(a)' ) trim ( text1 ) end if exit end if text_num = text_num + 1 ! ! Codes 0 through 9 are followed by a string. ! ! All we want to do is know when we can expect to be reading ! LINE data and when we can expect to be reading FACE data. ! if ( icode >= 0 .and. icode <= 9 ) then if ( s_eqi ( text2(1:6), '3DFACE' ) ) then mode = '3DFACE' ivert = 0 else if ( s_eqi ( text2(1:4), 'LINE' ) ) then mode = 'LINE' end if ! ! Codes 10 through 59 are followed by a real value. ! ! 10, 11, 12, ... are followed by a line of X data; ! 20, 21, 22, ... are followed by a line of Y data; ! 30, 31, 33, ... are followed by a line of Z data. ! else if ( icode >= 10 .and. icode <= 59 ) then call s_to_r ( text2, rval, ierror, lchar ) if ( ierror /= 0 ) then ierror = 2 rval = 0.0E+00 bad_num = bad_num + 1 if ( bad_num == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DXF_READ - Fatal error!' write ( *, '(a)' ) ' Could not interpret line:' write ( *, '(a)' ) trim ( text2 ) end if end if if ( mode == 'LINE' ) then if ( icode == 10 .and. line_num > 0 ) then line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if end if else if ( mode == '3DFACE' ) then if ( icode == 10 ) then face_num = face_num + 1 face_order(face_num) = 0 face_material(face_num) = material_num end if end if if ( icode >= 10 .and. icode <= 19 ) then ixyz = 1 else if ( icode >= 20 .and. icode <= 29 ) then ixyz = 2 else if ( icode >= 30 .and. icode <= 39 ) then ixyz = 3 end if cvec(ixyz) = rval ! ! Once the entire (X,Y,Z) triple has been read, check to see if the ! values in CVEC already exist in COR3. If so, save space by using ! the index of a previous copy. ! ! Otherwise, add CVEC to COR3, and increment COR3_NUM. ! if ( ixyz == 3 ) then if ( cor3_num <= 1000 ) then call rcol_find ( 3, 3, cor3_num, cor3, cvec, icor3 ) else icor3 = 0 end if if ( icor3 == 0 ) then cor3_num = cor3_num + 1 icor3 = cor3_num if ( cor3_num <= cor3_max ) then cor3(1:3,cor3_num) = cvec(1:3) end if else dup_num = dup_num + 1 end if if ( mode == 'LINE' ) then line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = icor3 - 1 + OFFSET line_material(line_num) = material_num end if else if ( mode == '3DFACE' ) then ivert = ivert + 1 face(ivert,face_num) = icor3 face_order(face_num) = face_order(face_num) + 1 end if end if ! ! Codes 60 through 79 are followed by an integer. ! else if ( icode >= 60 .and. icode <= 79 ) then call s_to_i ( text2, ival, ierror, lchar ) ! ! Codes 140 through 147 are followed by a real. ! else if ( icode >= 140 .and. icode <= 147 ) then call s_to_r ( text2, rval, ierror, lchar ) ! ! Codes 170 through 175 are followed by an integer. ! else if ( icode >= 170 .and. icode <= 175 ) then call s_to_i ( text2, ival, ierror, lchar ) ! ! Codes 210 through 239 are followed by a real. ! else if ( icode >= 210 .and. icode <= 239 ) then call s_to_r ( text2, rval, ierror, lchar ) ! ! Code 999 is followed by a (comment) string. ! else if ( icode == 999 ) then ! ! Codes 1000 through 1009 are followed by a string. ! else if ( icode >= 1000 .and. icode <= 1009 ) then ! ! Codes 1010 through 1059 are followed by a real. ! else if ( icode >= 1010 .and. icode <= 1059 ) then call s_to_r ( text2, rval, ierror, lchar ) ! ! Codes 1060 through 1079 are followed by an integer. ! else if ( icode >= 1060 .and. icode <= 1079 ) then call s_to_i ( text2, ival, ierror, lchar ) ! ! Unrecognized code. ! else bad_num = bad_num + 1 end if end do ! ! END OF INPUT. ! ! Slap a trailing "-1" on the end of the line indices. ! if ( line_num > 0 ) then line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if end if return end subroutine dxf_write ( cor3, cor3_max, face, face_max, face_num, & face_order, filein_name, fileout_name, iunit, line_dex, line_max, & line_num, order_max ) ! !******************************************************************************* ! !! DXF_WRITE writes graphics data to an AutoCAD DXF file. ! ! ! Example: ! ! 0 ! SECTION ! 2 ! HEADER ! 999 ! diamond.dxf created by IVREAD. ! 999 ! Original data in diamond.obj. ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! TABLES ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! BLOCKS ! 0 ! ENDSEC ! 0 ! SECTION ! 2 ! ENTITIES ! 0 ! LINE ! 8 ! 0 ! 10 ! 0.00 (X coordinate of beginning of line.) ! 20 ! 0.00 (Y coordinate of beginning of line.) ! 30 ! 0.00 (Z coordinate of beginning of line.) ! 11 ! 1.32 (X coordinate of end of line.) ! 21 ! 1.73 (Y coordinate of end of line.) ! 31 ! 2.25 (Z coordinate of end of line.) ! 0 ! 3DFACE ! 8 ! Cube ! 10 ! -0.50 (X coordinate of vertex 1) ! 20 ! 0.50 (Y coordinate of vertex 1) ! 30 ! 1.0 (Z coordinate of vertex 1) ! 11 ! 0.50 (X coordinate of vertex 2) ! 21 ! 0.50 (Y coordinate of vertex 2) ! 31 ! 1.0 (Z coordinate of vertex 2) ! 12 ! 0.50 (X coordinate of vertex 3) ! 22 ! 0.50 (Y coordinate of vertex 3) ! 32 ! 0.00 (Z coordinate of vertex 3) ! 0 ! ENDSEC ! 0 ! EOF ! ! ! Modified: ! ! 23 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor3_max integer face_max integer line_max integer order_max ! real cor3(3,cor3_max) integer face(order_max,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name integer i integer icor3 integer iface integer iunit integer ivert integer jcor3 integer line_dex(line_max) integer line_num logical newline integer, parameter :: OFFSET = 1 integer text_num ! text_num = 0 write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'SECTION' write ( iunit, '(i3)' ) 2 write ( iunit, '(a)' ) 'HEADER' write ( iunit, '(i3)' ) 999 write ( iunit, '(a,a)' ) trim ( fileout_name ), ' created by IVREAD.' write ( iunit, '(i3)' ) 999 write ( iunit, '(a,a)' ) 'Original data in ', trim ( filein_name ) // '.' write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'ENDSEC' text_num = text_num + 10 write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'SECTION' write ( iunit, '(i3)' ) 2 write ( iunit, '(a)' ) 'TABLES' write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'ENDSEC' text_num = text_num + 6 write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'SECTION' write ( iunit, '(i3)' ) 2 write ( iunit, '(a)' ) 'BLOCKS' write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'ENDSEC' text_num = text_num + 6 write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'SECTION' write ( iunit, '(i3)' ) 2 write ( iunit, '(a)' ) 'ENTITIES' text_num = text_num + 4 jcor3 = 0 newline = .true. do i = 1, line_num icor3 = line_dex(i) if ( line_dex(i) - OFFSET == -1 ) then newline = .true. ! ! LINE_DEX(I) is the index of a new point that begins or continues a line. ! else ! ! LINE_DEX(I) is the index of a new point that continues a line. ! Output the pair of points that define this segment of the line. ! if ( .not. newline ) then write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'LINE' write ( iunit, '(i3)' ) 8 write ( iunit, '(i3)' ) 0 write ( iunit, '(i3)' ) 10 write ( iunit, '(g12.4)' ) cor3(1,jcor3) write ( iunit, '(i3)' ) 20 write ( iunit, '(g12.4)' ) cor3(2,jcor3) write ( iunit, '(i3)' ) 30 write ( iunit, '(g12.4)' ) cor3(3,jcor3) write ( iunit, '(i3)' ) 11 write ( iunit, '(g12.4)' ) cor3(1,icor3) write ( iunit, '(i3)' ) 21 write ( iunit, '(g12.4)' ) cor3(2,icor3) write ( iunit, '(i3)' ) 31 write ( iunit, '(g12.4)' ) cor3(3,icor3) text_num = text_num + 16 end if ! ! Save the index of this new point, and note that a line is in progress. ! jcor3 = icor3 newline = .false. end if end do ! ! Handle faces. ! This is going to fail bigtime if FACE_ORDER is larger than 9 ! do iface = 1, face_num write ( iunit, '(a)' ) ' 0' write ( iunit, '(a)' ) '3DFACE' write ( iunit, '(a)' ) ' 8' write ( iunit, '(a)' ) ' Cube' text_num = text_num + 4 do ivert = 1, face_order(iface) icor3 = face(ivert,iface) write ( iunit, '(i3)' ) 10 + ivert - 1 write ( iunit, '(g12.4)' ) cor3(1,icor3) write ( iunit, '(i3)' ) 20 + ivert - 1 write ( iunit, '(g12.4)' ) cor3(2,icor3) write ( iunit, '(i3)' ) 30 + ivert - 1 write ( iunit, '(g12.4)' ) cor3(3,icor3) text_num = text_num + 6 end do end do write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'ENDSEC' write ( iunit, '(i3)' ) 0 write ( iunit, '(a)' ) 'EOF' text_num = text_num + 4 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DXF_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine edge_add_nodes ( edge, edge_max, edge_num, iface, n1, n2, ierror ) ! !******************************************************************************* ! !! EDGE_ADD_NODES adds the edge defined by two nodes to the edge list. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input/output, integer EDGE_NUM, the number of edges. ! ! Input, integer IFACE, the face to which the nodes belong. ! ! Input, integer N1, N2, two nodes which form an edge. ! ! Output, integer IERROR, error flag, 0 = no error, nonzero = error. ! implicit none ! integer edge_max ! integer edge(4,edge_max) integer edge_num integer ierror integer iface integer n1 integer n2 ! if ( edge_num < edge_max ) then edge_num = edge_num + 1 edge(1,edge_num) = n1 edge(2,edge_num) = n2 edge(3,edge_num) = iface edge(4,edge_num) = 0 ierror = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EDGE_ADD_NODES - Fatal error!' write ( *, '(a,i6)' ) ' Exceeding EDGE_MAX = ', edge_max ierror = 1 end if return end subroutine edge_bound ( edge, edge_max, edge_num ) ! !******************************************************************************* ! !! EDGE_BOUND reports the edges which are part of the boundary. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer EDGE_NUM, the number of edges. ! implicit none ! integer edge_max ! integer bound_num logical, parameter :: DEBUG = .false. integer edge(4,edge_max) integer edge_num integer iedge ! if ( DEBUG ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Boundary edges:' write ( *, '(a)' ) ' ' end if bound_num = 0 do iedge = 1, edge_num if ( edge(4,iedge) == 0 ) then bound_num = bound_num + 1 if ( DEBUG ) then write ( *, '(2i6)' ) edge(2,iedge), edge(1,iedge) end if end if end do write ( *, '(a,i6,a)' ) 'EDGE_BOUND found ', bound_num, ' boundary edges.' return end subroutine edge_match_face ( edge, edge_max, edge_num, face_list, n, index ) ! !******************************************************************************* ! !! EDGE_MATCH_FACE seeks an edge common to a face and the edge list. ! ! ! Note: ! ! If a common edge is found, then the information in the face node ! list is adjusted so that the first two entries correspond to the ! matching edge in EDGE, but in reverse order. ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer EDGE_NUM, the number of edges. ! ! Input/output, integer FACE_LIST(N), the list of nodes making a face. ! ! Input, integer N, the number of nodes in the face. ! ! Output, integer INDEX, the results of the search. ! 0, there is no edge common to the face and the EDGE array. ! nonzero, edge INDEX is common to the face and the EDGE array. ! implicit none ! integer n integer edge_max ! integer edge(4,edge_max) integer edge_num integer face_list(n) integer iedge integer index integer j integer jp1 integer n1 integer n2 ! index = 0 if ( n <= 0 ) then return end if if ( edge_num <= 0 ) then return end if do j = 1, n if ( j == n ) then jp1 = 1 else jp1 = j + 1 end if n1 = face_list(j) n2 = face_list(jp1) do iedge = 1, edge_num if ( edge(1,iedge) == n2 .and. edge(2,iedge) == n1 ) then call ivec_rotate ( n, 1 - j, face_list ) index = iedge return else if ( edge(1,iedge) == n1 .and. edge(2,iedge) == n2 ) then call ivec_rotate ( n, n - jp1, face_list ) call ivec_reverse ( n, face_list ) index = iedge return end if end do end do return end subroutine edge_match_nodes ( edge, edge_max, edge_num, n1, n2, iedge ) ! !******************************************************************************* ! !! EDGE_MATCH_NODES seeks an edge of the form (N1,N2) or (N2,N1) in EDGE. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer EDGE_NUM, the number of edges. ! ! Input, integer N1, N2, two nodes that form an edge. ! ! Output, integer IEDGE, the results of the search. ! 0, no matching edge was found. ! nonzero, edge IEDGE of the EDGE array matches (N1,N2) or (N2,N1). ! implicit none ! integer edge_max ! integer edge(4,edge_max) integer edge_num integer i integer iedge integer n1 integer n2 ! iedge = 0 do i = 1, edge_num if ( ( n1 == edge(1,i) .and. n2 == edge(2,i) ) .or. & ( n2 == edge(1,i) .and. n1 == edge(2,i) ) ) then iedge = i return end if end do return end subroutine edge_null_delete ( cor3, cor3_max, face, face_max, face_num, & face_order, order_max, vertex_normal ) ! !******************************************************************************* ! !! EDGE_NULL_DELETE deletes face edges with zero length. ! ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) logical, parameter :: debug = .false. real distsq integer edge_num integer edge_num_del integer face(order_max,face_max) integer face_num integer face_order(face_max) integer face_order2 integer face2(100) integer iface integer inode integer ivert integer j integer jnode integer jvert real vertex_normal(3,order_max,face_max) real vertex_normal2(3,100) ! edge_num = 0 edge_num_del = 0 ! ! Consider each face. ! do iface = 1, face_num ! ! Consider each pair of consecutive vertices. ! face_order2 = 0 do ivert = 1, face_order(iface) edge_num = edge_num + 1 jvert = ivert + 1 if ( jvert > face_order(iface) ) then jvert = 1 end if inode = face(ivert,iface) jnode = face(jvert,iface) distsq = sum ( ( cor3(1:3,inode) - cor3(1:3,jnode) )**2 ) if ( distsq /= 0.0E+00 ) then face_order2 = face_order2 + 1 face2(face_order2) = face(ivert,iface) vertex_normal2(1:3,face_order2) = vertex_normal(1:3,ivert,iface) else edge_num_del = edge_num_del + 1 end if end do face_order(iface) = face_order2 do ivert = 1, face_order(iface) face(ivert,iface) = face2(ivert) vertex_normal(1:3,ivert,iface) = vertex_normal2(1:3,ivert) end do end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EDGE_NULL_DELETE:' write ( *, '(a,i6,a)' ) ' There are a total of ', edge_num, ' edges.' write ( *, '(a,i6,a)' ) ' Of these, ', edge_num_del, & ' were of zero length, and deleted.' end if return end function enorm_nd ( n, x ) ! !******************************************************************************* ! !! ENORM_ND computes the Euclidean norm of a vector in ND. ! ! ! Modified: ! ! 27 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of the space. ! ! Input, real X(N), the coordinates of the vector. ! ! Output, real ENORM_ND, the Euclidean norm of the vector. ! implicit none ! integer n ! real enorm_nd integer i real x(n) ! enorm_nd = 0.0E+00 do i = 1, n enorm_nd = enorm_nd + x(i) * x(i) end do enorm_nd = sqrt ( enorm_nd ) return end function enorm0_3d ( x0, y0, z0, x1, y1, z1 ) ! !******************************************************************************* ! !! ENORM0_3D computes the Euclidean norm of (P1-P0) in 3D. ! ! ! Modified: ! ! 16 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X0, Y0, Z0, X1, Y1, Z1, the coordinates of the points ! P0 and P1. ! ! Output, real ENORM0_3D, the Euclidean norm of (P1-P0). ! implicit none ! real enorm0_3d real x0 real x1 real y0 real y1 real z0 real z1 ! enorm0_3d = sqrt ( ( x1 - x0 )**2 + ( y1 - y0 )**2 + ( z1 - z0 )**2 ) return end subroutine face_area_set ( cor3, cor3_max, face, face_area, face_max, & face_num, face_order, order_max ) ! !******************************************************************************* ! !! FACE_AREA_SET computes the area of the faces. ! ! ! Formula: ! ! The area is the sum of the areas of the triangles formed by ! node N with consecutive pairs of nodes. ! ! Reference: ! ! Adrian Bowyer and John Woodwark, ! A Programmer's Geometry, ! Butterworths, 1983. ! ! Modified: ! ! 13 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Output, real FACE_AREA(FACE_MAX), the area of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices allowed per face. ! implicit none ! integer cor3_max integer face_max integer order_max ! real alpha real area_max real area_min real area_tri real base real cor3(3,cor3_max) logical, parameter :: debug = .false. real dot integer face(order_max,face_max) real face_area(face_max) integer face_num integer face_num_del integer face_order(face_max) real height integer i integer i1 integer i2 integer i3 integer iface real tol real x1 real x2 real x3 real y1 real y2 real y3 real z1 real z2 real z3 ! do iface = 1, face_num face_area(iface) = 0.0E+00 do i = 1, face_order(iface) - 2 i1 = face(i,iface) i2 = face(i+1,iface) i3 = face(i+2,iface) x1 = cor3(1,i1) y1 = cor3(2,i1) z1 = cor3(3,i1) x2 = cor3(1,i2) y2 = cor3(2,i2) z2 = cor3(3,i2) x3 = cor3(1,i3) y3 = cor3(2,i3) z3 = cor3(3,i3) ! ! Find the projection of (P3-P1) onto (P2-P1). ! dot = ( x2 - x1 ) * ( x3 - x1 ) + & ( y2 - y1 ) * ( y3 - y1 ) + & ( z2 - z1 ) * ( z3 - z1 ) base = sqrt ( ( x2 - x1 )**2 + ( y2 - y1 )**2 + ( z2 - z1 )**2 ) ! ! The height of the triangle is the length of (P3-P1) after its ! projection onto (P2-P1) has been subtracted. ! if ( base == 0.0E+00 ) then height = 0.0E+00 else alpha = dot / base**2 height = sqrt ( ( x3 - x1 - alpha * ( x2 - x1 ) )**2 + & ( y3 - y1 - alpha * ( y2 - y1 ) )**2 + & ( z3 - z1 - alpha * ( z2 - z1 ) )**2 ) end if area_tri = 0.5E+00 * base * height face_area(iface) = face_area(iface) + area_tri end do end do area_min = minval ( face_area(1:face_num) ) area_max = maxval ( face_area(1:face_num) ) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_AREA_SET:' write ( *, '(a,g14.6)' ) ' Minimum face area is ', area_min write ( *, '(a,g14.6)' ) ' Maximum face area is ', area_max end if tol = area_max / 10000.0E+00 if ( area_min < tol ) then face_num_del = 0 do iface = 1, face_num if ( face_area(iface) < tol ) then face_order(iface) = 0 face_num_del = face_num_del + 1 end if end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_AREA_SET:' write ( *, '(a,i6,a)' ) ' Marked ', face_num_del, & ' tiny faces for deletion.' end if end if return end subroutine face_check ( edge, edge_max, edge_num, face, face_material, & face_max, face_normal, face_num, face_object, face_order, face_rank, & face_tier, object_num, order_max, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! FACE_CHECK checks and analyzes a set of faces. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, or 0 if the edge is used once. ! ! Input, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces ! ! Input, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Output, integer FACE_OBJECT(FACE_NUM), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Output, integer FACE_RANK(FACE_NUM), is an ordered list of faces. ! FACE_RANK(1) is the index of the face in the first tier of the ! first object, followed by second tier faces, and so on until ! object one is complete. Object two follows, and so on. ! ! Output, integer FACE_TIER(FACE_NUM). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer ORDER_MAX, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer EDGE_NUM, the number of edges. ! ! Input, integer FACE_NUM, the number of faces. ! ! Output, integer OBJECT_NUM, the number of objects. ! ! Input, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer edge_max integer order_max integer face_max ! integer edge(4,edge_max) integer edge_num integer face(order_max,face_max) integer face_fixed integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_object(face_max) integer face_order(face_max) integer face_rank(face_max) integer face_tier(face_max) integer i integer ierror integer j integer object_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! ! Organize the faces into layered objects. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_CHECK:' write ( *, '(a)' ) ' Determine edge-connected objects.' call object_build ( face, face_num, face_object, face_order, face_rank, & face_tier, object_num, order_max ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of objects = ', object_num if ( face_num <= 20 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Object, Tier' write ( *, '(a)' ) ' ' do i = 1, face_num write ( *, '(3i6)' ) i, face_object(i), face_tier(i) end do end if if ( face_num <= 20 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Preferred order:' write ( *, '(a)' ) ' Order, Face' write ( *, '(a)' ) ' ' do i = 1, face_num write ( *, '(i6,i6)' ) i, face_rank(i) end do end if ! ! Reorder the faces by object and tier. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Reorder the faces.' call face_sort ( face, face_material, face_max, face_normal, face_num, & face_object, face_order, face_tier, order_max, & vertex_material, vertex_normal ) if ( face_num <= 20 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Label, Object, Tier' write ( *, '(a)' ) ' ' do i = 1, face_num write ( *, '(4i6)' ) i, face_rank(i), face_object(i), face_tier(i) end do end if ! ! Construct the edge list. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Construct the edge list.' write ( *, '(a)' ) '(While doing so, check for edges used more' write ( *, '(a)' ) 'than twice.)' call face_to_edge ( edge, edge_max, edge_num, face, face_num, & face_order, ierror, order_max ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_CHECK - Fatal error!' write ( *, '(a)' ) ' FACE_TO_EDGE failed.' return end if if ( face_num <= 20 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Edge, Node1, Node2, Face1, Face2, Tier, Object' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I, node1(i), node2(i), face1(i), face2(i)' write ( *, '(a)' ) ' ' do i = 1, edge_num write ( *, '(10i3)' ) i, edge(1:4,i) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Order, Nodes' write ( *, '(a)' ) ' ' do i = 1, face_num write ( *, '(10i3)' ) i, face_order(i), & ( face(j,i), j = 1, face_order(i) ) end do end if ! ! Now force faces to have a consistent orientation. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Force faces to consistent orientation.' call face_flip ( edge, edge_max, edge_num, face, face_fixed, face_num, & face_order, order_max ) if ( face_num <= 20 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Order, Nodes' write ( *, '(a)' ) ' ' do i = 1, face_num write ( *, '(10i3)' ) i, face_order(i), & ( face(j,i), j = 1, face_order(i) ) end do end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'List boundary edges.' call edge_bound ( edge, edge_max, edge_num ) return end subroutine face_flip ( edge, edge_max, edge_num, face, face_fixed, face_num, & face_order, order_max ) ! !******************************************************************************* ! !! FACE_FLIP flips faces to achieve a consistent orientation. ! ! ! Modified: ! ! 09 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces. ! ! Input, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer ORDER_MAX, the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer FACE_FIXED, the number of bad faces that were found. ! ! Input, integer EDGE_NUM, the number of edges. ! ! Input, integer FACE_NUM, the number of faces. ! implicit none ! integer edge_max integer order_max integer face_num ! integer edge(4,edge_max) integer edge_num integer f1 integer f2 integer face(order_max,face_num) integer face_fixed integer face_order(face_num) integer iedge integer j integer jp1 integer m1 integer m2 integer n1 integer n2 ! face_fixed = 0 do iedge = 1, edge_num n1 = edge(1,iedge) n2 = edge(2,iedge) f1 = edge(3,iedge) f2 = edge(4,iedge) ! ! For now, just whine unless (N1,N2) is positive in F1 and negative in F2. ! if ( f1 /= 0 ) then do j = 1, face_order(f1) if ( j < face_order(f1) ) then jp1 = j + 1 else jp1 = j end if m1 = face(j,f1) m2 = face(jp1,f1) if ( m1 == n1 .and. m2 == n2 ) then exit else if ( m1 == n2 .and. m2 == n1 ) then face_fixed = face_fixed + 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_FLIP - Warning!' write ( *, '(a)' ) ' Bad orientation:' write ( *, '(a,i6)' ) ' Face ', f1 write ( *, '(a,i6)' ) ' Side ', j exit end if end do end if if ( f2 /= 0 ) then do j = 1, face_order(f2) if ( j < face_order(f2) ) then jp1 = j + 1 else jp1 = j end if m1 = face(j,f2) m2 = face(jp1,f2) if ( m1 == n2 .and. m2 == n1 ) then exit else if ( m1 == n1 .and. m2 == n2 ) then face_fixed = face_fixed + 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_FLIP - Warning!' write ( *, '(a)' ) 'Bad orientation:' write ( *, '(a,i6)' ) ' Face ', f2 write ( *, '(a,i6)' ) ' Side ', j exit end if end do end if end do write ( *, '(a,i6,a)' ) 'FACE_FLIP found ', face_fixed, & ' badly oriented faces.' return end subroutine face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) ! !******************************************************************************* ! !! FACE_NORMAL_AVE sets face normals as average of face vertex normals. ! ! ! Modified: ! ! 19 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer face_max integer order_max ! logical, parameter :: debug = .false. real face_normal(3,face_max) integer face_num integer face_order(face_max) integer iface integer ivert integer nfix real norm real vertex_normal(3,order_max,face_max) ! if ( face_num <= 0 ) then return end if nfix = 0 do iface = 1, face_num norm = sqrt ( sum ( face_normal(1:3,iface)**2 ) ) if ( norm == 0.0E+00 ) then nfix = nfix + 1 face_normal(1:3,iface) = 0.0E+00 do ivert = 1, face_order(iface) face_normal(1:3,iface) = face_normal(1:3,iface) + & vertex_normal(1:3,ivert,iface) end do norm = sqrt ( sum ( face_normal(1:3,iface)**2 ) ) if ( norm == 0.0E+00 ) then face_normal(1:3,iface) = 1.0E+00 / sqrt ( 3.0E+00 ) else face_normal(1:3,iface) = face_normal(1:3,iface) / norm end if end if end do if ( nfix > 0 ) then if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'FACE_NORMAL_AVE: Recomputed ', nfix, & ' face normals by averaging face vertex normals.' end if end if return end subroutine face_null_delete ( face, face_area, face_material, face_max, & face_num, face_order, order_max, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! FACE_NULL_DELETE deletes faces of order less than 3. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normal vectors ! at vertices. ! implicit none ! integer face_max integer order_max ! logical, parameter :: debug = .false. integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) integer face_num integer face_num2 integer face_order(face_max) integer iface integer ivert integer j integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! ! Drop faces of order 0, 1 or 2. ! face_num2 = 0 do iface = 1, face_num if ( face_order(iface) >= 3 ) then face_num2 = face_num2 + 1 if ( face_num2 /= iface ) then face_area(face_num2) = face_area(iface) face_material(face_num2) = face_material(iface) face_order(face_num2) = face_order(iface) face(1:order_max,face_num2) = face(1:order_max,iface) vertex_material(1:order_max,face_num2) = & vertex_material(1:order_max,iface) vertex_normal(1:3,1:order_max,face_num2) = & vertex_normal(1:3,1:order_max,iface) end if end if end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_NULL_DELETE' write ( *, '(a,i6,a)' ) ' There are a total of ', face_num, ' faces.' write ( *, '(a,i6,a)' ) ' Of these, ', face_num2, ' passed the order test.' end if face_num = face_num2 return end subroutine face_print ( cor3, cor3_max, face, face_index, face_material, & face_max, face_normal, face_num, face_order, order_max, vertex_material, & vertex_normal ) ! !******************************************************************************* ! !! FACE_PRINT prints out information about a face. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer IFACE, the face about which information is desired. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer face(order_max,face_max) integer face_index integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(order_max) integer i integer ivert integer j integer k integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! if ( face_index < 1 .or. face_index > face_num ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_PRINT - Error!' write ( *, '(a,i6)' ) ' Face indices must be between 1 and ', face_num write ( *, '(a,i6)' ) ' But your requested value was ', face_index return end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_PRINT' write ( *, '(a,i6)' ) ' Information about face ', face_index write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The number of vertices is ', face_order(face_index) write ( *, '(a,i6)' ) ' Face material is ', face_material(face_index) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Vertex list:' write ( *, '(a)' ) ' Vertex #, Node #, Material #, X, Y, Z' write ( *, '(a)' ) ' ' do ivert = 1, face_order(face_index) j = face(ivert,face_index) k = vertex_material(ivert,face_index) write ( *, '(3i8,3f10.4)' ) ivert, j, k, cor3(1,j), cor3(2,j), cor3(3,j) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Face normal vector:' write ( *, '(a)' ) ' ' write ( *, '(3f10.4)' ) face_normal(1:3,face_index) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Vertex face normals:' write ( *, '(a)' ) ' ' do ivert = 1, face_order(face_index) write ( *, '(i8,3f10.4)' ) ivert, vertex_normal(1:3,ivert,face_index) end do return end subroutine face_reverse_order ( cor3_max, cor3_normal, cor3_num, face, & face_max, face_normal, face_num, face_order, order_max, & vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! FACE_REVERSE_ORDER reverses the order of the nodes in each face. ! ! ! Discussion: ! ! Reversing the order of the nodes requires that the normal vectors ! be reversed as well, so this routine will automatically reverse ! the normals associated with nodes, vertices and faces. ! ! Modified: ! ! 25 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_MAX, the maximum number of nodes. ! ! Input/output, real COR3_NORMAL(3,COR3_MAX), normals at nodes. ! ! Input, integer COR3_NUM, the number of nodes. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), normals at faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! ! Input/output, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex textures. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3_normal(3,cor3_max) integer cor3_num integer face(order_max,face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) integer i integer iface integer itemp integer ivert integer j integer m real temp integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) ! do iface = 1, face_num m = face_order(iface) do ivert = 1, m/2 call i_swap ( face(ivert,iface), face(m+1-ivert,iface) ) call i_swap ( vertex_material(ivert,iface), & vertex_material(m+1-ivert,iface) ) do j = 1, 3 call r_swap ( vertex_normal(j,ivert,iface), & vertex_normal(j,m+1-ivert,iface) ) end do do j = 1, 2 call r_swap ( vertex_tex_uv(j,ivert,iface), & vertex_tex_uv(j,m+1-ivert,iface) ) end do end do end do cor3_normal(1:3,1:cor3_num) = - cor3_normal(1:3,1:cor3_num) face_normal(1:3,1:face_num) = - face_normal(1:3,1:face_num) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_REVERSE_ORDER' write ( *, '(a)' ) ' Each list of nodes defining a face' write ( *, '(a)' ) ' has been reversed; related information,' write ( *, '(a)' ) ' including normal vectors, was also updated.' return end subroutine face_sort ( face, face_material, face_max, face_normal, face_num, & face_object, face_order, face_tier, order_max, vertex_material, & vertex_normal ) ! !******************************************************************************* ! !! FACE_SORT renumbers the faces in order of object and tier. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, integer FACE_OBJECT(FACE_NUM), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input/output, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Input/output, integer FACE_TIER(FACE_NUM). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer ORDER_MAX, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer order_max integer face_max ! integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_object(face_max) integer face_order(face_max) integer face_tier(face_max) integer i integer iface integer indx integer isgn integer itemp integer ivert integer jface real temp integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! iface = 0 jface = 0 indx = 0 isgn = 0 do call sort_heap_external ( face_num, indx, iface, jface, isgn ) ! ! Interchange faces IFACE and JFACE. ! if ( indx > 0 ) then do i = 1, order_max call i_swap ( face(i,iface), face(i,jface) ) end do call i_swap ( face_material(iface), face_material(jface) ) call i_swap ( face_object(iface), face_object(jface) ) call i_swap ( face_order(iface), face_order(jface) ) call i_swap ( face_tier(iface), face_tier(jface) ) do i = 1, 3 call r_swap ( face_normal(i,iface), face_normal(i,jface) ) end do do ivert = 1, order_max call i_swap ( vertex_material(ivert,iface), vertex_material(ivert,jface) ) end do do i = 1, 3 do ivert = 1, order_max call r_swap ( vertex_normal(i,ivert,iface), vertex_normal(i,ivert,jface) ) end do end do ! ! Compare faces IFACE and JFACE. ! else if ( indx < 0 ) then if ( ( face_object(iface) < face_object(jface) ) .or. & ( face_object(iface) == face_object(jface) .and. & face_tier(iface) < face_tier(jface) ) ) then isgn = -1 else isgn = +1 end if else if ( indx == 0 ) then exit end if end do return end subroutine face_subset ( cor3, cor3_max, cor3_num, face, face_material, & face_max, face_normal, face_num, face_order, ierror, line_num, list, & order_max, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! FACE_SUBSET selects a subset of the current faces as the new object. ! ! ! Warning: ! ! The original graphic object is overwritten by the new one. ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Workspace, integer LIST(COR3_MAX), contains the indices of the points ! to be copied from the old graphics object to the new one. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer LINE_NUM, the number of lines. ! This routine resets LINE_NUM to zero, since we will be dropping ! as many points as possible. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer cor3_num integer cor3_num2 integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) integer i integer ierror integer iface integer iface1 integer iface2 integer inc integer ivert integer j integer k integer line_num integer list(cor3_max) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! ierror = 0 line_num = 0 ! ! Get the first and last faces to save, IFACE1 and IFACE2. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter lowest face number to save,' write ( *, '(a,i6)' ) 'between 1 and ', face_num read ( *, * ) iface1 if ( iface1 < 1 .or. iface1 > face_num ) then write ( *, '(a)' ) 'Illegal choice!' ierror = 1 return end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter highest face number to save' write ( *, '(a,i6,a,i6)' ) 'between ', iface1, ' and ', face_num read ( *, * ) iface2 if ( iface2 < iface1 .or. iface2 > face_num ) then write ( *, '(a)' ) 'Illegal choice!' ierror = 1 return end if inc = iface1 - 1 ! ! "Slide" the data for the saved faces down the face arrays. ! do iface = 1, iface2 + 1 - iface1 face_material(iface) = face_material(iface+inc) face_order(iface) = face_order(iface+inc) do ivert = 1, order_max face(ivert,iface) = face(ivert,iface+inc) vertex_material(ivert,iface) = vertex_material(ivert,iface+inc) vertex_normal(1:3,ivert,iface) = vertex_normal(1:3,ivert,iface+inc) end do face_normal(1:3,iface) = face_normal(1:3,iface+inc) end do ! ! Now reset the number of faces. ! face_num = iface2 + 1 - iface1 ! ! Now, for each point I, set LIST(I) = J if point I is the J-th ! point we are going to save, and 0 otherwise. Then J will be ! the new label of point I. ! list(1:cor3_num) = 0 cor3_num2 = 0 do iface = 1, face_num do ivert = 1, face_order(iface) j = face(ivert,iface) if ( list(j) == 0 ) then cor3_num2 = cor3_num2 + 1 list(j) = cor3_num2 end if end do end do ! ! Now make the nonzero list entries rise in order, so that ! we can compress the COR3 data in a minute. ! cor3_num2 = 0 do i = 1, cor3_num if ( list(i) /= 0 ) then cor3_num2 = cor3_num2 + 1 list(i) = cor3_num2 end if end do ! ! Relabel the FACE array with the new node indices. ! do iface = 1, face_num do ivert = 1, face_order(iface) j = face(ivert,iface) face(ivert,iface) = list(j) end do end do ! ! Rebuild the COR3 array by sliding data down. ! do i = 1, cor3_num k = list(i) if ( k /= 0 ) then cor3(1:3,k) = cor3(1:3,i) end if end do cor3_num = cor3_num2 return end subroutine face_to_edge ( edge, edge_max, edge_num, face, face_num, & face_order, ierror, order_max ) ! !******************************************************************************* ! !! FACE_TO_EDGE converts face data to edge data. ! ! ! Discussion: ! ! The computation will fail if: ! ! More than two faces claim to share an edge (Node1,Node2). ! Not enough storage is set aside by EDGE_MAX. ! ! If is expected that the edge (Node1,Node2) in Face1 is traversed in ! the opposite sense, as (Node2,Node1), in Face2. If this is not the ! case, then some faces may need to be reoriented, but that will not ! affect the computation. ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer EDGE(4,EDGE_MAX), contains edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, or 0 if the edge is used once. ! ! Input, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces. ! ! Input, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Output, integer IERROR, error flag: 0 = no error, nonzero = error. ! ! Input, integer EDGE_MAX, the maximum number of edges. ! ! Input, integer ORDER_MAX, the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer EDGE_NUM, the number of edges. ! ! Input, integer FACE_NUM, the number of faces. ! implicit none ! integer edge_max integer order_max integer face_num ! integer edge(4,edge_max) integer edge_num integer face(order_max,face_num) integer face_order(face_num) integer i integer iedge integer ierror integer iface integer index integer j integer jp1 integer n1 integer n2 ! ! Initialize. ! ierror = 0 edge(1:4,1:edge_max) = 0 edge_num = 0 ! ! Consider face #I. ! do iface = 1, face_num ! ! Seek an edge of face IFACE that already occurs in the edge list. ! If there is one, then slide and reverse the entries in FACE(*,IFACE) ! so that that edge occurs first, and in the opposite sense to its ! occurrence in the edge list. ! call edge_match_face ( edge, edge_max, edge_num, face(1,iface), & face_order(iface), index ) ! ! Now, in any case, we know that the first two nodes in FACE(*,IFACE) ! are the negative of an existing edge, or no nodes in FACE(*,IFACE) ! occur in any existing edge. ! do j = 1, face_order(iface) n1 = face(j,iface) if ( j == face_order(iface) ) then jp1 = 1 else jp1 = j + 1 end if n2 = face(jp1,iface) call edge_match_nodes ( edge, edge_max, edge_num, n1, n2, iedge ) if ( iedge == 0 ) then call edge_add_nodes ( edge, edge_max, edge_num, iface, n1, n2, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_EDGE - Fatal error!' write ( *, '(a)' ) ' EDGE_ADD_NODES failed.' ierror = 1 return end if else if ( edge(4,iedge) == 0 ) then edge(4,iedge) = iface else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_EDGE - Fatal error!' write ( *, '(a,2i6)' ) ' Edge between nodes ', edge(1,iedge), edge(2,iedge) write ( *, '(a)' ) ' is used at least 3 times, by faces:' write ( *, '(3i6)' ) edge(3,iedge), edge(4,iedge), iface ierror = 1 return end if end do end do return end subroutine face_to_line ( debug, face, face_max, face_num, face_order, & line_dex, line_material, line_max, line_num, line_prune, & order_max, vertex_material ) ! !******************************************************************************* ! !! FACE_TO_LINE converts face information to line information. ! ! ! Discussion: ! ! In some cases, the graphic information represented by polygonal faces ! must be converted to a representation based solely on line segments. ! This is particularly true if a VLA file is being written. ! ! Modified: ! ! 29 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input/output, integer LINE_DEX(LINE_MAX), nodes forming a line, ! terminated by -1. ! ! Output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_PRUNE, pruning option. ! 0, no pruning, draw every line. ! nonzero, prune. Only draw the line from node I to node J if I < J. ! This should cut down on repeated drawing of lines in the common ! case of a face mesh where each line is drawn twice, once with positive ! and once with negative orientation. In other cases, pruning ! may omit some lines that only occur with negative orientation. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer LINE_NUM, the number of line data items. ! ! Input, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer face_max integer line_max integer order_max ! logical debug integer face(order_max,face_max) integer face_num integer face_order(face_max) integer i integer icor3 integer iface integer ivert integer jcor3 integer jvert integer line_dex(line_max) integer line_material(line_max) integer line_num integer line_prune integer, parameter :: OFFSET = 1 integer vertex_material(order_max,face_max) ! ! Case 1: ! No line pruning. ! if ( line_prune == 0 ) then do iface = 1, face_num do ivert = 1, face_order(iface) icor3 = face(ivert,iface) line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = icor3 line_material(line_num) = vertex_material(ivert,iface) end if end do ivert = 1 icor3 = face(ivert,iface) line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = icor3 line_material(line_num) = vertex_material(ivert,iface) end if line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if end do ! ! Case 2: ! Simple-minded line pruning. ! Only draw line (I,J) if I < J. ! else do iface = 1, face_num do ivert = 1, face_order(iface) icor3 = face(ivert,iface) if ( ivert < face_order(iface) ) then jvert = ivert + 1 else jvert = 1 end if jcor3 = face(jvert,iface) if ( icor3 < jcor3 ) then if ( line_num + 3 <= line_max ) then line_num = line_num + 1 line_dex(line_num) = icor3 line_material(line_num) = vertex_material(ivert,iface) line_num = line_num + 1 line_dex(line_num) = jcor3 line_material(line_num) = vertex_material(jvert,iface) line_num = line_num + 1 line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if end if end do end do end if if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_LINE:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I, LINE_DEX(I), LINE_MATERIAL(I)' write ( *, '(a)' ) ' ' do i = 1, line_num write ( *, '(i6,2x,i6,2x,i6)' ) i, line_dex(i), line_material(i) end do end if return end subroutine face_touch ( face, face_order, order_max, face_num, iface, jface, & touch ) ! !******************************************************************************* ! !! FACE_TOUCH reports whether two polygonal faces touch. ! ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces. ! ! Input, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Input, integer ORDER_MAX, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer IFACE, JFACE, the faces to be checked. ! ! Output, integer TOUCH: ! 0, the faces do not touch; ! +1, the faces touch, both using an arc in the same direction; ! -1, the faces touch, using an arc in opposite directions. ! implicit none ! integer order_max integer face_num ! integer face(order_max,face_num) integer face_order(face_num) integer i integer iface integer j integer jface integer m integer mp1 integer mm1 integer n integer np1 integer touch ! touch = 0 ! ! Arc N1-N2 on IFACE must be matched by arc N1-N2 or N2-N1 on JFACE. ! do i = 1, face_order(iface) n = face(i,iface) if ( i < face_order(iface) ) then np1 = face(i+1,iface) else np1 = face(1,iface) end if do j = 1, face_order(jface) m = face(j,jface) if ( j < face_order(jface) ) then mp1 = face(j+1,jface) else mp1 = face(1,jface) end if if ( j > 1 ) then mm1 = face(j-1,jface) else mm1 = face(face_order(jface),jface) end if if ( n == m ) then if ( np1 == mp1 ) then touch = + 1 return else if ( np1 == mm1 ) then touch = - 1 return end if end if end do end do return end subroutine file_get_next_word ( iunit, word, text, num_text, ierror ) ! !******************************************************************************* ! !! FILE_GET_NEXT_WORD returns the next word and trailing context from a file. ! ! ! Discussion: ! ! The file should have been opened before calling this routine. ! The file should contain ASCII text, which can be thought of as ! words separated by one or more blanks. ! ! Modified: ! ! 12 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input, integer IUNIT, the unit number associated with the file. ! ! Output, character ( len = * ) WORD, the next word in the file. If the ! current line of the file is blank, or if the file has been exhausted, ! WORD will be set to ' '. ! ! Input/output, character ( len = * ) TEXT, the remaining text of the line ! that contains the information in WORD. On each call, the next word ! in TEXT is extracted until TEXT is empty, when it is refilled by ! reading another line from the file. Because TEXT contains information ! needed by this routine, it should not be altered by the user ! between calls. ! ! Input/output, integer NUM_TEXT, the number of lines read from the file. ! Before the first call to this routine, the user should set NUM_TEXT ! to 0. ! ! Output, integer IERROR, error flag. ! 0, no error, another word was read, and returned in WORD. ! 1, end of file. WORD and TEXT were set to ' '. ! implicit none ! integer ierror integer ihi integer ilo integer ios integer iunit integer lenc integer num_text character ( len = * ) text character ( len = * ) word ! ierror = 0 ! ! If NUM_TEXT is zero, then initialize TEXT. ! if ( num_text <= 0 ) then num_text = 0 text = ' ' end if ! ! If TEXT is blank, try to read a new line from the file. ! if ( text == ' ' ) then read ( iunit, '(a)', iostat = ios ) text if ( ios /= 0 ) then ierror = 1 word = ' ' text = ' ' return end if num_text = num_text + 1 if ( text == ' ' ) then word = ' ' return end if end if ! ! Extract the next word from TEXT into WORD and return. ! lenc = len_trim ( text ) ! ! Find ILO, the index of the first nonblank in TEXT. ! ilo = 1 do while ( text(ilo:ilo) == ' ' ) ilo = ilo + 1 end do ! ! Find IHI, the index of the last consecutive nonblank after the one at ILO. ! ihi = ilo do while ( ihi+1 <= lenc ) if ( text(ihi+1:ihi+1) == ' ' ) then exit end if ihi = ihi + 1 end do ! ! Set WORD. ! word = text(ilo:ihi) ! ! Slide TEXT to the left. ! if ( ihi+1 <= lenc ) then text = text(ihi+1:) else text = ' ' end if return end subroutine file_name_ext_get ( filnam, i, j ) ! !******************************************************************************* ! !! FILE_NAME_EXT_GET determines the "extension" of a file name. ! ! ! Definition: ! ! The "extension" of a filename is the string of characters ! that appears after the LAST period in the name. A file ! with no period, or with a period as the last character ! in the name, has a "null" extension. ! ! Note: ! ! Blanks are unusual in filenames. This routine ignores all ! trailing blanks, but will treat initial or internal blanks ! as regular characters acceptable in a file name. ! ! Example: ! ! FILNAM I J ! ! bob.for 5 7 ! N.B.C.D 7 7 ! Naomi. 0 0 ! Arthur 0 0 ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILNAM, a file name to be examined. ! ! Output, integer I, J, the indices of the first and last characters ! in the file extension. ! ! If at least one period occurs in the filename, and at least one ! nonblank character follows that period, then I will be the index ! of the first character after the period, and J the index of the ! last nonblank character after the period. The extension is ! therefore equal to FILNAM(I:J). ! ! Otherwise, I and J will be returned as 0, indicating that the file ! has no extension. ! implicit none ! character ( len = * ) filnam integer i integer j integer s_index_last ! i = s_index_last ( filnam, '.' ) if ( i /= 0 ) then j = len_trim ( filnam ) if ( i == j ) then i = 0 j = 0 else i = i + 1 end if else j = 0 end if return end subroutine hello ( cor3_max, face_max, line_max, material_max, order_max, & point_max, texture_max ) ! !******************************************************************************* ! !! HELLO prints out a message about the program. ! ! ! Modified: ! ! 14 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer LINE_MAX, the maximum number of lines. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum vertices per face. ! ! Input, integer POINT_MAX, the maximum number of points to display. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Hello: This is IVRead,' write ( *, '(a)' ) ' a program which can convert some files from' write ( *, '(a)' ) ' some 3D graphics format to some others:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ".ase" 3D Studio Max ASCII export;' write ( *, '(a)' ) ' ".byu" Movie.BYU surface geometry;' write ( *, '(a)' ) ' ".dxf" AutoCAD DXF;' write ( *, '(a)' ) ' ".hrc" SoftImage hierarchy;' write ( *, '(a)' ) ' ".iv" SGI Open Inventor;' write ( *, '(a)' ) ' ".obj" WaveFront Advanced Visualizer;' write ( *, '(a)' ) ' ".oogl" OOGL file (input only);' write ( *, '(a)' ) ' ".pov" Persistence of Vision (output only);' write ( *, '(a)' ) ' ".ps" PostScript (output only)(NOT READY);' write ( *, '(a)' ) ' ".smf" Michael Garland''s format;' write ( *, '(a)' ) ' ".stl" ASCII StereoLithography;' write ( *, '(a)' ) ' ".stla" ASCII StereoLithography;' write ( *, '(a)' ) ' ".tec" TECPLOT (output only);' write ( *, '(a)' ) ' ".tri" [Greg Hood triangles, ASCII];' write ( *, '(a)' ) ' ".tria" [Greg Hood triangles, ASCII];' write ( *, '(a)' ) ' ".ts" Mathematica ThreeScript (output only);' write ( *, '(a)' ) ' ".3s" Mathematica ThreeScript (output only);' write ( *, '(a)' ) ' ".txt" Text (output only);' write ( *, '(a)' ) ' ".ucd" AVS unstructured cell data (output only);' write ( *, '(a)' ) ' ".vla" VLA; (points and lines);' write ( *, '(a)' ) ' ".wrl" VRML;' write ( *, '(a)' ) ' ".xgl" XGL (output only) (DEVELOPMENT)' write ( *, '(a)' ) ' ".xyz" XYZ (points and lines);' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Current limits:' write ( *, '(a)') ' ' write ( *, '(i8,a)' ) cor3_max, ' points;' write ( *, '(i8,a)' ) line_max, ' line items;' write ( *, '(i8,a)' ) face_max, ' faces.' write ( *, '(a)' ) ' ' write ( *, '(i8,a)' ) order_max, ' vertices per face;' write ( *, '(i8,a)' ) point_max, ' points to display;' write ( *, '(i8,a)' ) material_max, ' materials;' write ( *, '(i8,a)' ) texture_max, ' textures.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Last modified: 04 June 2002.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Send problem reports to burkardt@iastate.edu.' return end subroutine help ! !******************************************************************************* ! !! HELP prints out a help message about the interactive commands. ! ! ! Modified: ! ! 29 June 1999 ! ! Author: ! ! John Burkardt ! implicit none ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HELP:' write ( *, '(a)' ) ' Batch commands to convert IN_FILE to OUT_FILE:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ivread in_file out_file' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ivread -rn in_file out_file' write ( *, '(a)' ) ' Reverse normals before output.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ivread -rf in_file out_file' write ( *, '(a)' ) ' Reverse faces and normals before output.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HELP:' write ( *, '(a)' ) ' These are legal interactive commands:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' < in_file Read data from a file.' write ( *, '(a)' ) ' << out_file Append data from a file' write ( *, '(a)' ) ' to current information.' write ( *, '(a)' ) ' > out_file Write data out to a file.' write ( *, '(a)' ) ' B Switch byte swapping option.' write ( *, '(a)' ) ' D Switch debug option.' write ( *, '(a)' ) ' F Print info about one face.' write ( *, '(a)' ) ' H Print this help message.' write ( *, '(a)' ) ' I Info, print out recent changes.' write ( *, '(a)' ) ' LINE_PRUNE Set FACE_TO_LINE pruning option.' write ( *, '(a)' ) ' LINES Convert faces to lines.' write ( *, '(a)' ) ' N Recompute normal vectors.' write ( *, '(a)' ) ' O Use an average node normal.' write ( *, '(a)' ) ' Q Quit.' write ( *, '(a)' ) ' REVERSE Reverse the normal vectors.' write ( *, '(a)' ) ' RELAX Smooth surface via relaxation.' write ( *, '(a)' ) ' S Select face subset.' write ( *, '(a)' ) ' T Transform data.' write ( *, '(a)' ) ' U Renumber faces and analyze.' write ( *, '(a)' ) ' V Convert polygons to triangles.' write ( *, '(a)' ) ' W Reverse faces and normals.' return end subroutine hrc_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, & ierror, iunit, line_dex, line_material, line_max, line_num, & material_max, material_name, material_num, material_rgba, & order_max, text_num, texture_max, texture_name, texture_num, & vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! HRC_READ reads graphics information from a SoftImage HRC file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! HRCH: Softimage 4D Creative Environment v3.00 ! ! ! model ! { ! name "cube_10x10" ! scaling 1.000 1.000 1.000 ! rotation 0.000 0.000 0.000 ! translation 0.000 0.000 0.000 ! ! mesh ! { ! flag ( PROCESS ) ! discontinuity 60.000 ! ! vertices 8 ! { ! [0] position -5.000 -5.000 -5.000 ! [1] position -5.000 -5.000 5.000 ! [2] position -5.000 5.000 -5.000 ! [3] position -5.000 5.000 5.000 ! [4] position 5.000 -5.000 -5.000 ! [5] position 5.000 -5.000 5.000 ! [6] position 5.000 5.000 -5.000 ! [7] position 5.000 5.000 5.000 ! } ! ! polygons 6 ! { ! [0] nodes 4 ! { ! [0] vertex 0 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 1 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [2] vertex 3 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [3] vertex 2 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! } ! material 0 ! [1] nodes 4 ! { ! [0] vertex 1 ! normal 0.000 0.000 1.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 5 ! ! ...etc..... ! ! [5] nodes 4 ! { ! [0] vertex 2 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 3 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [2] vertex 7 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [3] vertex 6 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! } ! material 0 ! } ! ! edges 12 ! { ! [1] vertices 3 2 ! [2] vertices 2 0 ! [3] vertices 0 1 ! [4] vertices 1 3 ! [5] vertices 7 3 ! [6] vertices 1 5 ! [7] vertices 5 7 ! [8] vertices 6 7 ! [9] vertices 5 4 ! [10] vertices 4 6 ! [11] vertices 2 6 ! [12] vertices 4 0 ! } ! } ! ! material [0] ! { ! name "kazoo" ! type PHONG ! ambient 0.0 1.0 0.0E+00 ! diffuse 1.0 0.0 0.0E+00 ! specular 0.0 0.0 1.0E+00 ! exponent 50.0E+00 ! reflectivity 0.0E+00 ! transparency 0.0E+00 ! refracIndex 1.0E+00 ! glow 0 ! coc 0.0E+00 ! } ! ! texture [0] ! { ! name "/usr/users/foss/HOUSE/PICTURES/mellon" ! glbname "t2d1" ! anim STATIC ! method XY ! repeat 1 1 ! scaling 1.000 1.000 ! offset 0.000 0.000 ! pixelInterp ! effect INTENSITY ! blending 1.000 ! ambient 0.977 ! diffuse 1.000 ! specular 0.966 ! reflect 0.000 ! transp 0.000 ! roughness 0.000 ! reflMap 1.000 ! rotation 0.000 ! txtsup_rot 0.000 0.000 0.000 ! txtsup_trans 0.000 0.000 0.000 ! txtsup_scal 1.000 1.000 1.000 ! } ! ! } ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BAD_NUM, the number of bad text lines. ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Output, integer DUP_NUM, the number of duplicate points that were dropped. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated ! by -1. ! ! Input/output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input/output, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Input/output, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B ! and A values. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer TEXT_NUM, the number of text lines. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Input/output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), ! texture names. ! ! Input/output, integer TEXTURE_NUM, the number of textures. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! ! Input/output, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex ! texture coordinates. ! implicit none ! integer cor3_max integer face_max integer, parameter :: level_max = 10 integer line_max integer material_max integer order_max integer texture_max ! integer bad_num character ( len = 4 ) char4 real cor3(3,cor3_max) integer cor3_num integer cor3_num_old logical, parameter :: debug = .FALSE. logical done integer dup_num integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name integer i integer icor3 integer ierror integer ios integer iunit integer ival1 integer ival2 integer ival3 integer ival4 integer ivert integer iword integer jval integer lchar integer level character ( len = 256 ) level_name(0:level_max) integer line_dex(line_max) integer line_material(line_max) integer line_num logical lval character ( len = * ) material_name(material_max) integer material_num integer material_num_old real material_rgba(4,material_max) integer nlbrack integer nrbrack integer, parameter :: OFFSET = 1 real rval logical s_eqi logical s_is_i real temp(3) character ( len = 256 ) text integer text_num character ( len = * ) texture_name(texture_max) integer texture_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) character ( len = 256 ) word character ( len = 256 ) word2 character ( len = 256 ) wordm1 real x real y real z ! ierror = 0 ival1 = 0 ival2 = 0 ival3 = 0 ival4 = 0 jval = 0 level = 0 level_name(0) = 'Top' nlbrack = 0 nrbrack = 0 cor3_num_old = cor3_num material_num_old = material_num word = ' ' wordm1 = ' ' ! ! Read a line of text from the file. ! 10 continue read ( iunit, '(a)', iostat = ios ) text if ( ios /= 0 ) then go to 50 end if text_num = text_num + 1 if ( text == ' ' ) then go to 10 end if ! ! The first line of the file must be the header. ! if ( text_num == 1 ) then if ( .not. s_eqi ( text(1:5), 'HRCH:' ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HRC_READ - Fatal error!' write ( *, '(a)' ) ' The input file has a bad header.' write ( *, '(a)' ) trim ( text ) return else go to 10 end if end if done = .true. iword = 0 ! ! Save the previous word read. ! It helps when a word depends on its cotext_num. ! 20 continue if ( word /= ' ' .and. word .ne. ',' ) then wordm1 = word end if ! ! Read a word from the line. ! call word_next_read ( text, word, done ) ! ! If no more words in this line, read in a whole new line. ! if ( done ) then go to 10 end if ! ! Ignore blanks and commas. ! if ( word == ' ' .or. word == ',' ) then go to 20 end if ! ! Count the words in the current line, and the total. ! iword = iword + 1 ! ! If the word is a curly bracket, count it. ! if ( word == '{' ) then nlbrack = nlbrack + 1 else if ( word .eq. '}' ) then nrbrack = nrbrack + 1 if ( nlbrack < nrbrack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HRC_READ - Fatal error!' write ( *, '(a,i6)' ) ' Extraneous right bracket, line ', text_num write ( *, '(a)' ) trim ( text ) write ( *, '(a)' ) 'Currently processing field:' write ( *, '(a)' ) trim ( level_name(level) ) ierror = 1 return end if end if ! ! If the word is a left bracket, the previous word is the name of a node. ! if ( word == '{' ) then level = nlbrack - nrbrack if ( level < 0 ) then write ( *, '(a)' ) 'Too many right brackets!' level = 0 else if ( level > level_max ) then write ( *, '(a)' ) 'Too many left brackets!' level = level_max end if level_name(level) = wordm1 if ( debug ) then write ( *, '(a)' ) ' ' do i = 0, level write ( *, '(i3,2x,a)' ) i, trim ( level_name(i) ) end do end if end if ! ! CONTROLPOINTS ! if ( s_eqi ( level_name(level), 'CONTROLPOINTS' ) ) then if ( word == '{' ) then else if ( word == '}' ) then line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = material_num end if level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'POSITION' ) ) then do i = 1, 3 call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) temp(i) = rval end do ! ! If the coordinate values already exist in COR3, then ! save space by using the index of a previous copy. ! if ( cor3_num <= 1000 ) then call rcol_find ( 3, 3, cor3_num, cor3, temp, icor3 ) else icor3 = 0 end if if ( icor3 == 0 ) then cor3_num = cor3_num + 1 if ( cor3_num <= cor3_max ) then cor3(1,cor3_num) = temp(1) cor3(2,cor3_num) = temp(2) cor3(3,cor3_num) = temp(3) end if icor3 = cor3_num else dup_num = dup_num + 1 end if line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = icor3 line_material(line_num) = material_num end if else go to 99 end if ! ! EDGES ! else if ( s_eqi ( level_name(level), 'EDGES' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VERTICES' ) ) then call word_next_read ( text, word2, done ) lval = s_is_i ( word2, jval ) line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = jval + cor3_num_old + OFFSET line_material(line_num) = material_num end if call word_next_read ( text, word2, done ) lval = s_is_i ( word2, jval ) line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = jval + cor3_num_old + OFFSET line_material(line_num) = material_num end if line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if else go to 99 end if ! ! MATERIAL ! else if ( s_eqi ( level_name(level), 'MATERIAL' ) ) then if ( word == '{' ) then material_num = material_num + 1 if ( material_num <= material_max ) then call i_to_s_zero ( material_num, char4 ) material_name(material_num) = 'Material_' // char4 end if else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then else if ( s_eqi ( word, 'AMBIENT' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'COC' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'DIFFUSE' ) ) then call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) material_rgba(1,material_num) = rval call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) material_rgba(2,material_num) = rval call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) material_rgba(3,material_num) = rval else if ( s_eqi ( word, 'EXPONENT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'GLOW' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'NAME' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) material_name(material_num) = word2 call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'REFLECTIVITY' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'REFRACINDEX' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'SPECULAR' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TRANSPARENCY' ) ) then call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) material_rgba(4,material_num) = 1.0E+00 - rval else if ( s_eqi ( word, 'TYPE' ) ) then call word_next_read ( text, word2, done ) else go to 99 end if ! ! MESH ! else if ( s_eqi ( level_name(level), 'MESH' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'DISCONTINUITY' ) ) then go to 10 else if ( s_eqi ( word, 'EDGES' ) ) then go to 10 else if ( s_eqi ( word, 'FLAG' ) ) then go to 10 else if ( s_eqi ( word, 'POLYGONS' ) ) then go to 10 else if ( s_eqi ( word, 'VERTICES' ) ) then go to 10 else go to 99 end if ! ! MODEL ! else if ( s_eqi ( level_name(level), 'MODEL' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'MATERIAL' ) ) then go to 10 else if ( s_eqi ( word, 'MESH' ) ) then go to 10 else if ( s_eqi ( word, 'NAME' ) ) then go to 10 else if ( s_eqi ( word, 'PATCH' ) ) then go to 10 else if ( s_eqi ( word, 'ROTATION' ) ) then go to 10 else if ( s_eqi ( word, 'SCALING' ) ) then go to 10 else if ( s_eqi ( word, 'SPLINE' ) ) then go to 10 else if ( s_eqi ( word, 'TRANSLATION' ) ) then go to 10 else go to 99 end if ! ! NODES ! else if ( s_eqi ( level_name(level), 'NODES' ) ) then if ( word == '{' ) then face_num = face_num + 1 ivert = 0 face_order(face_num) = 0 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'NORMAL' ) ) then call word_next_read ( text, word2, done ) call s_is_r ( word2, x, lval ) call word_next_read ( text, word2, done ) call s_is_r ( word2, y, lval ) call word_next_read ( text, word2, done ) call s_is_r ( word2, z, lval ) if ( face_num <= face_max .and. ivert <= order_max ) then vertex_normal(1,ivert,face_num) = x vertex_normal(2,ivert,face_num) = y vertex_normal(3,ivert,face_num) = z end if else if ( s_eqi ( word, 'UVTEXTURE' ) ) then call word_next_read ( text, word2, done ) call s_is_r ( word2, x, lval ) call word_next_read ( text, word2, done ) call s_is_r ( word2, y, lval ) if ( face_num <= face_max .and. ivert <= order_max ) then vertex_tex_uv(1,ivert,face_num) = x vertex_tex_uv(2,ivert,face_num) = y end if else if ( s_eqi ( word, 'VERTEX' ) ) then call word_next_read ( text, word2, done ) lval = s_is_i ( word2, jval ) ivert = ivert + 1 if ( ivert <= order_max .and. face_num <= face_max ) then face_order(face_num) = face_order(face_num) + 1 face(ivert,face_num) = jval + cor3_num_old + OFFSET end if ! ! What do I do with this? Define a vertex material? ! else if ( s_eqi ( word, 'VERTEXCOLOR' ) ) then call word_next_read ( text, word2, done ) lval = s_is_i ( word2, ival1 ) call word_next_read ( text, word2, done ) lval = s_is_i ( word2, ival2 ) call word_next_read ( text, word2, done ) lval = s_is_i ( word2, ival3 ) call word_next_read ( text, word2, done ) lval = s_is_i ( word2, ival4 ) else go to 99 end if ! ! PATCH ! ! JVB: I don't know what to do with this yet. ! else if ( s_eqi ( level_name(level), 'PATCH' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'APPROX_TYPE' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'CONTROLPOINTS' ) ) then go to 10 else if ( s_eqi ( word, 'CURV_U' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'CURV_V' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'RECMIN' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'RECMAX' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'RECURSION' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'SPACIAL' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TAGGEDPOINTS' ) ) then go to 10 else if ( s_eqi ( word, 'UCURVE' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'UPOINT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'USTEP' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'UTENSION' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'UTYPE' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VCLOSE' ) ) then else if ( s_eqi ( word, 'VCURVE' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VIEWDEP' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VPOINT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VSTEP' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VTENSION' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'VTYPE' ) ) then call word_next_read ( text, word2, done ) else go to 99 end if ! ! POLYGONS ! else if ( s_eqi ( level_name(level), 'POLYGONS' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'MATERIAL' ) ) then call word_next_read ( text, word2, done ) lval = s_is_i ( word2, jval ) face_material(face_num) = jval + material_num_old + OFFSET do i = 1, order_max vertex_material(i,face_num) = jval + material_num_old + OFFSET end do else if ( s_eqi ( word, 'NODES' ) ) then call word_next_read ( text, word2, done ) else go to 99 end if ! ! SPLINE ! else if ( s_eqi ( level_name(level), 'SPLINE' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'CONTROLPOINTS' ) ) then go to 10 else if ( s_eqi ( word, 'NAME' ) ) then go to 10 else if ( s_eqi ( word, 'NBKEYS' ) ) then go to 10 else if ( s_eqi ( word, 'STEP' ) ) then go to 10 else if ( s_eqi ( word, 'TENSION' ) ) then go to 10 else if ( s_eqi ( word, 'TYPE' ) ) then go to 10 else go to 99 end if ! ! TAGGEDPOINTS ! else if ( s_eqi ( level_name(level), 'TAGGEDPOINTS' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TAGGED' ) ) then call word_next_read ( text, word2, done ) else go to 99 end if ! ! TEXTURE ! else if ( s_eqi ( level_name(level), 'TEXTURE' ) ) then if ( word == '{' ) then texture_num = texture_num + 1 if ( texture_num <= texture_max ) then call i_to_s_zero ( texture_num, char4 ) texture_name(texture_num) = 'Texture_' // char4 end if else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then else if ( s_eqi ( word, 'AMBIENT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'ANIM' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'BLENDING' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'DIFFUSE' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'EFFECT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'GLBNAME' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'METHOD' ) ) then call word_next_read ( text, word2, done ) ! ! (I assume there are initial and trailing quotes in the NAME field, ! which are treated as separate words.) ! else if ( s_eqi ( word, 'NAME' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) texture_name(texture_num) = word2 call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'OFFSET' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'PIXELINTERP' ) ) then else if ( s_eqi ( word, 'REFLECT' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'REFLMAP' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'REPEAT' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'ROTATION' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'ROUGHNESS' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'SCALING' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'SPECULAR' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TRANSP' ) ) then call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TXTSUP_ROT' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TXTSUP_SCAL' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'TXTSUP_TRANS' ) ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else go to 99 end if ! ! VERTICES ! else if ( s_eqi ( level_name(level), 'VERTICES' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( word(1:1) == '[' ) then call word_next_read ( text, word2, done ) call word_next_read ( text, word2, done ) else if ( s_eqi ( word, 'POSITION' ) ) then cor3_num = cor3_num + 1 call word_next_read ( text, word2, done ) call s_is_r ( word2, x, lval ) call word_next_read ( text, word2, done ) call s_is_r ( word2, y, lval ) call word_next_read ( text, word2, done ) call s_is_r ( word2, z, lval ) if ( cor3_num <= cor3_max ) then cor3(1,cor3_num) = x cor3(2,cor3_num) = y cor3(3,cor3_num) = z end if else go to 99 end if ! ! Any other word: ! else end if go to 20 ! ! Bad data ! 99 continue bad_num = bad_num + 1 if ( bad_num <= 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HRC_READ - Warning!' write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( text ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HRC_READ - Fatal error!' write ( *, '(a)' ) ' Too many warnings!' return end if go to 10 ! ! Normal end of information in file. ! 50 continue ! ! Check the "materials" defining a line. ! ! If COORDINDEX is -1, so should be the MATERIALINDEX. ! If COORDINDEX is not -1, then the MATERIALINDEX shouldn't be either. ! do i = 1, line_num if ( line_dex(i) == -1 + OFFSET ) then line_material(i) = -1 + OFFSET else if ( line_material(i) == -1 + OFFSET ) then line_material(i) = material_num end if end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'HRC_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine hrc_write ( cor3, cor3_max, cor3_num, face, face_material, & face_max, face_num, face_order, fileout_name, iunit, line_dex, & line_max, line_num, material_max, material_name, material_num, & material_rgba, order_max, texture_max, texture_name, texture_num, & vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! HRC_WRITE writes graphics data to an HRC SoftImage file. ! ! ! Example: ! ! HRCH: Softimage 4D Creative Environment v3.00 ! ! ! model ! { ! name "cube_10x10" ! scaling 1.000 1.000 1.000 ! rotation 0.000 0.000 0.000 ! translation 0.000 0.000 0.000 ! ! mesh ! { ! flag ( PROCESS ) ! discontinuity 60.000 ! ! vertices 8 ! { ! [0] position -5.000 -5.000 -5.000 ! [1] position -5.000 -5.000 5.000 ! [2] position -5.000 5.000 -5.000 ! [3] position -5.000 5.000 5.000 ! [4] position 5.000 -5.000 -5.000 ! [5] position 5.000 -5.000 5.000 ! [6] position 5.000 5.000 -5.000 ! [7] position 5.000 5.000 5.000 ! } ! ! polygons 6 ! { ! [0] nodes 4 ! { ! [0] vertex 0 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 1 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [2] vertex 3 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [3] vertex 2 ! normal -1.000 0.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! } ! material 0 ! [1] nodes 4 ! { ! [0] vertex 1 ! normal 0.000 0.000 1.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 5 ! ! ...etc..... ! ! [5] nodes 4 ! { ! [0] vertex 2 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [1] vertex 3 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [2] vertex 7 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! [3] vertex 6 ! normal 0.000 1.000 0.000 ! uvTexture 0.000 0.000 ! vertexColor 255 178 178 178 ! } ! material 0 ! } ! ! edges 12 ! { ! [1] vertices 3 2 ! [2] vertices 2 0 ! [3] vertices 0 1 ! [4] vertices 1 3 ! [5] vertices 7 3 ! [6] vertices 1 5 ! [7] vertices 5 7 ! [8] vertices 6 7 ! [9] vertices 5 4 ! [10] vertices 4 6 ! [11] vertices 2 6 ! [12] vertices 4 0 ! } ! } ! ! material [0] ! { ! name "kazoo" ! type PHONG ! ambient 0.0 1.0 0.0E+00 ! diffuse 1.0 0.0 0.0E+00 ! specular 0.0 0.0 1.0E+00 ! exponent 50.0E+00 ! reflectivity 0.0E+00 ! transparency 0.0E+00 ! refracIndex 1.0E+00 ! glow 0 ! coc 0.0E+00 ! } ! ! texture [0] ! { ! name "/usr/users/foss/HOUSE/PICTURES/mellon" ! glbname "t2d1" ! anim STATIC ! method XY ! repeat 1 1 ! scaling 1.000 1.000 ! offset 0.000 0.000 ! pixelInterp ! effect INTENSITY ! blending 1.000 ! ambient 0.977 ! diffuse 1.000 ! specular 0.966 ! reflect 0.000 ! transp 0.000 ! roughness 0.000 ! reflMap 1.000 ! rotation 0.000 ! txtsup_rot 0.000 0.000 0.000 ! txtsup_trans 0.000 0.000 0.000 ! txtsup_scal 1.000 1.000 1.000 ! } ! ! } ! ! Modified: ! ! 24 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), face materials. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), material names. ! ! Input, integer MATERIAL_NUM, the number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture names. ! ! Input, integer TEXTURE_NUM, the number of textures. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Input, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer texture_max ! real cor3(3,cor3_max) integer cor3_num integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) fileout_name integer i integer iface integer iunit integer ivert integer j integer jhi integer jlo integer jrel integer k integer line_dex(line_max) integer line_num character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer npts integer nseg integer, parameter :: OFFSET = 1 character ( len = 100 ) text integer text_num character ( len = * ) texture_name(texture_max) integer texture_num real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) character ( len = 10 ) word real x real y real z ! nseg = 0 text_num = 0 write ( iunit, '(a)' ) 'HRCH: Softimage 4D Creative Environment v3.00' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) ' ' text_num = text_num + 3 write ( iunit, '(a)' ) 'model' write ( iunit, '(a)' ) '{' write ( iunit, '(a)' ) ' name "' // trim ( fileout_name ) // '"' write ( iunit, '(a)' ) ' scaling 1.000 1.000 1.000' write ( iunit, '(a)' ) ' rotation 0.000 0.000 0.000' write ( iunit, '(a)' ) ' translation 0.000 0.000 0.000' text_num = text_num + 6 if ( face_num > 0 ) then write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) ' mesh' write ( iunit, '(a)' ) ' {' write ( iunit, '(a)' ) ' flag ( PROCESS )' write ( iunit, '(a)' ) ' discontinuity 60.000' text_num = text_num + 5 ! ! Point coordinates. ! if ( cor3_num > 0 ) then write ( iunit, '(a)' ) ' ' write ( text, '(a, i8)' ) 'vertices ', cor3_num call s_blanks_delete ( text ) write ( iunit, '(4x,a)' ) trim ( text ) write ( iunit, '(a)' ) ' {' text_num = text_num + 3 do j = 1, cor3_num write ( word, '( ''['', i8, '']'' )' ) j-OFFSET call s_blank_delete ( word ) write ( text, '(a,'' position '',3f12.3)' ) trim ( word ), cor3(1:3,j) call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' }' text_num = text_num + 1 end if ! ! Faces. ! write ( iunit, '(a)' ) ' ' write ( text, '(a,i8)' ) 'polygons ', face_num call s_blanks_delete ( text ) write ( iunit, '(4x,a)' ) trim ( text ) write ( iunit, '(a)' ) ' {' text_num = text_num + 3 do iface = 1, face_num write ( word, '( ''['', i8, '']'' )' ) iface-OFFSET call s_blank_delete ( word ) write ( text, '(a,'' nodes '',i8 )' ) trim ( word ), face_order(iface) call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) write ( iunit, '(a)' ) ' {' text_num = text_num + 2 do ivert = 1, face_order(iface) write ( word, '( ''['', i8, '']'' )' ) ivert-OFFSET call s_blank_delete ( word ) write ( text, '( a,'' vertex '',i8 )' ) trim ( word ), & face(ivert,iface) - OFFSET call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) x = vertex_normal(1,ivert,iface) y = vertex_normal(2,ivert,iface) z = vertex_normal(3,ivert,iface) write ( text, '(a,3f12.3)' ) 'normal ', x, y, z call s_blanks_delete ( text ) write ( iunit, '(12x,a)' ) trim ( text ) x = vertex_tex_uv(1,ivert,iface) y = vertex_tex_uv(2,ivert,iface) write ( text, '(a,2f12.3)' ) 'uvTexture ', x, y call s_blanks_delete ( text ) write ( iunit, '(12x,a)' ) trim ( text ) text = 'vertexColor 255 178 178 178' call s_blanks_delete ( text ) write ( iunit, '(12x,a)' ) trim ( text ) text_num = text_num + 4 end do write ( iunit, '(a)' ) ' }' write ( text, '(''material '',i8)' ) face_material(iface) - OFFSET call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) text_num = text_num + 2 end do write ( iunit, '(a)' ) ' }' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 end if ! ! IndexedLineSet. ! if ( line_num > 0 ) then nseg = 0 jhi = 0 10 continue jlo = jhi ! ! Look for the next index JLO that is not -1. ! do jlo = jlo + 1 if ( jlo > line_num ) then go to 20 end if if ( line_dex(jlo) /= -1+OFFSET ) then exit end if end do ! ! Look for the highest following index JHI that is not -1. ! jhi = jlo + 1 if ( jhi > line_num ) then go to 20 end if if ( line_dex(jhi) == -1+OFFSET ) then go to 10 end if do while ( jhi < line_num ) if ( line_dex(jhi+1) == -1+OFFSET ) then exit end if jhi = jhi + 1 end do ! ! Our next line segment involves LINE_DEX indices JLO through JHI. ! nseg = nseg + 1 write ( text, '(''spl'', i8 )' ) nseg call s_blank_delete ( text ) npts = jhi + 1 - jlo write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) ' spline' write ( iunit, '(a)' ) ' {' write ( iunit, '(a)' ) ' name "' // trim ( text ) // '"' write ( iunit, '(a)' ) ' type LINEAR' write ( iunit, '(a,i8)' ) ' nbKeys ', npts write ( iunit, '(a)' ) ' tension 0.000' write ( iunit, '(a)' ) ' step 1' write ( iunit, '(a)' ) ' ' text_num = text_num + 9 write ( iunit, '(a)' ) ' controlpoints' write ( iunit, '(a)' ) ' {' text_num = text_num + 2 do j = jlo, jhi jrel = j - jlo k = line_dex(j) write ( word, '( ''['', i8, '']'')' ) jrel call s_blank_delete ( word ) write ( text, '( a, '' position '', 3f12.4)' ) & trim ( word ), cor3(1,k), cor3(2,k), cor3(3,k) call s_blanks_delete ( text ) write ( iunit, '(6x,a)' ) trim ( text ) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' }' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 go to 10 20 continue end if ! ! MATERIALS ! do i = 1, material_num write ( text, '(''['', i8, '']'' )' ) i-OFFSET call s_blank_delete ( text ) write ( iunit, '(a)' ) ' material ' // trim ( text ) write ( iunit, '(a)' ) ' {' write ( iunit, '(a)' ) 'name "' // trim ( material_name(i) ) // '"' write ( iunit, '(a)' ) ' type PHONG' write ( iunit, '(a,3f10.4)' ) ' ambient ', & material_rgba(1,i), material_rgba(2,i), material_rgba(3,i) write ( iunit, '(a,3f10.4)' ) ' diffuse ', & material_rgba(1,i), material_rgba(2,i), material_rgba(3,i) write ( iunit, '(a,3f10.4)' ) ' specular ', & material_rgba(1,i), material_rgba(2,i), material_rgba(3,i) write ( iunit, '(a)' ) ' exponent 50.0' write ( iunit, '(a)' ) ' reflectivity 0.0' write ( iunit, '(a,f10.4)' ) ' transparency ', 1.0E+00 - material_rgba(4,i) write ( iunit, '(a)' ) ' refracIndex 1.0' write ( iunit, '(a)' ) ' glow 0' write ( iunit, '(a)' ) ' coc 0.0' write ( iunit, '(a)' ) ' }' text_num = text_num + 14 end do ! ! TEXTURES ! do i = 1, texture_num write ( text, '(''['', i8, '']'' )' ) i-OFFSET call s_blank_delete ( text ) write ( iunit, '(a)' ) ' texture [' // trim ( text ) //']' write ( iunit, '(a)' ) '{' write ( iunit, '(a)' ) 'name "' // trim ( texture_name(i) ) // '"' write ( iunit, '(a)' ) 'glbname "t2d1"' write ( iunit, '(a)' ) 'anim STATIC' write ( iunit, '(a)' ) 'method XY' write ( iunit, '(a)' ) 'repeat 1 1' write ( iunit, '(a)' ) 'scaling 1.000 1.000' write ( iunit, '(a)' ) 'offset 0.000 0.000' write ( iunit, '(a)' ) 'pixelInterp' write ( iunit, '(a)' ) 'effect INTENSITY' write ( iunit, '(a)' ) 'blending 1.000' write ( iunit, '(a)' ) 'ambient 0.977' write ( iunit, '(a)' ) 'diffuse 1.000' write ( iunit, '(a)' ) 'specular 0.966' write ( iunit, '(a)' ) 'reflect 0.000' write ( iunit, '(a)' ) 'transp 0.000' write ( iunit, '(a)' ) 'roughness 0.000' write ( iunit, '(a)' ) 'reflMap 1.000' write ( iunit, '(a)' ) 'rotation 0.000' write ( iunit, '(a)' ) 'txtsup_rot 0.000 0.000 0.000' write ( iunit, '(a)' ) 'txtsup_trans 0.000 0.000 0.000' write ( iunit, '(a)' ) 'txtsup_scal 1.000 1.000 1.000' write ( iunit, '(a)' ) '}' write ( iunit, '(1x)' ) text_num = text_num + 25 end do write ( iunit, '(a)' ) '}' text_num = text_num + 1 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'HRC_WRITE - Wrote ', text_num, ' text lines to ' // trim ( fileout_name ) return end function i_modp ( i, j ) ! !******************************************************************************* ! !! I_MODP returns the nonnegative remainder of integer division. ! ! ! Formula: ! ! If ! NREM = I_MODP ( I, J ) ! NMULT = ( I - NREM ) / J ! then ! I = J * NMULT + NREM ! where NREM is always nonnegative. ! ! Comments: ! ! The MOD function computes a result with the same sign as the ! quantity being divided. Thus, suppose you had an angle A, ! and you wanted to ensure that it was between 0 and 360. ! Then mod(A,360) would do, if A was positive, but if A ! was negative, your result would be between -360 and 0. ! ! On the other hand, I_MODP(A,360) is between 0 and 360, always. ! ! Example: ! ! I J MOD I_MODP I_MODP Factorization ! ! 107 50 7 7 107 = 2 * 50 + 7 ! 107 -50 7 7 107 = -2 * -50 + 7 ! -107 50 -7 43 -107 = -3 * 50 + 43 ! -107 -50 -7 43 -107 = 3 * -50 + 43 ! ! Modified: ! ! 02 March 199 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the number to be divided. ! ! Input, integer J, the number that divides I. ! ! Output, integer I_MODP, the nonnegative remainder when I is ! divided by J. ! implicit none ! integer i integer i_modp integer j ! if ( j == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_MODP - Fatal error!' write ( *, '(a,i6)' ) ' I_MODP ( I, J ) called with J = ', j stop end if i_modp = mod ( i, j ) if ( i_modp < 0 ) then i_modp = i_modp + abs ( j ) end if return end subroutine i_swap ( i, j ) ! !******************************************************************************* ! !! I_SWAP switches two integer values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J. On output, the values of I and ! J have been interchanged. ! implicit none ! integer i integer j integer k ! k = i i = j j = k return end subroutine i_to_s_zero ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_ZERO converts an integer to a string, with zero padding. ! ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 000001 ! -1 -00001 ! 0 000000 ! 1952 001952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be right justified, and zero padded. ! If there is not enough space, the string will be filled with stars. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer intval integer ipos integer ival character ( len = * ) s ! s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! Working from right to left, strip off the digits of the integer ! and place them into S(ILO:IHI). ! ipos = ihi do while ( ival /= 0 .or. ipos == ihi ) idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 end do ! ! Fill the empties with zeroes. ! do i = ilo, ipos s(i:i) = '0' end do return end subroutine infile ( filein_name, ierror, filein_type ) ! !******************************************************************************* ! !! INFILE determines the input filename and type. ! ! ! Modified: ! ! 16 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Output, character ( len = 10 ) FILEIN_TYPE, the type of the file, which is ! set to the filename extension. ! implicit none ! character ( len = * ) filein_name character ( len = 10 ) filein_type integer i1 integer i2 integer ierror integer ios logical s_eqi ! ierror = 0 if ( filein_name == ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INFILE:' write ( *, '(a)' ) ' Enter the name of a graphics file to be read:' read ( *, '(a)', iostat = ios ) filein_name if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INFILE - Error!' write ( *, '(a)' ) ' The input file was not specified correctly.' ierror = ios return end if end if ! ! Determine the input file type. ! call file_name_ext_get ( filein_name, i1, i2 ) if ( i1 /= 0 ) then filein_type = filein_name(i1:i2) else filein_type = ' ' end if if ( filein_type == ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INFILE - Warning!' write ( *, '(a)' ) ' Could not determine the input file type.' write ( *, '(a)' ) ' The input file name is:' write ( *, '(a)' ) trim ( filein_name ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The file type should occur after the period.' write ( *, '(a)' ) ' Please specify the file type you are using:' write ( *, '(a)' ) ' 3s, ase, byu, dxf, hrc, iv, ' // & 'obj, oogl, smf, stl, stla, tri, tria, ts, vla, wrl, or xyz:' read ( *, '(a)', iostat = ios ) filein_type if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INFILE - Fatal error!' write ( *, '(a)' ) ' Input failure while reading input file type.' stop end if end if if ( .not. ( & s_eqi ( filein_type, '3S' ) .or. & s_eqi ( filein_type, 'ASE' ) .or. & s_eqi ( filein_type, 'BYU' ) .or. & s_eqi ( filein_type, 'DXF' ) .or. & s_eqi ( filein_type, 'HRC' ) .or. & s_eqi ( filein_type, 'IV' ) .or. & s_eqi ( filein_type, 'OBJ' ) .or. & s_eqi ( filein_type, 'OOGL' ) .or. & s_eqi ( filein_type, 'SMF' ) .or. & s_eqi ( filein_type, 'STL' ) .or. & s_eqi ( filein_type, 'STLA' ) .or. & s_eqi ( filein_type, 'TRI' ) .or. & s_eqi ( filein_type, 'TRIA' ) .or. & s_eqi ( filein_type, 'TS' ) .or. & s_eqi ( filein_type, 'VLA' ) .or. & s_eqi ( filein_type, 'WRL' ) .or. & s_eqi ( filein_type, 'XYZ' ) ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INFILE - Error!' write ( *, '(a)' ) ' The input file type was not acceptable!' return end if return end subroutine interact ( byte_swap, cor3, cor3_material, cor3_max, cor3_new, & cor3_normal, cor3_tex_uv, debug, edge, edge_max, face, face_area, & face_material, face_max, face_normal, face_object, face_order, face_rank, & face_tex_uv, face_tier, filein_name, fileout_name, ierror, line_dex, & line_material, line_max, line_prune, list, material_max, material_name, & material_rgba, order_max, object_name, point, point_max, & point_num, texture_max, texture_name, texture_temp, transform_matrix, & vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! INTERACT interacts with the user to specify input and output files. ! ! ! Modified: ! ! 13 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, real COR3(3,COR3_MAX), the coordinates of points. ! ! Workspace, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Workspace, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Workspace, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Workspace, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Workspace, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Workspace, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Output, integer IERROR, error flag. 0 = no error, nonzero = error. ! ! Workspace, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated ! by -1. ! ! Workspace, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Workspace, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Workspace, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), ! texture names. ! ! Workspace, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Workspace, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Workspace, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer edge_max integer face_max integer line_max integer material_max integer order_max integer point_max integer texture_max ! logical byte_swap character ( len = 100 ) command real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_new(3,cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical debug integer edge(4,edge_max) integer face(order_max,face_max) real face_area(face_max) integer face_index integer face_material(face_max) real face_normal(3,face_max) integer face_object(face_max) integer face_order(face_max) integer face_rank(face_max) real face_tex_uv(2,face_max) integer face_tier(face_max) character ( len = * ) filein_name character ( len = 10 ) filein_type character ( len = * ) fileout_name character ( len = 10 ) fileout_type integer i integer icor3 integer ierror integer iface integer ios integer ivert integer j integer line_dex(line_max) integer line_material(line_max) integer line_prune integer list(cor3_max) character ( len = * ) material_name(material_max) real material_rgba(4,material_max) integer edge_num integer face_num integer group_num integer line_num integer material_num integer object_num integer point(point_max) integer point_num integer texture_num character ( len = * ) object_name logical s_eqi character ( len = * ) texture_name(texture_max) real texture_temp(2,order_max*face_max) real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) real x real y real z ! ! Print an introductory message. ! call hello ( cor3_max, face_max, line_max, material_max, order_max, & point_max, texture_max ) ! ! Get the next user command. ! do ierror = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' )'Enter command ( or "Help" )' read ( *, '(a)', iostat = ios ) command if ( ios /= 0 ) then ierror = ios write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Fatal error!' write ( *, '(a)' ) ' Unexpected end of input.' return end if ! ! << means read a new file, and add it to the current information. ! if ( command(1:2) == '<<' ) then filein_name = command(3:) call s_blank_delete ( filein_name ) call infile ( filein_name, ierror, filein_type ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' The input file name was unacceptable!' cycle end if call data_read ( cor3, cor3_material, cor3_max, & cor3_normal, cor3_num, cor3_tex_uv, debug, face, face_area, & face_material, face_max, face_normal, face_num, face_order, & face_tex_uv, filein_name, filein_type, group_num, ierror, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, vertex_material, vertex_normal, vertex_tex_uv ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' The input data was not read properly.' ierror = 0 end if ! ! Get the next input file to be examined. ! else if ( command(1:1) == '<' ) then filein_name = command(2:) call s_blank_delete ( filein_name ) call infile ( filein_name, ierror, filein_type ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' The input file name was unacceptable!' cycle end if call data_init ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, cor3_tex_uv, face, face_area, face_material, face_max, & face_normal, face_num, face_order, face_tex_uv, group_num, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_name, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, transform_matrix, vertex_material, vertex_normal, & vertex_tex_uv ) call data_read ( cor3, cor3_material, cor3_max, & cor3_normal, cor3_num, cor3_tex_uv, debug, face, face_area, & face_material, face_max, face_normal, face_num, face_order, & face_tex_uv, filein_name, filein_type, group_num, ierror, line_dex, & line_material, line_max, line_num, material_max, material_name, & material_num, material_rgba, object_num, order_max, & point, point_max, point_num, texture_max, texture_name, texture_num, & texture_temp, vertex_material, vertex_normal, vertex_tex_uv ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' The input data was not read properly.' ierror = 0 end if ! ! The ">" command specifies output. ! else if ( command(1:1) == '>' ) then fileout_name = command(2:) call s_blank_delete ( fileout_name ) ! ! Check the output filename. ! call outfile ( filein_name, fileout_name, ierror, fileout_type ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' Improper output file name.' ierror = 0 cycle end if ! ! Write the output file. ! call data_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, debug, face, face_material, face_max, face_normal, & face_num, face_order, face_tex_uv, filein_name, fileout_name, & fileout_type, ierror, line_dex, line_material, line_max, line_num, & line_prune, material_name, material_max, material_num, material_rgba, & object_name, order_max, point, point_max, point_num, texture_max, & texture_name, texture_num, vertex_material, vertex_normal, & vertex_tex_uv ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' An error occurred during output.' ierror = 0 cycle end if ! ! B: Switch byte swapping option: ! else if ( s_eqi ( command(1:1), 'B' ) ) then byte_swap = .not. byte_swap if ( byte_swap ) then write ( *, '(a)' ) 'Byte swapping set to TRUE.' else write ( *, '(a)' ) 'Byte swapping set to FALSE.' end if ! ! D: Switch debug option: ! else if ( s_eqi ( command(1:1), 'D' ) ) then debug = .not. debug if ( debug ) then write ( *, '(a)' ) 'Debug option set to TRUE.' else write ( *, '(a)' ) 'Debug option set to FALSE.' end if ! ! F: Check a face: ! else if ( s_eqi ( command(1:1), 'F' ) ) then if ( face_num <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Input a graphical object with faces first!' cycle end if write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'Enter a face between 1 and ', face_num read ( *, * ) face_index call face_print ( cor3, cor3_max, face, face_index, face_material, & face_max, face_normal, face_num, face_order, order_max, & vertex_material, vertex_normal ) ! ! HELP: ! else if ( s_eqi ( command(1:1), 'H' ) ) then call help ! ! INFO: ! else if ( s_eqi ( command, 'INFO' ) ) then call news ! ! INVERT: ! Make an inverted copy of the object to give it thickness. ! else if ( s_eqi ( command(1:3), 'INV' ) ) then call object_invert ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, face, face_material, face_max, face_normal, face_num, & face_order, material_max, material_name, material_num, material_rgba, & order_max, vertex_material, vertex_normal ) ! ! LINE_PRUNE: ! Set line pruning option. ! else if ( s_eqi ( command, 'LINE_PRUNE' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SET THE LINE PRUNING OPTION:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' 0 means no pruning;' write ( *, '(a)' ) ' nonzero means only generate line (I,J)' write ( *, '(a)' ) ' if I < J.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The line pruning option is now ', line_prune write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Enter your line_pruning option:' read ( *, * ) line_prune ! ! LINES: ! Convert all faces to lines. ! else if ( s_eqi ( command, 'LINES' ) ) then if ( face_num > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Note:' write ( *, '(a)' ) ' Face information will be converted' write ( *, '(a)' ) ' to line information.' call face_to_line ( debug, face, face_max, face_num, face_order, & line_dex, line_material, line_max, line_num, line_prune, & order_max, vertex_material ) if ( line_num > line_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Note:' write ( *, '(a)' ) ' Some face information was lost.' write ( *, '(a,i6)' ) ' The maximum number of lines is ', line_max write ( *, '(a,i6)' ) ' but we would need at least ', line_num line_num = line_max end if face_num = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Note:' write ( *, '(a)' ) ' There were no faces to convert.' end if ! ! NORMALS: recompute the normal vectors for vertices on faces, ! and average these to get face normal vectors. ! else if ( s_eqi ( command(1:1), 'N' ) ) then do iface = 1, face_num do ivert = 1, face_order(iface) vertex_normal(1:3,ivert,iface) = 0.0E+00 end do end do call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) cor3_normal(1:3,1:cor3_num) = 0.0E+00 call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) face_normal(1:3,1:face_num) = 0.0E+00 call face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) ! ! OHELL: ! Use the node normals. ! Set the vertex normals equal to the node normals. ! Set the face normals by averaging vertex normals. ! else if ( s_eqi ( command(1:1), 'O' ) ) then ! ! Recompute any zero vertex normals from vertex positions. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Making sure all vertex normals are defined.' call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) ! ! Compute node normals by averaging vertex normals. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Averaging vertex normals at each node.' cor3_normal(1:3,1:cor3_num) = 0.0E+00 call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) ! ! Copy node normals into vertex normals. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Replacing vertex normals by average.' do iface = 1, face_num do ivert = 1, face_order(iface) icor3 = face(ivert,iface) vertex_normal(1:3,ivert,iface) = cor3_normal(1:3,icor3) end do end do ! ! Recompute zero face normals by averaging vertex normals. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Averaging vertex normals to get face normals.' call face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) ! ! QUIT: ! else if ( s_eqi ( command(1:1), 'Q' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - End of interaction.' ierror = 0 exit ! ! REVERSE: Reverse normal vectors. ! else if ( s_eqi ( command(1:3), 'REV' ) ) then cor3_normal(1:3,1:cor3_num) = - cor3_normal(1:3,1:cor3_num) face_normal(1:3,1:face_num) = - face_normal(1:3,1:face_num) do iface = 1, face_num do ivert = 1, face_order(iface) vertex_normal(1:3,ivert,iface) = - vertex_normal(1:3,ivert,iface) end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Note:' write ( *, '(a)' ) ' Reversed node, face and vertex normals.' ! ! RELAX: Smooth the surface via relaxation. ! else if ( s_eqi ( command(1:3), 'REL' ) ) then call node_relax ( cor3, cor3_max, cor3_new, cor3_num, face, face_max, & face_num, face_order, order_max ) cor3(1:3,1:cor3_num) = cor3_new(1:3,1:cor3_num) ! ! S: Select a few faces, discard rest: ! else if ( s_eqi ( command(1:1), 'S' ) ) then call face_subset ( cor3, cor3_max, cor3_num, face, face_material, & face_max, face_normal, face_num, face_order, ierror, line_num, & list, order_max, vertex_material, vertex_normal ) ! ! T: Transform data. ! else if ( s_eqi ( command(1:1), 'T' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'For now, we only offer point scaling.' write ( *, '(a)' ) 'Enter X, Y, Z scale factors:' read ( *, * ) x, y, z cor3(1,1:cor3_num) = cor3(1,1:cor3_num) * x cor3(2,1:cor3_num) = cor3(2,1:cor3_num) * y cor3(3,1:cor3_num) = cor3(3,1:cor3_num) * z call cor3_range ( cor3, cor3_max, cor3_num ) do iface = 1, face_num do ivert = 1, face_order(iface) vertex_normal(1:3,ivert,iface) = 0.0E+00 end do end do call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) cor3_normal(1:3,1:cor3_num) = 0.0E+00 call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) face_normal(1:3,1:face_num) = 0.0E+00 call face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) ! ! U: Renumber faces, count objects: ! else if ( s_eqi ( command(1:1), 'U' ) ) then call face_check ( edge, edge_max, edge_num, face, face_material, & face_max, face_normal, face_num, face_object, face_order, face_rank, & face_tier, object_num, order_max, vertex_material, vertex_normal ) ! ! V: Convert polygons to triangles. ! else if ( s_eqi ( command(1:1), 'V' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Convert polygonal faces to triangles.' call poly_2_tri ( face, face_material, face_max, face_num, face_order, & ierror, order_max, vertex_material ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Conversion attempt abandoned.' else write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'Number of faces is now ', face_num do iface = 1, face_num do ivert = 1, face_order(iface) vertex_normal(1:3,ivert,iface) = 0.0E+00 end do end do call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) cor3_normal(1:3,1:cor3_num) = 0.0E+00 call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) face_normal(1:3,1:face_num) = 0.0E+00 call face_normal_ave ( face_max, face_normal, face_num, face_order, & order_max, vertex_normal ) end if ! ! W: Reverse the order of the nodes that define each face. ! else if ( s_eqi ( command(1:1), 'W' ) ) then call face_reverse_order ( cor3_max, cor3_normal, cor3_num, face, & face_max, face_normal, face_num, face_order, order_max, & vertex_material, vertex_normal, vertex_tex_uv ) ! ! Unintelligible! ! else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' Your command was not recognized:' write ( *, '(a)' ) trim ( command ) end if if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTERACT - Warning!' write ( *, '(a)' ) ' An error occurred during this action.' ierror = 0 end if end do return end subroutine intnex ( line, ival, done ) ! !******************************************************************************* ! !! INTNEX "reads" integers from a string, one at a time. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) LINE, a string, presumably containing ! integers. These may be separated by spaces or commas. ! ! Output, integer IVAL. If DONE is FALSE, then IVAL contains the ! "next" integer read from LINE. If DONE is TRUE, then ! IVAL is zero. ! ! Input/output, logical DONE. ! On input with a fresh value of LINE, the user should set ! DONE to TRUE. ! On output, the routine sets DONE to FALSE if another integer ! was read, or TRUE if no more integers could be read. ! implicit none ! logical done integer ierror integer ival integer lchar character ( len = * ) line integer, save :: next = 1 ! ival = 0 if ( done ) then next = 1 done = .false. end if if ( next > len(line) ) then done = .true. return end if call s_to_i ( line(next:), ival, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then done = .true. next = 1 else done = .false. next = next + lchar end if return end subroutine iv_point_write ( cor3, cor3_max, cor3_num, filein_name, & fileout_name, line_dex, line_max, line_num, iunit ) ! !******************************************************************************* ! !! IV_POINT_WRITE writes point and line data to an Inventor file. ! ! ! Discussion: ! ! This routine is only called when there are no faces. In that ! case, extra effort is made to display the points and lines which ! ordinarily are not displayed when the faces carry the visual information. ! ! Example: ! ! #Inventor V2.0 ascii ! ! Separator { ! Info { ! string "Inventor file generated by IVREAD. ! Original data in file cube.iv." ! } ! Separator { ! LightModel { ! model PHONG ! } ! Coordinate3 { ! point [ ! 8.59816 5.55317 -3.05561, ! 8.59816 2.49756 0.000000E+00, ! ...etc... ! 2.48695 2.49756 -3.05561, ! ] ! } ! Material { diffuseColor 0.0 1.0 0.0 } ! IndexedLineSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! } ! Material { diffuseColor 1.0 0.0 0.0 } ! Transform { translation 1.0 1.0 1.0 } ! Sphere { radius 0.05 } ! Transform { translation 0.1 0.0 0.0 } ! Sphere { radius 0.05 } ! Transform { translation 0.0 0.1 0.0 } ! Sphere { radius 0.05 } ! Transform { translation 0.0 0.0 0.1 } ! Sphere { radius 0.05 } ! } ! } ! ! Modified: ! ! 13 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! implicit none ! integer cor3_max integer line_max ! real cor3(3,cor3_max) integer cor3_num character ( len = * ) filein_name character ( len = * ) fileout_name integer icor3 integer iunit integer j integer length integer line_dex(line_max) integer line_num character ( len = 100 ) text integer text_num character ( len = 20 ) word ! text_num = 0 write ( iunit, '(a)' ) '#Inventor V2.0 ascii' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'Separator {' write ( iunit, '(a)' ) ' Info {' write ( iunit, '(a)' ) ' string "' // trim ( fileout_name ) & // ' generated by IVREAD."' write ( iunit, '(a)' ) ' string "Original data in file ' // & trim ( filein_name ) // '."' write ( iunit, '(a)' ) ' }' write ( iunit, '(a)' ) ' Separator {' text_num = text_num + 8 write ( iunit, '(a)' ) ' LightModel {' write ( iunit, '(a)' ) ' model PHONG' write ( iunit, '(a)' ) ' }' text_num = text_num + 3 ! ! Point coordinates. ! write ( iunit, '(a)' ) ' Coordinate3 {' write ( iunit, '(a)' ) ' point [' text_num = text_num + 2 do icor3 = 1, cor3_num write ( text, '(3f12.4,'','')' ) cor3(1:3,icor3) call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 ! ! IndexedLineSet ! if ( line_num > 0 ) then write ( iunit, '(a)' ) ' Material { diffuseColor 0.0 1.0 0.0}' write ( iunit, '(a)' ) ' IndexedLineSet {' ! ! IndexedLineSet coordIndex ! write ( iunit, '(a)' ) ' coordIndex [' text_num = text_num + 2 text = ' ' length = 0 do j = 1, line_num write ( word, '(i8,'','')' ) line_dex(j) - 1 call s_cat ( text, word, text ) length = length + 1 if ( line_dex(j)-1 == -1 .or. length >= 10 .or. j >= line_num ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 end if ! ! Draw Spheres. ! write ( iunit, '(a)' ) ' Material { diffuseColor 1.0 0.0 0.0}' text_num = text_num + 1 do icor3 = 1, cor3_num if ( icor3 == 1 ) then write ( text, '(3f12.4)' ) cor3(1:3,icor3) else write ( text, '(3f12.4)' ) cor3(1:3,icor3) - cor3(1:3,icor3-1) end if call s_blanks_delete ( text ) write ( iunit, '(a)' ) ' Transform { translation ' // & trim ( text ) // '}' write ( iunit, '(a)' ) ' Sphere { radius 0.03 }' text_num = text_num + 2 end do ! ! Close up the Separator node. ! write ( iunit, '(a)' ) ' }' ! ! Close up the Separator node. ! write ( iunit, '(a)' ) '}' text_num = text_num + 2 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'IV_POINT_WRITE - Wrote ', text_num, & ' text lines to ' // trim ( fileout_name ) return end subroutine iv_read ( bad_num, cor3, cor3_max, cor3_num, & debug, face, face_max, face_num, face_order, filein_name, ierror, & iunit, line_dex, line_material, line_max, line_num, material_max, & material_num, material_rgba, order_max, text_num, & texture_max, texture_name, texture_num, texture_temp, & vertex_material, vertex_normal, vertex_tex_uv ) ! !******************************************************************************* ! !! IV_READ reads graphics information from an Inventor file. ! ! ! Diagnostics: ! ! For now, we are going to apply the following kludge, which is an ! improvement over the previous situation. The transform matrix ! will be initialized to the identity; every time a new transform ! matrix is specified, it will OVERWRITE the old one. Every point ! and vector that is read in will be multiplied by the current ! transform matrix. That's it for now. We need to start using ! the transform matrix, and eventually, we need to start using ! it more accurately than this. ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! #Inventor V2.0 ascii ! ! Separator { ! Info { ! string "Inventor file generated by IVREAD. ! Original data in file cube.iv." ! } ! Separator { ! LightModel { ! model PHONG ! } ! MatrixTransform { matrix ! 0.9 0.0 0.0 0.0E+00 ! 0.0 -0.9 0.0 0.0E+00 ! 0.0 0.0 -1.5 0.0E+00 ! 0.0 0.0 0.0 1.0E+00 ! } ! Material { ! ambientColor 0.2 0.2 0.2 ! diffuseColor [ ! 0.8 0.8 0.8, ! 0.7 0.1 0.1, ! 0.1 0.8 0.2, ! ] ! emissiveColor 0.0 0.0 0.0E+00 ! specularColor 0.0 0.0 0.0E+00 ! shininess 0.2 ! transparency [ ! 0.0, 0.5, 1.0, ! ] ! } ! Texture2 { ! filename "fred.rgb" ! wrapS REPEAT ! wrapT REPEAT ! model MODULATE ! blendColor 0.0 0.0 0.0E+00 ! } ! TextureCoordinateBinding { ! value PER_VERTEX_INDEXED ! } ! MaterialBinding { ! value PER_VERTEX_INDEXED ! } ! NormalBinding { ! value PER_VERTEX_INDEXED ! } ! ShapeHints { ! vertexOrdering COUNTERCLOCKWISE ! shapeType UNKNOWN_SHAPE_TYPE ! faceType CONVEX ! creaseAngle 6.28319 ! } ! Coordinate3 { ! point [ ! 8.59816 5.55317 -3.05561, ! 8.59816 2.49756 0.000000E+00, ! ...etc... ! 2.48695 2.49756 -3.05561, ! ] ! } ! TextureCoordinate2 { ! point [ ! 0.0 1.0, ! 0.1, 0.8, ! ...etc... ! 0.4 0.7, ! ] ! } ! Normal { ! vector [ ! 0.71 0.71 0.0, ! ...etc... ! 0.32 0.32 0.41, ! ] ! } ! ! IndexedLineSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! materialIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! } ! ! IndexedFaceSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! materialIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! normalIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! textureCoordIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! } ! ! IndexedTriangleStripSet { ! vertexProperty VertexProperty { ! vertex [ x y z, ! ... ! x y z ] ! normal [ x y z, ! ... ! x y z ] ! materialBinding OVERALL ! normalBinding PER_VERTEX_INDEXED ! } ! coordIndex [ i, j, k, l, m, -1, n, o, p, q, r, s, t, u, -1, ! v, w, x, -1 ..., -1 ] ! normalIndex -1 ! } ! ! } ! } ! ! Modified: ! ! 18 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BAD_NUM, number of bad lines of text read. ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input, logical DEBUG, debugging switch. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, integer LINE_DEX(LINE_MAX), nodes forming a line, ! terminated by -1. ! ! Input/output, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Input/output, integer LINE_NUM, the number of line definition items. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Input/output, integer TEXTURE_NUM, the number of textures. ! ! Output, integer TEXT_NUM, number of lines in the file. ! ! Input/output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture ! names. ! ! Workspace, real TEXTURE_TEMP(2,ORDER_MAX*FACE_MAX), texture coordinates. ! ! Output, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Input/output, integer VERTEX_MATERIAL(ORDER_MAX,FACE_MAX), vertex ! materials. ! ! Output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! ! Input/output, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer, parameter :: level_max = 10 integer line_max integer material_max integer order_max integer texture_max ! real b integer bad_num character ( len = 4 ) char4 real cor3(3,cor3_max) integer cor3_num integer cor3_num_old logical debug logical done integer face(order_max,face_max) integer face_num integer face_num2 integer face_order(face_max) character ( len = * ) filein_name real g integer i integer icol integer icolor integer ierror integer iface integer iface_num integer ios integer iprint integer irow integer iunit integer iuv integer ivert integer iword integer ix integer ixyz integer iy integer iz integer jval integer k integer level character ( len = 256 ) level_name(0:level_max) integer line_dex(line_max) integer line_material(line_max) integer line_num integer line_num2 logical lval ! character ( len = 30 ) material_binding integer material_default integer material_num integer material_num_old real material_rgba(4,material_max) integer nlbrack integer normal_bad_num ! character ( len = 30 ) normal_binding real normal_temp(3,order_max*face_max) integer normal_temp_num integer nrbrack integer nu integer nv integer, parameter :: OFFSET = 1 real r real r3vec(3) real rgb(3) real rval logical s_eqi logical s_is_i character ( len = 256 ) text integer text_num ! character ( len = 30 ) texture_coordinate_binding character ( len = * ) texture_name(texture_max) integer texture_num real texture_temp(2,order_max*face_max) integer texture_temp_num real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) real vertex_tex_uv(2,order_max,face_max) character ( len = 256 ) word character ( len = 256 ) wordm1 ! cor3_num_old = cor3_num face_num2 = face_num icol = 0 ierror = 0 iface_num = face_num iprint = 1 irow = 0 iuv = 0 ix = 0 ixyz = 0 iy = 0 iz = 0 jval = 0 level = 0 level_name(0) = 'Top' line_num2 = line_num material_num_old = material_num ! material_binding = 'PER_VERTEX_INDEXED' material_default = 1 nlbrack = 0 normal_bad_num = 0 ! normal_binding = 'PER_VERTEX_INDEXED' normal_temp_num = 0 nrbrack = 0 nu = 0 nv = 0 rval = 0.0E+00 texture_temp_num = 0 call tmat_init ( transform_matrix ) word = ' ' wordm1 = ' ' ! ! Read a line of text from the file. ! do read ( iunit, '(a)', iostat = ios ) text if ( ios /= 0 ) then exit end if text_num = text_num + 1 if ( debug ) then if ( text_num == iprint ) then write ( *, '(a,i6)' ) 'Line ', iprint iprint = 2 * iprint end if end if if ( text == ' ' ) then cycle end if ! ! The first line of the file must be the header. ! if ( text_num == 1 ) then if ( .not. s_eqi ( text(1:9), '#Inventor' ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IV_READ - Fatal error!' write ( *, '(a)' ) ' The input file has a bad header.' write ( *, '(a)' ) trim ( text ) return else cycle end if end if done = .true. iword = 0 ! ! Save the previous word read. It helps when a word depends ! on its context. ! 20 continue if ( word /= ' ' .and. word /= ',' ) then wordm1 = word end if ! ! Read a word from the line. ! call word_next_read ( text, word, done ) ! ! If no more words in this line, read in a whole new line. ! if ( done ) then cycle end if ! ! Skip over comments. ! if ( word(1:1) == '#' ) then cycle end if ! ! Ignore blanks and commas. ! if ( word == ' ' .or. word == ',' ) then go to 20 end if ! ! Count the words in the current line, and the total. ! iword = iword + 1 ! ! If the word is a curly or square bracket, count it. ! if ( word == '{' .or. word == '[' ) then nlbrack = nlbrack + 1 if ( debug ) then write ( *, '(a)' ) word(1:1) end if else if ( word .eq. '}' .or. word == ']' ) then if ( debug ) then write ( *, '(a)' ) word(1:1) end if nrbrack = nrbrack + 1 if ( nlbrack < nrbrack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IV_READ - Fatal error!' write ( *, '(a,i6)' ) ' Extraneous right bracket, line ', text_num write ( *, '(a)' ) trim ( text ) write ( *, '(a)' ) 'Currently processing field:' write ( *, '(a)' ) trim ( level_name(level) ) ierror = 1 return end if end if ! ! If the word is a left bracket, then the previous word ! is the name of a node. ! if ( word == '{' .or. word == '[' ) then level = nlbrack - nrbrack if ( level < 0 ) then write ( *, '(a)' ) 'Too many right brackets!' level = 0 else if ( level > level_max ) then write ( *, '(a)' ) 'Too many left brackets!' level = level_max end if level_name(level) = wordm1 if ( debug ) then write ( *, '(a)' ) ' ' do i = 0, level write ( *, '(i3,2x,a)' ) i, trim ( level_name(i) ) end do end if end if ! ! BASECOLOR ! if ( s_eqi ( level_name(level), 'BASECOLOR' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'RGB' ) ) then else go to 99 end if ! ! COORDINATE3 ! else if ( s_eqi ( level_name(level), 'COORDINATE3' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'POINT' ) ) then else go to 99 end if ! ! COORDINATE4 ! else if ( s_eqi ( level_name(level), 'COORDINATE4' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'POINT' ) ) then else go to 99 end if ! ! COORDINDEX ! else if ( s_eqi ( level_name(level), 'COORDINDEX' ) ) then if ( word == '[' ) then ivert = 0 else if ( word == ']' ) then level = nlbrack - nrbrack ! ! (indexedlineset) COORDINDEX ! else if ( s_eqi ( level_name(level-1), 'INDEXEDLINESET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then if ( jval < -1 ) then bad_num = bad_num + 1 else line_num = line_num + 1 if ( line_num <= line_max ) then if ( jval == -1 ) then line_material(line_num) = -1 + OFFSET else line_material(line_num) = material_default jval = jval + cor3_num_old end if line_dex(line_num) = jval + OFFSET end if end if else go to 99 end if ! ! (indexedfaceset) COORDINDEX ! else if ( s_eqi ( level_name(level-1), 'INDEXEDFACESET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then if ( jval == -1 ) then ivert = 0 else ivert = ivert + 1 if ( ivert == 1 ) then face_num = face_num + 1 if ( face_num <= face_max ) then face_order(face_num) = 0 end if end if if ( face_num <= face_max ) then face_order(face_num) = face_order(face_num) + 1 if ( ivert <= order_max ) then face(ivert,face_num) = jval + cor3_num_old + OFFSET end if end if vertex_material(ivert,face_num) = material_default end if end if ! ! (indexednurbssurface) COORDINDEX ! else if ( s_eqi ( level_name(level-1), 'INDEXEDNURBSSURFACE' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then else if ( word == '[' ) then else if ( word == ']' ) then do i = 1, nu-1 line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = i - 1 + cor3_num_old + OFFSET end if end do do i = nu, nu*(nv-1), nu line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = i - 1 + cor3_num_old + OFFSET end if end do do i = nu*nv, nu*nv-nu+2, -1 line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = i - 1 + cor3_num_old + OFFSET end if end do do i = nu*(nv-1)+1, 1, -nu line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = i - 1 + cor3_num_old + OFFSET end if end do line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET end if end if ! ! (indexedtrianglestripset) COORDINDEX ! ! First three coordinate indices I1, I2, I3 define a triangle. ! Next triangle is defined by I2, I3, I4 (actually, I4, I3, I2 ! to stay with same counterclockwise sense). ! Next triangle is defined by I3, I4, I5 ( don't need to reverse ! odd numbered triangles) and so on. ! List is terminated with -1. ! else if ( s_eqi ( level_name(level-1), 'INDEXEDTRIANGLESTRIPSET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then if ( jval == -1 ) then ivert = 0 else ivert = ivert + 1 ix = iy iy = iz iz = jval + cor3_num_old if ( ivert == 1 ) then face_num = face_num + 1 if ( face_num <= face_max ) then face(ivert,face_num) = jval + cor3_num_old + OFFSET face_order(face_num) = 3 end if else if ( ivert == 2 .or. ivert == 3 ) then if ( face_num <= face_max ) then face(ivert,face_num) = jval + cor3_num_old + OFFSET end if else face_num = face_num + 1 if ( face_num <= face_max ) then face_order(face_num) = 3 if ( mod ( ivert, 2 ) == 1 ) then face(1,face_num) = ix + OFFSET face(2,face_num) = iy + OFFSET face(3,face_num) = iz + OFFSET else face(1,face_num) = iz + OFFSET face(2,face_num) = iy + OFFSET face(3,face_num) = ix + OFFSET end if end if end if ! ! ??? This can't be right.??? ! ! Very very tentative guess as to how indices into the normal ! vector array are set up... ! ! if ( face_num <= face_max .and. ivert >= 3 ) then ! do j = 1, order_max ! vertex_normal(1:3,j,face_num) = normal(1:3,ix + OFFSET) ! end do ! end if end if end if end if ! ! INDEXEDFACESET ! else if ( s_eqi ( level_name(level), 'INDEXEDFACESET' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'COORDINDEX' ) ) then ivert = 0 ! ! 19 October 2001 ! ! If material binding is per node indexed... ! else if ( s_eqi ( word, 'MATERIALINDEX' ) ) then else if ( s_eqi ( word, 'NORMALINDEX' ) ) then else if ( s_eqi ( word, 'TEXTURECOORDINDEX' ) ) then if ( texture_num <= 0 ) then texture_num = 1 call i_to_s_zero ( texture_num, char4 ) texture_name(texture_num) = 'Texture_' // char4 end if else go to 99 end if ! ! INDEXEDLINESET ! else if ( s_eqi ( level_name(level), 'INDEXEDLINESET' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'COORDINDEX' ) ) then ! ! 19 October 2001: ! If I start collecting this data, then I have to allow lines to ! have materials by line, by segment, or by vertex... ! else if ( s_eqi ( word, 'MATERIALINDEX' ) ) then else go to 99 end if ! ! INDEXEDNURBSSURFACE ! else if ( s_eqi ( level_name(level), 'INDEXEDNURBSSURFACE' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'NUMUCONTROLPOINTS') ) then call word_next_read ( text, word, done ) lval = s_is_i ( word, jval ) if ( lval ) then nu = jval else nu = 0 go to 99 end if else if ( s_eqi ( word, 'NUMVCONTROLPOINTS' ) ) then call word_next_read ( text, word, done) lval = s_is_i ( word, jval ) if ( lval ) then nv = jval else nv = 0 go to 99 end if else if ( s_eqi ( word, 'COORDINDEX' ) ) then else if ( s_eqi ( word, 'UKNOTVECTOR' ) ) then else if ( s_eqi ( word, 'VKNOTVECTOR' ) ) then else go to 99 end if ! ! INDEXEDTRIANGLESTRIPSET ! else if ( s_eqi ( level_name(level), 'INDEXEDTRIANGLESTRIPSET' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VERTEXPROPERTY' ) ) then call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'COORDINDEX' ) ) then ivert = 0 else if ( s_eqi ( word, 'NORMALINDEX' ) ) then call word_next_read ( text, word, done ) if ( word == '[' ) then nlbrack = nlbrack + 1 level = level + 1 level_name(level) = 'NORMALINDEX' else if ( word == '-1' ) then do iface = 1, face_num do ivert = 1, face_order(iface) k = face(ivert,iface) vertex_normal(1:3,ivert,iface) = normal_temp(1:3,k) end do end do end if else go to 99 end if ! ! INFO ! else if ( s_eqi ( level_name(level), 'INFO' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'STRING' ) ) then else if ( word == '"' ) then else end if ! ! LIGHTMODEL ! ! Read, but ignore. ! else if ( s_eqi ( level_name(level), 'LIGHTMODEL' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'MODEL' ) ) then else end if ! ! MATERIAL ! ! Read, but ignore for now, except that the ambient color information ! is used to set (default) material #1. ! else if ( s_eqi ( level_name(level), 'MATERIAL' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'AMBIENTCOLOR' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, g, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, b, lval ) material_rgba(1:3,1) = (/ r, g, b /) else if ( s_eqi ( word, 'EMISSIVECOLOR' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, g, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, b, lval ) else if ( s_eqi ( word, 'DIFFUSECOLOR' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, g, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, b, lval ) else if ( s_eqi ( word, 'SHININESS' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) else if ( s_eqi ( word, 'SPECULARCOLOR' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, g, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, b, lval ) else if ( s_eqi ( word, 'TRANSPARENCY' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) else end if ! ! MATERIALBINDING ! ! OVERALL: Whole object has same material; ! PER_FACE: One material for each face; ! PER_FACE_INDEXED: One material for each face, indexed; ! PER_PART: One material for each part; ! PER_PART_INDEXED: One material for each part, indexed; ! PER_VERTEX: One material for each vertex; ! PER_VERTEX_INDEXED: One material for each vertex, indexed. ! else if ( s_eqi ( level_name(level), 'MATERIALBINDING' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VALUE' ) ) then call word_next_read ( text, word, done ) ! material_binding = word else bad_num = bad_num + 1 write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( text ) end if ! ! MATERIALINDEX ! else if ( s_eqi ( level_name(level), 'MATERIALINDEX' ) ) then if ( word == '[' ) then ivert = 0 else if ( word == ']' ) then level = nlbrack - nrbrack ! ! (indexedfaceset) MATERIALINDEX ! else if ( s_eqi ( level_name(level-1), 'INDEXEDFACESET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then if ( jval == -1 ) then ivert = 0 else ivert = ivert + 1 if ( ivert == 1 ) then face_num2 = face_num2 + 1 end if if ( face_num2 <= face_max ) then if ( jval /= -1 ) then jval = jval + cor3_num_old end if vertex_material(ivert,face_num2) = jval + OFFSET end if end if else go to 99 end if ! ! (indexedlineset) MATERIALINDEX ! else if ( s_eqi ( level_name(level-1), 'INDEXEDLINESET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then line_num2 = line_num2 + 1 if ( line_num2 <= line_max ) then if ( jval /= -1 ) then ! jval = jval + cor3_num_old jval = jval + material_num_old end if line_material(line_num2) = jval + OFFSET end if else go to 99 end if else lval = s_is_i ( word, jval ) if ( lval ) then else go to 99 end if end if ! ! MATRIXTRANSFORM ! else if ( s_eqi ( level_name(level), 'MATRIXTRANSFORM' ) ) then if ( word == '{' ) then else if ( word == '}' ) then if ( irow /= 4 .or. icol .ne. 4 ) then write ( *, '(a)' ) 'Incomplete MatrixTransform!' end if level = nlbrack - nrbrack else if ( s_eqi ( word, 'MATRIX' ) ) then irow = 1 icol = 0 else call s_is_r ( word, rval, lval ) if ( lval ) then icol = icol + 1 if ( icol > 4 ) then icol = 1 irow = irow + 1 if ( irow > 4 ) then go to 99 end if end if transform_matrix(irow,icol) = rval else go to 99 end if end if ! ! NORMAL ! ! The field "VECTOR" may be followed by three numbers, ! (handled here), or by a square bracket, and sets of three numbers. ! else if ( s_eqi ( level_name(level), 'NORMAL' ) ) then ! ! (vertexproperty) NORMAL ! Just stick the normal vectors into NORMAL_TEMP for now, ! retrieve them at COORDINDEX time. ! if ( s_eqi ( level_name(level-1), 'VERTEXPROPERTY' ) ) then if ( word == '[' ) then ixyz = 0 else if ( word == ']' ) then level = nlbrack - nrbrack else call s_is_r ( word, rval, lval ) if ( lval ) then ixyz = ixyz + 1 if ( ixyz > 3 ) then ixyz = 1 end if if ( ixyz == 1 ) then normal_temp_num = normal_temp_num + 1 end if if ( normal_temp_num <= order_max*face_max ) then r3vec(ixyz) = rval if ( ixyz == 3 ) then call tmat_mxv ( transform_matrix, r3vec, r3vec ) normal_temp(1:3,normal_temp_num) = r3vec(1:3) end if end if else go to 99 end if end if ! ! (anythingelse) NORMAL. ! else if ( word == '{' ) then ixyz = 0 normal_temp_num = 0 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VECTOR' ) ) then else go to 99 end if end if ! ! NORMALBINDING ! OVERALL: Whole object has same normal. ! PER_FACE: One normal per face; ! PER_FACE_INDEXED: one normal per face, indexed; ! PER_FACE: one normal per part; ! PER_FACE_INDEXED: one normal per part, indexed. ! PER_VERTEX: one normal per vertex; ! PER_VERTEX_INDEXED: one normal per vertex, indexed. ! else if ( s_eqi ( level_name(level), 'NORMALBINDING' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VALUE' ) ) then call word_next_read ( text, word, done ) ! normal_binding = word else bad_num = bad_num + 1 write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( text ) end if ! ! NORMALINDEX ! else if ( s_eqi ( level_name(level), 'NORMALINDEX' ) ) then ! ! (indexedtrianglestripset) NORMALINDEX ! if ( s_eqi ( level_name(level-1), 'INDEXEDTRIANGLESTRIPSET' ) ) then lval = s_is_i ( word, jval ) if ( lval ) then else if ( word == '[' ) then else if ( word == ']' ) then level = nlbrack - nrbrack end if ! ! (indexedFaceSet) NORMALINDEX ! else if ( word == '[' ) then ivert = 0 else if ( word == ']' ) then level = nlbrack - nrbrack else lval = s_is_i ( word, jval ) if ( lval ) then if ( jval == -1 ) then ivert = 0 else ivert = ivert + 1 if ( ivert == 1 ) then iface_num = iface_num + 1 end if if ( iface_num <= face_max .and. jval <= normal_temp_num ) then vertex_normal(1:3,ivert,iface_num) = normal_temp(1:3,jval + OFFSET) end if end if else go to 99 end if end if end if ! ! (coordinate3) POINT ! else if ( s_eqi ( level_name(level), 'POINT' ) ) then if ( s_eqi ( level_name(level-1), 'COORDINATE3' ) ) then if ( word == '[' ) then ixyz = 0 cor3_num_old = cor3_num else if ( word == ']' ) then level = nlbrack - nrbrack else call s_is_r ( word, rval, lval ) if ( lval ) then ixyz = ixyz + 1 if ( ixyz > 3 ) then ixyz = 1 end if r3vec(ixyz) = rval if ( ixyz == 3 ) then cor3_num = cor3_num + 1 call tmat_mxp ( transform_matrix, r3vec, r3vec ) if ( cor3_num <= cor3_max ) then cor3(1:3,cor3_num) = r3vec(1:3) end if end if else go to 99 end if end if ! ! (texturecoordinate2) POINT ! else if ( s_eqi ( level_name(level-1), 'TEXTURECOORDINATE2' ) ) then if ( word == '[' ) then iuv = 0 texture_temp_num = 0 else if ( word == ']' ) then level = nlbrack - nrbrack else call s_is_r ( word, rval, lval ) if ( lval ) then iuv = iuv + 1 if ( iuv > 2 ) then iuv = 1 end if texture_temp(iuv,texture_temp_num+1) = rval if ( iuv == 2 ) then texture_temp_num = texture_temp_num + 1 end if else go to 99 end if end if end if ! ! RGB ! else if ( s_eqi ( level_name(level), 'RGB' ) ) then if ( s_eqi ( level_name(level-1), 'BASECOLOR' ) ) then if ( word == '[' ) then icolor = 0 else if ( word == ']' ) then level = nlbrack - nrbrack else call s_is_r ( word, rval, lval ) if ( lval ) then icolor = icolor + 1 rgb(icolor) = rval if ( icolor == 3 ) then material_num = material_num + 1 material_rgba(1:3,material_num) = rgb(1:3) icolor = 0 end if else go to 99 end if end if end if ! ! SEPARATOR ! else if ( s_eqi ( level_name(level), 'SEPARATOR' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else end if ! ! SHAPEHINTS ! ! Read, but ignore. ! else if ( s_eqi ( level_name(level), 'SHAPEHINTS' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'CREASEANGLE' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, rval, lval ) else if ( s_eqi ( word, 'FACETYPE' ) ) then call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'SHAPETYPE' ) ) then call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'VERTEXORDERING' ) ) then call word_next_read ( text, word, done ) else go to 99 end if ! ! TEXTURE2 ! else if ( s_eqi ( level_name(level), 'TEXTURE2' ) ) then if ( word == '{' ) then texture_num = texture_num + 1 else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'BLENDCOLOR' ) ) then call word_next_read ( text, word, done ) call s_is_r ( word, r, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, g, lval ) call word_next_read ( text, word, done ) call s_is_r ( word, b, lval ) else if ( s_eqi ( word, 'FILENAME' ) ) then call word_next_read ( text, word, done ) call word_next_read ( text, word, done ) texture_name(texture_num) = word call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'IMAGE' ) ) then go to 99 else if ( s_eqi ( word, 'MODEL' ) ) then call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'WRAPS' ) ) then call word_next_read ( text, word, done ) else if ( s_eqi ( word, 'WRAPT' ) ) then call word_next_read ( text, word, done ) else end if ! ! TEXTURECOORDINATE2 ! else if ( s_eqi ( level_name(level), 'TEXTURECOORDINATE2' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'POINT' ) ) then else go to 99 end if ! ! TEXTURECOORDINATEBINDING ! ! PER_VERTEX: One texture coordinate for each vertex; ! PER_VERTEX_INDEXED: One texture coordinate for each vertex, indexed. ! else if ( s_eqi ( level_name(level), 'TEXTURECOORDINATEBINDING' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VALUE' ) ) then call word_next_read ( text, word, done ) ! texture_coordinate_binding = word else bad_num = bad_num + 1 write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( text ) end if ! ! TEXTURECOORDINDEX ! else if ( s_eqi ( level_name(level), 'TEXTURECOORDINDEX' ) ) then if ( word == '[' ) then ivert = 0 iface = 0 else if ( word == ']' ) then level = nlbrack - nrbrack else lval = s_is_i ( word, jval ) if ( lval ) then if ( jval == -1 ) then ivert = 0 else ivert = ivert + 1 if ( ivert == 1 ) then iface = iface + 1 end if if ( iface <= face_max ) then vertex_tex_uv(1:2,ivert,iface) = texture_temp(1:2,jval + OFFSET) end if end if else go to 99 end if end if ! ! UKNOTVECTOR ! else if ( s_eqi ( level_name(level), 'UKNOTVECTOR' ) ) then if ( word == '[' ) then go to 20 else if ( word == ']' ) then level = nlbrack - nrbrack go to 20 else lval = s_is_i ( word, jval ) end if ! ! VECTOR ! else if ( s_eqi ( level_name(level), 'VECTOR' ) ) then if ( word == '[' ) then else if ( word == ']' ) then level = nlbrack - nrbrack ! ! (normal) VECTOR. ! For some reason, Joel's program is spewing out occasional ! NAN normal vectors. This should not halt the program. ! else if ( s_eqi ( level_name(level-1), 'NORMAL' ) ) then if ( word(1:13) == 'nan0x7ffffe00' ) then lval = .true. rval = 1.0E+00 / sqrt ( 3.0E+00 ) normal_bad_num = normal_bad_num + 1 else call s_is_r ( word, rval, lval ) end if if ( lval ) then ixyz = ixyz + 1 if ( ixyz > 3 ) then ixyz = 1 end if if ( ixyz == 1 ) then normal_temp_num = normal_temp_num + 1 end if r3vec(ixyz) = rval if ( ixyz == 3 ) then if ( normal_temp_num <= order_max * face_max ) then normal_temp(1:3,normal_temp_num) = r3vec(1:3) end if end if else go to 99 end if end if ! ! (vertexproperty) VERTEX ! else if ( s_eqi ( level_name(level), 'VERTEX' ) ) then if ( s_eqi ( level_name(level-1), 'VERTEXPROPERTY' ) ) then if ( word == '[' ) then ixyz = 0 cor3_num_old = cor3_num else if ( word == ']' ) then level = nlbrack - nrbrack else call s_is_r ( word, rval, lval ) if ( lval ) then ixyz = ixyz + 1 if ( ixyz > 3 ) then ixyz = 1 end if if ( cor3_num+1 <= cor3_max ) then cor3(ixyz,cor3_num+1) = rval end if if ( ixyz == 3 ) then cor3_num = cor3_num + 1 end if else go to 99 end if end if end if ! ! (indexedtrianglestripset) VERTEXPROPERTY ! else if ( s_eqi ( level_name(level), 'VERTEXPROPERTY' ) ) then if ( word == '{' ) then else if ( word == '}' ) then level = nlbrack - nrbrack else if ( s_eqi ( word, 'VERTEX' ) ) then else if ( s_eqi ( word, 'MATERIALBINDING' ) ) then call word_next_read ( text, word, done ) ! material_binding = word else if ( s_eqi ( word, 'NORMAL' ) ) then ixyz = 0 else if ( s_eqi ( word, 'NORMALBINDING' ) ) then call word_next_read ( text, word, done ) ! normal_binding = word else go to 99 end if ! ! VKNOTVECTOR ! else if ( s_eqi ( level_name(level), 'VKNOTVECTOR' ) ) then if ( word == '[' ) then go to 20 else if ( word == ']' ) then level = nlbrack - nrbrack go to 20 else lval = s_is_i ( word, jval ) end if ! ! Any other word: ! else end if go to 20 ! ! Bad data ! 99 continue bad_num = bad_num + 1 if ( bad_num <= 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IV_READ - Warning!' write ( *, '(a)' ) ' Bad data on level ' // trim ( level_name(level) ) write ( *, '(a)' ) ' Bad word: ' // trim ( word ) write ( *, '(a,i6)' ) ' Line number: ', text_num write ( *, '(a)' ) trim ( text ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IV_READ - Fatal error!' write ( *, '(a)' ) ' Too many warnings!' return end if end do ! ! End of information in file. ! ! ! Reset the transformation matrix to the identity, cause we ! went ahead and applied it. ! call tmat_init ( transform_matrix ) ! ! Check the "materials" defining a line. ! ! If COORDINDEX is -1, so should be the MATERIALINDEX. ! If COORDINDEX is not -1, then the MATERIALINDEX shouldn't be either. ! do i = 1, line_num if ( line_dex(i) == -1 + OFFSET ) then line_material(i) = -1 + OFFSET else if ( line_material(i) == -1 + OFFSET ) then line_material(i) = material_num end if end do ! ! Complain once about bad entries in normal vectors. ! if ( normal_bad_num > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IV_READ - Warning!' write ( *, '(i6,a)' ) normal_bad_num, ' bad normal vector entries.' end if ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'IV_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine iv_write ( cor3, cor3_max, cor3_normal, cor3_num, face, & face_max, face_num, face_order, filein_name, fileout_name, & iunit, line_dex, line_material, line_max, line_num, material_max, & material_num, material_rgba, order_max, texture_max, & texture_num, texture_name, vertex_material, vertex_tex_uv ) ! !******************************************************************************* ! !! IV_WRITE writes graphics data to an Inventor file. ! ! ! Example: ! ! #Inventor V2.0 ascii ! ! Separator { ! Info { ! string "Inventor file generated by IVREAD. ! Original data in file cube.iv." ! } ! Separator { ! LightModel { ! model PHONG ! } ! MatrixTransform { matrix ! 0.9 0.0 0.0 0.0 ! 0.0 -0.9 0.0 0.0 ! 0.0 0.0 -1.5 0.0 ! 0.0 0.0 0.0 1.0 ! } ! Material { ! ambientColor 0.2 0.2 0.2 ! diffuseColor [ ! 0.8 0.8 0.8, ! 0.7 0.1 0.1, ! 0.1 0.8 0.2, ! ] ! emissiveColor 0.0 0.0 0.0 ! specularColor 0.0 0.0 0.0 ! shininess 0.2 ! transparency [ ! 0.0, 0.5, 1.0, ! ] ! } ! Texture2 { ! filename "fred.rgb" ! wrapS REPEAT ! wrapT REPEAT ! model MODULATE ! blendColor 0.0 0.0 0.0 ! } ! TextureCoordinateBinding { ! value PER_VERTEX_INDEXED ! } ! MaterialBinding { ! value PER_VERTEX_INDEXED ! } ! NormalBinding { ! value PER_VERTEX_INDEXED ! } ! ShapeHints { ! vertexOrdering COUNTERCLOCKWISE ! shapeType UNKNOWN_SHAPE_TYPE ! faceType CONVEX ! creaseAngle 6.28319 ! } ! Coordinate3 { ! point [ ! 8.59816 5.55317 -3.05561, ! 8.59816 2.49756 0.000000, ! ...etc... ! 2.48695 2.49756 -3.05561, ! ] ! } ! TextureCoordinate2 { ! point [ ! 0.0 1.0, ! 0.1, 0.8, ! ...etc... ! 0.4 0.7, ! ] ! } ! Normal { ! vector [ ! 0.71 0.71 0.0, ! ...etc... ! 0.32 0.32 0.41, ! ] ! } ! ! IndexedLineSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! materialIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! } ! ! IndexedFaceSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! materialIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! normalIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! textureCoordIndex [ ! 0, 0, 0, -1, 1, 1, 1, -1, 2, 2, 2, ! ...etc... ! 64, -1, ! ] ! } ! ! IndexedTriangleStripSet { ! vertexProperty VertexProperty { ! vertex [ x y z, ! ... ! x y z ] ! normal [ x y z, ! ... ! x y z ] ! materialBinding OVERALL ! normalBinding PER_VERTEX_INDEXED ! } ! coordIndex [ i, j, k, l, m, -1, n, o, p, q, r, s, t, u, -1, ! v, w, x, -1 ..., -1 ] ! normalIndex -1 ! } ! ! } ! } ! ! Modified: ! ! 18 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, real COR3_NORMAL(3,COR3_MAX), normals at nodes. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MATERIAL(LINE_MAX), the material of each line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer MATERIAL_NUM, the number of materials. ! ! Input, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and A values. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_NUM, the number of textures. ! ! Input, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Input, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input, real VERTEX_TEX_UV(2,ORDER_MAX,FACE_MAX), vertex texture ! coordinates. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max integer texture_max ! real cor3(3,cor3_max) real cor3_normal(3,cor3_max) integer cor3_num integer face(order_max,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name integer i integer icor3 integer iface integer ihi integer ilo integer itemp integer iunit integer ivert integer j integer jtemp integer length integer line_dex(line_max) integer line_material(line_max) integer line_num integer material_num real material_rgba(4,material_max) integer ndx integer, parameter :: OFFSET = 1 character ( len = 200 ) text integer text_num character ( len = * ) texture_name(texture_max) integer texture_num real transform_matrix(4,4) integer vertex_material(order_max,face_max) real vertex_tex_uv(2,order_max,face_max) character ( len = 20 ) word ! text_num = 0 write ( iunit, '(a)' ) '#Inventor V2.0 ascii' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'Separator {' write ( iunit, '(a)' ) ' Info {' write ( iunit, '(a)' ) ' string "' // trim ( fileout_name ) & // ' generated by IVREAD."' write ( iunit, '(a)' ) ' string "Original data in file ' // & trim ( filein_name ) // '."' write ( iunit, '(a)' ) ' }' write ( iunit, '(a)' ) ' Separator {' text_num = text_num + 8 ! ! LightModel: ! ! BASE_COLOR ignores light sources, and uses only diffuse color ! and transparency. Even without normal vector information, ! the object will show up. However, you won't get shadow ! and lighting effects. ! ! PHONG uses the Phong lighting model, accounting for light sources ! and surface orientation. This is the default. I believe ! you need accurate normal vector information in order for this ! option to produce nice pictures. ! ! DEPTH ignores light sources, and calculates lighting based on ! the location of the object within the near and far planes ! of the current camera's view volume. ! write ( iunit, '(a)' ) ' LightModel {' write ( iunit, '(a)' ) ' model PHONG' write ( iunit, '(a)' ) ' }' text_num = text_num + 3 ! ! Transformation matrix. ! call tmat_init ( transform_matrix ) write ( iunit, '(a)' ) ' MatrixTransform { matrix' do i = 1, 4 write ( iunit, '(8x,4g14.6)' ) transform_matrix(i,1:4) end do write ( iunit, '(a)' ) ' }' ! ! Material ! I think you're only allowed one ambient color. We take that from ! material 1. ! write ( iunit, '(a)' ) ' Material {' write ( iunit, '(a,3f7.3)' ) ' ambientColor ', material_rgba(1:3,1) write ( iunit, '(a)' ) ' diffuseColor [' text_num = text_num + 3 do i = 1, material_num write ( iunit, '(8x,3f8.4,'','')' ) material_rgba(1:3,i) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' emissiveColor 0.0 0.0 0.0' write ( iunit, '(a)' ) ' specularColor 0.0 0.0 0.0' write ( iunit, '(a)' ) ' shininess 0.2' write ( iunit, '(a)' ) ' transparency [' text_num = text_num + 4 do ilo = 1, material_num, 10 ihi = min ( ilo + 9, material_num ) write ( iunit, '(8x,10(f7.3,'',''))' ) 1.0E+00 - material_rgba(4,ilo:ihi) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 ! ! TEXTURE2 ! ! FLAW: We can only handle one texture right now. ! if ( texture_num > 0 ) then write ( iunit, '(a)' ) ' Texture2 {' write ( iunit, '(a)' ) ' filename "' // trim ( texture_name(1) ) & // '"' write ( iunit, '(a)' ) ' wrapS REPEAT' write ( iunit, '(a)' ) ' wrapT REPEAT' write ( iunit, '(a)' ) ' model MODULATE' write ( iunit, '(a)' ) ' blendColor 0.0 0.0 0.0' write ( iunit, '(a)' ) ' }' text_num = text_num + 7 end if ! ! TextureCoordinateBinding ! write ( iunit, '(a)' ) ' TextureCoordinateBinding {' write ( iunit, '(a)' ) ' value PER_VERTEX_INDEXED' write ( iunit, '(a)' ) ' }' text_num = text_num + 3 ! ! MaterialBinding ! write ( iunit, '(a)' ) ' MaterialBinding {' write ( iunit, '(a)' ) ' value PER_VERTEX_INDEXED' write ( iunit, '(a)' ) ' }' text_num = text_num + 3 ! ! NormalBinding ! ! PER_VERTEX promises that we will write a list of normal vectors ! in a particular order, namely, the normal vectors for the vertices ! of the first face, then the second face, and so on. ! ! PER_VERTEX_INDEXED promises that we will write a list of normal vectors, ! and then, as part of the IndexedFaceSet, we will give a list of ! indices referencing this normal vector list. ! write ( iunit, '(a)' ) ' NormalBinding {' write ( iunit, '(a)' ) ' value PER_VERTEX_INDEXED' write ( iunit, '(a)' ) ' }' text_num = text_num + 3 ! ! ShapeHints ! write ( iunit, '(a)' ) ' ShapeHints {' write ( iunit, '(a)' ) ' vertexOrdering COUNTERCLOCKWISE' write ( iunit, '(a)' ) ' shapeType UNKNOWN_SHAPE_TYPE' write ( iunit, '(a)' ) ' faceType CONVEX' write ( iunit, '(a)' ) ' creaseAngle 6.28319' write ( iunit, '(a)' ) ' }' text_num = text_num + 6 ! ! Point coordinates. ! write ( iunit, '(a)' ) ' Coordinate3 {' write ( iunit, '(a)' ) ' point [' text_num = text_num + 2 do icor3 = 1, cor3_num write ( text, '(3f12.4,'','')' ) cor3(1:3,icor3) call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 ! ! Texture coordinates. ! if ( texture_num > 0 ) then write ( iunit, '(a)' ) ' TextureCoordinate2 {' write ( iunit, '(a)' ) ' point [' text_num = text_num + 2 do iface = 1, face_num do ivert = 1, face_order(iface) write ( text, '(2f12.4,'','')' ) vertex_tex_uv(1:2,ivert,iface) call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 end do end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 end if ! ! Normal vectors. ! Use the normal vectors associated with nodes. ! if ( face_num > 0 ) then write ( iunit, '(a)' ) ' Normal { ' write ( iunit, '(a)' ) ' vector [' text_num = text_num + 2 do icor3 = 1, cor3_num write ( text, '(3f12.4,'','')' ) cor3_normal(1:3,icor3) call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 end if ! ! IndexedLineSet ! if ( line_num > 0 ) then write ( iunit, '(a)' ) ' IndexedLineSet {' ! ! IndexedLineSet coordIndex ! write ( iunit, '(a)' ) ' coordIndex [' text_num = text_num + 2 text = ' ' length = 0 do j = 1, line_num write ( word, '(i8,'','')' ) line_dex(j) - OFFSET call s_cat ( text, word, text ) length = length + 1 if ( line_dex(j)-OFFSET == -1 .or. length >= 10 .or. j >= line_num ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do write ( iunit, '(a)' ) ' ]' text_num = text_num + 1 ! ! IndexedLineSet materialIndex. ! write ( iunit, '(a)' ) ' materialIndex [' text_num = text_num + 1 text = ' ' length = 0 do j = 1, line_num write ( word, '(i8,'','')' ) line_material(j) - OFFSET call s_cat ( text, word, text ) length = length + 1 if ( line_material(j)-OFFSET == -1 .or. & length >= 10 .or. j >= line_num ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' text_num = text_num + 2 end if ! ! IndexedFaceSet. ! if ( face_num > 0 ) then write ( iunit, '(a)' ) ' IndexedFaceSet {' ! ! IndexedFaceSet coordIndex ! write ( iunit, '(a)' ) ' coordIndex [' text_num = text_num + 2 text = ' ' length = 0 do iface = 1, face_num do ivert = 1, face_order(iface) + 1 if ( ivert <= face_order(iface) ) then itemp = face(ivert,iface) - OFFSET else itemp = 0 - OFFSET end if write ( word, '(i8,'','')' ) itemp call s_cat ( text, word, text ) length = length + 1 if ( itemp == -1 .or. length >= 10 .or. & ( iface == face_num .and. ivert == face_order(iface) + 1 ) ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do end do write ( iunit, '(a)' ) ' ]' text_num = text_num + 1 ! ! IndexedFaceSet normalIndex ! if ( texture_num > 0 ) then write ( iunit, '(a)' ) ' normalIndex [' text_num = text_num + 1 text = ' ' length = 0 do iface = 1, face_num do ivert = 1, face_order(iface) + 1 if ( ivert <= face_order(iface) ) then itemp = face(ivert,iface) - OFFSET else itemp = 0 - OFFSET end if write ( word, '(i8,'','')' ) itemp call s_cat ( text, word, text ) length = length + 1 if ( itemp == -1 .or. length >= 10 .or. & ( iface == face_num .and. ivert == face_order(iface) + 1 ) ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do end do write ( iunit, '(a)' ) ' ]' text_num = text_num + 1 end if ! ! IndexedFaceSet textureCoordIndex ! write ( iunit, '(a)' ) ' textureCoordIndex [' text_num = text_num + 1 text = ' ' length = 0 itemp = 0 do iface = 1, face_num do ivert = 1, face_order(iface) + 1 if ( ivert <= face_order(iface) ) then jtemp = itemp itemp = itemp + 1 else jtemp = - 1 end if write ( word, '(i8,'','')' ) jtemp call s_cat ( text, word, text ) length = length + 1 if ( jtemp == -1 .or. length >= 10 .or. & ( iface == face_num .and. ivert == face_order(iface) + 1 ) ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do end do write ( iunit, '(a)' ) ' ]' text_num = text_num + 1 ! ! IndexedFaceSet materialIndex ! write ( iunit, '(a)' ) ' materialIndex [' text_num = text_num + 1 text = ' ' length = 0 ndx = 0 do iface = 1, face_num do ivert = 1, face_order(iface) + 1 if ( ivert <= face_order(iface) ) then itemp = vertex_material(ivert,iface) - OFFSET ndx = ndx + 1 else itemp = 0 - OFFSET end if write ( word, '(i8,'','')' ) itemp call s_cat ( text, word, text ) length = length + 1 if ( itemp == -1 .or. length >= 10 .or. & ( iface == face_num .and. ivert == face_order(iface) + 1 ) ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text_num = text_num + 1 text = ' ' length = 0 end if end do end do write ( iunit, '(a)' ) ' ]' text_num = text_num + 1 write ( iunit, '(a)' ) ' }' text_num = text_num + 1 end if ! ! Close up the Separator node. ! write ( iunit, '(a)' ) ' }' ! ! Close up the Separator node. ! write ( iunit, '(a)' ) '}' text_num = text_num + 2 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'IV_WRITE - Wrote ', text_num, & ' text lines to ' // trim ( fileout_name ) return end subroutine ivec_max ( nval, iarray, imax ) ! !******************************************************************************* ! !! IVEC_MAX computes the maximum element of an integer array. ! ! ! Modified: ! ! 09 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NVAL, the number of entries in the array. ! ! Input, integer IARRAY(NVAL), the array. ! ! Output, integer IMAX, the value of the largest entry in the array. ! implicit none ! integer nval ! integer i integer iarray(nval) integer imax ! if ( nval <= 0 ) then imax = 0 else imax = iarray(1) do i = 2, nval imax = max ( imax, iarray(i) ) end do end if return end subroutine ivec_reverse ( n, x ) ! !******************************************************************************* ! !! IVEC_REVERSE reverses the elements of an integer vector. ! ! ! Example: ! ! Input: ! ! N = 5, X = ( 11, 12, 13, 14, 15 ). ! ! Output: ! ! X = ( 15, 14, 13, 12, 11 ). ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer X(N), the array to be reversed. ! implicit none ! integer n ! integer i integer temp integer x(n) ! do i = 1, n/2 temp = x(i) x(i) = x(n+1-i) x(n+1-i) = temp end do return end subroutine ivec_rotate ( n, m, a ) ! !******************************************************************************* ! !! IVEC_ROTATE rotates an object in place. ! ! ! Example: ! ! Input: ! ! N = 5, M = 2 ! A = ( 1, 2, 3, 4, 5 ) ! ! Output: ! ! A = ( 4, 5, 1, 2, 3 ). ! ! Modified: ! ! 07 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects. ! ! Input, integer M, the number of positions to the right that ! each element should be moved. Elements that shift pass position ! N "wrap around" to the beginning of the array. ! ! Input/output, integer A(N), the array to be rotated. ! implicit none ! integer n ! integer a(n) integer i_modp integer iget integer iput integer istart integer m integer mcopy integer nset integer temp ! ! Force M to be positive, between 0 and N-1. ! mcopy = i_modp ( m, n ) if ( mcopy == 0 ) then return end if istart = 0 nset = 0 do istart = istart + 1 if ( istart > n ) then exit end if temp = a(istart) iget = istart ! ! Copy the new value into the vacated entry. ! do iput = iget iget = iget - mcopy if ( iget < 1 ) then iget = iget + n end if if ( iget == istart ) then exit end if a(iput) = a(iget) nset = nset + 1 end do a(iput) = temp nset = nset + 1 if ( nset >= n ) then exit end if end do return end function lcon ( chr ) ! !******************************************************************************* ! !! LCON reports whether a character is a control character or not. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character CHR, is the character to be tested. ! ! Output, logical LCON, TRUE if CHR is a control character, and ! FALSE otherwise. ! implicit none ! character chr logical lcon ! if ( ichar ( chr ) <= 31 .or. ichar ( chr ) >= 127 ) then lcon = .true. else lcon = .false. end if return end subroutine mesh_t3 ( face, face_max, face_num, face_order, m, n, order_max ) ! !******************************************************************************* ! !! MESH_T3 produces a grid of pairs of 3 node triangles. ! ! ! Example: ! ! Input: ! ! M = 4, N = 3 ! ! Output: ! ! FACE = ! 1, 4, 2; ! 5, 2, 4; ! 2, 5, 3; ! 6, 3, 5; ! 4, 7, 5; ! 8, 5, 7 ! 5, 8, 6; ! 9, 6, 8; ! 7, 10, 8; ! 11, 8, 10; ! 8, 11, 9; ! 12, 9, 11. ! ! Diagram: ! ! 3----6----9---12 ! |\ 4 |\ 8 |\12 | ! | \ | \ | \ | ! | \ | \ | \ | ! | 3\| 7\| 11\| ! 2----5----8---11 ! |\ 2 |\ 6 |\10 | ! | \ | \ | \ | ! | \ | \ | \ | ! | 1\| 5\| 9\| ! 1----4----7---10 ! ! Modified: ! ! 17 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX); FACE(I,J) contains the ! index of the I-th vertex of the J-th face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the order of each face. ! ! Input, integer M, N, the number of nodes that form the mesh. ! ! Input, integer ORDER_MAX, the maximum order for any face. ! integer face_max integer order_max ! integer face(order_max,face_max) integer face_num integer face_order(face_max) integer i integer j integer m integer n ! if ( face_num + 2 * ( m - 1 ) * ( n - 1 ) > face_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MESH_T3 - Fatal error!' write ( *, '(a)' ) ' Not enough storage for new faces.' write ( *, '(a,i6)' ) ' Current number of faces is ', face_num write ( *, '(a,i6)' ) ' Maximum number of faces is ', face_max write ( *, '(a,i6)' ) ' New faces needed: ', 2 * ( m - 1 ) * ( n - 1 ) stop end if do j = 1, n - 1 do i = 1, m - 1 face_num = face_num + 1 face_order(face_num) = 3 face(1,face_num) = cor3_num + ( i - 1 ) * n + j face(2,face_num) = cor3_num + i * n + j face(3,face_num) = cor3_num + ( i - 1 ) * n + j + 1 face_num = face_num + 1 face_order(face_num) = 3 face(1,face_num) = cor3_num + i * n + j + 1 face(2,face_num) = cor3_num + ( i - 1 ) * n + j + 1 face(3,face_num) = cor3_num + i * n + j end do end do return end subroutine news ! !******************************************************************************* ! !! NEWS prints out news (old and new) about the program. ! ! ! Modified: ! ! 13 June 2002 ! ! Author: ! ! John Burkardt ! implicit none ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWS:' write ( *, '(a)' ) ' This is a list of changes to the program:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' 13 June 2002:' write ( *, '(a)' ) ' Modifying IV_POINT_WRITE to add line data.' write ( *, '(a)' ) ' My goal is to display Voronoi diagrams on a sphere.' write ( *, '(a)' ) ' 04 June 2002:' write ( *, '(a)' ) ' Added XYZ_READ.' write ( *, '(a)' ) ' Added IV_POINT_WRITE.' write ( *, '(a)' ) ' 23 February 2002:' write ( *, '(a)' ) ' Modified the PostScript header.' write ( *, '(a)' ) ' 13 October 2001:' write ( *, '(a)' ) ' Added TS_WRITE.' write ( *, '(a)' ) ' 05 June 2001:' write ( *, '(a)' ) ' Restored XYZ_WRITE.' write ( *, '(a)' ) ' 14 June 2000:' write ( *, '(a)' ) ' FORTRAN90 conversion.' write ( *, '(a)' ) ' 06 October 1999:' write ( *, '(a)' ) ' Trying to retrieve PS_WRITE from old code.' write ( *, '(a)' ) ' 03 August 1999:' write ( *, '(a)' ) ' Corrected TMAT_ROT_VECTOR.' write ( *, '(a)' ) ' 29 June 1999:' write ( *, '(a)' ) ' IV_READ and IV_WRITE support UV textures.' write ( *, '(a)' ) ' 24 June 1999:' write ( *, '(a)' ) ' HRC_WRITE and TXT_WRITE write texture info.' write ( *, '(a)' ) ' BYU_WRITE writes Movie.BYU format.' write ( *, '(a)' ) ' 23 June 1999:' write ( *, '(a)' ) ' HRC_READ and HRC_WRITE use vertex textures.' write ( *, '(a)' ) ' 08 June 1999:' write ( *, '(a)' ) ' Added simple TECPLOT output.' write ( *, '(a)' ) ' Added Greg Hood "TRI" triangle output.' write ( *, '(a)' ) ' 02 June 1999:' write ( *, '(a)' ) ' Adding material names.' write ( *, '(a)' ) ' 26 May 1999:' write ( *, '(a)' ) ' Internal LINE_PRUNE option added.' write ( *, '(a)' ) ' 24 May 1999:' write ( *, '(a)' ) ' STLA_WRITE automatically decomposes any' write ( *, '(a)' ) ' non-triangular faces before writing them.' write ( *, '(a)' ) ' 23 May 1999:' write ( *, '(a)' ) ' DXF_WRITE can output faces.' write ( *, '(a)' ) ' 22 May 1999:' write ( *, '(a)' ) ' VLA output includes line versions of faces.' write ( *, '(a)' ) ' 04 May 1999:' write ( *, '(a)' ) ' SMF_READ/WRITE support face/node material,' write ( *, '(a)' ) ' normal, texture coordinates.' write ( *, '(a)' ) ' 01 May 1999:' write ( *, '(a)' ) ' Relaxation smoothing option added.' write ( *, '(a)' ) ' 27 April 1999:' write ( *, '(a)' ) ' SMF_READ and SMF_WRITE handle SMF2.0 colors.' write ( *, '(a)' ) ' 23 April 1999:' write ( *, '(a)' ) ' Better POV_WRITE material treatment.' write ( *, '(a)' ) ' FACE_MATERIAL vs VERTEX_MAT fixup.' write ( *, '(a)' ) ' 21 April 1999:' write ( *, '(a)' ) ' Trying to get IV_READ to merge two files.' write ( *, '(a)' ) ' 20 April 1999:' write ( *, '(a)' ) ' Added << option, trying to get OBJ_READ' write ( *, '(a)' ) ' to merge two files.' write ( *, '(a)' ) ' 26 March 1999' write ( *, '(a)' ) ' Added RGB_TO_HUE routine;' write ( *, '(a)' ) ' Adding UCD_WRITE.' write ( *, '(a)' ) ' 23 February 1999' write ( *, '(a)' ) ' In HRC_WRITE, made specular and ambient' write ( *, '(a)' ) ' material colors the same as diffuse.' write ( *, '(a)' ) ' 15 February 1999' write ( *, '(a)' ) ' Trying to get grid lines in OOGL.' write ( *, '(a)' ) ' 13 February 1999' write ( *, '(a)' ) ' Added face area calculation.' write ( *, '(a)' ) ' 12 February 1999' write ( *, '(a)' ) ' Added new color scheme to IV_WRITE.' write ( *, '(a)' ) ' 10 February 1999' write ( *, '(a)' ) ' HRC_READ should now be able to read ' write ( *, '(a)' ) ' material data.' write ( *, '(a)' ) ' 09 February 1999' write ( *, '(a)' ) ' HRC_WRITE now writes out material data.' write ( *, '(a)' ) ' Moving all RGB material information' write ( *, '(a)' ) ' into MATERIAL_RGBA, with other items' write ( *, '(a)' ) ' using pointers to index it.' write ( *, '(a)' ) ' 08 February 1999' write ( *, '(a)' ) ' Adding "OOGL" file format for Greg Foss.' write ( *, '(a)' ) ' 02 December 1998' write ( *, '(a)' ) ' Restored VRML write.' write ( *, '(a)' ) ' Set up simple hooks for texture map names.' write ( *, '(a)' ) ' 19 November 1998' write ( *, '(a)' ) ' IV_WRITE uses PER_VERTEX normal binding.' write ( *, '(a)' ) ' 18 November 1998' write ( *, '(a)' ) ' Added node-based normal vectors.' write ( *, '(a)' ) ' 17 November 1998' write ( *, '(a)' ) ' Added face node ordering reversal option.' write ( *, '(a)' ) ' 23 October 1998' write ( *, '(a)' ) ' Added polygon to triangle option.' write ( *, '(a)' ) ' 20 October 1998' write ( *, '(a)' ) ' Added interactive scaling patch.' write ( *, '(a)' ) ' Inserted TMAT routines.' write ( *, '(a)' ) ' 19 October 1998' write ( *, '(a)' ) ' SMF_READ and SMF_WRITE added.' write ( *, '(a)' ) ' 12 October 1998' write ( *, '(a)' ) ' Added FACE_CHECK code.' write ( *, '(a)' ) ' 08 October 1998' write ( *, '(a)' ) ' Added POV_WRITE;' write ( *, '(a)' ) ' Added SET_VERTEX_NORMAL;' write ( *, '(a)' ) ' Modified normal vector computation.' write ( *, '(a)' ) ' 30 August 1998' write ( *, '(a)' ) ' Still trying to fix up normals, because' write ( *, '(a)' ) ' of OBJ_READ and OBJ_WRITE complications.' write ( *, '(a)' ) ' 29 August 1998' write ( *, '(a)' ) ' OBJ_READ and OBJ_WRITE now handle normals,' write ( *, '(a)' ) ' and read and write normals to file.' write ( *, '(a)' ) ' OBJ_READ can handle // face format.' write ( *, '(a)' ) ' 28 August 1998' write ( *, '(a)' ) ' STLA_READ and STLA_WRITE seem OK after' write ( *, '(a)' ) ' the normal changes.' write ( *, '(a)' ) ' 27 August 1998' write ( *, '(a)' ) ' Trying better NORMAL storage approach.' write ( *, '(a)' ) ' 21 August 1998' write ( *, '(a)' ) ' Trying to add HRC_READ.' write ( *, '(a)' ) ' TXT_WRITE improved.' write ( *, '(a)' ) ' 20 August 1998' write ( *, '(a)' ) ' Adding linear splines to HRC_WRITE.' write ( *, '(a)' ) ' 19 August 1998' write ( *, '(a)' ) ' Automatic normal computation for OBJ files.' write ( *, '(a)' ) ' SoftImage HRC output added.' write ( *, '(a)' ) ' Normal vector computation improved.' write ( *, '(a)' ) ' 18 August 1998' write ( *, '(a)' ) ' Improved treatment of face materials and normals.' write ( *, '(a)' ) ' 17 August 1998' write ( *, '(a)' ) ' The maximum number of vertices per face' write ( *, '(a)' ) ' was increased to 35.' write ( *, '(a)' ) ' The maximum input line length was increased' write ( *, '(a)' ) ' to 256 characters.' write ( *, '(a)' ) ' 10 August 1998:' write ( *, '(a)' ) ' Output DXF files have a comment now.' write ( *, '(a)' ) ' OBJ_READ corrected line indexing problem.' write ( *, '(a)' ) ' 24 July 1998:' write ( *, '(a)' ) ' INCHECK checks the input data.' write ( *, '(a)' ) ' DXF_READ suppresses duplicate points.' write ( *, '(a)' ) ' Removed grid routines.' write ( *, '(a)' ) ' LINES(2,*) -> LINE_DEX(), LINE_MATERIAL().' write ( *, '(a)' ) ' PS and VRML output dropped.' write ( *, '(a)' ) ' OBJ_WRITE line output tightened up.' write ( *, '(a)' ) ' 22 July 1998:' write ( *, '(a)' ) ' STLA_READ suppresses duplicate points.' write ( *, '(a)' ) ' 21 July 1998:' write ( *, '(a)' ) ' VLA_READ suppresses duplicate points.' write ( *, '(a)' ) ' OBJ_WRITE outputs line data now.' write ( *, '(a)' ) ' 15 July 1998:' write ( *, '(a)' ) ' Added STLA_READ and STLA_WRITE.' write ( *, '(a)' ) ' 11 July 1998:' write ( *, '(a)' ) ' DXF_READ and DXF_WRITE use IV data.' write ( *, '(a)' ) ' Dropped XYZ data structures.' write ( *, '(a)' ) ' 10 July 1998:' write ( *, '(a)' ) ' Dropped XYZ input/output option.' write ( *, '(a)' ) ' VLA_READ and VLA_WRITE use IV data.' write ( *, '(a)' ) ' 08 July 1998:' write ( *, '(a)' ) ' Added OBJ_READ and OBJ_WRITE.' write ( *, '(a)' ) ' Set ORDER_MAX=4, to allow for quad faces.' write ( *, '(a)' ) ' 05 July 1998:' write ( *, '(a)' ) ' Added RF command to reverse faces.' write ( *, '(a)' ) ' Fixed 0/1 index based problem for FACE.' write ( *, '(a)' ) ' 04 July 1998:' write ( *, '(a)' ) ' Added CHECK command to examine a face.' write ( *, '(a)' ) ' 03 July 1998:' write ( *, '(a)' ) ' Only converting data when necessary.' write ( *, '(a)' ) ' Alternate IV triangles have opposite sense.' write ( *, '(a)' ) ' NORMALS command will recompute normals.' write ( *, '(a)' ) ' 02 July 1998:' write ( *, '(a)' ) ' Trying to write simple ASE files.' write ( *, '(a)' ) ' 01 July 1998:' write ( *, '(a)' ) ' Tentative attempts to read new IV data,' write ( *, '(a)' ) ' INDEXEDTRIANGLESTRIP.' write ( *, '(a)' ) ' 03 June 1998:' write ( *, '(a)' ) ' MATERIALINDEX works for IV faces AND lines.' write ( *, '(a)' ) ' 02 June 1998:' write ( *, '(a)' ) ' Trying to sort out -1/0 LINES confusion.' write ( *, '(a)' ) ' VRML_WRITE uses Inventor data.' write ( *, '(a)' ) ' I got VRML_WRITE to do color lines.' write ( *, '(a)' ) ' I need to reconcile RGBCOLOR/FACE/NODE.' write ( *, '(a)' ) ' 15 May 1998:' write ( *, '(a)' ) ' Set up RGBCOLOR for new color handling.' write ( *, '(a)' ) ' 08 May 1998:' write ( *, '(a)' ) ' Preparing for IV PER_VERTEX_INDEXED.' write ( *, '(a)' ) ' 06 May 1998:' write ( *, '(a)' ) ' Added "reverse normal" option.' write ( *, '(a)' ) ' Added 3D projected plane grid.' write ( *, '(a)' ) ' 05 May 1998:' write ( *, '(a)' ) ' Added projection into 3D plane.' write ( *, '(a)' ) ' Added spherical grid lines.' write ( *, '(a)' ) ' 04 May 1998:' write ( *, '(a)' ) ' Sphere projection set up.' write ( *, '(a)' ) ' The PostScript output seems OK.' write ( *, '(a)' ) ' 30 April 1998:' write ( *, '(a)' ) ' Adding 2D PostScript output option.' write ( *, '(a)' ) ' 23 April 1998:' write ( *, '(a)' ) ' ASE->IV surface information sorta works.' write ( *, '(a)' ) ' 22 April 1998:' write ( *, '(a)' ) ' IVREAD accepts command line arguments.' write ( *, '(a)' ) ' 21 April 1998:' write ( *, '(a)' ) ' IV_WRITE now writes a default material.' write ( *, '(a)' ) ' 20 April 1998:' write ( *, '(a)' ) ' ASE_READ tries to read vertex color.' write ( *, '(a)' ) ' 17 April 1998:' write ( *, '(a)' ) ' ASE_READ reads transform matrix.' write ( *, '(a)' ) ' Overhauled ReadIV routine.' write ( *, '(a)' ) ' 16 April 1998:' write ( *, '(a)' ) ' Increased big array limits.' write ( *, '(a)' ) ' Adding ASE_READ.' write ( *, '(a)' ) ' 15 April 1998:' write ( *, '(a)' ) ' VLA intensities parameterized in INTENSE.' write ( *, '(a)' ) ' Got VRML option to work.' write ( *, '(a)' ) ' 14 April 1998:' write ( *, '(a)' ) ' Added VRML_WRITE.' write ( *, '(a)' ) ' 13 April 1998:' write ( *, '(a)' ) ' Made program command driven.' write ( *, '(a)' ) ' Started projection option.' write ( *, '(a)' ) ' 10 April 1998:' write ( *, '(a)' ) ' Added Min/Max coordinate print.' write ( *, '(a)' ) ' Compressed IV output.' return end subroutine node_relax ( cor3, cor3_max, cor3_new, cor3_num, face, face_max, & face_num, face_order, order_max ) ! !******************************************************************************* ! !! NODE_RELAX smooths a shape by an averaging operation on the node positions. ! ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of the nodes. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Output, real COR3_NEW(3,COR3_MAX), the new, averaged coordinates of ! the nodes. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), is the number of nodes ! making up each face. ! ! Input, integer ORDER_MAX, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Local variables: ! ! Integer COR3_NUMBER(COR3_MAX), the number of node neighbors of node I. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) real cor3_new(3,cor3_max) integer cor3_num integer cor3_number(cor3_max) integer face(order_max,face_max) integer face_num integer face_order(face_max) integer i integer icor3 integer iface integer inode integer ivert integer jnode ! ! COR3_NEW will contain the new averaged coordinates. ! cor3_number(1:cor3_num) = 0 cor3_new(1:3,1:cor3_num) = 0.0E+00 ! ! Consider each edge. Essentially, the edge (I,J) is a signal to ! add the old coordinates of I to the new J coordinates, and vice versa. ! ! Because we are using a face representation, many, perhaps all the ! edges, will show up repeatedly, probably twice. To keep the algorithm ! simple, for now we will simply use an edge every time it shows up ! in a face, which means that edges that occur in multiple faces ! will be weighted more. ! do iface = 1, face_num inode = face(face_order(iface),iface) do ivert = 1, face_order(iface) jnode = inode inode = face(ivert,iface) cor3_number(inode) = cor3_number(inode) + 1 cor3_number(jnode) = cor3_number(jnode) + 1 cor3_new(1:3,jnode) = cor3_new(1:3,jnode) + cor3(1:3,inode) cor3_new(1:3,inode) = cor3_new(1:3,inode) + cor3(1:3,jnode) end do end do ! ! Copy the new into the old. ! do icor3 = 1, cor3_num if ( cor3_number(icor3) /= 0 ) then cor3_new(1:3,icor3) = cor3_new(1:3,icor3) / real ( cor3_number(icor3) ) end if end do return end subroutine node_to_vertex_material ( cor3_material, cor3_max, face, & face_max, face_num, face_order, order_max, vertex_material ) ! !******************************************************************************* ! !! NODE_TO_VERTEX_MATERIAL extends node material definitions to vertices. ! ! ! Discussion: ! ! A NODE is a point in space. ! A VERTEX is a node as used in a particular face. ! One node may be used as a vertex in several faces, or none. ! ! Modified: ! ! 27 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COR3_MATERIAL(COR3_MAX), the material index of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer cor3_max integer face_max integer order_max ! integer cor3_material(cor3_max) integer face(order_max,face_max) integer face_order(face_max) integer iface integer ivert integer node integer face_num integer vertex_material(order_max,face_max) ! do iface = 1, face_num do ivert = 1, face_order(iface) node = face(ivert,iface) vertex_material(ivert,iface) = cor3_material(node) end do end do return end subroutine obj_read ( bad_num, cor3, cor3_max, cor3_num, face, & face_material, face_max, face_num, face_order, filein_name, & group_num, ierror, iunit, line_dex, line_material, line_max, & line_num, material_max, material_name, material_num, material_rgba, & object_num, order_max, text_num, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! OBJ_READ reads graphics information from a Wavefront OBJ file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! # magnolia.obj ! ! mtllib ./vp.mtl ! ! g ! v -3.269770 -39.572201 0.876128 ! v -3.263720 -39.507999 2.160890 ! ... ! v 0.000000 -9.988540 0.000000 ! vn 1.0 0.0 0.0E+00 ! ... ! vn 0.0 1.0 0.0E+00 ! g stem ! s 1 ! usemtl brownskn ! f 8 9 11 10 ! f 12 13 15 14 ! ... ! f 788 806 774 ! ! Modified: ! ! 13 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BAD_NUM, the number of bad text lines encountered. ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input/output, integer GROUP_NUM, the number of groups. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated ! by -1. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input/output, integer LINE_MATERIAL(LINE_MAX), material index for ! each line. ! ! Input/output, integer LINE_NUM, the number of line definition items. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input/output, integer OBJECT_NUM, the number of objects. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer TEXT_NUM, the number of lines of text read from ! the file. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer cor3_max integer face_max integer line_max integer material_max integer order_max ! integer bad_num real cor3(3,cor3_max) integer cor3_num integer cor3_num_base logical done integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name integer group_num integer i integer i1 integer i2 integer ierror integer ios integer itemp integer iunit integer ivert integer iword integer lchar character ( len = 256 ) line integer line_dex(line_max) integer line_material(line_max) integer line_num character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) real normal_temp(3,order_max*face_max) integer object_num integer, parameter :: OFFSET = 1 real r real s logical s_eqi integer text_num real temp integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) integer vertex_normal_num character ( len = 256 ) word character ( len = 256 ) word1 ! ierror = 0 ! ! Save a copy of the input value of COR3_NUM to use as a base. ! cor3_num_base = cor3_num bad_num = 0 text_num = 0 vertex_normal_num = 0 word = ' ' ! ! Read a line of text from the file. ! do read ( iunit, '(a)', iostat = ios ) line if ( ios /= 0 ) then exit end if text_num = text_num + 1 ! ! Replace any control characters (in particular, TAB's) by blanks. ! call s_control_blank ( line ) done = .true. iword = 0 ! ! Read a word from the line. ! call word_next_read ( line, word, done ) ! ! If no more words in this line, read a new line. ! if ( done ) then cycle end if ! ! If this word begins with '#' or '$', then it's a comment. Read a new line. ! if ( word(1:1) == '#' .or. word(1:1) == '$' ) then cycle end if iword = iword + 1 if ( iword == 1 ) then word1 = word end if ! ! BEVEL ! Bevel interpolation. ! if ( s_eqi ( word1, 'BEVEL' ) ) then ! ! BMAT ! Basis matrix. ! else if ( s_eqi ( word1, 'BMAT' ) ) then ! ! C_INTERP ! Color interpolation. ! else if ( s_eqi ( word1, 'C_INTERP' ) ) then ! ! CON ! Connectivity between free form surfaces. ! else if ( s_eqi ( word1, 'CON' ) ) then ! ! CSTYPE ! Curve or surface type. ! else if ( s_eqi ( word1, 'CSTYPE' ) ) then ! ! CTECH ! Curve approximation technique. ! else if ( s_eqi ( word1, 'CTECH' ) ) then ! ! CURV ! Curve. ! else if ( s_eqi ( word1, 'CURV' ) ) then ! ! CURV2 ! 2D curve. ! else if ( s_eqi ( word1, 'CURV2' ) ) then ! ! D_INTERP ! Dissolve interpolation. ! else if ( s_eqi ( word1, 'D_INTERP' ) ) then ! ! DEG ! Degree. ! else if ( s_eqi ( word1, 'DEG' ) ) then ! ! END ! End statement. ! else if ( s_eqi ( word1, 'END' ) ) then ! ! F V1 V2 V3 ... ! or ! F V1/VT1/VN1 V2/VT2/VN2 ... ! or ! F V1//VN1 V2//VN2 ... ! ! Face. ! A face is defined by the vertices. ! Optionally, slashes may be used to include the texture vertex ! and vertex normal indices. ! else if ( s_eqi ( word1, 'F' ) ) then face_num = face_num + 1 ivert = 0 do ivert = ivert + 1 call word_next_read ( line, word, done ) if ( done ) then exit end if ! ! Locate the slash characters in the word, if any. ! i1 = index ( word, '/' ) if ( i1 > 0 ) then i2 = index ( word(i1+1:), '/' ) + i1 else i2 = 0 end if ! ! Read the vertex index. ! call s_to_i ( word, itemp, ierror, lchar ) if ( ierror /= 0 ) then itemp = -1 ierror = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OBJ_READ - Error!' write ( *, '(a)' ) ' Bad FACE field.' write ( *, '(a)' ) trim ( word ) end if if ( ivert <= order_max .and. face_num <= face_max ) then face(ivert,face_num) = itemp + cor3_num_base vertex_material(ivert,face_num) = material_num end if if ( face_num <= face_max ) then face_material(face_num) = material_num face_order(face_num) = ivert end if ! ! If there are two slashes, then read the data following the second one. ! if ( i2 > 0 ) then call s_to_i ( word(i2+1:), itemp, ierror, lchar ) if ( 1 <= itemp .and. itemp <= vertex_normal_num ) then vertex_normal(1:3,ivert,face_num) = normal_temp(1:3,itemp) end if end if end do ! ! G ! Group name. ! else if ( s_eqi ( word1, 'G' ) ) then group_num = group_num + 1 ! ! HOLE ! Inner trimming loop. ! else if ( s_eqi ( word1, 'HOLE' ) ) then ! ! L ! A line, described by a sequence of vertex indices. ! Are the vertex indices 0 based or 1 based? ! else if ( s_eqi ( word1, 'L' ) ) then do call word_next_read ( line, word, done ) ! ! If no more indices, tack a "-1" on the end. ! if ( done ) then line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = -1 + OFFSET line_material(line_num) = -1 + OFFSET end if exit end if ! ! Otherwise, extract the node index and add it to the line list. ! call s_to_i ( word, itemp, ierror, lchar ) line_num = line_num + 1 if ( line_num <= line_max ) then line_dex(line_num) = itemp line_material(line_num) = material_num end if end do ! ! LOD ! Level of detail. ! else if ( s_eqi ( word1, 'LOD' ) ) then ! ! MG ! Merging group. ! else if ( s_eqi ( word1, 'MG' ) ) then ! ! MTLLIB ! Material library. ! else if ( s_eqi ( word1, 'MTLLIB' ) ) then ! ! O ! Object name. ! else if ( s_eqi ( word1, 'O' ) ) then object_num = object_num + 1 ! ! P ! Point. ! else if ( s_eqi ( word1, 'P' ) ) then ! ! PARM ! Parameter values. ! else if ( s_eqi ( word1, 'PARM' ) ) then ! ! S ! Smoothing group. ! else if ( s_eqi ( word1, 'S' ) ) then ! ! SCRV ! Special curve. ! else if ( s_eqi ( word1, 'SCRV' ) ) then ! ! SHADOW_OBJ ! Shadow casting. ! else if ( s_eqi ( word1, 'SHADOW_OBJ' ) ) then ! ! SP ! Special point. ! else if ( s_eqi ( word1, 'SP' ) ) then ! ! STECH ! Surface approximation technique. ! else if ( s_eqi ( word1, 'STECH' ) ) then ! ! STEP ! Stepsize. ! else if ( s_eqi ( word1, 'STEP' ) ) then ! ! SURF ! Surface. ! else if ( s_eqi ( word1, 'SURF' ) ) then ! ! TRACE_OBJ ! Ray tracing. ! else if ( s_eqi ( word1, 'TRACE_OBJ' ) ) then ! ! TRIM ! Outer trimming loop. ! else if ( s_eqi ( word1, 'TRIM' ) ) then ! ! USEMTL ! Material name. ! else if ( s_eqi ( word1, 'USEMTL' ) ) then call word_next_read ( line, word, done ) material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = word call r_random ( 0.0E+00, 1.0E+00, r ) material_rgba(1,material_num) = r call r_random ( 0.0E+00, 1.0E+00, r ) material_rgba(2,material_num) = r call r_random ( 0.0E+00, 1.0E+00, r ) material_rgba(3,material_num) = r material_rgba(4,material_num) = 1.0E+00 end if ! ! V X Y Z W ! Geometric vertex. ! ! (X,Y,Z) is the coordinate of the vertex. ! W is optional, a weight used for rational curves and surfaces. ! The default for W is 1. ! else if ( s_eqi ( word1, 'V' ) ) then cor3_num = cor3_num + 1 do i = 1, 3 call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) if ( cor3_num <= cor3_max ) then cor3(i,cor3_num) = temp end if end do ! ! VN ! Vertex normals. ! else if ( s_eqi ( word1, 'VN' ) ) then vertex_normal_num = vertex_normal_num + 1 if ( vertex_normal_num <= order_max*face_max ) then do i = 1, 3 call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) normal_temp(i,vertex_normal_num) = temp end do end if ! ! VT ! Vertex texture. ! else if ( s_eqi ( word1, 'VT' ) ) then ! ! VP ! Parameter space vertices. ! else if ( s_eqi ( word1, 'VP' ) ) then ! ! Unrecognized keyword. ! else bad_num = bad_num + 1 if ( bad_num <= 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'OBJ_READ: Bad data on line ', text_num write ( *, '(a)' ) ' Bad word: ' // trim ( word ) end if end if end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'OBJ_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine obj_write ( cor3, cor3_max, cor3_num, face, face_max, face_num, & face_order, filein_name, fileout_name, iunit, line_dex, line_max, & line_num, order_max, vertex_normal ) ! !******************************************************************************* ! !! OBJ_WRITE writes graphics information to a WaveFront OBJ file. ! ! ! Example: ! ! # magnolia.obj ! ! mtllib ./vp.mtl ! ! g Group001 ! v -3.269770 -39.572201 0.876128 ! v -3.263720 -39.507999 2.160890 ! ... ! v 0.000000 -9.988540 0.000000 ! vn 0.0 1.0 0.0E+00 ! vn 1.0 0.0 0.0E+00 ! ... ! vn 0.0 0.0 1.0E+00 ! s 1 ! usemtl brownskn ! f 8//1 9//2 11//3 10//4 ! f 12//5 13//6 15//7 14//8 ! ... ! f 788//800 806//803 774//807 ! ! Modified: ! ! 13 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer cor3_max integer face_max integer line_max integer order_max ! real cor3(3,cor3_max) integer cor3_num integer face(order_max,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name integer i integer iface integer ihi integer ilo integer indexvn integer iunit integer ivert integer j integer line_dex(line_max) integer line_num integer nl integer, parameter :: OFFSET = 1 character ( len = 256 ) text integer text_num character ( len = 256 ) text2 real vertex_normal(3,order_max,face_max) real w ! text_num = 0 write ( iunit, '(a)' ) '# ' // trim ( fileout_name ) // ' created by IVREAD.' write ( iunit, '(a)' ) '# Original data in ' // trim ( filein_name ) // '.' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'g Group001' write ( iunit, '(a)' ) ' ' text_num = text_num + 5 ! ! V: vertex coordinates. ! w = 1.0E+00 do j = 1, cor3_num write ( text, '(a1,2x,4g14.6)' ) 'v', cor3(1:3,j), w call s_blanks_delete ( text ) write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do ! ! VN: vertex face normal vectors. ! if ( face_num > 0 ) then write ( iunit, '(a)' ) ' ' text_num = text_num + 1 end if do iface = 1, face_num do ivert = 1, face_order(iface) write ( text, '(a2,2x,3f7.3)' ) 'vn', vertex_normal(1:3,ivert,iface) call s_blanks_delete ( text ) write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do end do ! ! F: Faces, specified as ! vertex index/texture vertex index/normal index ! if ( face_num > 0 ) then write ( iunit, '(a)' ) ' ' text_num = text_num + 1 end if indexvn = 0 do iface = 1, face_num text = 'f' do ivert = 1, face_order(iface) indexvn = indexvn + 1 text2 = ' ' write ( text2(2:), '(i8, ''//'', i8 )' ) face(ivert,iface), indexvn call s_blank_delete ( text2(2:) ) call s_cat ( text, text2, text ) end do write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do ! ! L: lines, specified as a sequence of vertex indices. ! nl = 0 if ( line_num > 0 ) then write ( iunit, '(a)' ) ' ' text_num = text_num + 1 ihi = 0 ilo = ihi do do ihi = ihi + 1 if ( ihi >= line_num ) then exit end if if ( line_dex(ihi) == -1 + OFFSET ) then exit end if end do write ( iunit, '(a,20i8)' ) 'l', line_dex(ilo+1:ihi-1) text_num = text_num + 1 nl = nl + 1 if ( ihi >= line_num ) then exit end if ilo = ihi end do end if ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'OBJ_WRITE - Wrote ', text_num, & ' text lines to ' // trim ( fileout_name ) return end subroutine object_build ( face, face_num, face_object, face_order, & face_rank, face_tier, object_num, order_max ) ! !******************************************************************************* ! !! OBJECT_BUILD builds edge-connected "objects" out of polygonal faces. ! ! ! Modified: ! ! 14 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(ORDER_MAX,FACE_NUM), the nodes making faces. ! ! Output, integer FACE_OBJECT(FACE_NUM), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input, integer FACE_ORDER(FACE_NUM), the number of nodes per face. ! ! Output, integer FACE_RANK(FACE_NUM), is an ordered list of faces. ! FACE_RANK(1) is the index of the face in the first tier of the ! first object, followed by second tier faces, and so on until ! object one is complete. Object two follows, and so on. ! ! Output, integer FACE_TIER(FACE_NUM). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer ORDER_MAX, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer FACE_NUM, the number of faces. ! ! Output, integer OBJECT_NUM, the number of objects. ! implicit none ! integer order_max integer face_num ! logical, parameter :: DEBUG = .false. integer face(order_max,face_num) integer face_object(face_num) integer face_order(face_num) integer face_rank(face_num) integer face_tier(face_num) integer i integer iface integer ihi integer ihi_next integer ilo integer ilo_next integer iprint integer irank integer jface integer jrank integer object_num integer seed integer tier integer touch ! ! Initialization. ! iprint = 1 object_num = 0 if ( face_num <= 0 ) then return end if face_object(1:face_num) = 0 face_rank(1:face_num) = 0 face_tier(1:face_num) = 0 irank = 0 seed = 1 ! ! Begin the next object, seeded with face SEED. ! 10 continue tier = 1 object_num = object_num + 1 irank = irank + 1 jrank = irank if ( irank == iprint .or. irank == face_num ) then write ( *, '(2i6)' ) irank, seed iprint = 2 * iprint end if face_rank(irank) = seed face_tier(seed) = tier face_object(seed) = object_num ilo = irank ihi = irank ! ! Begin the next tier of faces, which are neighbors of faces we ! found in the previous tier. ! 20 continue tier = tier + 1 ilo_next = ihi + 1 ihi_next = ihi do jface = 1, face_num if ( face_tier(jface) == 0 ) then do i = ilo, ihi iface = face_rank(i) call face_touch ( face, face_order, order_max, face_num, iface, & jface, touch ) if ( touch /= 0 ) then if ( DEBUG ) then write ( *, '(a,2i6)' ) 'Touching faces: ', iface, jface end if ihi_next = ihi_next + 1 irank = irank + 1 if ( irank == iprint .or. irank == face_num ) then write ( *, '(2i6)' ) irank, jface iprint = 2 * iprint end if face_rank(irank) = jface face_tier(jface) = tier face_object(jface) = object_num go to 30 end if end do end if 30 continue end do if ( ihi_next >= ilo_next ) then ilo = ilo_next ihi = ihi_next go to 20 end if write ( *, '(a,i6,a,i6,a)' ) 'Object ', object_num, ' uses ', & irank + 1 - jrank, ' faces.' jrank = irank ! ! No neighbors were found, so this object is complete. ! Search for an unused face, which will be the seed of the next object. ! do iface = 1, face_num if ( face_tier(iface) == 0 ) then seed = iface go to 10 end if end do return end subroutine object_invert ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, face, face_material, face_max, face_normal, face_num, & face_order, material_max, material_name, material_num, material_rgba, & order_max, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! OBJECT_INVERT makes an inverted duplicate of the object. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer FACE_NUM, the number of faces. ! ! Output, integer MATERIAL_NUM, the number of materials. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max ! real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real, parameter :: EPS = 0.01E+00 integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) integer icor3 integer icor32 integer iface integer iface2 integer ivert integer ivert2 integer j character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! ! Check. ! if ( 2 * face_num > face_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OBJECT_INVERT - Fatal error!' write ( *, '(a)' ) ' 2 * FACE_NUM exceeds FACE_MAX.' return end if if ( 2 * cor3_num > cor3_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OBJECT_INVERT - Fatal error!' write ( *, '(a)' ) ' 2 * COR3_NUM exceeds COR3_MAX.' return end if ! ! If there aren't 5 materials, add some. ! if ( material_num < 5 ) then material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = 'Red_Material' material_rgba(1,material_num) = 1.0E+00 material_rgba(2,material_num) = 0.0E+00 material_rgba(3,material_num) = 0.0E+00 material_rgba(4,material_num) = 1.0E+00 write ( *, '(a)' ) 'OBJECT_INVERT - Adding dummy red material' end if end if if ( material_num < 5 ) then material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = 'Green_Material' material_rgba(1,material_num) = 0.0E+00 material_rgba(2,material_num) = 1.0E+00 material_rgba(3,material_num) = 0.0E+00 material_rgba(4,material_num) = 1.0E+00 write ( *, '(a)' ) 'OBJECT_INVERT - Adding dummy green material' end if end if ! ! Generate new points, displaced by EPS in the negative direction. ! do icor3 = 1, cor3_num icor32 = icor3 + cor3_num if ( cor3_material(icor3) == 1 ) then cor3_material(icor32) = 2 else if ( cor3_material(icor3) == 3 ) then cor3_material(icor32) = 4 else if ( cor3_material(icor3) == 4 ) then cor3_material(icor3) = 3 cor3_material(icor32) = 4 else if ( cor3_material(icor3) == 5 ) then cor3_material(icor3) = 3 cor3_material(icor32) = 5 end if cor3(1:3,icor32) = cor3(1:3,icor3) - EPS * cor3_normal(1:3,icor3) cor3_normal(1:3,icor32) = - cor3_normal(1:3,icor3) end do ! ! Generate new faces. ! do iface = 1, face_num iface2 = face_num + iface face_order(iface2) = face_order(iface) if ( face_material(iface) == 1 ) then face_material(iface2) = 2 else if ( face_material(iface) == 3 ) then face_material(iface2) = 4 else if ( face_material(iface) == 4 ) then face_material(iface) = 3 face_material(iface2) = 4 else if ( face_material(iface) == 5 ) then face_material(iface) = 3 face_material(iface2) = 5 end if do ivert = 1, face_order(iface) ivert2 = face_order(iface) + 1 - ivert face(ivert2,iface2) = face(ivert,iface) + cor3_num if ( vertex_material(ivert,iface) == 1 ) then vertex_material(ivert2,iface2) = 2 else if ( vertex_material(ivert,iface) == 3 ) then vertex_material(ivert2,iface2) = 4 else if ( vertex_material(ivert,iface) == 4 ) then vertex_material(ivert,iface) = 3 vertex_material(ivert2,iface2) = 4 else if ( vertex_material(ivert,iface) == 5 ) then vertex_material(ivert,iface) = 3 vertex_material(ivert2,iface2) = 5 end if vertex_normal(1:3,ivert2,iface2) = - vertex_normal(1:3,ivert,iface) end do face_normal(1:3,iface2) = - face_normal(1:3,iface) end do cor3_num = 2 * cor3_num face_num = 2 * face_num write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OBJECT_INVERT: Information:' write ( *, '(a,i6)' ) ' Number of points = ', cor3_num write ( *, '(a,i6)' ) ' Number of faces = ', face_num return end subroutine oogl_read ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & face, face_area, face_material, face_max, face_normal, face_num, & face_order, filein_name, ierror, iunit, material_max, material_name, & material_num, material_rgba, ncol_oogl, nrow_oogl, order_max, text_num, & vertex_material, vertex_normal ) ! !******************************************************************************* ! !! OOGL_READ reads graphics information from a OOGL file. ! ! ! Diagnostics: ! ! Note that raw READ statements are used. As written, the ! code can't handle a blank line, or deal with a case where ! information runs over to a new line. ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! {CMESH ! 5 3 ! 0.0 0.0 0.0 0.94 0.70 0.15 1.00 ! 1.0 0.0 0.0 0.94 0.70 0.15 1.00 ! 2.0 0.0 0.0 0.94 0.70 0.15 1.00 ! 3.0 0.0 0.0 0.94 0.70 0.15 1.00 ! 4.0 0.0 0.0 0.94 0.70 0.15 1.00 ! 0.0 1.0 0.0 0.94 0.70 0.15 1.00 ! 1.0 1.0 0.0 0.94 0.70 0.15 1.00 ! 2.0 1.0 0.0 0.94 0.70 0.15 1.00 ! 3.0 1.0 0.0 0.94 0.70 0.15 1.00 ! 4.0 1.0 0.0 0.94 0.70 0.15 1.00 ! 0.0 2.0 0.0 0.94 0.70 0.15 1.00 ! 1.0 2.0 0.0 0.94 0.70 0.15 1.00 ! 2.0 2.0 0.0 0.94 0.70 0.15 1.00 ! 3.0 2.0 0.0 0.94 0.70 0.15 1.00 ! 4.0 2.0 0.0 0.94 0.70 0.15 1.00 ! } ! ! Modified: ! ! 27 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Workspace, real FACE_AREA(FACE_MAX), the area of each face. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input/output, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B ! and A values. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Output, integer TEXT_NUM, the number of lines of text read from ! the file. ! ! ?, integer NCOL_OOGL, ? ! ! ?, integer NROW_OOGL, ? ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! ?, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), ? ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max ! real a real b integer b2l2 integer b2r2 integer black character ( len = 4 ) char4 logical clipping real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real dist integer face(order_max,face_max) real face_area(face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name real g logical grid integer i integer icor3 logical identify integer ierror integer iface integer imat logical invert integer ios integer itemp integer iunit integer j integer jvert integer k character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer nclip integer ncol_oogl integer ngold integer nrow_oogl real r real rgba(4) integer t2l2 integer t2r2 integer text_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) integer white real x real y real z ! ierror = 0 text_num = 0 ! ! 30 March 1999 ! KLUDGE WARNING: ! For our current purposes, we need to have the following materials defined. ! ! Set up material #1 = GOLD. ! material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = 'Gold_Material' material_rgba(1,material_num) = 0.94E+00 material_rgba(2,material_num) = 0.70E+00 material_rgba(3,material_num) = 0.15E+00 material_rgba(4,material_num) = 1.0E+00 end if ! ! Set up material #2 = DARK BLUE. ! material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = 'Dark_Blue_Material' material_rgba(1,material_num) = 0.24E+00 material_rgba(2,material_num) = 0.00E+00 material_rgba(3,material_num) = 0.85E+00 material_rgba(4,material_num) = 1.0E+00 end if ! ! Set up material #3 = LIGHT BLUE. ! material_num = material_num + 1 if ( material_num <= material_max ) then material_name(material_num) = 'Light_Blue_Material' material_rgba(1,material_num) = 0.24E+00 material_rgba(2,material_num) = 0.70E+00 material_rgba(3,material_num) = 0.85E+00 material_rgba(4,material_num) = 1.0E+00 end if ! ! A node with grid coordinates (I,J) will be mapped to a ! node number ( I - 1 ) * NCOL + J ! read ( iunit, *, iostat = ios ) if ( ios /= 0 ) then go to 50 end if text_num = text_num + 1 read ( iunit, *, iostat = ios ) ncol_oogl, nrow_oogl if ( ios /= 0 ) then go to 50 end if text_num = text_num + 1 do i = 1, nrow_oogl do j = 1, ncol_oogl read ( iunit, *, iostat = ios ) x, y, z, r, g, b, a if ( ios /= 0 ) then go to 50 end if text_num = text_num + 1 cor3_num = cor3_num + 1 ! ! 25 February 1999: ! In the data we've seen, the first and last columns have almost ! identical X,Y,Z coordinates and it might help if they were identical. ! if ( cor3_num <= cor3_max ) then cor3(1,cor3_num) = x cor3(2,cor3_num) = y cor3(3,cor3_num) = z if ( j == ncol_oogl ) then itemp = cor3_num + 1 - ncol_oogl dist = sqrt ( ( cor3(1,cor3_num) - cor3(1,itemp) )**2 & + ( cor3(2,cor3_num) - cor3(2,itemp) )**2 & + ( cor3(3,cor3_num) - cor3(3,itemp) )**2 ) if ( dist > 0.0E+00 .and. dist < 0.000001E+00 ) then cor3(1,cor3_num) = cor3(1,itemp) cor3(2,cor3_num) = cor3(2,itemp) cor3(3,cor3_num) = cor3(3,itemp) end if end if end if ! ! Some of the input data has had RGBA values that are negative. ! Do not allow this. ! rgba(1) = min ( max ( 0.0E+00, r ), 1.0E+00 ) rgba(2) = min ( max ( 0.0E+00, g ), 1.0E+00 ) rgba(3) = min ( max ( 0.0E+00, b ), 1.0E+00 ) rgba(4) = min ( max ( 0.0E+00, a ), 1.0E+00 ) ! ! See if the RGBA values of this material match those of a material ! that has already been defined. ! if ( material_num <= 1000 ) then call rcol_find ( 4, 4, material_num, material_rgba, rgba, imat ) else imat = 0 end if if ( imat == 0 ) then material_num = material_num + 1 if ( material_num <= material_max ) then call i_to_s_zero ( material_num, char4 ) material_name(material_num) = 'Material_' // char4 material_rgba(1:4,material_num) = rgba(1:4) imat = material_num else imat = 0 end if end if if ( cor3_num <= cor3_max ) then cor3_material(cor3_num) = imat end if end do end do read ( iunit, *, iostat = ios ) if ( ios /= 0 ) then go to 50 end if text_num = text_num + 1 ! ! Now set up the faces from the grid of points that were defined. ! clipping = .false. nclip = 0 do i = 2, nrow_oogl do j = 2, ncol_oogl b2l2 = ( i - 2 ) * ncol_oogl + j - 1 b2r2 = ( i - 2 ) * ncol_oogl + j t2l2 = ( i - 1 ) * ncol_oogl + j - 1 t2r2 = ( i - 1 ) * ncol_oogl + j if ( .not. clipping ) then face_num = face_num + 1 face_material(face_num) = cor3_material(t2r2) face_order(face_num) = 3 k = t2r2 face(1,face_num) = k vertex_material(1,face_num) = cor3_material(t2r2) k = b2r2 face(2,face_num) = k vertex_material(2,face_num) = cor3_material(b2r2) k = b2l2 face(3,face_num) = k vertex_material(3,face_num) = cor3_material(b2l2) face_num = face_num + 1 face_material(face_num) = cor3_material(t2l2) face_order(face_num) = 3 k = t2l2 face(1,face_num) = k vertex_material(1,face_num) = cor3_material(t2l2) k = t2r2 face(2,face_num) = k vertex_material(2,face_num) = cor3_material(t2r2) k = b2l2 face(3,face_num) = k vertex_material(3,face_num) = cor3_material(b2l2) else ngold = 0 if ( cor3_material(t2r2) == 3 ) then ngold = ngold + 1 end if if ( cor3_material(b2r2) == 3 ) then ngold = ngold + 1 end if if ( cor3_material(b2l2) == 3 ) then ngold = ngold + 1 end if if ( cor3_material(t2l2) == 3 ) then ngold = ngold + 1 end if if ( ngold >= 3 ) then face_num = face_num + 1 face_material(face_num) = 3 face_order(face_num) = 3 k = t2r2 face(1,face_num) = k vertex_material(1,face_num) = 3 k = b2r2 face(2,face_num) = k vertex_material(2,face_num) = 3 k = b2l2 face(3,face_num) = k vertex_material(3,face_num) = 3 face_num = face_num + 1 face_material(face_num) = 3 face_order(face_num) = 3 k = t2l2 face(1,face_num) = k vertex_material(1,face_num) = 3 k = t2r2 face(2,face_num) = k vertex_material(2,face_num) = 3 k = b2l2 face(3,face_num) = k vertex_material(3,face_num) = 3 else nclip = nclip + 2 end if end if end do end do if ( nclip > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_READ:' write ( *, '(a,i6,a)' ) ' "Clipped" ', nclip, ' faces.' end if ! ! Set "identify" TRUE to identify the repeated points at the first ! and last, and along the sides. ! identify = .true. if ( identify ) then do iface = 1, face_num do jvert = 1, face_order(iface) i = face(jvert,iface) if ( i <= ncol_oogl ) then face(jvert,iface) = 1 else if ( i <= nrow_oogl * ncol_oogl .and. & i > ( nrow_oogl - 1 ) * ncol_oogl ) then face(jvert,iface) = ( nrow_oogl - 1 ) * ncol_oogl + 1 end if end do end do do iface = 1, face_num do jvert = 1, face_order(iface) i = face(jvert,iface) if ( i <= nrow_oogl * ncol_oogl .and. mod ( i, ncol_oogl ) == 0 ) then face(jvert,iface) = face(jvert,iface) - ncol_oogl + 1 end if end do end do end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_READ - Information:' write ( *, '(a,i6)' ) ' Initial number of points = ', cor3_num write ( *, '(a,i6)' ) ' Initial number of faces = ', face_num invert = .false. grid = .false. if ( invert .or. grid) then ! ! Set up the normal vector information. ! call vertex_normal_set ( cor3, cor3_max, face, face_max, & face_num, face_order, order_max, vertex_normal ) call face_area_set ( cor3, cor3_max, face, face_area, face_max, & face_num, face_order, order_max ) cor3_normal(1:3,1:cor3_num) = 0.0E+00 call cor3_normal_set ( cor3_max, cor3_normal, face, face_area, & face_max, face_num, face_order, order_max, vertex_normal ) end if ! ! Make the other side of the surface. ! if ( invert ) then call object_invert ( cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, face, face_material, face_max, face_normal, face_num, & face_order, material_max, material_name, material_num, material_rgba, & order_max, vertex_material, vertex_normal ) end if ! ! Make the grid. ! if ( grid ) then black = 1 white = 2 call oogl_grid ( cor3, cor3_material, cor3_normal, face, face_material, & face_order, cor3_max, face_max, order_max, cor3_num, face_num, & ncol_oogl, nrow_oogl, black, white, invert, vertex_material ) end if ! ! 06 April 1999 ! KLUDGE #2 WARNING: ! For our current purposes, we need to guarantee that there ! is at least one node of each material. ! cor3_num = cor3_num + 1 cor3(1,cor3_num) = cor3(1,1) cor3(2,cor3_num) = cor3(1,1) cor3(3,cor3_num) = cor3(1,1) cor3_material(cor3_num) = 1 cor3_normal(1,cor3_num) = 1.0E+00 cor3_normal(2,cor3_num) = 0.0E+00 cor3_normal(3,cor3_num) = 0.0E+00 cor3_num = cor3_num + 1 cor3(1,cor3_num) = cor3(1,1) cor3(2,cor3_num) = cor3(1,1) cor3(3,cor3_num) = cor3(1,1) cor3_material(cor3_num) = 2 cor3_normal(1,cor3_num) = 1.0E+00 cor3_normal(2,cor3_num) = 0.0E+00 cor3_normal(3,cor3_num) = 0.0E+00 cor3_num = cor3_num + 1 cor3(1,cor3_num) = cor3(1,1) cor3(2,cor3_num) = cor3(1,1) cor3(3,cor3_num) = cor3(1,1) cor3_material(cor3_num) = 3 cor3_normal(1,cor3_num) = 1.0E+00 cor3_normal(2,cor3_num) = 0.0E+00 cor3_normal(3,cor3_num) = 0.0E+00 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'OOGL_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return ! ! Unexpected end of information. ! 50 continue write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_READ - Fatal error!' write ( *, '(a)' ) ' Unexpected end of information!' return end subroutine oogl_grid ( cor3, cor3_material, cor3_normal, face, face_material, & face_order, cor3_max, face_max, order_max, cor3_num, face_num, ncol_oogl, & nrow_oogl, black, white, invert, vertex_material ) ! !******************************************************************************* ! !! OOGL_GRID adds a grid to an OOGL data file. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Output, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer COR3_NUM, the number of points. ! ! Output, integer FACE_NUM, the number of faces. ! ! Output, integer MATERIAL_NUM, the number of materials. ! ! Output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer cor3_max integer face_max integer order_max ! integer base integer b2l2 integer b2r1u integer b2r2 integer b2r2u integer black real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real, parameter :: EPS = 0.0025E+00 integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) integer grid_nx integer, parameter :: GRID_NX_NUM = 20 integer grid_ny integer, parameter :: GRID_NY_NUM = 20 real, parameter :: GRID_WIDTH = 0.008E+00 integer i logical invert integer j integer k integer ncol_oogl real norm integer nrow_oogl integer nvert integer t1l2u integer t1r2u integer t2l2 integer t2l2u integer t2r1u integer t2r2 integer t2r2u integer vertex_material(order_max,face_max) integer white ! ! Determine the number of grid lines. ! grid_nx = ncol_oogl / GRID_NX_NUM grid_nx = min ( grid_nx, ncol_oogl - 1 ) grid_nx = max ( grid_nx, 1 ) grid_ny = nrow_oogl / GRID_NY_NUM grid_ny = min ( grid_ny, nrow_oogl - 1 ) grid_ny = max ( grid_ny, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_GRID:' write ( *, '(a,i6)' ) ' Grid spacing is ', grid_nx write ( *, '(a,i6)' ) ' by ', grid_ny ! ! Do the grid lines that I think of as running along the "top" of ! the affected faces. ! ! T2L2U---- ---- T2R2U ! T1L2U---- ---- T1R2U ! | .... .... | ! +--- ---- ---- ---+ ! ! T2L2 ---- ---- T2R2 ! | .... .... | ! | .... .... | ! B2L2 ---- ---- B2R2 ! do i = grid_ny+1, nrow_oogl, grid_ny do j = 2, ncol_oogl b2l2 = ( i - 2 ) * ncol_oogl + j - 1 b2r2 = ( i - 2 ) * ncol_oogl + j t2l2 = ( i - 1 ) * ncol_oogl + j - 1 t2r2 = ( i - 1 ) * ncol_oogl + j cor3_num = cor3_num + 1 t2l2u = cor3_num cor3(1:3,t2l2u) = cor3(1:3,t2l2) + EPS * cor3_normal(1:3,t2l2) cor3_material(cor3_num) = black cor3_num = cor3_num + 1 t2r2u = cor3_num do k = 1, 3 cor3(k,t2r2u) = cor3(k,t2r2) + EPS * cor3_normal(k,t2r2) end do cor3_material(cor3_num) = black cor3_num = cor3_num + 1 t1l2u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2l2) + EPS * cor3_normal(k,b2l2) & - cor3(k,t2l2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t1l2u) = cor3(k,t2l2u) + GRID_WIDTH * ( cor3(k,b2l2) & + EPS * cor3_normal(k,b2l2) - cor3(k,t2l2) ) * norm end do cor3_material(cor3_num) = black cor3_num = cor3_num + 1 t1r2u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2r2) + EPS * cor3_normal(k,b2r2) & - cor3(k,t2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t1r2u) = cor3(k,t2r2u) & + GRID_WIDTH * ( cor3(k,b2r2) + EPS * cor3_normal(k,b2r2) & - cor3(k,t2r2) ) * norm end do cor3_material(cor3_num) = black face_num = face_num + 1 face_material(face_num) = black face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = t2l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t1l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black face_num = face_num + 1 face_material(face_num) = black face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = t1l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t1r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black end do end do write ( *, '(a)' ) 'OOGL_GRID2: Done "top" grid.' ! ! Do the grid lines that I think of as running along the "right" of ! the affected faces. ! ! +--- ---- T2R1U-T2R2U ! | .... | | ! | .... | | ! +--- ---- B2R1U-B2R2U ! ! T2L2 ---- ---- T2R2 ! | .... .... | ! | .... .... | ! B2L2 ---- ---- B2R2 ! do j = grid_nx+1, ncol_oogl, grid_nx do i = 2, nrow_oogl b2l2 = ( i - 2 ) * ncol_oogl + j - 1 b2r2 = ( i - 2 ) * ncol_oogl + j t2l2 = ( i - 1 ) * ncol_oogl + j - 1 t2r2 = ( i - 1 ) * ncol_oogl + j cor3_num = cor3_num + 1 b2r2u = cor3_num do k = 1, 3 cor3(k,b2r2u) = cor3(k,b2r2) + EPS * cor3_normal(k,b2r2) end do cor3_material(cor3_num) = black cor3_num = cor3_num + 1 t2r2u = cor3_num do k = 1, 3 cor3(k,t2r2u) = cor3(k,t2r2) + EPS * cor3_normal(k,t2r2) end do cor3_material(cor3_num) = black cor3_num = cor3_num + 1 t2r1u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,t2l2) + EPS * cor3_normal(k,t2l2) & - cor3(k,t2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t2r1u) = cor3(k,t2r2u) + GRID_WIDTH * ( cor3(k,t2l2) + & EPS * cor3_normal(k,t2l2) - cor3(k,t2r2) ) * norm end do cor3_material(cor3_num) = black cor3_num = cor3_num + 1 b2r1u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2l2) + EPS * cor3_normal(k,b2l2) & - cor3(k,b2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,b2r1u) = cor3(k,b2r2u) + GRID_WIDTH * ( cor3(k,b2l2) & + EPS * cor3_normal(k,b2l2) - cor3(k,b2r2) ) * norm end do cor3_material(cor3_num) = black face_num = face_num + 1 face_material(face_num) = black face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = b2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black face_num = face_num + 1 face_material(face_num) = black face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = b2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black nvert = nvert + 1 k = b2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = black end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_GRID - Added black "grid lines".' write ( *, '(a,i6)' ) ' Number of points = ', cor3_num write ( *, '(a,i6)' ) ' Number of faces = ', face_num ! ! Do the grid lines that I think of as running along the "top" of ! the affected faces. ! ! T2L2U---- ---- T2R2U ! T1L2U---- ---- T1R2U ! | .... .... | ! +--- ---- ---- ---+ ! ! T2L2 ---- ---- T2R2 ! | .... .... | ! | .... .... | ! B2L2 ---- ---- B2R2 ! if ( .not. invert ) then return end if base = ncol_oogl * nrow_oogl write ( *, '(a,i6)' ) 'BASE = ', base do i = grid_ny+1, nrow_oogl, grid_ny do j = 2, ncol_oogl b2l2 = base + ( i - 2 ) * ncol_oogl + j - 1 b2r2 = base + ( i - 2 ) * ncol_oogl + j t2l2 = base + ( i - 1 ) * ncol_oogl + j - 1 t2r2 = base + ( i - 1 ) * ncol_oogl + j cor3_num = cor3_num + 1 t2l2u = cor3_num do k = 1, 3 cor3(k,t2l2u) = cor3(k,t2l2) + EPS * cor3_normal(k,t2l2) end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 t2r2u = cor3_num do k = 1, 3 cor3(k,t2r2u) = cor3(k,t2r2) + EPS * cor3_normal(k,t2r2) end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 t1l2u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2l2) + EPS * cor3_normal(k,b2l2) & - cor3(k,t2l2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t1l2u) = cor3(k,t2l2u) + GRID_WIDTH * ( cor3(k,b2l2) & + EPS * cor3_normal(k,b2l2) - cor3(k,t2l2) ) * norm end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 t1r2u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2r2) + EPS * cor3_normal(k,b2r2) & - cor3(k,t2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t1r2u) = cor3(k,t2r2u) + GRID_WIDTH * ( cor3(k,b2r2) & + EPS * cor3_normal(k,b2r2) - cor3(k,t2r2) ) * norm end do cor3_material(cor3_num) = white face_num = face_num + 1 face_material(face_num) = white face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = t2l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t1l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white face_num = face_num + 1 face_material(face_num) = white face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = t1l2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t1r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_GRID - Added white top "grid lines".' write ( *, '(a,i6)' ) ' Number of points = ', cor3_num write ( *, '(a,i6)' ) ' Number of faces = ', face_num ! ! Do the grid lines that I think of as running along the "right" of ! the affected faces. ! ! +--- ---- T2R1U-T2R2U ! | .... | | ! | .... | | ! +--- ---- B2R1U-B2R2U ! ! T2L2 ---- ---- T2R2 ! | .... .... | ! | .... .... | ! B2L2 ---- ---- B2R2 ! do j = grid_nx+1, ncol_oogl, grid_nx do i = 2, nrow_oogl b2l2 = base + ( i - 2 ) * ncol_oogl + j - 1 b2r2 = base + ( i - 2 ) * ncol_oogl + j t2l2 = base + ( i - 1 ) * ncol_oogl + j - 1 t2r2 = base + ( i - 1 ) * ncol_oogl + j cor3_num = cor3_num + 1 b2r2u = cor3_num do k = 1, 3 cor3(k,b2r2u) = cor3(k,b2r2) + EPS * cor3_normal(k,b2r2) end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 t2r2u = cor3_num do k = 1, 3 cor3(k,t2r2u) = cor3(k,t2r2) + EPS * cor3_normal(k,t2r2) end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 t2r1u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,t2l2) + EPS * cor3_normal(k,t2l2) & - cor3(k,t2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,t2r1u) = cor3(k,t2r2u) + GRID_WIDTH * ( cor3(k,t2l2) & + EPS * cor3_normal(k,t2l2) - cor3(k,t2r2) ) * norm end do cor3_material(cor3_num) = white cor3_num = cor3_num + 1 b2r1u = cor3_num norm = 0.0E+00 do k = 1, 3 norm = norm + ( cor3(k,b2l2) + EPS * cor3_normal(k,b2l2) & - cor3(k,b2r2) )**2 end do norm = sqrt ( norm ) if ( norm /= 0.0E+00 ) then norm = 1.0E+00 / norm end if do k = 1, 3 cor3(k,b2r1u) = cor3(k,b2r2u) + GRID_WIDTH * ( cor3(k,b2l2) & + EPS * cor3_normal(k,b2l2) - cor3(k,b2r2) ) * norm end do cor3_material(cor3_num) = white face_num = face_num + 1 face_material(face_num) = white face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = b2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white face_num = face_num + 1 face_material(face_num) = white face_order(face_num) = 3 nvert = 0 nvert = nvert + 1 k = b2r1u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = t2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white nvert = nvert + 1 k = b2r2u face(nvert,face_num) = k vertex_material(nvert,face_num) = white end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OOGL_GRID - Added white "grid lines".' write ( *, '(a,i6)' ) ' Number of points = ', cor3_num write ( *, '(a,i6)' ) ' Number of faces = ', face_num return end subroutine outfile ( filein_name, fileout_name, ierror, fileout_type ) ! !******************************************************************************* ! !! OUTFILE determines the output filename and type. ! ! ! Modified: ! ! 13 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Output, integer IERROR, an error flag. ! ! Output, character ( len = 10 ) FILEOUT_TYPE, the type of the file, which is ! set to the filename extension. Typical values include ! 'ase', 'dxf', 'iv', 'obj', 'pov', 'ps', 'smf', 'stl', 'stla', ! 'tec', 'tri', 'ts', 'txt', 'vla', 'wrl', 'xgl', or 'xyz'. ! implicit none ! character ( len = * ) filein_name character ( len = * ) fileout_name character ( len = 10 ) fileout_type integer i1 integer i2 integer ierror integer ios logical s_eqi ! ierror = 0 if ( filein_name == ' ' ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OUTFILE - Error!' write ( *, '(a)' ) ' You must read a file IN before you can' write ( *, '(a)' ) ' write a file OUT.' return end if if ( fileout_name == ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OUTFILE:' write ( *, '(a)' ) ' Enter the output filename to be created,' write ( *, '(a)' ) ' or hit return if done.' read ( *, '(a)', iostat = ios ) fileout_name if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OUTFILE - Error!' write ( *, '(a)' ) ' The output file was not specified correctly.' ierror = ios fileout_name = ' ' return end if end if ! ! Determine the output file type. ! call file_name_ext_get ( fileout_name, i1, i2 ) if ( i1 /= 0 ) then fileout_type = fileout_name(i1:i2) else fileout_type = ' ' end if if ( .not. ( & s_eqi ( fileout_type, 'ASE' ) .or. s_eqi ( fileout_type, 'BYU' ) .or. & s_eqi ( fileout_type, 'DXF' ) .or. s_eqi ( fileout_type, 'HRC' ) .or. & s_eqi ( fileout_type, 'IV' ) .or. s_eqi ( fileout_type, 'OBJ' ) .or. & s_eqi ( fileout_type, 'POV' ) .or. s_eqi ( fileout_type, 'PS' ) .or. & s_eqi ( fileout_type, 'SMF' ) .or. s_eqi ( fileout_type, 'STL' ) .or. & s_eqi ( fileout_type, 'STLA' ) .or. s_eqi ( fileout_type, 'TEC' ) .or. & s_eqi ( fileout_type, 'TRI' ) .or. s_eqi ( fileout_type, 'TRIA' ) .or. & s_eqi ( fileout_type, 'TS' ) .or. & s_eqi ( fileout_type, 'TXT' ) .or. s_eqi ( fileout_type, 'UCD' ) .or. & s_eqi ( fileout_type, 'VLA' ) .or. s_eqi ( fileout_type, 'WRL' ) .or. & s_eqi ( fileout_type, 'XGL' ) .or. s_eqi ( fileout_type, 'XYZ' ) ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OutFile could not determine the file type.' write ( *, '(a)' ) ' The output file name is:' write ( *, '(a)' ) trim ( fileout_name ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The file type should occur after the period.' write ( *, '(a)' ) ' Please specify the file type you are using:' write ( *, '(a)' ) ' Enter "ase", "byu", "dxf", "hrc", "iv",' write ( *, '(a)' ) ' "obj", "pov", "ps", "smf", "stl", "tec",' write ( *, '(a)' ) ' "tri", "ts", "txt", "ucd", "vla", "wrl", ' write ( *, '(a)' ) ' "xgl", or "xyz":' read ( *, '(a)' ) fileout_type call s_cap ( fileout_type ) if ( .not. ( & s_eqi ( fileout_type, 'ASE' ) .or. s_eqi ( fileout_type, 'BYU' ) .or. & s_eqi ( fileout_type, 'DXF' ) .or. s_eqi ( fileout_type, 'HRC' ) .or. & s_eqi ( fileout_type, 'IV' ) .or. s_eqi ( fileout_type, 'OBJ' ) .or. & s_eqi ( fileout_type, 'POV' ) .or. s_eqi ( fileout_type, 'PS' ) .or. & s_eqi ( fileout_type, 'SMF' ) .or. s_eqi ( fileout_type, 'STL' ) .or. & s_eqi ( fileout_type, 'STLA' ) .or. s_eqi ( fileout_type, 'TEC' ) .or. & s_eqi ( fileout_type, 'TRI' ) .or. s_eqi ( fileout_type, 'TRIA' ) .or. & s_eqi ( fileout_type, 'TS' ) .or. & s_eqi ( fileout_type, 'TXT' ) .or. s_eqi ( fileout_type, 'UCD' ) .or. & s_eqi ( fileout_type, 'VLA' ) .or. s_eqi ( fileout_type, 'WRL' ) .or. & s_eqi ( fileout_type, 'XGL' ) .or. s_eqi ( fileout_type, 'XYZ' ) ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OUTFILE - Error!' write ( *, '(a)' ) ' The file type was not acceptable!' return end if end if return end function pi ( ) ! !******************************************************************************* ! !! PI returns the value of pi. ! ! ! Modified: ! ! 04 December 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real PI, the value of pi. ! implicit none ! real pi ! pi = 3.14159265358979323846264338327950288419716939937510E+00 return end subroutine plane_exp2imp_3d ( x1, y1, z1, x2, y2, z2, x3, y3, z3, a, b, c, d ) ! !******************************************************************************* ! !! PLANE_EXP2IMP_3D converts an explicit plane to implicit form in 3D. ! ! ! Definition: ! ! The explicit form of a plane in 3D is ! ! (X1,Y1,Z1), (X2,Y2,Z2), (X3,Y3,Z3). ! ! The implicit form of a plane in 3D is ! ! A * X + B * Y + C * Z + D = 0 ! ! Reference: ! ! Adrian Bowyer and John Woodwark, ! A Programmer's Geometry, ! Butterworths, 1983. ! ! Modified: ! ! 04 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X1, Y1, Z1, X2, Y2, X2, X3, Y3, Z3, are three points ! on the plane, which must be distinct, and not collinear. ! ! Output, real A, B, C, D, coefficients which describe the plane. ! implicit none ! real a real b real c real d real x1 real x2 real x3 real y1 real y2 real y3 real z1 real z2 real z3 a = ( y2 - y1 ) * ( z3 - z1 ) - ( z2 - z1 ) * ( y3 - y1 ) b = ( z2 - z1 ) * ( x3 - x1 ) - ( x2 - x1 ) * ( z3 - z1 ) c = ( x2 - x1 ) * ( y3 - y1 ) - ( y2 - y1 ) * ( x3 - x1 ) d = - x2 * a - y2 * b - z2 * c return end subroutine plane_imp_point_nearest_3d ( a, b, c, d, x, y, z, xn, yn, zn ) ! !******************************************************************************* ! !! PLANE_IMP_POINT_NEAREST_3D: nearest point on a implicit plane to a point in 3D. ! ! ! Definition: ! ! The implicit form of a plane in 3D is: ! ! A * X + B * Y + C * Z + D = 0 ! ! Modified: ! ! 16 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real A, B, C, D, coefficients that define the plane as ! the set of points for which A*X+B*Y+C*Z+D = 0. ! ! Input, real X, Y, Z, the coordinates of the point. ! ! Output, real XN, YN, ZN, the coordinates of the nearest point on ! the plane. ! implicit none ! real a real b real c real d real t real x real xn real y real yn real z real zn ! if ( a == 0.0E+00 .and. b == 0.0E+00 .and. c == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLANE_IMP_POINT_NEAREST_3D - Fatal error!' write ( *, '(a)' ) ' A = B = C = 0.' stop end if ! ! The normal N to the plane is (A,B,C). ! ! The line defined by (XN-X)/A = (YN-Y)/B = (ZN-Z)/C = T ! goes through (X,Y,Z) and is parallel to N. ! ! Solving for the point (XN,YN,ZN) we get ! ! XN = A*T+X ! YN = B*T+Y ! ZN = C*T+Z ! ! Now place these values in the equation for the plane: ! ! A*(A*T+X) + B*(B*T+Y) + C*(C*T+Z) + D = 0 ! ! and solve for T: ! ! T = (-A*X-B*Y-C*Z-D) / (A * A + B * B + C * C ) ! t = - ( a * x + b * y + c * z + d ) / ( a * a + b * b + c * c ) xn = x + a * t yn = y + b * t zn = z + c * t return end subroutine points_distance_3d ( dis, x1, y1, z1, x2, y2, z2 ) ! !******************************************************************************* ! !! POINTS_DISTANCE_3D finds the distance between two points in 3D. ! ! ! Modified: ! ! 27 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real DIS, the distance between the points. ! ! Input, real X1, Y1, Z1, X2, Y2, Z2, determines the pair of points ! (X1,Y1,Z1) and (X2,Y2,Z2) whose distance apart is be determined. ! implicit none ! real dis real x1 real x2 real y1 real y2 real z1 real z2 ! dis = sqrt ( ( x1 - x2 )**2 + ( y1 - y2 )**2 + ( z1 - z2 )**2 ) return end subroutine poly_2_tri ( face, face_material, face_max, face_num, face_order, & ierror, order_max, vertex_material ) ! !******************************************************************************* ! !! POLY_2_TRI converts a collection of polygons into a collection of triangles. ! ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Output, integer IERROR, error flag. ! 0, no error. ! 1, the algorithm failed because FACE_MAX was too small. ! 2, the algorithm failed because there were faces of order < 3. ! 3, the algorithm failed because there were faces of order > ORDER_MAX. ! ! Input, integer FACE_MAX, the maximum number of faces allowed. ! ! Input, integer ORDER_MAX, the maximum number of vertices allowed per face. ! ! Input/output, integer FACE_NUM, the number of faces. This value is updated ! on return. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer face_max integer order_max ! integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_num2 integer face_order(face_max) integer ierror integer iface integer iface_old integer ivert integer k integer vertex_material(order_max,face_max) ! ierror = 0 face_num2 = 0 do iface = 1, face_num if ( face_order(iface) < 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_2_TRI - Fatal error!' write ( *, '(a,i6,a)' ) ' Face ', iface, ' is illegal.' write ( *, '(a,i6)' ) ' Number of vertices is ', face_order(iface) ierror = 2 return else if ( face_order(iface) > order_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_2_TRI - Fatal error!' write ( *, '(a,i6,a)' ) ' Face ', iface, ' is illegal.' write ( *, '(a,i6)' ) ' Number of vertices is ', face_order(iface) write ( *, '(a,i6)' ) ' ORDER_MAX is ', order_max ierror = 3 return end if do ivert = 3, face_order(iface) face_num2 = face_num2 + 1 end do end do if ( face_num2 > face_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_2_TRI - Fatal error!' write ( *, '(a)' ) ' FACE_MAX is too small to replace all faces' write ( *, '(a)' ) ' by triangles.' write ( *, '(a,i6)' ) ' FACE_MAX = ', face_max write ( *, '(a,i6)' ) ' FACE_NUM2 = ', face_num2 ierror = 1 return end if iface_old = face_num k = face_order(iface_old) do iface = face_num2, 1, -1 if ( k < 3 ) then iface_old = iface_old - 1 k = face_order(iface_old) end if face_material(iface) = face_material(iface_old) face_order(iface) = 3 face(1,iface) = face(1,iface_old) vertex_material(1,iface) = vertex_material(1,iface_old) do ivert = 2, 3 face(ivert,iface) = face(k+ivert-3,iface_old) vertex_material(ivert,iface) = vertex_material(k+ivert-3,iface_old) end do k = k - 1 end do face_num = face_num2 return end subroutine pov_write ( cor3, cor3_max, face, face_material, face_max, & face_num, face_order, filein_name, fileout_name, iunit, & material_max, material_num, material_rgba, order_max, vertex_normal ) ! !******************************************************************************* ! !! POV_WRITE writes graphics information to a POV file. ! ! ! Example: ! ! // cone.pov created by IVREAD. ! // Original data in cone.iv. ! ! #version 3.0E+00 ! #include "colors.inc" ! #include "shapes.inc" ! global_settings { assumed_gamma 2.2 } ! ! camera { ! right < 4/3, 0, 0> ! up < 0, 1, 0 > ! sky < 0, 1, 0 > ! angle 20 ! location < 0, 0, -300 > ! look_at < 0, 0, 0> ! } ! ! light_source { < 20, 50, -100 > color White } ! ! background { color SkyBlue } ! ! #declare Material001 = texture { ! pigment { color rgb < 0.8, 0.2, 0.2> } ! finish { ambient 0.2 diffuse 0.5 } ! } ! ! #declare Material002 = texture { ! pigment { color rgb < 0.2, 0.2, 0.8> } ! finish { ambient 0.2 diffuse 0.5 } ! } ! ! mesh { ! smooth_triangle { ! < 0.29, -0.29, 0.0>, < 0.0, 0.0, -1.0 >, ! < 38.85, 10.03, 0.0>, < 0.0, 0.0, -1.0 >, ! < 40.21, -0.29, 0.0>, < 0.0, 0.0, -1.0 > ! texture { Material002 } } ! ... ! smooth_triangle { ! < 0.29, -0.29, 70.4142 >, < 0.0, 0.0, 1.0 >, ! < 8.56, -2.51, 70.4142 >, < 0.0, 0.0, 1.0 >, ! < 8.85, -0.29, 70.4142 >, < 0.0, 0.0, 1.0 > ! texture { Material001 } } ! } ! ! Modified: ! ! 23 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), face materials. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer MATERIAL_NUM, the number of materials. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and A values. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals at vertices. ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max ! real b character ( len = 4 ) char4 character comma real cor3(3,cor3_max) integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name real g integer i integer i_mat integer iunit integer j integer jj integer jlo integer k real material_rgba(4,material_max) integer material_num real r character ( len = 100 ) text integer text_num real vertex_normal(3,order_max,face_max) ! text_num = 0 write ( iunit, '(a)' ) '// ' // trim ( fileout_name ) // ' created by IVREAD.' write ( iunit, '(a)' ) '// Original data in ' // trim ( filein_name ) // '.' text_num = text_num + 2 ! ! Initial declarations. ! write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) '#version 3.0' write ( iunit, '(a)' ) '#include "colors.inc"' write ( iunit, '(a)' ) '#include "shapes.inc"' write ( iunit, '(a)' ) 'global_settings { assumed_gamma 2.2 }' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'camera { ' write ( iunit, '(a)' ) ' right < 4/3, 0, 0>' write ( iunit, '(a)' ) ' up < 0, 1, 0 >' write ( iunit, '(a)' ) ' sky < 0, 1, 0 >' write ( iunit, '(a)' ) ' angle 20' write ( iunit, '(a)' ) ' location < 0, 0, -300 >' write ( iunit, '(a)' ) ' look_at < 0, 0, 0>' write ( iunit, '(a)' ) '}' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'light_source { < 20, 50, -100 > color White }' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'background { color SkyBlue }' text_num = text_num + 15 ! ! Declare RGB textures. ! do i = 1, material_num write ( iunit, '(a)' ) ' ' call i_to_s_zero ( i, char4 ) write ( iunit, '(a)' ) '#declare Material_' // char4 // ' = texture { ' r = material_rgba(1,i) g = material_rgba(2,i) b = material_rgba(3,i) write ( iunit, '(a,f4.2,a,f4.2,a,f4.2,a)' ) ' pigment { color rgb < ', & r, ',', g, ',', b ,' > } ' write ( iunit, '(a)' ) ' finish { ambient 0.2 diffuse 0.5 }' write ( iunit, '(a)' ) '}' end do ! ! Write one big object. ! write ( iunit, '(a)' ) 'mesh {' text_num = text_num + 1 ! ! Do the next face. ! do i = 1, face_num ! ! Break the face up into triangles, anchored at node 1. ! do jlo = 1, face_order(i) - 2 write ( iunit, '(a)' ) ' smooth_triangle { ' text_num = text_num + 1 do j = jlo, jlo + 2 if ( j == jlo ) then jj = 1 else jj = j end if k = face(jj,i) if ( j < jlo + 2 ) then comma = ',' else comma = ' ' end if write ( text, '(a,3(f10.3,a),3(f6.2,a),a )' ) & '<', cor3(1,k), ',', cor3(2,k), ',', cor3(3,k), '>, <', & vertex_normal(1,jj,i), ',', vertex_normal(2,jj,i), ',', & vertex_normal(3,jj,i), '>', comma call s_blanks_delete ( text ) write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do i_mat = face_material(i) call i_to_s_zero ( i_mat, char4 ) write ( iunit, '(a)' ) 'texture { Material_' // char4 // ' } }' text_num = text_num + 1 end do end do write ( iunit, '(a)' ) '}' text_num = text_num + 1 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'POV_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine project_2d ( cor2, cor3, ierror, cor2_max, cor3_max, cor2_num, & cor3_num ) ! !******************************************************************************* ! !! PROJECT_2D projects 3D data to 2D based on user choices. ! ! ! Discussion: ! ! Projections include: ! ! drop X coordinate, display YZ; ! drop Y coordinate, display XZ; ! drop Z coordinate, display XY; ! orthographic projection into a plane; ! perspective projection into a plane through a focus point; ! project X into YZ using an angle THETA; ! project Y into XZ using an angle THETA; ! project Z into XY using an angle THETA. ! ! Modified: ! ! 14 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real COR2(2,COR2_MAX), the projected 2D data. ! ! Input, real COR3(3,COR3_MAX), the data to project. ! ! Input, integer COR2_MAX, COR3_MAX, the maximum number of 2D and ! 3D points that can be handled. ! ! Output, integer COR2_NUM, the number of 2D points. ! ! Input, integer COR3_NUM, the number of 3D points. ! implicit none ! integer cor2_max integer cor3_max ! real cor2(2,cor2_max) integer cor2_num real cor3(3,cor3_max) integer cor3_num integer i integer ierror integer ios character ( len = 20 ) isay logical s_eqi real theta real x1 real x2 real x3 real xf real y1 real y2 real y3 real yf real z1 real z2 real z3 real zf ! ierror = 0 if ( cor3_num <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Fatal error!' write ( *, '(a)' ) ' Input COR3_NUM <= 0.' ierror = 1 return end if cor2_num = cor3_num write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Choose a projection from 3D -> 2D:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) '-X drop X coordinate, display YZ;' write ( *, '(a)' ) '-Y drop Y coordinate, display XZ;' write ( *, '(a)' ) '-Z drop Z coordinate, display XY;' write ( *, '(a)' ) 'OPLANE orthographic projection into plane.' write ( *, '(a)' ) 'PPLANE perspective projection into plane.' write ( *, '(a)' ) 'PX project X into YZ using THETA;' write ( *, '(a)' ) 'PY project Y into XZ using THETA;' write ( *, '(a)' ) 'PZ project Z into XY using THETA;' read ( *, '(a)', iostat = ios ) isay if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if if ( s_eqi ( isay, '-X' ) ) then do i = 1, cor3_num cor2(1,i) = cor3(2,i) cor2(2,i) = cor3(3,i) end do else if ( s_eqi ( isay, '-Y' ) ) then do i = 1, cor3_num cor2(1,i) = cor3(1,i) cor2(2,i) = cor3(3,i) end do else if ( s_eqi ( isay, '-Z' ) ) then do i = 1, cor3_num cor2(1,i) = cor3(1,i) cor2(2,i) = cor3(2,i) end do else if ( s_eqi ( isay, 'OPLANE' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter 3 (X,Y,Z) points on the plane:' read ( *, *, iostat = ios ) x1, y1, z1, x2, y2, z2, x3, y3, z3 if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if call project_oplane ( x1, y1, z1, x2, y2, z2, x3, y3, z3, & cor2, cor3, cor2_max, cor3_max, cor3_num ) else if ( s_eqi ( isay, 'PPLANE' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter 3 (X,Y,Z) points on the plane:' read ( *, *, iostat = ios ) x1, y1, z1, x2, y2, z2, x3, y3, z3 if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if write ( *, '(a)' ) 'Enter focus point (X,Y,Z):' read ( *, *, iostat = ios ) xf, yf, zf if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if call project_pplane ( x1, y1, z1, x2, y2, z2, x3, y3, z3, xf, yf, zf, & cor2, cor3, cor2_max, cor3_max, cor2_num, cor3_num ) else if ( s_eqi ( isay, 'PX' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter projection angle THETA in degrees:' read ( *, *, iostat = ios ) theta if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if call project_angle ( 'X', cor2, cor3, cor2_max, cor3_max, cor2_num, theta ) else if ( s_eqi ( isay, 'PY' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter projection angle THETA in degrees:' read ( *, *, iostat = ios ) theta if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if call project_angle ( 'Y', cor2, cor3, cor2_max, cor3_max, cor2_num, theta ) else if ( s_eqi ( isay, 'PZ' ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter projection angle THETA in degrees:' read ( *, *, iostat = ios ) theta if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Unexpected end of input.' ierror = ios return end if call project_angle ( 'Z', cor2, cor3, cor2_max, cor3_max, cor2_num, theta ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_2D - Error!' write ( *, '(a)' ) ' Unrecognized projection option!' cor2_num = 0 ierror = 1 end if return end subroutine project_angle ( cor, cor2, cor3, cor2_max, cor3_max, cor2_num, & theta ) ! !******************************************************************************* ! !! PROJECT_ANGLE converts 3D data to 2D using a presentation angle. ! ! ! Discussion: ! ! A "presentation angle" THETA is used to project the 3D point ! (X3D, Y3D, Z3D) to the 2D projection (XVAL,YVAL). ! ! The formula used if COR = 'X' is ! ! X2D = Y3D - sin ( THETA ) * X3D ! Y2D = Z3D - sin ( THETA ) * X3D ! ! Modified: ! ! 14 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character COR, the coordinate to be projected. ! COR should be 'X', 'Y', or 'Z'. ! ! Output, real COR2(2,COR2_MAX), the 2D projections. ! ! Input, real COR3(3,COR3_MAX), the 3D points to be projected. ! ! Input, integer COR2_MAX, COR3_MAX, the maximum number of 2D and ! 3D points allowed. ! ! Input, integer COR2_NUM, the number of 2D values to be computed. ! ! Input, real THETA, the presentation angle in degrees. ! implicit none ! integer cor2_max integer cor3_max ! character cor real cor2(2,cor2_max) integer cor2_num real cor3(3,cor3_max) integer i real pi logical s_eqi real stheta real theta ! stheta = sin ( pi() * theta / 180.0E+00 ) if ( cor2_num > cor2_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_ANGLE - Fatal error!' write ( *, '(a)' ) ' COR2_NUM is greater than COR2_MAX.' stop end if if ( cor2_num > cor3_max ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_ANGLE - Fatal error!' write ( *, '(a)' ) ' COR2_NUM is greater than COR3_MAX.' stop end if if ( s_eqi ( cor, 'X' ) ) then do i = 1, cor2_num cor2(1,i) = cor3(2,i) - stheta * cor3(1,i) cor2(2,i) = cor3(3,i) - stheta * cor3(1,i) end do else if ( s_eqi ( cor, 'Y' ) ) then do i = 1, cor2_num cor2(1,i) = cor3(1,i) - stheta * cor3(2,i) cor2(2,i) = cor3(3,i) - stheta * cor3(2,i) end do else if ( s_eqi ( cor, 'Z' ) ) then cor2(1,1:cor2_num) = cor3(1,1:cor2_num) - stheta * cor3(3,1:cor2_num) cor2(2,1:cor2_num) = cor3(2,1:cor2_num) - stheta * cor3(3,1:cor2_num) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PROJECT_ANGLE - Fatal error!' write ( *, '(a)' ) ' Unrecognized axis.' stop end if return end subroutine project_oplane ( x1, y1, z1, x2, y2, z2, x3, y3, z3, cor2, cor3, & cor2_max, cor3_max, cor3_num ) ! !******************************************************************************* ! !! PROJECT_OPLANE projects 3D points onto an orthographic plane. ! ! ! Modified: ! ! 14 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, are the ! coordinates of three points on the plane. ! ! Output, real COR2(2,COR2_MAX), the "local" in-plane coordinates ! of the projections of the object points. ! ! Input, real COR3(3,COR3_MAX), the (X,Y,Z) coordinates of the object ! points. ! ! Input, integer COR2_MAX, COR3_MAX, the maximum number of 2D and ! 3D points that can be handled. ! ! Input, integer COR3_NUM, the number of points to project. ! implicit none ! integer cor2_max integer cor3_max ! real a real b real c real cor2(2,cor2_max) real cor3(3,cor3_max) integer cor3_num real d real dot integer i real v1(3) real v2(3) real x1 real x2 real x3 real xn real y1 real y2 real y3 real yn real z1 real z2 real z3 real zn ! ! Put the plane into ABCD form. ! call plane_exp2imp_3d ( x1, y1, z1, x2, y2, z2, x3, y3, z3, a, b, c, d ) ! ! Compute the two basis vectors for the affine plane. ! v1(1) = x2 - x1 v1(2) = y2 - y1 v1(3) = z2 - z1 call vector_unit_nd ( 3, v1 ) v2(1) = x3 - x1 v2(2) = y3 - y1 v2(3) = z3 - z1 dot = v1(1) * v2(1) + v1(2) * v2(2) + v1(3) * v2(3) v2(1:3) = v2(1:3) - dot * v1(1:3) call vector_unit_nd ( 3, v2 ) ! ! For each point, its image in the plane is the nearest point ! in the plane. ! do i = 1, min ( cor3_num, cor3_max ) call plane_imp_point_nearest_3d ( a, b, c, d, cor3(1,i), cor3(2,i), & cor3(3,i), xn, yn, zn ) cor2(1,i) = ( xn - x1 ) * v1(1) + ( yn - y1 ) * v1(2) + ( zn - z1 ) * v1(3) cor2(2,i) = ( xn - x1 ) * v2(1) + ( yn - y1 ) * v2(2) + ( zn - z1 ) * v2(3) end do return end subroutine project_pplane ( x1, y1, z1, x2, y2, z2, x3, y3, z3, xf, yf, zf, & cor2, cor3, cor2_max, cor3_max, cor2_num, cor3_num ) ! !******************************************************************************* ! !! PROJECT_PPLANE projects a point through a focus point onto a perspective plane. ! ! ! Modified: ! ! 14 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, are the ! coordinates of three points on the plane. ! ! Input, real XF, YF, ZF, are the coordinates of the focus point. ! ! Output, real COR2(2,COR2_MAX), the "local" in-plane coordinates ! of the projections of the object points. ! ! Input, real COR3(3,COR3_MAX), the (X,Y,Z) coordinates of points ! to be projected. ! ! Input, integer COR2_MAX, COR3_MAX, the maximum number of 2D and ! 3D points that can be handled. ! ! Output, integer COR2_NUM, the number of projected points. ! ! Input, integer COR3_NUM, the number of points to project. ! implicit none ! integer cor2_max integer cor3_max ! real a real alpha real angle_rad_3d real b real beta real c real cor2(2,cor2_max) integer cor2_num real cor3(3,cor3_max) integer cor3_num real d real disfo real disfn real dot integer i real v1(3) real v2(3) real x1 real x2 real x3 real xf real xn real xp real y1 real y2 real y3 real yf real yn real yp real z1 real z2 real z3 real zf real zn real zp ! ! Put the plane into ABCD form. ! call plane_exp2imp_3d ( x1, y1, z1, x2, y2, z2, x3, y3, z3, a, b, c, d ) ! ! Get the nearest point on the plane to the focus. ! call plane_imp_point_nearest_3d ( a, b, c, d, xf, yf, zf, xn, yn, zn ) ! ! Get the distance from the focus to the plane. ! call points_distance_3d ( disfn, xf, yf, zf, xn, yn, zn ) ! ! If the focus lies in the plane, this is bad. We could still ! project points that actually lie in the plane, but we'll ! just bail out. ! if ( disfn == 0.0E+00 ) then cor2_num = 0 return end if ! ! Compute the two basis vectors for the affine plane. ! v1(1) = x2 - x1 v1(2) = y2 - y1 v1(3) = z2 - z1 call vector_unit_nd ( 3, v1 ) v2(1) = x3 - x1 v2(2) = y3 - y1 v2(3) = z3 - z1 dot = v1(1) * v2(1) + v1(2) * v2(2) + v1(3) * v2(3) v2(1:3) = v2(1:3) - dot * v1(1:3) call vector_unit_nd ( 3, v2 ) ! ! Process the points. ! do i = 1, min ( cor3_num, cor3_max ) ! ! Get the distance from the focus to the object. ! call points_distance_3d ( disfo, xf, yf, zf, cor3(1,i), cor3(2,i), & cor3(3,i) ) if ( disfo == 0.0E+00 ) then xp = xn yp = yn zp = zn else ! ! Compute ALPHA, the angle between (OBJECT-FOCUS) and (NEAREST-FOCUS). ! alpha = angle_rad_3d ( cor3(1,i), cor3(2,i), cor3(3,i), & xf, yf, zf, xn, yn, zn ) if ( cos ( alpha ) == 0.0E+00 ) then xp = xn yp = yn zp = zn else ! ! Multiplier BETA is Dist(NEAREST-FOCUS) / ( Cos(ALPHA)*Dist(OBJECT-FOCUS) ) ! beta = disfn / ( cos ( alpha ) * disfo ) ! ! Set the projected point. ! xp = xf + beta * ( cor3(1,i) - xf ) yp = yf + beta * ( cor3(2,i) - yf ) zp = zf + beta * ( cor3(3,i) - zf ) end if end if cor2(1,i) = ( xp - x1 ) * v1(1) + ( yp - y1 ) * v1(2) + ( zp - z1 ) * v1(3) cor2(2,i) = ( xp - x1 ) * v2(1) + ( yp - y1 ) * v2(2) + ( zp - z1 ) * v2(3) end do return end subroutine ps_write ( cor2, cor2_max, cor2_num, face, face_material, & face_max, face_num, face_order, fileout_name, iunit, line_dex, & line_material, line_max, line_num, material_max, & material_rgba, order_max ) ! !******************************************************************************* ! !! PS_WRITE writes 2D face and line information to a PostScript file. ! ! ! Discussion: ! ! The intent is that a 3D model will be projected in some way ! to a 2D model that can be printed out as a standard PostScript object. ! ! Modified: ! ! 23 February 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR2(2,COR2_MAX), the X and Y components of 2D points. ! ! Input, integer COR2_MAX, the maximum number of 2D points. ! ! Input, integer COR2_NUM, the number of 2D points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces defined. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which data is written. ! ! Input, integer LINE_DEX(LINE_MAX), nodes forming a line, terminated by -1. ! ! Input, integer LINE_MATERIAL(LINE_MAX), material index for line. ! ! Input, integer LINE_MAX, the maximum number of line definition items. ! ! Input, integer LINE_NUM, the number of line definition items. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and A values. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor2_max integer face_max integer line_max integer material_max integer order_max ! real alpha real blue real cor2(2,cor2_max) integer cor2_num character ( len = 9 ) date integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_order(face_max) character ( len = * ) fileout_name real green integer i integer iface integer imat integer imat_old integer iunit integer j integer jhi integer k logical lineopen integer line_dex(line_max) integer line_material(line_max) integer line_num integer margin real material_rgba(4,material_max) integer page_num integer pagexmax integer pagexmin integer pageymax integer pageymin integer plotxmax integer plotxmin integer plotxmin2 integer plotymax integer plotymin integer plotymin2 integer px integer py real red integer text_num character ( len = 8 ) time real xmax real xmin real ymax real ymin ! ! Initialization ! imat_old = -999 page_num = 1 text_num = 0 call date_and_time ( date, time ) ! ! Compute the bounding box. ! xmin = minval ( cor2(1,1:cor2_num) ) xmax = maxval ( cor2(1,1:cor2_num) ) ymin = minval ( cor2(2,1:cor2_num) ) ymax = maxval ( cor2(2,1:cor2_num) ) if ( xmin == xmax ) then xmin = cor2(1,1) - 0.5E+00 xmax = cor2(1,1) + 0.5E+00 end if if ( ymin == ymax ) then ymin = cor2(2,1) - 0.5E+00 ymax = cor2(2,1) + 0.5E+00 end if ! ! Compute the scale factor. ! pagexmax = 612 pagexmin = 0 pageymax = 792 pageymin = 0 margin = 36 plotxmax = pagexmax - margin plotxmin = pagexmin + margin plotymax = pageymax - margin plotymin = pageymin + margin alpha = min ( ( plotxmax - plotxmin ) / ( xmax - xmin ), & ( plotymax - plotymin ) / ( ymax - ymin ) ) ! ! Adjust PLOTXMIN and PLOTYMIN to center the image. ! plotxmin2 = 0.5E+00 * ( plotxmin + plotxmax - alpha * ( xmax - xmin ) ) plotymin2 = 0.5E+00 * ( plotymin + plotymax - alpha * ( ymax - ymin ) ) ! ! Prolog ! write ( iunit, '(a)' ) '%!PS-Adobe-3.0' write ( iunit, '(a)' ) '%%Creator: ivread.f90' write ( iunit, '(a)' ) '%%Title: ' // trim ( fileout_name ) write ( iunit, '(a,4i5)' ) '%%BoundingBox', plotxmin, plotymin, plotxmax, & plotymax write ( iunit, '(a)' ) '%%CreationDate: ' // date // ' ' // time write ( iunit, '(a)' ) '%%Pages: 1' write ( iunit, '(a)' ) '%%Document-Fonts: Times-Roman' write ( iunit, '(a)' ) '%%LanguageLevel: 2' write ( iunit, '(a)' ) '%%EndComments' write ( iunit, '(a)' ) '%%BeginProlog' write ( iunit, '(a)' ) '%%EndProlog' write ( iunit, '(a)' ) '/inch {72 mul} def' write ( iunit, '(a)' ) '%%Page: 1 1' write ( iunit, '(a)' ) 'save' text_num = text_num + 14 ! ! Fill the faces. ! red = 0.7E+00 green = 0.7E+00 blue = 0.0E+00 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' text_num = text_num + 1 do iface = 1, face_num imat = face_material(iface) if ( imat /= imat_old ) then imat_old = imat red = material_rgba(1,imat) green = material_rgba(2,imat) blue = material_rgba(3,imat) write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' end if jhi = face_order(iface) do j = 1, jhi + 1 if ( j <= face_order(iface) ) then k = face(j,iface) else k = face(1,iface) end if px = plotxmin2 + nint ( alpha * ( cor2(1,k) - xmin ) ) py = plotymin2 + nint ( alpha * ( cor2(2,k) - ymin ) ) if ( j == 1 ) then write ( iunit, '(a)' ) ' newpath' write ( iunit, '(2i4,a)' ) px, py, ' moveto' text_num = text_num + 2 else write ( iunit, '(2i4,a)' ) px, py, ' lineto' text_num = text_num + 1 end if end do write ( iunit, '(a)' ) ' fill' text_num = text_num + 1 end do ! ! Draw the boundaries of the faces as black lines. ! red = 0.0E+00 green = 0.0E+00 blue = 0.0E+00 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' text_num = text_num + 1 do iface = 1, face_num jhi = face_order(iface) do j = 1, jhi + 1 if ( j <= face_order(iface) ) then k = face(j,iface) else k = face(1,iface) end if px = plotxmin2 + nint ( alpha * ( cor2(1,k) - xmin ) ) py = plotymin2 + nint ( alpha * ( cor2(2,k) - ymin ) ) if ( j == 1 ) then write ( iunit, '(a)' ) ' newpath' write ( iunit, '(2i4,a)' ) px, py, ' moveto' text_num = text_num + 2 else write ( iunit, '(2i4,a)' ) px, py, ' lineto' text_num = text_num + 1 end if end do write ( iunit, '(a)' ) ' stroke' text_num = text_num + 1 end do ! ! Draw other lines. ! ! We need to set the color of the lines as specified by the user ! using LINE_MAT. ! lineopen = .false. do i = 1, line_num j = line_dex(i) if ( j <= 0 ) then write ( iunit, '(a)' ) ' stroke' text_num = text_num + 1 lineopen = .false. else imat = line_material(i) if ( imat /= imat_old ) then imat_old = imat red = material_rgba(1,imat) green = material_rgba(2,imat) blue = material_rgba(3,imat) write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' end if px = plotxmin2 + nint ( alpha * ( cor2(1,j) - xmin ) ) py = plotymin2 + nint ( alpha * ( cor2(2,j) - ymin ) ) if ( lineopen ) then write ( iunit, '(2i4,a)' ) px, py, ' lineto' text_num = text_num + 1 else write ( iunit, '(a)' ) ' newpath' write ( iunit, '(2i4,a)' ) px, py, ' moveto' text_num = text_num + 2 lineopen = .true. end if end if end do ! ! Write the epilog. ! write ( iunit, '(a)' ) 'showpage' write ( iunit, '(a)' ) 'grestore' write ( iunit, '(a)' ) '%%Trailer' write ( iunit, '(a)' ) 'end' write ( iunit, '(a)' ) '%%EOF' text_num = text_num + 5 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'PS_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine r_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! R_RANDOM returns a random real in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RLO, RHI, the minimum and maximum values. ! ! Output, real R, the randomly chosen value. ! implicit none ! logical, save :: seed = .false. real r real rhi real rlo real t ! if ( .not. seed ) then call random_seed seed = .true. end if ! ! Pick a random number in (0,1). ! call random_number ( harvest = t ) ! ! Set R. ! r = ( 1.0E+00 - t ) * rlo + t * rhi return end subroutine r_swap ( x, y ) ! !******************************************************************************* ! !! R_SWAP switches two real values. ! ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none ! real x real y real z ! z = x x = y y = z return end subroutine rcol_find ( lda, m, n, a, x, icol ) ! !******************************************************************************* ! !! RCOL_FIND seeks a table column equal to a real vector. ! ! ! Example: ! ! Input: ! ! M = 3, ! N = 4, ! ! A = ( ! 1. 2. 3. 4. ! 5. 6. 7. 8. ! 9. 10. 11. 12. ) ! ! x = ( 3., ! 7., ! 11. ) ! ! Output: ! ! ICOL = 3 ! ! Modified: ! ! 01 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, ! which must be at least M. ! ! Input, integer M, N, the number of rows and columns. ! ! Input, real A(LDA,N), a table of numbers, regarded as ! N columns of vectors of length M. ! ! Input, real X(M), a vector to be matched with a column of A. ! ! Output, integer ICOL, the index of the first column of A ! which exactly matches every entry of X, or 0 if no match ! could be found. ! implicit none ! integer lda integer m integer n ! real a(lda,n) integer i integer icol integer j real x(m) ! icol = 0 do j = 1, n icol = j do i = 1, m if ( x(i) /= a(i,j) ) then icol = 0 exit end if end do if ( icol /= 0 ) then return end if end do return end subroutine rgb_to_hue ( r, g, b, h ) ! !******************************************************************************* ! !! RGB_TO_HUE converts (R,G,B) colors to a hue value between 0 and 1. ! ! ! Discussion: ! ! The hue computed here should be the same as the H value computed ! for HLS and HSV, except that it ranges from 0 to 1 instead of ! 0 to 360. ! ! A monochromatic color ( white, black, or a shade of gray) does not ! have a hue. This routine will return a special value of H = -1 ! for such cases. ! ! Example: ! ! Color R G B H ! ! red 1.0 0.0 0.0 0.00 ! yellow 1.0 1.0 0.0 0.16 ! green 0.0 1.0 0.0 0.33 ! cyan 0.0 1.0 1.0 0.50 ! blue 0.0 0.0 1.0 0.67 ! magenta 1.0 0.0 1.0 0.83 ! ! black 0.0 0.0 0.0 -1.00 ! gray 0.5 0.5 0.5 -1.00 ! white 1.0 1.0 1.0 -1.00 ! ! Modified: ! ! 25 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, G, B, the red, green and blue values of the color. ! These values should be between 0 and 1. ! ! Output, real H, the corresponding hue of the color, or -1.0 if ! the color is monochromatic. ! implicit none ! real b real b2 real g real g2 real h real r real r2 real rgbmax real rgbmin ! ! Make sure the colors are between 0 and 1. ! r2 = min ( max ( r, 0.0E+00 ), 1.0E+00 ) g2 = min ( max ( g, 0.0E+00 ), 1.0E+00 ) b2 = min ( max ( b, 0.0E+00 ), 1.0E+00 ) ! ! Compute the minimum and maximum of R, G and B. ! rgbmax = r2 rgbmax = max ( rgbmax, g2 ) rgbmax = max ( rgbmax, b2 ) rgbmin = r2 rgbmin = min ( rgbmin, g2 ) rgbmin = min ( rgbmin, b2 ) ! ! If RGBMAX = RGBMIN, then the color has no hue. ! if ( rgbmax == rgbmin ) then h = - 1.0E+00 ! ! Otherwise, we need to determine the dominant color. ! else if ( r2 == rgbmax ) then h = ( g2 - b2 ) / ( rgbmax - rgbmin ) else if ( g2 == rgbmax ) then h = 2.0E+00 + ( b2 - r2 ) / ( rgbmax - rgbmin ) else if ( b2 == rgbmax ) then h = 4.0E+00 + ( r2 - g2 ) / ( rgbmax - rgbmin ) end if h = h / 6.0E+00 ! ! Make sure H lies between 0 and 1.0. ! if ( h < 0.0E+00 ) then h = h + 1.0E+00 else if ( h > 1.0E+00 ) then h = h - 1.0E+00 end if end if return end subroutine relnex ( line, rval, done ) ! !******************************************************************************* ! !! RELNEX "reads" real numbers from a string, one at a time. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) LINE, a string, presumably containing real ! numbers. These may be separated by spaces or commas. ! ! Output, real RVAL. If DONE is FALSE, then RVAL contains the ! "next" real value read from LINE. If DONE is TRUE, then ! RVAL is zero. ! ! Input/output, logical DONE. ! On input with a fresh value of LINE, the user should set ! DONE to TRUE. ! On output, the routine sets DONE to FALSE if another real ! value was read, or TRUE if no more reals could be read. ! implicit none ! logical done integer ierror integer lchar character ( len = * ) line integer, save :: next = 1 real rval ! rval = 0.0E+00 if ( done ) then next = 1 done = .false. end if if ( next > len_trim ( line ) ) then done = .true. return end if call s_to_r ( line(next:), rval, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then done = .true. next = 1 else done = .false. next = next + lchar end if return end subroutine rvec_to_s ( n, x, s ) ! !******************************************************************************* ! !! RVEC_TO_S "writes" a real vector into a string. ! ! ! Discussion: ! ! The values will be separated by commas and a single space. ! If the string is too short, then data will be lost. ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of X. ! ! Input, real X(N), a vector to be written to a string. ! ! Output, character ( len = * ) S, a string to which the real vector ! has been written. ! implicit none ! integer n ! integer i character ( len = * ) s character ( len = 14 ) s2 real x(n) ! do i = 1, n if ( x(i) == 0.0E+00 ) then s2 = '0' else if ( abs ( x(i) ) >= 1.0E+10 ) then write ( s2, '(g14.6)' ) x(i) call s_trim_zeros ( s2 ) else if ( real ( int ( x(i) ) ) == x(i) ) then write ( s2, '(i12)' ) int ( x(i) ) else write ( s2, '(g14.6)' ) x(i) call s_trim_zeros ( s2 ) end if if ( i == 1 ) then s = adjustl ( s2 ) else s = trim ( s ) // ', ' // adjustl ( s2 ) end if end do return end subroutine s_blank_delete ( s ) ! !******************************************************************************* ! !! S_BLANK_DELETE removes blanks from a string, left justifying the remainder. ! ! ! Comment: ! ! All TAB characters are also removed. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! character c integer iget integer iput integer nchar character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! iput = 0 nchar = len_trim ( s ) do iget = 1, nchar c = s(iget:iget) if ( c /= ' ' .and. c /= TAB ) then iput = iput + 1 s(iput:iput) = c end if end do s(iput+1:) = ' ' return end subroutine s_blanks_delete ( s ) ! !******************************************************************************* ! !! S_BLANKS_DELETE replaces consecutive blanks by one blank. ! ! ! Discussion: ! ! The remaining characters are left justified and right padded with blanks. ! TAB characters are converted to spaces. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer j integer nchar character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! j = 0 newchr = ' ' nchar = len_trim ( s ) do i = 1, nchar oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = ' ' end if s(i:i) = ' ' if ( oldchr /= ' ' .or. newchr /= ' ' ) then j = j + 1 s(j:j) = newchr end if end do return end subroutine s_cap ( string ) ! !******************************************************************************* ! !! S_CAP replaces any lowercase letters by uppercase ones in a string. ! ! ! Modified: ! ! 16 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) STRING, the string to be transformed. ! implicit none ! character c integer i integer nchar character ( len = * ) string ! nchar = len_trim ( string ) do i = 1, nchar c = string(i:i) call ch_cap ( c ) string(i:i) = c end do return end subroutine s_cat ( s1, s2, s3 ) ! !******************************************************************************* ! !! S_CAT concatenates two strings to make a third string. ! ! ! Modified: ! ! 11 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the "prefix" string. ! ! Input, character ( len = * ) S2, the "postfix" string. ! ! Output, character ( len = * ) S3, the string made by ! concatenating S1 and S2, ignoring any trailing blanks. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 ! s3 = trim ( s1 ) // trim ( s2 ) return end subroutine s_control_blank ( s ) ! !******************************************************************************* ! !! S_CONTROL_BLANK replaces control characters with blanks. ! ! ! Definition: ! ! A "control character" has ASCII code <= 31 or ASCII code => 127. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! logical ch_is_control integer i integer nchar character ( len = * ) s ! nchar = len_trim ( s ) do i = 1, nchar if ( ch_is_control ( s(i:i) ) ) then s(i:i) = ' ' end if end do return end function s_eqi ( strng1, strng2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRNG1, STRNG2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! integer i integer len1 integer len2 integer lenc logical s_eqi character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 ! len1 = len ( strng1 ) len2 = len ( strng2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc s1 = strng1(i:i) s2 = strng2(i:i) call ch_cap ( s1 ) call ch_cap ( s2 ) if ( s1 /= s2 ) then return end if end do do i = lenc + 1, len1 if ( strng1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( strng2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end function s_index_last ( s, sub ) ! !******************************************************************************* ! !! S_INDEX_LAST finds the LAST occurrence of a given substring. ! ! ! Discussion: ! ! It returns the location in the string at which the substring SUB is ! first found, or 0 if the substring does not occur at all. ! ! The routine is also trailing blank insensitive. This is very ! important for those cases where you have stored information in ! larger variables. If S is of length 80, and SUB is of ! length 80, then if S = 'FRED' and SUB = 'RED', a match would ! not be reported by the standard FORTRAN INDEX, because it treats ! both variables as being 80 characters long! This routine assumes that ! trailing blanks represent garbage! ! ! This means that this routine cannot be used to find, say, the last ! occurrence of a substring 'A ', since it assumes the blank space ! was not specified by the user, but is, rather, padding by the ! system. However, as a special case, this routine can properly handle ! the case where either S or SUB is all blanks. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string to be searched. ! ! Input, character ( len = * ) SUB, the substring to search for. ! ! Output, integer S_INDEX_LAST. 0 if SUB does not occur in ! the string. Otherwise S_INDEX_LAST = I, where S(I:I+LENS-1) = SUB, ! where LENS is the length of SUB, and is the last place ! this happens. ! implicit none ! integer i integer j integer llen1 integer llen2 character ( len = * ) s integer s_index_last character ( len = * ) sub ! s_index_last = 0 llen1 = len_trim ( s ) llen2 = len_trim ( sub ) ! ! In case S or SUB is blanks, use LEN ! if ( llen1 == 0 ) then llen1 = len ( s ) end if if ( llen2 == 0 ) then llen2 = len ( sub ) end if if ( llen2 > llen1 ) then return end if do j = 1, llen1+1-llen2 i = llen1 + 2 - llen2 - j if ( s(i:i+llen2-1) == sub ) then s_index_last = i return end if end do return end function s_is_i ( string, ival ) ! !******************************************************************************* ! !! S_IS_I returns .TRUE. if STRING represents an integer. ! ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the string to be checked. ! ! Output, integer IVAL. If S_IS_INT is TRUE, then IVAL is the ! integer represented. Otherwise IVAL is 0. ! ! Output, logical S_IS_I, .TRUE. if STRING represents an integer. ! implicit none ! integer ierror integer ival integer lchar integer lenc logical s_is_i character ( len = * ) string ! lenc = len_trim ( string ) call s_to_i ( string, ival, ierror, lchar ) if ( ierror == 0 .and. lchar >= lenc ) then s_is_i = .true. else s_is_i = .false. ival = 0 end if return end subroutine s_is_r ( string, rval, lval ) ! !******************************************************************************* ! !! S_IS_R returns .TRUE. if STRING represents a real number. ! ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, the string to be checked. ! ! Output, real RVAL. If ISREAL is TRUE, then RVAL is the real ! number represented. Otherwise RVAL is 0. ! ! Output, logical LVAL, .TRUE. if STRING represents a real number. ! implicit none ! integer ierror integer lchar logical lval real rval character ( len = * ) string ! call s_to_r ( string, rval, ierror, lchar ) if ( ierror == 0 .and. lchar >= len_trim ( string ) ) then lval = .true. else lval = .false. rval = 0.0E+00 end if return end subroutine s_to_i ( s, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If STRING is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character of S used to make IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last character ( len = * ) s ! ierror = 0 istate = 0 isgn = 1 ival = 0 do i = 1, len_trim ( s ) c = s(i:i) ! ! Haven't read anything. ! if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read the sign, expecting digits. ! else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read at least one digit, expecting more. ! else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else ival = isgn * ival last = i - 1 return end if end if end do ! ! If we read all the characters in the string, see if we're OK. ! if ( istate == 2 ) then ival = isgn * ival last = len_trim ( s ) else ierror = 1 last = 0 end if return end subroutine s_to_r ( s, r, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_R reads a real number from a string. ! ! ! Discussion: ! ! This routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the real number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 spaces ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon. ! ! with most quantities optional. ! ! Examples: ! ! S R ! ! '1' 1.0E+00 ! ' 1 ' 1.0E+00 ! '1A' 1.0E+00 ! '12,34,56' 12.0E+00 ! ' 34 7' 34.0E+00 ! '-1E2ABCD' -100.0E+00 ! '-1X2ABCD' -1.0E+00 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0E+00 ! '17d2' 1700.0E+00 ! '-14e-2' -0.14 ! 'e2' 100.0E+00 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 12 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, real R, the real value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LCHAR, the number of characters read from ! the string to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! logical ch_eqi character c integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar integer nchar integer ndig real r real rbot real rexp real rtop character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! nchar = len_trim ( s ) ierror = 0 r = 0.0E+00 lchar = - 1 isgn = 1 rtop = 0.0E+00 rbot = 1.0E+00 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do lchar = lchar + 1 c = s(lchar+1:lchar+1) ! ! Blank or TAB character. ! if ( c == ' ' .or. c == TAB ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = - 1 else if ( ihave == 6 ) then ihave = 7 jsgn = - 1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( ihave >= 6 .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lge ( c, '0' ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0E+00 * rtop + real ( ndig ) else if ( ihave == 5 ) then rtop = 10.0E+00 * rtop + real ( ndig ) rbot = 10.0E+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 .or. lchar+1 >= nchar ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0E+00 else if ( jbot == 1 ) then rexp = 10.0E+00**( jsgn * jtop ) else rexp = jsgn * jtop rexp = rexp / jbot rexp = 10.0E+00**rexp end if end if r = isgn * rexp * rtop / rbot return end subroutine s_trim_zeros ( s ) ! !******************************************************************************* ! !! S_TRIM_ZEROS removes trailing zeros from a string. ! ! ! Example: ! ! Input: ! ! S = '1401.072500' ! ! Output: ! ! S = '1401.0725' ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be operated on. ! implicit none ! integer i character ( len = * ) s ! i = len_trim ( s ) do while ( i > 0 .and. s(i:i) == '0' ) s(i:i) = ' ' i = i - 1 end do return end subroutine smf_read ( bad_num, cor3, cor3_material, cor3_max, cor3_normal, & cor3_num, cor3_tex_uv, debug, face, face_material, face_max, & face_normal, face_num, face_order, face_tex_uv, filein_name, & group_num, ierror, iunit, material_max, material_name, material_num, & material_rgba, order_max, text_num, texture_max, texture_num, & texture_name, vertex_material ) ! !******************************************************************************* ! !! SMF_READ reads graphics information from an SMF file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! #SMF2.0 ! # cube_face.smf ! # This example demonstrates how an RGB color can be assigned to ! # each face of an object. ! # ! # First, define the geometry of the cube. ! # ! v 0.0 0.0 0.0 ! v 1.0 0.0 0.0 ! v 0.0 1.0 0.0 ! v 1.0 1.0 0.0 ! v 0.0 0.0 1.0 ! v 1.0 0.0 1.0 ! v 0.0 1.0 1.0 ! v 1.0 1.0 1.0 ! f 1 4 2 ! f 1 3 4 ! f 5 6 8 ! f 5 8 7 ! f 1 2 6 ! f 1 6 5 ! f 2 4 8 ! f 2 8 6 ! f 4 3 7 ! f 4 7 8 ! f 3 1 5 ! f 3 5 7 ! # ! # Colors will be bound 1 per face. ! # ! bind c face ! c 1.0 0.0 0.0 ! c 1.0 0.0 0.0 ! c 0.0 1.0 0.0 ! c 0.0 1.0 0.0 ! c 0.0 0.0 1.0 ! c 0.0 0.0 1.0 ! c 1.0 1.0 0.0 ! c 1.0 1.0 0.0 ! c 0.0 1.0 1.0 ! c 0.0 1.0 1.0 ! c 1.0 0.0 1.0 ! c 1.0 0.0 1.0 ! # ! # Normal vectors will be bound 1 per face. ! # ! bind n face ! n 0.0 0.0 -1.0 ! n 0.0 0.0 -1.0 ! n 0.0 0.0 1.0 ! n 0.0 0.0 1.0 ! n 0.0 -1.0 0.0 ! n 0.0 -1.0 0.0 ! n 1.0 0.0 0.0 ! n 1.0 0.0 0.0 ! n 0.0 1.0 0.0 ! n 0.0 1.0 0.0 ! n -1.0 0.0 0.0 ! n -1.0 0.0 0.0 ! # ! # Texture coordinate pairs will be bound 1 per face. ! # ! bind r face ! r 0.0 0.0 ! r 0.0 0.1 ! r 0.0 0.2 ! r 0.0 0.3 ! r 0.1 0.0 ! r 0.1 0.1 ! r 0.1 0.2 ! r 0.1 0.3 ! r 0.2 0.0 ! r 0.2 0.1 ! r 0.2 0.2 ! r 0.2 0.3 ! ! Modified: ! ! 30 October 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input/output, integer COR3_MATERIAL(COR3_MAX), the material index of ! each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates ! for nodes. ! ! Input, logical DEBUG, debugging switch. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of ! vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, character ( len = * ) MATERIAL_NAME(MATERIAL_MAX), ! material names. ! ! Input/output, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and ! A values. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer BAD_NUM, the number of bad lines of text in the file. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer GROUP_NUM, the number of groups. ! ! Input/output, integer MATERIAL_NUM, the number of materials. ! ! Output, integer TEXT_NUM, the number of lines of text in the file. ! ! Input/output, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), ! texture names. ! ! Output, real TRANSFORM_MATRIX(4,4), the transformation matrix. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max integer texture_max ! real angle character axis real b integer bad_num character ( len = 4 ) char4 character cnr real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) logical debug logical done real dx real dy integer face(order_max,face_max) integer face_count integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) real face_tex_uv(2,face_max) character ( len = * ) filein_name real g integer group_num integer i integer icor3_normal integer icor3_tex_uv integer ierror integer iface_normal integer iface_tex_uv integer imat integer ios integer itemp integer iunit integer ivert integer iword integer k integer lchar integer level character ( len = 256 ) line character ( len = 30 ) material_binding character ( len = * ) material_name(material_max) integer material_num real material_rgba(4,material_max) integer node_count character ( len = 30 ) normal_binding real r real rgba(4) logical s_eqi real sx real sy real sz real temp integer text_num character ( len = 30 ) texture_binding character ( len = * ) texture_name(texture_max) integer texture_num real transform_matrix(4,4) character ( len = 30 ) type real u real v integer vertex_base integer vertex_correction integer vertex_material(order_max,face_max) character ( len = 256 ) word character ( len = 256 ) word1 real x real xvec(3) real y real z ! face_count = 0 ierror = 0 icor3_normal = 0 icor3_tex_uv = 0 iface_normal = 0 iface_tex_uv = 0 level = 0 material_binding = 'UNDEFINED' normal_binding = 'UNDEFINED' node_count = 0 texture_binding = 'UNDEFINED' vertex_base = cor3_num vertex_correction = 0 word = ' ' call tmat_init ( transform_matrix ) ! ! Read a line of text from the file. ! 10 continue read ( iunit, '(a)', iostat = ios ) line if ( ios /= 0 ) then go to 30 end if if ( debug ) then write ( *, '(a)' ) trim ( line ) end if text_num = text_num + 1 ! ! Replace any control characters (in particular, TAB's) by blanks. ! call s_control_blank ( line ) done = .true. iword = 0 ! ! Read a word from the line. ! call word_next_read ( line, word, done ) if ( debug ) then write ( *, '(a)' ) trim ( word ) end if ! ! If no more words in this line, read a new line. ! if ( done ) then go to 10 end if ! ! If this word begins with '#' or '$', then it's a comment. Read a new line. ! if ( word(1:1) == '#' .or. word(1:1) == '$' ) then go to 10 end if iword = iword + 1 if ( iword == 1 ) then word1 = word end if ! ! BEGIN ! Reset the transformation matrix to identity. ! Node numbering starts at zero again. (Really, this is level based) ! (Really should define a new transformation matrix, and concatenate.) ! (Also, might need to keep track of level.) ! if ( s_eqi ( word1, 'BEGIN' ) ) then level = level + 1 vertex_base = cor3_num group_num = group_num + 1 call tmat_init ( transform_matrix ) ! ! BIND [c|n|r] [vertex|face] ! Specify the binding for RGB color, Normal, or Texture. ! Options are "vertex" or "face" ! else if ( s_eqi ( word1, 'BIND' ) ) then call word_next_read ( line, cnr, done ) call word_next_read ( line, type, done ) if ( s_eqi ( cnr, 'C' ) ) then if ( s_eqi ( type, 'VERTEX' ) ) then material_binding = 'PER_VERTEX' else if ( s_eqi ( type, 'FACE' ) ) then material_binding = 'PER_FACE' end if else if ( s_eqi ( cnr, 'N' ) ) then if ( s_eqi ( type, 'VERTEX' ) ) then normal_binding = 'PER_VERTEX' else if ( s_eqi ( type, 'FACE' ) ) then normal_binding = 'PER_FACE' end if else if ( s_eqi ( cnr, 'R' ) ) then if ( s_eqi ( type, 'VERTEX' ) ) then texture_binding = 'PER_VERTEX' else if ( s_eqi ( type, 'FACE' ) ) then texture_binding = 'PER_FACE' end if end if ! ! C ! Specify an RGB color, with R, G, B between 0.0 and 1.0. ! else if ( s_eqi ( word1, 'C' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, r, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, g, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, b, ierror, lchar ) ! ! Set up a temporary material (R,G,B,1.0). ! Add the material to the material database, or find the index of ! a matching material already in. ! Assign the material of the node or face to this index. ! rgba(1) = r rgba(2) = g rgba(3) = b rgba(4) = 1.0E+00 if ( material_num <= 1000 ) then call rcol_find ( 4, 4, material_num, material_rgba, rgba, imat ) else imat = 0 end if if ( imat == 0 ) then material_num = material_num + 1 if ( material_num <= material_max ) then call i_to_s_zero ( material_num, char4 ) material_name(material_num) = 'Material_' // char4 material_rgba(1:4,material_num) = rgba(1:4) imat = material_num else imat = 0 end if end if if ( material_binding == 'PER_FACE' ) then face_count = face_count + 1 face_material(face_count) = imat else if ( material_binding == 'PER_VERTEX' ) then node_count = node_count + 1 cor3_material(node_count) = imat else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SMF_READ - Fatal error!' write ( *, '(a)' ) ' Material binding undefined!' stop end if ! ! END ! Drop down a level. ! else if ( s_eqi ( word1, 'END' ) ) then level = level - 1 if ( level < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SMF_READ - Fatal error!' write ( *, '(a)' ) ' More END statements than BEGINs.' write ( *, '(a,i6)' ) ' Stopping on line ', text_num stop end if ! ! F V1 V2 V3 ... ! Face. ! A face is defined by the vertices. ! else if ( s_eqi ( word1, 'F' ) ) then face_num = face_num + 1 face_material(face_num) = material_num ivert = 0 do ivert = ivert + 1 call word_next_read ( line, word, done ) if ( done ) then exit end if ! ! Read the vertex index. ! Note that vertex indices start back at 0 each time a BEGIN is entered. ! The strategy here won't handle nested BEGIN's, just one at a time. ! call s_to_i ( word, itemp, ierror, lchar ) if ( ierror /= 0 ) then itemp = -1 ierror = 0 write ( *, '(a)' ) 'SMF_READ - Error!' write ( *, '(a)' ) ' Bad FACE field.' write ( *, '(a)' ) trim ( word ) end if if ( ivert <= order_max .and. face_num <= face_max ) then face(ivert,face_num) = itemp + vertex_base vertex_material(ivert,face_num) = material_num end if if ( face_num <= face_max ) then face_order(face_num) = ivert end if end do go to 10 ! ! N ! Specify a normal vector. ! else if ( s_eqi ( word1, 'N' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, x, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, y, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, z, ierror, lchar ) if ( normal_binding == 'PER_FACE' ) then iface_normal = iface_normal + 1 face_normal(1,iface_normal) = x face_normal(2,iface_normal) = y face_normal(3,iface_normal) = z else if ( normal_binding == 'PER_VERTEX' ) then icor3_normal = icor3_normal + 1 cor3_normal(1,icor3_normal) = x cor3_normal(2,icor3_normal) = y cor3_normal(3,icor3_normal) = z else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SMF_READ - Fatal error!' write ( *, '(a)' ) ' Normal binding undefined!' stop end if ! ! R ! Specify a texture coordinate. ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'R' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, u, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, v, ierror, lchar ) if ( texture_binding == 'PER_FACE' ) then iface_tex_uv = iface_tex_uv + 1 face_tex_uv(1,iface_tex_uv) = u face_tex_uv(2,iface_tex_uv) = v else if ( texture_binding == 'PER_VERTEX' ) then icor3_tex_uv = icor3_tex_uv + 1 cor3_tex_uv(1,icor3_tex_uv) = u cor3_tex_uv(2,icor3_tex_uv) = v else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SMF_READ - Fatal error!' write ( *, '(a)' ) ' Texture binding undefined!' stop end if ! ! ROT [x|y|z] ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'ROT' ) ) then call word_next_read ( line, axis, done ) call word_next_read ( line, word, done ) call s_to_r ( word, angle, ierror, lchar ) call tmat_rot_axis ( transform_matrix, transform_matrix, angle, axis ) ! ! SCALE ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'SCALE' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, sx, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, sy, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, sz, ierror, lchar ) call tmat_scale ( transform_matrix, transform_matrix, sx, sy, sz ) ! ! SET VERTEX_CORRECTION ! Specify increment to add to vertex indices in file. ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'SET' ) ) then call word_next_read ( line, word, done ) call word_next_read ( line, word, done ) call s_to_i ( word, vertex_correction, ierror, lchar ) ! ! T V1 V2 V3 ! Triangle ! (Added 30 October 2001, JVB) ! else if ( s_eqi ( word1, 'T' ) ) then face_num = face_num + 1 face_material(face_num) = material_num do ivert = 1, 3 call word_next_read ( line, word, done ) if ( done ) then exit end if ! ! Read the vertex index. ! Note that vertex indices start back at 0 each time a BEGIN is entered. ! The strategy here won't handle nested BEGIN's, just one at a time. ! call s_to_i ( word, itemp, ierror, lchar ) if ( ierror /= 0 ) then itemp = -1 ierror = 0 write ( *, '(a)' ) 'SMF_READ - Error!' write ( *, '(a)' ) ' Bad TRIANGLE field.' write ( *, '(a)' ) trim ( word ) end if if ( ivert <= order_max .and. face_num <= face_max ) then face(ivert,face_num) = itemp + vertex_base vertex_material(ivert,face_num) = material_num end if if ( face_num <= face_max ) then face_order(face_num) = ivert end if end do go to 10 ! ! T_SCALE ! Specify a translation to texture coordinates. ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'T_SCALE' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, dx, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, dy, ierror, lchar ) ! ! T_TRANS ! Specify a translation to texture coordinates. ! (Read, but ignore for now.) ! else if ( s_eqi ( word1, 'T_TRANS' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, dx, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, dy, ierror, lchar ) ! ! TEX ! Specify a filename containing the texture. ! else if ( s_eqi ( word1, 'TEX' ) ) then call word_next_read ( line, word, done ) texture_num = texture_num + 1 texture_name(texture_num) = word ! ! TRANS ! else if ( s_eqi ( word1, 'TRANS' ) ) then call word_next_read ( line, word, done ) call s_to_r ( word, x, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, y, ierror, lchar ) call word_next_read ( line, word, done ) call s_to_r ( word, z, ierror, lchar ) call tmat_trans ( transform_matrix, transform_matrix, x, y, z ) ! ! V X Y Z ! Geometric vertex. ! else if ( s_eqi ( word1, 'V' ) ) then cor3_num = cor3_num + 1 do i = 1, 3 call word_next_read ( line, word, done ) call s_to_r ( word, temp, ierror, lchar ) xvec(i) = temp end do ! ! Apply current transformation matrix. ! Right now, we can only handle one matrix, not a stack of ! matrices representing nested BEGIN/END's. ! call tmat_mxp ( transform_matrix, xvec, xvec ) if ( cor3_num <= cor3_max ) then cor3(1:3,cor3_num) = xvec(1:3) end if ! ! Unrecognized keyword. ! else bad_num = bad_num + 1 if ( bad_num <= 10 ) then write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'SMF_READ: Bad data on line ', text_num write ( *, '(a)' ) ' Bad word: ' // trim ( word ) end if end if go to 10 ! ! End of information in file. ! 30 continue ! ! Extend the material definition ! * from the face to the vertices and nodes, or ! * from the vertices to the faces and nodes. ! if ( material_binding == 'PER_FACE' ) then do ivert = 1, order_max vertex_material(ivert,1:face_num) = face_material(1:face_num) end do call vertex_to_node_material ( cor3_material, cor3_max, face, & face_order, face_max, order_max, face_num, vertex_material ) else if ( material_binding == 'PER_VERTEX' ) then call node_to_vertex_material ( cor3_material, cor3_max, face, & face_max, face_num, face_order, order_max, vertex_material ) face_material(1:face_num) = vertex_material(1,1:face_num) end if ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'SMF_READ - Read ', text_num, ' text lines from ' & // trim ( filein_name ) return end subroutine smf_write ( cor3, cor3_material, cor3_max, cor3_normal, cor3_num, & cor3_tex_uv, face, face_max, face_num, face_order, filein_name, & fileout_name, iunit, material_max, material_rgba, order_max, & texture_max, texture_name, texture_num ) ! !******************************************************************************* ! !! SMF_WRITE writes graphics information to an SMF file. ! ! ! Example: ! ! #SMF2.0E+00 ! # cube_face.smf ! # This example demonstrates how an RGB color can be assigned to ! # each face of an object. ! # ! # First, define the geometry of the cube. ! # ! v 0.0 0.0 0.0E+00 ! v 1.0 0.0 0.0E+00 ! v 0.0 1.0 0.0E+00 ! v 1.0 1.0 0.0E+00 ! v 0.0 0.0 1.0E+00 ! v 1.0 0.0 1.0E+00 ! v 0.0 1.0 1.0E+00 ! v 1.0 1.0 1.0E+00 ! f 1 4 2 ! f 1 3 4 ! f 5 6 8 ! f 5 8 7 ! f 1 2 6 ! f 1 6 5 ! f 2 4 8 ! f 2 8 6 ! f 4 3 7 ! f 4 7 8 ! f 3 1 5 ! f 3 5 7 ! # ! # Colors will be bound 1 per face. ! # ! bind c face ! c 1.0 0.0 0.0 ! c 1.0 0.0 0.0 ! c 0.0 1.0 0.0 ! c 0.0 1.0 0.0 ! c 0.0 0.0 1.0 ! c 0.0 0.0 1.0 ! c 1.0 1.0 0.0 ! c 1.0 1.0 0.0 ! c 0.0 1.0 1.0 ! c 0.0 1.0 1.0 ! c 1.0 0.0 1.0 ! c 1.0 0.0 1.0 ! # ! # Normal vectors will be bound 1 per face. ! # ! bind n face ! n 0.0 0.0 -1.0 ! n 0.0 0.0 -1.0 ! n 0.0 0.0 1.0 ! n 0.0 0.0 1.0 ! n 0.0 -1.0 0.0 ! n 0.0 -1.0 0.0 ! n 1.0 0.0 0.0 ! n 1.0 0.0 0.0 ! n 0.0 1.0 0.0 ! n 0.0 1.0 0.0 ! n -1.0 0.0 0.0 ! n -1.0 0.0 0.0 ! # ! # Texture coordinate pairs will be bound 1 per face. ! # ! bind r face ! r 0.0 0.0 ! r 0.0 0.1 ! r 0.0 0.2 ! r 0.0 0.3 ! r 0.1 0.0 ! r 0.1 0.1 ! r 0.1 0.2 ! r 0.1 0.3 ! r 0.2 0.0 ! r 0.2 0.1 ! r 0.2 0.2 ! r 0.2 0.3 ! ! Modified: ! ! 05 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MATERIAL(COR3_MAX), the material index of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, real COR3_NORMAL(3,COR3_MAX), normals at nodes. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, real COR3_TEX_UV(2,COR3_MAX), UV texture coordinates for nodes. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and A values. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input, integer TEXTURE_MAX, the maximum number of textures. ! ! Input, character ( len = * ) TEXTURE_NAME(TEXTURE_MAX), texture names. ! ! Input, integer TEXTURE_NUM, the number of textures. ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max integer texture_max ! real b real cor3(3,cor3_max) integer cor3_material(cor3_max) real cor3_normal(3,cor3_max) integer cor3_num real cor3_tex_uv(2,cor3_max) integer face(order_max,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name real g integer i integer icor3 integer iface integer imat integer iunit integer ivert real material_rgba(4,material_max) real r character ( len = 256 ) text integer text_num character ( len = * ) texture_name(texture_max) integer texture_num ! text_num = 0 write ( iunit, '(a)' ) '#$SMF 1.0' write ( iunit, '(a, i8)' ) '#$vertices ', cor3_num write ( iunit, '(a, i8)' ) '#$faces ', face_num write ( iunit, '(a)' ) '#' write ( iunit, '(a)' ) '# ' // trim ( fileout_name ) // ' created by IVREAD.' write ( iunit, '(a)' ) '# Original data in ' // trim ( filein_name ) // '.' write ( iunit, '(a)' ) '#' text_num = text_num + 7 ! ! V: vertex coordinates. ! do icor3 = 1, cor3_num write ( text, '(a1,2x,3g14.6)' ) 'v', cor3(1:3,icor3) call s_blanks_delete ( text ) write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do ! ! F: Faces. ! if ( face_num > 0 ) then write ( iunit, '(a)' ) ' ' text_num = text_num + 1 end if do iface = 1, face_num write ( text, '(a1,2x,10i8)' ) 'f', & ( face(ivert,iface), ivert = 1, face_order(iface) ) call s_blanks_delete ( text ) write ( iunit, '(a)' ) trim ( text ) text_num = text_num + 1 end do ! ! Material binding. ! write ( iunit, '(a)' ) 'bind c vertex' text_num = text_num + 1 ! ! Material RGB values at each node. ! do icor3 = 1, cor3_num imat = cor3_material(icor3) r = material_rgba(1,imat) g = material_rgba(2,imat) b = material_rgba(3,imat) write ( iunit, '(a,1x,3f6.2)' ) 'c', r, g, b text_num = text_num + 1 end do ! ! Normal binding. ! write ( iunit, '(a)' ) 'bind n vertex' text_num = text_num + 1 ! ! Normal vector at each node. ! do icor3 = 1, cor3_num write ( iunit, '(a,1x,3f6.2)' ) 'n', cor3_normal(1:3,icor3) text_num = text_num + 1 end do if ( texture_num > 0 ) then ! ! Texture filename ! write ( iunit, '(a)' ) 'tex ' // trim ( texture_name(1) ) text_num = text_num + 1 ! ! Texture binding. ! write ( iunit, '(a)' ) 'bind r vertex' text_num = text_num + 1 ! ! Texture coordinates at each node. ! do icor3 = 1, cor3_num write ( iunit, '(a,1x,3f6.2)' ) 'r', cor3_tex_uv(1:2,icor3) text_num = text_num + 1 end do end if ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'SMF_WRITE - Wrote ', text_num, & ' text lines to ' // trim ( fileout_name ) return end subroutine sort_heap_external ( n, indx, i, j, isgn ) ! !******************************************************************************* ! !! SORT_HEAP_EXTERNAL externally sorts a list of items into linear order. ! ! ! Discussion: ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Modified: ! ! 12 November 2000 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer N, the number of items to be sorted. ! ! Input/output, integer INDX, the main communication signal. ! ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! ! On return, if INDX is ! ! greater than 0, ! * interchange items I and J; ! * call again. ! ! less than 0, ! * compare items I and J; ! * set ISGN = -1 if I precedes J, ISGN = +1 if J precedes I; ! * call again. ! ! equal to 0, the sorting is done. ! ! Output, integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! ! Input, integer ISGN, results of comparison of elements I and J. ! (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I precedes J; ! ISGN => 0 means J precedes I. ! implicit none ! integer i integer indx integer isgn integer j integer, save :: k = 0 integer, save :: k1 = 0 integer n integer, save :: n1 = 0 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then n1 = n k = n / 2 k1 = k ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i = i + 1 end if j = k1 k1 = i indx = - 1 return end if if ( isgn > 0 ) then indx = 2 return end if if ( k <= 1 ) then if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end if k = k - 1 k1 = k ! ! INDX > 0, the user was asked to make an interchange. ! else if ( indx == 1 ) then k1 = k end if do i = 2 * k1 if ( i == n1 ) then j = k1 k1 = i indx = - 1 return else if ( i <= n1 ) then j = i + 1 indx = - 2 return end if if ( k <= 1 ) then exit end if k = k - 1 k1 = k end do if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end subroutine stla_read ( bad_num, cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_normal, face_num, face_order, & filein_name, ierror, iunit, material_num, object_num, order_max, & text_num, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! STLA_READ reads graphics information from an ASCII StereoLithography file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! solid MYSOLID ! facet normal 0.4 0.4 0.2 ! outerloop ! vertex 1.0 2.1 3.2 ! vertex 2.1 3.7 4.5 ! vertex 3.1 4.5 6.7 ! endloop ! endfacet ! ... ! facet normal 0.2 0.2 0.4 ! outerloop ! vertex 2.0 2.3 3.4 ! vertex 3.1 3.2 6.5 ! vertex 4.1 5.5 9.0 ! endloop ! endfacet ! endsolid MYSOLID ! ! Modified: ! ! 17 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input/output, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input/output, integer LINE_NUM, the number of line items. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! implicit none ! integer cor3_max integer face_max integer order_max ! integer bad_num real cor3(3,cor3_max) integer cor3_num logical done integer dup_num integer face(order_max,face_max) integer face_material(face_max) real face_normal(3,face_max) integer face_num integer face_order(face_max) character ( len = * ) filein_name integer i integer icor3 integer ierror integer ios integer istate integer iunit integer ivert integer lchar integer material_num integer object_num real rval logical s_eqi real temp(3) character ( len = 256 ) text integer text_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) character ( len = 256 ) word1 character ( len = 256 ) word2 ! ierror = 0 istate = 0 ! ! Read the next line of text. ! do read ( iunit, '(a)', iostat = ios ) text if ( ios /= 0 ) then if ( istate /= 0 .and. istate /= 1 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning.' write ( *, '(a)' ) ' End-of-file, but model not finished.' end if exit end if text_num = text_num + 1 done = .true. ! ! Read the first word in the line. ! call word_next_read ( text, word1, done ) ! ! "Doctor" the text, changing a beginning occurrence of: ! ! END FACET to ENDFACET ! END LOOP to ENDLOOP ! END SOLID to ENDSOLID ! FACET NORMAL to FACETNORMAL ! OUTER LOOP to OUTERLOOP ! if ( s_eqi ( word1, 'END' ) .or. & s_eqi ( word1, 'FACET' ) .or. & s_eqi ( word1, 'OUTER' ) ) then call word_next_read ( text, word2, done ) call s_cat ( word1, word2, word1 ) end if ! ! This first word tells us what to do. ! ! SOLID - begin a new solid. ! Valid in state 0, moves to state 1. ! ENDSOLID - end current solid. ! Valid in state 1, moves to state 0. ! ! FACETNORMAL - begin a new facet. ! Valid in state 0 or 1, moves to state 2. ! ENDFACET - end current facet. ! Valid in state 2, moves to state 1. ! ! OUTERLOOP - begin a list of vertices. ! Valid in state 2, moves to state 3. ! ENDLOOP - end vertex list. ! Valid in state 3, moves to state 2. ! ! VERTEX - give coordinates of next vertex. ! Valid in state 3. ! ! End of file - ! Valid in state 0 or 1. ! if ( s_eqi ( word1, 'SOLID' ) ) then if ( istate == 0 ) then istate = 1 object_num = object_num + 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for SOLID.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'ENDSOLID' ) ) then if ( istate == 1 ) then istate = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for ENDSOLID.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'FACETNORMAL' ) ) then if ( istate == 0 .or. istate == 1 ) then istate = 2 face_num = face_num + 1 if ( face_num <= face_max ) then face_material(face_num) = material_num face_order(face_num) = 0 do i = 1, 3 face_normal(i,face_num) = 0.0E+00 call word_next_read ( text, word2, done ) if ( .not. done ) then call s_to_r ( word2, rval, ierror, lchar ) if ( ierror == 0 ) then face_normal(i,face_num) = rval end if end if end do end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for FACET.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'ENDFACET' ) ) then if ( istate == 2 ) then istate = 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for ENDFACET.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'OUTERLOOP' ) ) then if ( istate == 2 ) then istate = 3 ivert = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for OUTERLOOP.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'ENDLOOP' ) ) then if ( istate == 3 ) then istate = 2 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for ENDLOOP.' bad_num = bad_num + 1 ierror = 1 exit end if else if ( s_eqi ( word1, 'VERTEX' ) ) then if ( istate == 3 ) then do i = 1, 3 call word_next_read ( text, word2, done ) call s_to_r ( word2, rval, ierror, lchar ) temp(i) = rval end do ! ! If the coordinate values already exist in COR3, then ! save space by using the index of a previous copy. ! if ( cor3_num <= 1000 ) then call rcol_find ( 3, 3, cor3_num, cor3, temp, icor3 ) else icor3 = 0 end if if ( icor3 == 0 ) then cor3_num = cor3_num + 1 icor3 = cor3_num if ( cor3_num <= cor3_max ) then cor3(1:3,cor3_num) = temp(1:3) end if else dup_num = dup_num + 1 end if ivert = ivert + 1 if ( ivert <= order_max .and. face_num <= face_max ) then face(ivert,face_num) = icor3 vertex_material(ivert,face_num) = material_num vertex_normal(1:3,ivert,face_num) = face_normal(1:3,face_num) end if if ( face_num <= face_max .and. face_order(face_num) < order_max ) then face_order(face_num) = face_order(face_num) + 1 end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Model not in right state for VERTEX.' bad_num = bad_num + 1 ierror = 1 exit end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STLA_READ - Warning!' write ( *, '(a)' ) ' Unrecognized line in file.' bad_num = bad_num + 1 ierror = 1 exit end if end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'STLA_READ - Read ', text_num, & ' text lines from ' // trim ( filein_name ) return end subroutine stla_write ( cor3, cor3_max, face, face_max, face_normal, & face_num, face_order, filein_name, fileout_name, iunit, order_max ) ! !******************************************************************************* ! !! STLA_WRITE writes graphics information to an ASCII StereoLithography file. ! ! ! Example: ! ! solid MYSOLID ! facet normal 0.4 0.4 0.2 ! outerloop ! vertex 1.0 2.1 3.2 ! vertex 2.1 3.7 4.5 ! vertex 3.1 4.5 6.7 ! endloop ! endfacet ! ... ! facet normal 0.2 0.2 0.4 ! outerloop ! vertex 2.0 2.3 3.4 ! vertex 3.1 3.2 6.5 ! vertex 4.1 5.5 9.0E+00 ! endloop ! endfacet ! endsolid MYSOLID ! ! Discussion: ! ! The polygons in an STL file should only be triangular. This routine ! will try to automatically decompose higher-order polygonal faces into ! suitable triangles, without actually modifying the internal graphics ! data. ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, real FACE_NORMAL(3,FACE_MAX), the normal vector at each face. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer face(order_max,face_max) real face_normal(3,face_max) integer face_num integer face_num2 integer face_order(face_max) character ( len = * ) filein_name character ( len = * ) fileout_name integer i integer iface integer iunit integer jvert integer node integer text_num ! text_num = 0 write ( iunit, '(a,a)' ) 'solid MYSOLID created by IVREAD, ' // & 'original data in ', trim ( filein_name ) text_num = text_num + 1 face_num2 = 0 do iface = 1, face_num do jvert = 3, face_order(iface) face_num2 = face_num2 + 1 write ( iunit, '('' facet normal '', 3g14.6)' ) face_normal(1:3,iface) text_num = text_num + 1 write ( iunit, '(a)' ) ' outer loop' text_num = text_num + 1 node = face(1,iface) write ( iunit, '('' vertex '', 3g14.6)' ) cor3(1:3,node) text_num = text_num + 1 node = face(jvert-1,iface) write ( iunit, '('' vertex '', 3g14.6)' ) cor3(1:3,node) text_num = text_num + 1 node = face(jvert,iface) write ( iunit, '('' vertex '', 3g14.6)' ) cor3(1:3,node) text_num = text_num + 1 write ( iunit, '(a)' ) ' endloop' write ( iunit, '(a)' ) 'endfacet' text_num = text_num + 2 end do end do write ( iunit, '(a)' ) 'endsolid MYSOLID' text_num = text_num + 1 ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'STLA_WRITE - Wrote ', text_num, & ' text lines to ' // trim ( fileout_name ) if ( face_num2 /= face_num ) then write ( *, '(a,i6)' ) ' Number of faces in original data was ', face_num write ( *, '(a,i6)' ) & ' Number of triangular faces in decomposed data was ', face_num2 end if return end subroutine tec_write ( cor3, cor3_material, cor3_max, cor3_num, face, & face_max, face_num, face_order, fileout_name, iunit, material_max, & material_rgba, order_max ) ! !******************************************************************************* ! !! TEC_WRITE writes graphics information to a TECPLOT file. ! ! ! Discussion: ! ! The file format used is appropriate for 3D finite element ! surface zone data. Polygons are decomposed into triangles where ! necessary. ! ! Example: ! ! TITLE = "cube.tec created by IVREAD." ! VARIABLES = "X", "Y", "Z", "R", "G", "B" ! ZONE T="TRIANGLES", N=8, E=12, F=FEPOINT, ET=TRIANGLE ! 0.0 0.0 0.0 0.0 0.0 0.0 ! 1.0 0.0 0.0 1.0 0.0 0.0 ! 1.0 1.0 0.0 1.0 1.0 0.0 ! 0.0 1.0 0.0 0.0 1.0 0.0 ! 0.0 0.0 1.0 0.0 0.0 1.0 ! 1.0 0.0 1.0 1.0 0.0 1.0 ! 1.0 1.0 1.0 1.0 1.0 1.0 ! 0.0 1.0 1.0 0.0 1.0 1.0 ! 1 4 2 ! 2 4 3 ! 1 5 8 ! 1 2 5 ! 2 6 5 ! 2 3 6 ! 3 7 6 ! 3 4 7 ! 4 8 7 ! 4 1 8 ! 5 6 8 ! 6 7 8 ! ! Modified: ! ! 08 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MATERIAL(COR3_MAX), the material of each node. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, integer COR3_NUM, the number of points. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, real MATERIAL_RGBA(4,MATERIAL_MAX), material R, G, B and A values. ! ! Input, integer MATERIAL_MAX, the maximum number of materials. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! implicit none ! integer cor3_max integer face_max integer material_max integer order_max ! real b real cor3(3,cor3_max) integer cor3_material(cor3_max) integer cor3_num integer face(order_max,face_max) integer face2(3) integer face_num integer face_num2 integer face_order(face_max) character ( len = * ) fileout_name real g integer i integer icor3 integer iface integer imat integer iunit integer jlo real material_rgba(4,material_max) integer text_num real r ! ! Determine the number of triangular faces. ! face_num2 = 0 do i = 1, face_num do jlo = 1, face_order(i) - 2 face_num2 = face_num2 + 1 end do end do text_num = 0 write ( iunit, '(a)' ) '"' // trim ( fileout_name ) // ' created by IVREAD."' write ( iunit, '(a)' ) 'VARIABLES = "X", "Y", "Z", "R", "G", "B"' write ( iunit, '(a,i6,a,i6,a)' ) 'ZONE T="TRIANGLES", N=', cor3_num, & ', E=', face_num2, ', F=FEPOINT, ET=TRIANGLE' text_num = text_num + 3 ! ! Write out X, Y, Z, R, G, B per node. ! do icor3 = 1, cor3_num imat = cor3_material(icor3) r = material_rgba(1,imat) g = material_rgba(2,imat) b = material_rgba(3,imat) write ( iunit, '(6g11.3)' ) cor3(1,icor3), cor3(2,icor3), cor3(3,icor3), & r, g, b text_num = text_num + 1 end do ! ! Do the next face. ! do iface = 1, face_num ! ! Break the face up into triangles, anchored at node 1. ! do jlo = 1, face_order(iface) - 2 face2(1) = face( 1,iface) face2(2) = face(jlo+1,iface) face2(3) = face(jlo+2,iface) write ( iunit, '(3i6)' ) face2(1), face2(2), face2(3) text_num = text_num + 1 end do end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'TEC_WRITE - Wrote ', text_num, ' text lines to ' & // trim ( fileout_name ) return end subroutine timestamp ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine tmat_init ( a ) ! !******************************************************************************* ! !! TMAT_INIT initializes the geometric transformation matrix. ! ! ! Definition: ! ! The geometric transformation matrix can be thought of as a 4 by 4 ! matrix "A" having components: ! ! r11 r12 r13 t1 ! r21 r22 r23 t2 ! r31 r32 r33 t3 ! 0 0 0 1 ! ! This matrix encodes the rotations, scalings and translations that ! are applied to graphical objects. ! ! A point P = (x,y,z) is rewritten in "homogeneous coordinates" as ! PH = (x,y,z,1). Then to apply the transformations encoded in A to ! the point P, we simply compute A * PH. ! ! Individual transformations, such as a scaling, can be represented ! by simple versions of the transformation matrix. If the matrix ! A represents the current set of transformations, and we wish to ! apply a new transformation B, then the original points are ! transformed twice: B * ( A * PH ). The new transformation B can ! be combined with the original one A, to give a single matrix C that ! encodes both transformations: C = B * A. ! ! Modified: ! ! 19 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the geometric transformation matrix. ! implicit none ! real a(4,4) integer i integer j ! do i = 1, 4 do j = 1, 4 if ( i == j ) then a(i,j) = 1.0E+00 else a(i,j) = 0.0E+00 end if end do end do return end subroutine tmat_mxm ( a, b, c ) ! !******************************************************************************* ! !! TMAT_MXM multiplies two geometric transformation matrices. ! ! ! Note: ! ! The product is accumulated in a temporary array, and then assigned ! to the result. Therefore, it is legal for any two, or all three, ! of the arguments to share memory. ! ! Modified: ! ! 13 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the first geometric transformation matrix. ! ! Input, real B(4,4), the second geometric transformation matrix. ! ! Output, real C(4,4), the product A * B. ! implicit none ! real a(4,4) real b(4,4) real c(4,4) ! c(1:4,1:4) = matmul ( a(1:4,1:4), b(1:4,1:4) ) return end subroutine tmat_mxp ( a, x, y ) ! !******************************************************************************* ! !! TMAT_MXP multiplies a geometric transformation matrix times a point. ! ! ! Modified: ! ! 13 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the geometric transformation matrix. ! ! Input, real X(3), the point to be multiplied. The fourth component ! of X is implicitly assigned the value of 1. ! ! Output, real Y(3), the result of A*X. The product is accumulated in ! a temporary vector, and then assigned to the result. Therefore, it ! is legal for X and Y to share memory. ! implicit none ! real a(4,4) real x(3) real y(3) ! y(1:3) = a(1:3,4) + matmul ( a(1:3,1:3), x(1:3) ) return end subroutine tmat_mxp2 ( a, x, y, n ) ! !******************************************************************************* ! !! TMAT_MXP2 multiplies a geometric transformation matrix times N points. ! ! ! Modified: ! ! 20 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the geometric transformation matrix. ! ! Input, real X(3,N), the points to be multiplied. ! ! Output, real Y(3,N), the transformed points. Each product is ! accumulated in a temporary vector, and then assigned to the ! result. Therefore, it is legal for X and Y to share memory. ! implicit none ! integer n ! real a(4,4) integer k real x(3,n) real y(3,n) ! do k = 1, n y(1:3,k) = a(1:3,4) + matmul ( a(1:3,1:3), x(1:3,k) ) end do return end subroutine tmat_mxv ( a, x, y ) ! !******************************************************************************* ! !! TMAT_MXV multiplies a geometric transformation matrix times a vector. ! ! ! Modified: ! ! 13 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the geometric transformation matrix. ! ! Input, real X(3), the vector to be multiplied. The fourth component ! of X is implicitly assigned the value of 1. ! ! Output, real Y(3), the result of A*X. The product is accumulated in ! a temporary vector, and then assigned to the result. Therefore, it ! is legal for X and Y to share memory. ! implicit none ! real a(4,4) real x(3) real y(3) ! y(1:3) = a(1:3,4) + matmul ( a(1:3,1:3), x(1:3) ) return end subroutine tmat_rot_axis ( a, b, angle, axis ) ! !******************************************************************************* ! !! TMAT_ROT_AXIS applies a coordinate axis rotation to the geometric transformation matrix. ! ! ! Modified: ! ! 11 December 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the current geometric transformation matrix. ! ! Output, real B(4,4), the modified geometric transformation matrix. ! A and B may share the same memory. ! ! Input, real ANGLE, the angle, in degrees, of the rotation. ! ! Input, character AXIS, is 'X', 'Y' or 'Z', specifying the coordinate ! axis about which the rotation occurs. ! implicit none ! real a(4,4) real angle real angle_rad character axis real b(4,4) real c(4,4) real d(4,4) real degrees_to_radians integer i integer j ! angle_rad = degrees_to_radians ( angle ) call tmat_init ( c ) if ( axis == 'X' .or. axis == 'x' ) then c(2,2) = cos ( angle_rad ) c(2,3) = - sin ( angle_rad ) c(3,2) = sin ( angle_rad ) c(3,3) = cos ( angle_rad ) else if ( axis == 'Y' .or. axis == 'y' ) then c(1,1) = cos ( angle_rad ) c(1,3) = sin ( angle_rad ) c(3,1) = - sin ( angle_rad ) c(3,3) = cos ( angle_rad ) else if ( axis == 'Z' .or. axis == 'z' ) then c(1,1) = cos ( angle_rad ) c(1,2) = - sin ( angle_rad ) c(2,1) = sin ( angle_rad ) c(2,2) = cos ( angle_rad ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TMAT_ROT_AXIS - Fatal error!' write ( *, '(a)' ) ' Illegal rotation axis: ' // axis write ( *, '(a)' ) ' Legal choices are ''X'', ''Y'', or ''Z''.' return end if call tmat_mxm ( c, a, d ) b(1:4,1:4) = d(1:4,1:4) return end subroutine tmat_rot_vector ( a, b, angle, axis ) ! !******************************************************************************* ! !! TMAT_ROT_VECTOR: arbitrary axis rotation to geometric transformation matrix. ! ! ! Modified: ! ! 11 December 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the current geometric transformation matrix. ! ! Output, real B(4,4), the modified geometric transformation matrix. ! A and B may share the same memory. ! ! Input, real ANGLE, the angle, in degrees, of the rotation. ! ! Input, real AXIS(3), the axis vector about which rotation occurs. ! AXIS may not be the zero vector. ! implicit none ! real a(4,4) real angle real angle_rad real axis(3) real b(4,4) real c(4,4) real ca real d(4,4) real degrees_to_radians integer i integer j real norm real sa real v1 real v2 real v3 ! v1 = axis(1) v2 = axis(2) v3 = axis(3) norm = sqrt ( v1 * v1 + v2 * v2 + v3 * v3 ) if ( norm == 0.0E+00 ) then return end if v1 = v1 / norm v2 = v2 / norm v3 = v3 / norm angle_rad = degrees_to_radians ( angle ) ca = cos ( angle_rad ) sa = sin ( angle_rad ) call tmat_init ( c ) c(1,1) = v1 * v1 + ca * ( 1.0E+00 - v1 * v1 ) c(1,2) = ( 1.0E+00 - ca ) * v1 * v2 - sa * v3 c(1,3) = ( 1.0E+00 - ca ) * v1 * v3 + sa * v2 c(2,1) = ( 1.0E+00 - ca ) * v2 * v1 + sa * v3 c(2,2) = v2 * v2 + ca * ( 1.0E+00 - v2 * v2 ) c(2,3) = ( 1.0E+00 - ca ) * v2 * v3 - sa * v1 c(3,1) = ( 1.0E+00 - ca ) * v3 * v1 - sa * v2 c(3,2) = ( 1.0E+00 - ca ) * v3 * v2 + sa * v1 c(3,3) = v3 * v3 + ca * ( 1.0E+00 - v3 * v3 ) call tmat_mxm ( c, a, d ) b(1:4,1:4) = d(1:4,1:4) return end subroutine tmat_scale ( a, b, sx, sy, sz ) ! !******************************************************************************* ! !! TMAT_SCALE applies a scaling to the geometric transformation matrix. ! ! ! Modified: ! ! 19 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the current geometric transformation matrix. ! ! Output, real B(4,4), the modified geometric transformation matrix. ! A and B may share the same memory. ! ! Input, real SX, SY, SZ, the scalings to be applied to the X, Y and ! Z coordinates. ! implicit none ! real a(4,4) real b(4,4) real c(4,4) real d(4,4) integer i integer j real sx real sy real sz ! call tmat_init ( c ) c(1,1) = sx c(2,2) = sy c(3,3) = sz call tmat_mxm ( c, a, d ) b(1:4,1:4) = d(1:4,1:4) return end subroutine tmat_shear ( a, b, axis, s ) ! !******************************************************************************* ! !! TMAT_SHEAR applies a shear to the geometric transformation matrix. ! ! ! Modified: ! ! 19 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the current geometric transformation matrix. ! ! Output, real B(4,4), the modified geometric transformation matrix. ! A and B may share the same memory. ! ! Input, character ( len = 2 ) AXIS, is 'XY', 'XZ', 'YX', 'YZ', 'ZX' or 'ZY', ! specifying the shear equation: ! ! XY: x' = x + s * y; ! XZ: x' = x + s * z; ! YX: y' = y + s * x; ! YZ: y' = y + s * z; ! ZX: z' = z + s * x; ! ZY: z' = z + s * y. ! ! Input, real S, the shear coefficient. ! implicit none ! real a(4,4) character ( len = 2 ) axis real b(4,4) real c(4,4) real d(4,4) integer i integer j real s ! call tmat_init ( c ) if ( axis == 'XY' .or. axis == 'xy' ) then c(1,2) = s else if ( axis == 'XZ' .or. axis == 'xz' ) then c(1,3) = s else if ( axis == 'YX' .or. axis == 'yx' ) then c(2,1) = s else if ( axis == 'YZ' .or. axis == 'yz' ) then c(2,3) = s else if ( axis == 'ZX' .or. axis == 'zx' ) then c(3,1) = s else if ( axis == 'ZY' .or. axis == 'zy' ) then c(3,2) = s else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TMAT_SHEAR - Fatal error!' write ( *, '(a)' ) ' Illegal shear axis: ' // axis write ( *, '(a)' ) ' Legal choices are XY, XZ, YX, YZ, ZX, or ZY.' return end if call tmat_mxm ( c, a, d ) b(1:4,1:4) = d(1:4,1:4) return end subroutine tmat_trans ( a, b, x, y, z ) ! !******************************************************************************* ! !! TMAT_TRANS applies a translation to the geometric transformation matrix. ! ! ! Modified: ! ! 19 October 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Foley, van Dam, Feiner, Hughes, ! Computer Graphics, Principles and Practice, ! Addison Wesley, Second Edition, 1990. ! ! Parameters: ! ! Input, real A(4,4), the current geometric transformation matrix. ! ! Output, real B(4,4), the modified transformation matrix. ! A and B may share the same memory. ! ! Input, real X, Y, Z, the translation. This may be thought of as the ! point that the origin moves to under the translation. ! implicit none ! real a(4,4) real b(4,4) integer i integer j real x real y real z ! do i = 1, 4 do j = 1, 4 if ( i == 1 .and. j == 4 ) then b(1,4) = a(1,4) + x else if ( i == 2 .and. j == 4 ) then b(2,4) = a(2,4) + y else if ( i == 3 .and. j == 4 ) then b(3,4) = a(3,4) + z else b(i,j) = a(i,j) end if end do end do return end subroutine tria_read ( cor3, cor3_max, cor3_num, dup_num, face, & face_material, face_max, face_num, face_order, filein_name, ierror, & iunit, order_max, text_num, vertex_material, vertex_normal ) ! !******************************************************************************* ! !! TRIA_READ reads graphics information from an ASCII triangle file. ! ! ! Discussion: ! ! It is intended that the information read from the file can ! either start a whole new graphics object, or simply be added ! to a current graphics object via the '<<' command. ! ! This is controlled by whether the input values have been zeroed ! out or not. This routine simply tacks on the information it ! finds to the current graphics object. ! ! Example: ! ! 12 <-- Number of triangles ! ! (x,y,z) and (nx,ny,nz) of normal vector at: ! ! 0.0 0.0 0.0 0.3 0.3 0.3 node 1 of triangle 1. ! 1.0 0.0 0.0 0.3 0.1 0.3 node 2 of triangle 1, ! 0.0 1.0 0.0 0.3 0.1 0.3 node 3 of triangle 1, ! 1.0 0.5 0.0 0.3 0.1 0.3 node 1 of triangle 2, ! ... ! 0.0 0.5 0.5 0.3 0.1 0.3 node 3 of triangle 12. ! ! Modified: ! ! 22 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input/output, integer COR3_NUM, the number of points. ! ! Input/output, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input/output, integer FACE_MATERIAL(FACE_MAX), the material of each face. ! ! Input/output, integer FACE_ORDER(FACE_MAX), the number of vertices ! per face. ! ! Input, character ( len = * ) FILEIN_NAME, the name of the input file. ! ! Output, integer IERROR, an error flag. ! ! Input, integer IUNIT, the FORTRAN unit from which data is read. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer ORDER_MAX, the maximum number of vertices per face. ! ! Output, integer DUP_NUM, the number of duplicate nodes discovered. ! ! Input/output, integer FACE_NUM, the number of faces. ! ! Output, integer TEXT_NUM, the number of lines of input text. ! ! Input/output, integer VERTEX_MAT(ORDER_MAX,FACE_MAX), vertex materials. ! ! Input/output, real VERTEX_NORMAL(3,ORDER_MAX,FACE_MAX), normals ! at vertices. ! implicit none ! integer cor3_max integer face_max integer order_max ! real cor3(3,cor3_max) integer cor3_num real cvec(3) integer dup_num integer face(order_max,face_max) integer face_material(face_max) integer face_num integer face_num2 integer face_order(face_max) character ( len = * ) filein_name integer i integer icor3 integer ierror integer iface integer iface_hi integer iface_lo integer ios integer iunit integer ivert real r1 real r2 real r3 real r4 real r5 real r6 integer text_num integer vertex_material(order_max,face_max) real vertex_normal(3,order_max,face_max) ! ierror = 0 ! ! Read the number of (triangular) faces. ! (This is added on to the current number, if any). ! read ( iunit, *, iostat = ios ) face_num2 if ( ios /= 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIA_READ - Warning.' write ( *, '(a)' ) ' End-of-file, but the model was not finished.' return end if text_num = text_num + 1 ! ! For each triangle. ! iface_lo = face_num + 1 iface_hi = face_num + face_num2 do iface = iface_lo, iface_hi if ( iface <= FACE_MAX ) then face_order(iface) = 3 face_material(iface) = 1 end if ! ! For each face of a triangle: ! do ivert = 1, face_order(iface) read ( iunit, *, iostat = ios ) r1, r2, r3, r4, r5, r6 if ( ios /= 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIA_READ - Warning.' write ( *, '(a)' ) ' End-of-file, but the model was not finished.' return end if text_num = text_num + 1 cvec(1) = r1 cvec(2) = r2 cvec(3) = r3 if ( cor3_num <= 1000 ) then call rcol_find ( 3, 3, cor3_num, cor3, cvec, icor3 ) else icor3 = 0 end if if ( icor3 == 0 ) then cor3_num = cor3_num + 1 icor3 = cor3_num if ( cor3_num <= cor3_max ) then cor3(1:3,cor3_num) = cvec(1:3) end if else dup_num = dup_num + 1 end if if ( iface <= FACE_MAX ) then face(ivert,iface) = icor3 vertex_material(ivert,iface) = 1 vertex_normal(1,ivert,iface) = r4 vertex_normal(2,ivert,iface) = r5 vertex_normal(3,ivert,iface) = r6 end if end do face_num = iface end do ! ! Report. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6,a)' ) 'TRIA_READ - Read ', text_num, & ' text lines from ' // trim ( filein_name ) return end subroutine tria_write ( cor3, cor3_max, cor3_normal, face, face_max, face_num, & face_order, fileout_name, iunit, order_max ) ! !******************************************************************************* ! !! TRIA_WRITE writes the graphics data to an ASCII "triangle" file. ! ! ! Discussion: ! ! This is just a private format that Greg Hood requested from me. ! ! Example: ! ! 12 <-- Number of triangles ! ! (x,y,z) and (nx,ny,nz) of normal vector at: ! ! 0.0 0.0 0.0 0.3 0.3 0.3 node 1 of triangle 1. ! 1.0 0.0 0.0 0.3 0.1 0.3 node 2 of triangle 1, ! 0.0 1.0 0.0 0.3 0.1 0.3 node 3 of triangle 1, ! 1.0 0.5 0.0 0.3 0.1 0.3 node 1 of triangle 2, ! ... ! 0.0 0.5 0.5 0.3 0.1 0.3 node 3 of triangle 12. ! ! Modified: ! ! 23 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,COR3_MAX), the coordinates of points. ! ! Input, integer COR3_MAX, the maximum number of points. ! ! Input, real COR3_NORMAL(3,COR3_MAX), the normal vector at each node. ! ! Input, integer FACE(ORDER_MAX,FACE_MAX), the nodes making faces. ! ! Input, integer FACE_MAX, the maximum number of faces. ! ! Input, integer FACE_NUM, the number of faces. ! ! Input, integer FACE_ORDER(FACE_MAX), the number of vertices per face. ! ! Input, character ( len = * ) FILEOUT_NAME, the name of the output file. ! ! Input, integer IUNIT, the FORTRAN unit to which output is written. ! ! Input, integer OR