C***************************************************************************** C C PLT_POV.F C C***************************************************************************** C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ program plt_pov C***************************************************************************** C C Name : plt_pov() C C Description : A tool for creating POV-Ray input from O plot files. C C Created : T. Alwyn Jones, April '99 C C Modified : Mark Harris, See 'version' variable for latest update C C Copyright : Dept. Mol. Bol., BMC, Uppsala, Sweden, 2001 C C Language : Fortran 77, extended with C 16-char variables, 'implicit none' C Dependencies : none C C Calls : all internal C C ASTs : none C C============================================================================= C C Notes : C C Build with '% f77 plt_pov.f -o plt_pov' C Under OSX use '% gfortran -O -ffixed-line-length-132 -m32 -o plt_pov plt_pov.f' C C Invoke with '% plt_pov -help' for a complete list of options. C C If you want to use the -complete option, you must change the C value of the variable 'incl_dir' to point at the location of C the povray include files on your system. C C Compiles directly on Dec Alpha and Linux. C For SGI uncomment date_and_time routine at end of file (remove 'csgi'). C C============================================================================= implicit none integer nblen, lib_get_foreign integer lib_sys_trnlog, i_am_unix, find_words character*1024 upcase, lowcase, get_option, replace_string character*1024 remove_char real matrix_determinant integer i, j, k, ct_lin, ct_pol, ct_obj, ct, errcod, debug real q(3,3), lin(3,1000), poly(6,100), colour(3), colour_cue(3), cyl(7) real sph(4) character file*132, line*132, cmnd*20, obj(20)*20, text*132, string*132 character line_mixed*132 logical in_obj, in_kamra real text_crds(3), bounds(4),x,y,z, trans_flag, def_trans_flag real cam_dist, all_polys(9,3,9000), tri_col(3,9000) real poly_normal(6,100), map_rgb(3) real kamra(3,1000) integer dashed_flag, op_flag, iostat, istart, iend, complete_flag integer contig_poly_flag, smooth_flag, obj_flag, incl_len, list_flag integer blackground_flag, shadowless_flag, obj_count, nblacks integer start_obj_flag, norm_flag, map_col_flag, ribbon_flag integer megapov_flag, kamra_count, depth_flag, ilen integer nwords, word_starts(25), word_ends(25) character*1024 version, banner, date_string, option, ext, pov_inc_dir character*1024 buffer, cmd_buff, tmp_buffer, str_tmp, new_buffer character*1024 filename_in, filename_out, listfile_out, def_list_out character*1024 def_filename_in, def_filename_out, def_line, word character*1024 def_filetype_in, def_filetype_out, obj_nam, obj_clean character*1024 incl_dir, object_name, obj_list(1000), black_list(100) common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) C***************************************************************************** C Initialise simple variables C***************************************************************************** incl_dir = './' ! Location of POV-Ray files. call GETENV('POV_INC_DIR', pov_inc_dir) ! unless overwritten by ENV if (nblen(pov_inc_dir) .ne. 0) incl_dir = pov_inc_dir C***************************************************************************** version = ' plt_pov v1.3 Last update : 25-Feb-04' banner = ' ONO plot file to POV-Ray translator' filename_in = ' ' filename_out = ' ' def_filename_in = 'o.plt' def_filename_out = 'all.pov' def_list_out = 'plt_pov.lst' def_filetype_in = '.pdb' def_filetype_out = '.pov' def_line = 'CPK S N O TOON' object_name = 'onomol' line = ' ' op_flag = 0 obj_count = 0 debug = 0 dashed_flag = 0 trans_flag = -0.1 def_trans_flag = 0.5 complete_flag = 0 cam_dist = 20 contig_poly_flag = 0 smooth_flag = 0 obj_flag = 0 list_flag = 0 blackground_flag = 0 shadowless_flag = 0 start_obj_flag = 0 ribbon_flag = 0 megapov_flag = 0 depth_flag = 0 kamra_count = 0 map_col_flag = 0 map_rgb(1) = 0.11 map_rgb(2) = 0.12 map_rgb(3) = 0.93 bounds(1)= -10 bounds(2)= 10 bounds(3)= -10 bounds(4)= 10 nblacks = 19 black_list(1) = '_map' ! NB "_map" must be first element (note lowercase) black_list(2) = '_col' ! NB "_col" must be second element black_list(3) = 'everything' black_list(4) = 'prompt_window' black_list(5) = 'disp_' black_list(6) = 'object_' black_list(7) = '_dot' black_list(8) = '_3d' black_list(9) = 'menu' black_list(10) = 'toon' black_list(11) = 'right_image' black_list(12) = 'left_image' black_list(13) = 'display' black_list(14) = 'density' black_list(15) = 'control' black_list(16) = 'display' black_list(17) = 'graph' black_list(18) = 'bones' black_list(19) = 'rebuild' C***************************************************************************** C Introduce C***************************************************************************** call date_and_time(date_string) write (6,1001) write (6,1015) ('=',i=1,max(1,nblen(version)+1)) write (6,1001) version(1:max(1,nblen(version))) write (6,1015) ('=',i=1,max(1,nblen(version)+1)) write (6,1001) write (buffer,1000) banner(1:max(1,nblen(banner))) write (6,1015) ('-',i=1,max(1,nblen(buffer)+1)) write (6,1001) buffer(1:max(1,nblen(buffer))) write (6,1015) ('-',i=1,max(1,nblen(buffer)+1)) write (6,1001) C****************************************************************************** C Look for command_line parameters. C****************************************************************************** iostat = lib_get_foreign(cmd_buff) if (iostat .ne. 1) goto 9999 C****************************************************************************** C if '/HELP', then print out help and exit. C****************************************************************************** if (cmd_buff(1:1) .eq. '?' .or. cmd_buff(2:5) .eq. 'help' .or. & get_option(cmd_buff,'HELP') .ne. 'NOT__FOUND') then write (6,1001) 'Command-line parameters are as follows :' write (6,1001) write (6,1001) '[Filename(in)]' write (6,1001) '[-INput = filename(in)]' write (6,1001) '[-OBJects = "object list"]' write (6,1001) '[-NAME = object name]' write (6,1001) '[-OUTput [= filename(out)] ]' c write (6,1001) '[-MAP_COLour [=RRRGGGBBB] ]' write (6,1001) '[-POVINClude_dir [= directory]' write (6,1001) '[-LIST_file_output [= filename]' write (6,1001) '[-COMPlete_povray_input_file [= camera_distance]' write (6,1001) '[-MEGApov_enabled' write (6,1001) '[-DEPTH_cueing [= strength]' write (6,1001) '[-TRANSparent_surfaces_on]' write (6,1001) '[-SHADOWless (with -complete)]' write (6,1001) '[-BLACK_background (with -complete)]' c write (6,1001) '[-SMOOTH_curves]' write (6,1001) '[-DEBugging_on]' write (6,1001) write (6,1001) 'More info at : '// * 'http://xray.bmc.uu.se/markh/notes/plt_pov_help.html' write (6,1001) goto 9999 end if C****************************************************************************** C Get input filename from '/IN' or from first non-introduced parameter C****************************************************************************** if (get_option(cmd_buff,'NON__INTRODUCED') .ne. 'NOT__FOUND') then filename_in = get_option(cmd_buff,'NON__INTRODUCED') op_flag = op_flag+1 end if C****************************************************************************** C Other options C****************************************************************************** if (get_option(cmd_buff,'IN') .ne. 'NOT__FOUND') then ! /INput filename_in = get_option(cmd_buff,'IN') if (nblen(filename_in) .gt. 0) then def_filename_out = filename_in i = index(filename_in,';') if (i .gt. 0)def_filename_out = 1 filename_in(1:index(filename_in,';')-1) istart = 1 iend = nblen(filename_in) i = index(filename_in,']') if (i .gt. 0) istart = i+1 i = index(filename_in(istart:),'.') if (i .gt. 1) iend = istart+i-2 def_filename_out = filename_in(istart:iend)//def_filetype_out else if (get_option(cmd_buff,'IN') .ne. 'NOT__FOUND') 1 filename_in = def_filename_in end if op_flag = op_flag + 1 end if if (get_option(cmd_buff,'OUT') .ne. 'NOT__FOUND') then ! /OUT filename_out = get_option(cmd_buff,'OUT') ! look for param to /OUT if (nblen(filename_out) .eq. 0) then filename_out = def_filename_out i = index(def_filename_out,';') if (i .gt. 0)filename_out = 1 def_filename_out(1:index(def_filename_out,';')-1) else if (filename_out .eq. 'IN') then filename_out = filename_in i = index(filename_in,';') if (i .gt. 0)filename_out = 1 filename_in(1:index(filename_in,';')-1) end if op_flag = op_flag + 1 end if if (get_option(cmd_buff,'LIST') .ne. 'NOT__FOUND') then ! /LIST listfile_out = get_option(cmd_buff,'LIST') ! look for param to /LIST if (nblen(listfile_out) .eq. 0) then listfile_out = def_list_out end if op_flag = op_flag + 1 list_flag = 3 ! also channel number end if c There is a bug here. Next line fails if OBJ is only CLP ! if (get_option(cmd_buff,'OBJ') .ne. 'NOT__FOUND') then ! /OBJ line = get_option(cmd_buff,'OBJ') ! look for param to /OBJ if (nblen(line) .eq. 0) then line = def_line end if op_flag = op_flag + 1 obj_flag = 1 end if if (get_option(cmd_buff,'NAME') .ne. 'NOT__FOUND') then ! /NAME str_tmp = get_option(cmd_buff,'NAME') ! look for param to /NAME if (nblen(str_tmp) .gt. 0) object_name = lowcase(str_tmp) op_flag = op_flag + 1 end if if (get_option(cmd_buff,'POVINC') .ne. 'NOT__FOUND') then ! /INCLUDE str_tmp = get_option(cmd_buff,'POVINC') ! look for param to /INCL if (nblen(str_tmp) .gt. 0) incl_dir = str_tmp op_flag = op_flag + 1 end if if (get_option(cmd_buff,'TRANS') .ne. 'NOT__FOUND') then! /TRANS_parent trans_flag = def_trans_flag str_tmp = get_option(cmd_buff,'TRANS') ! look for param to /TRANS if (nblen(str_tmp) .gt. 0) then read(str_tmp,*,iostat=iostat) trans_flag end if end if if (get_option(cmd_buff,'MAP_COL') .ne. 'NOT__FOUND') then! /MAP_COL str_tmp = get_option(cmd_buff,'MAP_COL') ! look for param to /MAP_COL if (nblen(str_tmp) .gt. 0) then read(str_tmp,222,iostat=iostat) i,j,k 222 format (i3,i3,i3) map_rgb(1) = i/256.0 map_rgb(2) = j/256.0 map_rgb(3) = k/256.0 map_col_flag = 1 end if end if if (get_option(cmd_buff,'COMP') .ne. 'NOT__FOUND') then! /COMPlete complete_flag = 1 str_tmp = get_option(cmd_buff,'COMP') ! look for param to /COMP if (nblen(str_tmp) .gt. 0) then read(str_tmp,*,iostat=iostat) cam_dist end if end if if (get_option(cmd_buff,'SMOOTH') .ne. 'NOT__FOUND') then! /SMOOTH smooth_flag = 1 print * print *, 'Smooth surfaces not implemented yet' print * str_tmp = get_option(cmd_buff,'SMOOTH') ! look for param to /SMOOTH if (nblen(str_tmp) .gt. 0) then read(str_tmp,*,iostat=iostat) smooth_flag end if end if if (get_option(cmd_buff,'BLACK') .ne. 'NOT__FOUND') then! /BLACK blackground_flag = 1 end if if (get_option(cmd_buff,'SHADOW') .ne. 'NOT__FOUND') then! /SHADOW shadowless_flag = 1 end if if (get_option(cmd_buff,'MEGA') .ne. 'NOT__FOUND') then! /MEGApov megapov_flag = 1 end if if (get_option(cmd_buff,'DEPTH') .ne. 'NOT__FOUND') then! /DEPTH_cueing depth_flag = 5 str_tmp = get_option(cmd_buff,'DEPTH') ! look for param to /DEBug if (nblen(str_tmp) .gt. 0) then read(str_tmp,*,iostat=iostat) depth_flag depth_flag = max(-5,depth_flag) depth_flag = min(5,depth_flag) end if end if if (get_option(cmd_buff,'DEB') .ne. 'NOT__FOUND') then ! /DEBug debug = 1 str_tmp = get_option(cmd_buff,'DEB') ! look for param to /DEBug if (nblen(str_tmp) .gt. 0) then read(str_tmp,*,iostat=iostat) debug else debug = 1 end if end if filename_in = lowcase(filename_in) def_filename_in = lowcase(def_filename_in) filename_out = lowcase(filename_out) def_filename_out = lowcase(def_filename_out) listfile_out = lowcase(listfile_out) C****************************************************************************** C Flag unused options C****************************************************************************** tmp_buffer = get_option(cmd_buff,'OPTIONS__LEFT') C****************************************************************************** C Prompt if no cmd-line prms C****************************************************************************** if (nblen(filename_in) .eq. 0) then 10 write (6,1009) 'O plot input file <' & //def_filename_in(1:max(1,nblen(def_filename_in)))//'> : ' read (5,1000,end=9999, err=10) filename_in if(nblen(filename_in) .eq. 0) filename_in = def_filename_in & (1:max(1,nblen(def_filename_in)))//' ' end if open (1, file=filename_in, status='OLD', form='Formatted') 20 format (a) if (nblen(filename_out) .eq. 0) then 12 write (6,1009) 'Output POV file <' & //def_filename_out(1:nblen(def_filename_out))// & '> : ' read (5,1000,end=9999, err=12) filename_out if(nblen(filename_out) .eq. 0) filename_out = def_filename_out & (1:max(1,nblen(def_filename_out)))//' ' end if open (2,file=filename_out, status='unknown',form='Formatted') if (list_flag .gt. 0) then open(list_flag,file=listfile_out, status='unknown',form='Formatted') end if if (obj_flag .eq. 0) then call find_objs(list_flag,nblacks,black_list) if (nblen(line) .eq. 0) then write (6,40) 40 format (' Include which objects ','(type on one line, * = all) : ',$) read (5,20) line if (nblen(line).eq.0) line = "*" end if end if ct_obj = 0 ct = 1 do i=1,10 call dcdwrd (line, ct, cmnd) if (cmnd .eq. ' ') goto 110 ct_obj = ct_obj+1 call lwcase (cmnd) obj(ct_obj) = cmnd end do 110 continue print * PRINT *,'Number of object strings entered =', ct_obj c print *, 'objs : ',(obj(i), i=1,ct_obj) if (ct_obj .eq. 0) then print * print *, 'No objects requested, so nothing to do, Byeeee....' print * end if in_obj = .false. ct_lin = 0 in_kamra = .false. C****************************************************************************** C Debug C****************************************************************************** if (debug .gt. 0) then print *, 'Transparency = ',trans_flag print *, 'Smooth = ',smooth_flag print *, 'Map colours = ',map_rgb(1),map_rgb(2),map_rgb(3) end if C****************************************************************************** C Write header for complete POV-Ray output file, if requested C****************************************************************************** if (complete_flag .eq. 1) then incl_len = nblen(incl_dir) write (2,1000) '// File created by plt_pov from '// 1 filename_in(1:nblen(filename_in))//' '//date_string(1:8) write (2,1000) '// ' write (2,1000) '// ================================ ' write (2,1000) '// ' if (megapov_flag .eq. 1) then write (2,1000) '#version unofficial MegaPov 0.7; '// 1 ' // Mray_MegaPov' write (2,1000) '// ' write (2,1000) '#version 0.31; '// 1 ' // Mray_MegaPov' else end if write (2,1000) '// You may want to change the Camera_Distance below' write (2,1000) '// ' write (2,1600) '#declare Camera_Distance =',cam_dist,';'// 1 ' // Mray_CamDist' write (2,1600) '// Mray_ModCamDist' 1600 format(a,f6.1,a) write (2,1000) '// ' write (2,1000) '#include "'//incl_dir(1:incl_len)//'/colors.inc"' write (2,1000) '#include "'//incl_dir(1:incl_len)//'/textures.inc"' write (2,1000) '#include "'//incl_dir(1:incl_len)//'/finish.inc"' write (2,1000) '#include "'//incl_dir(1:incl_len)//'/shapes.inc"' write (2,1000) '//#include "'//incl_dir(1:incl_len)//'/spline.inc"' write (2,1000) '// ' write (2,1000) '#declare Plastic_Lines = finish '// 1 '{specular 0.5 roughness 0.04 ambient .3 diffuse .6} '// 2 ' // Mray_Plines' write (2,1000) '#declare Plastic_Ribbons = finish '// 1 '{specular 0.2 roughness 0.08 ambient .5 diffuse .3} '// 2 ' // Mray_Pribs' write (2,1000) '#declare Plastic_Maps = finish '// 1 '{specular 0.5 roughness 0.04 ambient .3 diffuse .6} '// 2 ' // Mray_Pmaps' write (2,1000) '#declare Plastic_Balls = finish '// 1 '{specular 0.5 roughness 0.04 ambient .3 diffuse .6} '// 2 ' // Mray_Pballs' write (2,1000) '#declare Plastic_Sticks = finish '// 1 '{specular 0.3 roughness 0.04 ambient .3 diffuse .6} '// 2 ' // Mray_Psticks' write (2,1000) '// ' write (2,1000) '#declare Metallic_Lines = finish '// 1 '{specular 0.8 roughness 0.01 ambient .25 diffuse .5'// 2 ' metallic brilliance 4 reflection 0.5} '// 2 ' // Mray_Plines' write (2,1000) '#declare Metallic_Ribbons = finish '// 1 '{specular 0.8 roughness 0.01 ambient .25 diffuse .5'// 2 ' metallic brilliance 4 reflection 0.5} '// 2 ' // Mray_Pribs' write (2,1000) '#declare Metallic_Maps = finish '// 1 '{specular 0.8 roughness 0.01 ambient .25 diffuse .5'// 2 ' metallic brilliance 4 reflection 0.5} '// 2 ' // Mray_Pmaps' write (2,1000) '#declare Metallic_Balls = finish '// 1 '{specular 0.8 roughness 0.01 ambient .25 diffuse .5'// 2 ' metallic brilliance 4 reflection 0.5} '// 2 ' // Mray_Pballs' write (2,1000) '#declare Metallic_Sticks = finish '// 1 '{specular 0.8 roughness 0.01 ambient .25 diffuse .5'// 2 ' metallic brilliance 4 reflection 0.5} '// 2 ' // Mray_Psticks' write (2,1000) '// ' write (2,1000) '#declare Trans_Map = 0.5; // Mray_MapT' write (2,1000) '#declare Trans_Ball = 0.0; // Mray_BallT' write (2,1000) '#declare Trans_Stick = 0.0; // Mray_StickT' write (2,1000) '#declare Trans_Ribbon = 0.0; // Mray_RibbT' write (2,1000) '#declare Trans_Other = 0.0; // Mray_OtherT' write (2,1000) '//' write (2,1000) '#declare Text_Scale = 1.0; // Mray_TxtScal' write (2,1000) '#declare Line_Width = 0.02; // Mray_LinWid' write (2,1000) '#declare Hb_Dot_Size = 0.08; // Mray_HbDot' write (2,1000) '//' write (2,1000) '#declare Ttf_File = "'//incl_dir(1:incl_len)// 1 '/arial.ttf'//'" // Mray_ttf' write (2,1000) '//' write (2,1000) '#declare lpos1 = <-35,30,150> ;'// 1 ' // Mray_Lpos1' write (2,1000) '#declare lcol1 = color red 1 green 1 blue 1 '// 1 ' // Mray_Lcol1' write (2,1000) '#declare lpos2 = <35,30,150> ;'// 1 ' // Mray_Lpos2' write (2,1000) '#declare lcol2 = color red .5 green .5 blue .5 '// 1 ' // Mray_Lcol2' write (2,1000) '//' write (2,1000) '#declare Wall_Dist = -5.0 '// 1 ' //Mray_WallDist' write (2,1000) '#declare Texture_Colour = color rgb <0.8,0.8,0.8>'// 1 ' //Mray_TextureCol' write (2,1000) '#declare Plain = texture{pigment{Texture_Colour}}'// 1 ' //Mray_PlainTexture' write (2,1000) '//' if (blackground_flag .eq. 0) then write (2,1000) 'background {White} // Mray_Bgrnd' else write (2,1000) 'background {Black} // Mray_Bgrnd' end if write (2,1000) '//' write (2,1000) '#declare Stereo_On = no; // Mray_SterOn' write (2,1000) '#declare Sep_Stereo = 10.0; // Mray_SterSep' write (2,1000) '#declare Frame_Scale_Stereo = 0.5; // Mray_FSS' write (2,1000) '#declare Frame_Scale_Mono = 1; // Mray_FSM' write (2,1000) '#declare Stereo_Cross = yes; // Mray_SterCrs' write (2,1000) '//' write (2,1000) '#if (Stereo_On = yes)' write (2,1000) '#declare Stereo_Sep = Sep_Stereo;' write (2,1000) '#declare Frame_Scale = Frame_Scale_Stereo;' write (2,1000) '#else' write (2,1000) '#declare Stereo_Sep = 0.0;' write (2,1000) '#declare Frame_Scale = Frame_Scale_Mono;' write (2,1000) '#end' write (2,1000) '//' write (2,1000) '#if (Stereo_Cross = no) ' write (2,1000) '#declare Stereo_Angle = 2.0; // Mray_SteAng1' write (2,1000) '#else' write (2,1000) '#declare Stereo_Angle = -2.0; // Mray_SteAng2' write (2,1000) '#end' write (2,1000) '//' write (2,1000) '// Mray_StartCamera' write (2,1000) 'camera { location <0.0, 0.0, Camera_Distance>' write (2,1000) 'direction <0, 0, 1.0> // Mray_Direct1' write (2,1000) 'look_at <0, 0, 0> // Mray_Look1' write (2,1000) 'up y/Frame_Scale right x/Frame_Scale' write (2,1000) 'orthographic // Mray_Ortho1' write (2,1000) '}' write (2,1000) '// Mray_EndCamera' write (2,1000) '//' write (2,1000) '#declare fixtures = union {' write (2,1000) '////plane {z, Wall_Dist texture {White_Marble}}'// 1 ' // Mray_Plane' if (shadowless_flag .eq. 0) then write (2,1000) 'light_source {lpos1 lcol1} '// 1 ' // Mray_Light1' write (2,1000) 'light_source {lpos2 lcol2} '// 1 ' // Mray_Light2' else write (2,1000) 'light_source {lpos1 lcol1 shadowless} '// 1 ' // Mray_Light1' write (2,1000) 'light_source {lpos2 lcol2 shadowless} '// 1 ' // Mray_Light2' end if write (2,1000) '}' write (2,1000) ' ' write (*,1000) 1 '==========================================================' write (*,1000) ' ' write (*,1000) 'You have chosen to output a complete POV-Ray file.' write (*,1000) 'You may need to change the value of Camera_Distance' write (*,1000) 1 'in the output file to get a reasonably-sized picture.' write (*,1000) ' ' write (*,1000) 1 'You can see your picture by using the following commands :' write (*,1000) ' ' write (*,1000) '% x-povray -i '// 1 filename_out(1:nblen(filename_out))//' -o myfile.tga' write (*,1000) '% xv myfile.tga ' write (*,1000) ' ' write (*,1000) 1 '==========================================================' write (*,1000) ' ' end if C****************************************************************************** C Interpret file (mostly Alwyn code) C****************************************************************************** call write_header(object_name,trans_flag) 10000 continue read (1, 20, end = 1010) line line_mixed = line 2000 call lwcase (line) 999 format (1x,a) ct = 1 call dcdwrd (line, ct, cmnd) if (cmnd .eq. 'translate') then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 3, t, errcod) else if (cmnd .eq. 'transform') then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 9, q, errcod) do i=1,3 do j=1,3 r(i,j) = q(j,i) end do end do c fix matrix 'feature' x = r(1,1)+r(1,2)+r(1,3) y = r(2,1)+r(2,2)+r(2,3) z = r(3,1)+r(3,2)+r(3,3) x=sqrt(x*x+y*y+z*z)/sqrt(3.0) else if (cmnd .eq. 'scale') then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 1, scale, errcod) else if (cmnd .eq. 'slab') then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 2, slab, errcod) cmrh slab(1) = 0. cmrh slab(2) = 2*slab(2) else if (cmnd .eq. 'begin') then ribbon_flag = 0 C MRH setting colour to grey for each new object, C so colouring must be deliberate c colour(1) = 0.5 c colour(2) = 0.5 c colour(3) = 0.5 if (index(line,"map") .gt. 0 .and. map_col_flag .gt. 0) then colour(1) = map_rgb(1) colour(2) = map_rgb(2) colour(3) = map_rgb(3) end if call out_colour(colour) dashed_flag = 0 if (debug .gt. 5) PRINT 999,line call dcdwrd (line, ct, cmnd) do i=1,ct_obj do j=1,20 if (obj(i)(j:j) .eq. ' ') then if ((obj(i)(1:j-1) .eq. cmnd(1:j-1)) .or. 1 (obj(i)(1:j-1) .eq. 'allting') .or. ! MRH 11-May-99 1 (obj(i)(1:j-1) .eq. '*')) then ! MRH 7-Sep-99 obj_nam = cmnd(1:nblen(cmnd)) if (obj_nam(1:nblen(obj_nam)) .eq. 'kamra_col1') then in_kamra = .true. goto 335 else in_kamra = .false. end if do 331 k = 3, nblacks ! NB Skip 1st and 2nd elements (_map + _col) if(index(obj_nam,black_list(k) 1 (1:nblen(black_list(k)))).ne.0)goto 335 331 continue in_obj = .true. if (debug .gt. 1) print 999, 'OBJECT : '//cmnd(1:j-1) start_obj_flag = 1 obj_count = obj_count + 1 obj_list(obj_count) = obj_nam obj_clean = obj_nam do k = 1,nblen(obj_list(obj_count)) if (obj_clean(k:k) .eq. '$') then obj_clean(k:k) = '_' ribbon_flag = 1 end if end do c POV-Ray doesn't like leading numeric if (obj_clean(1:1) .eq. '1') obj_clean(1:1) = 'Q' if (obj_clean(1:1) .eq. '2') obj_clean(1:1) = 'R' if (obj_clean(1:1) .eq. '3') obj_clean(1:1) = 'S' if (obj_clean(1:1) .eq. '4') obj_clean(1:1) = 'T' if (obj_clean(1:1) .eq. '5') obj_clean(1:1) = 'U' if (obj_clean(1:1) .eq. '6') obj_clean(1:1) = 'V' if (obj_clean(1:1) .eq. '7') obj_clean(1:1) = 'W' if (obj_clean(1:1) .eq. '8') obj_clean(1:1) = 'X' if (obj_clean(1:1) .eq. '9') obj_clean(1:1) = 'Y' if (obj_clean(1:1) .eq. '0') obj_clean(1:1) = 'Z' write (2,333) '#declare ', 1 obj_clean(1:nblen(obj_clean)),'= union {' 333 format (a,a,a) goto 10000 else goto 400 end if end if end do 400 continue end do 335 continue else if (cmnd .eq. 'window') then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 4, bounds, errcod) else if (cmnd .eq. 'colour') then if (in_obj) then if (debug .gt. 5) PRINT 999,line call dcdfff (line, ct, 3, colour, errcod) if (ct_lin .ne. 0) then cclinux call out_line (ct_lin, line) ct_lin = 0 end if call out_colour (colour) end if else if (cmnd .eq. 'line_type') then call dcdwrd (line, ct, string) if (string(1:5) .eq. 'solid') dashed_flag = 0 if (string(1:6) .eq. 'dashed') dashed_flag = 1 if (string(1:6) .eq. 'dotted') dashed_flag = 2 if (string(1:8) .eq. 'dot_dash') dashed_flag = 3 else if (cmnd .eq. 'polygon') then ! can this work ???? norm_flag = 0 if (.not. in_obj) goto 10000 if (debug .gt. 5) PRINT 999,line ct_pol = 0 300 read (1, 20, end = 1010) line if (debug .gt. 5) PRINT 999,line if (line(1:6) .eq. 'normal') then norm_flag = 1 ct_pol = 0 goto 300 end if if (line(1:1) .eq. ' ' .and. index(line,"nan") .le. 0) then ct_pol = ct_pol+1 ct = 1 if (norm_flag .eq. 0) then call dcdfff (line, ct, 3, poly(1,ct_pol), errcod) else call dcdfff (line, ct, 3, poly(4,ct_pol), errcod) end if goto 300 end if if (ct_lin .ne. 0) then call out_line (ct_lin, lin) ct_lin = 0 end if if (norm_flag .eq. 0) then call out_poly (ct_pol, poly) else call out_poly_normal (ct_pol, poly) end if goto 2000 else if (cmnd .eq. 'smooth_triangles') then if (.not. in_obj) goto 10000 if (debug .gt. 5) PRINT 999,line c ct = 1 c ct_pol = ct_pol+1 ct_pol = 1 i = 1 k = 1 c Ugly triple read here. Fix it. read (1, 20, end = 1010) line ct = 1 call dcdfff (line, ct, 6, poly_normal(1,1), errcod) read (1, 20, end = 1010) line ct = 1 call dcdfff (line, ct, 6, poly_normal(1,2), errcod) read (1, 20, end = 1010) line ct = 1 call dcdfff (line, ct, 6, poly_normal(1,3), errcod) 66 format (a,6f7.2) cc print 665 , 'pp:',(poly_normal(i,1),i=1,6) 665 format(1x,a,6f5.2) CC call out_poly_normal (ct_pol, poly_normal) call out_poly_normal (3, poly_normal) goto 10000 else if (cmnd .eq. 'poly_normal') then ! probably wrong ! if (.not. in_obj) goto 10000 if (debug .gt. 5) PRINT 999,line ct_pol = 0 302 read (1, 20, end = 1010) line if (debug .gt. 5) PRINT 999,line if (line(1:1) .eq. ' ') then ct_pol = ct_pol+1 ct = 1 call dcdfff (line, ct, 6, poly_normal(1,ct_pol), errcod) goto 302 end if call out_poly_normal (ct_pol, poly_normal) goto 2000 else if (cmnd .eq. 'move') then C --------------------------------- kamra stuff ----------------------- if (in_kamra) then kamra_count = kamra_count + 1 nwords = find_words(line,word_starts,word_ends) word = line(word_starts(2):word_ends(2)) read (word,*) kamra(1,kamra_count) word = line(word_starts(3):word_ends(3)) read (word,*) kamra(2,kamra_count) word = line(word_starts(4):word_ends(4)) read (word,*) kamra(3,kamra_count) x = kamra(1,kamra_count) y = kamra(2,kamra_count) z = kamra(3,kamra_count) do 180 j=1,3 kamra(j,kamra_count) = (x*r(j,1)+y*r(j,2)+z*r(j,3)+t(j))*scale 180 continue cc Was used in reads above, before Linux. MRH 27Nov02 cc 777 format(f) goto 10000 end if C ----------------------------- end kamra stuff ----------------------- if (.not. in_obj) goto 10000 if (ct_lin .ne. 0) then call out_line (ct_lin, lin) ct_lin = 0 end if if (debug .gt. 5) PRINT 999,line ct_lin = 1 call dcdfff (line, ct, 3, lin(1,ct_lin), errcod) else if (cmnd .eq. 'line') then if (.not. in_obj) goto 10000 ct_lin = ct_lin+1 call dcdfff (line, ct, 3, lin(1,ct_lin), errcod) if (ct_lin .gt. 100) then if (debug .gt. 5) PRINT *,'Too many in move/lineto' call out_line (ct_lin, lin) ct_lin = 0 end if else if (cmnd .eq. 'cylinder') then if (.not. in_obj) goto 10000 call dcdfff (line, ct, 7, cyl, errcod) call out_cyl (cyl) if (debug .gt. 1) print *, 'cylinder :',cyl(1),cyl(2),cyl(3) else if (cmnd .eq. 'text') then if (.not. in_obj) goto 10000 call dcdfff (line, ct, 3, text_crds, errcod) cc text = line(ct:) text = line_mixed(ct:) call out_text (text_crds,text) if (debug.gt.1) print *, 'text :',text(1:20),text_crds(1),text_crds(2) else if (cmnd .eq. 'sphere') then if (.not. in_obj) goto 10000 call dcdfff (line, ct, 4, sph, errcod) call out_sph (sph) else if (cmnd .eq. 'end_object') then if (.not. in_obj) goto 10000 if (debug .gt. 5) PRINT 999,line if (ct_lin .ne. 0) then call out_line (ct_lin, lin) ct_lin = 0 end if if (start_obj_flag .eq. 1) then write (2,*) '}' start_obj_flag = 0 end if in_obj = .false. end if goto 10000 1010 continue call write_tail(trans_flag,object_name,obj_count,obj_list) if (complete_flag .eq. 1) then ccc write (2,1000) 'object { '//object_name(1:nblen(object_name))//' }' write (2,1000) '// ' write (2,1000) '#declare left_s = union {' write (2,1000) 'object { onomol' write (2,1000) 'rotate x*000 // Mray_Xrot' write (2,1000) 'rotate y*000 // Mray_Yrot' write (2,1000) 'rotate z*000 // Mray_Zrot' write (2,1000) 'translate x*000 // Mray_Xtrans' write (2,1000) 'translate y*000 // Mray_Ytrans' write (2,1000) 'translate z*000 // Mray_Ztrans' write (2,1000) '}' write (2,1000) 'fixtures' write (2,1000) ' ' write (2,1000) '#if (Stereo_Sep)' write (2,1000) 'rotate y*180 // Why, oh, why ?? // Mray_Silvertape' write (2,1000) 'matrix<1,0,0,0,1,0,0,0,-1,0,0,0>// Mray_Silvertape' write (2,1000) '#end' write (2,1000) '}' write (2,1000) ' ' write (2,1000) 'object {left_s' write (2,1000) ' ' write (2,1000) '#if (Stereo_Sep)' write (2,1000) 'rotate y*Stereo_Angle' write (2,1000) '#end ' write (2,1000) 'rotate y*000 // Mray_YSMrot' write (2,1000) 'translate x*Stereo_Sep' write (2,1000) '}' write (2,1000) '//' write (2,1000) '#if (Stereo_Sep)' write (2,1000) '// Mray_StartCamera' write (2,1000) 'camera { location <0.0,0.0,Camera_Distance>' write (2,1000) 'direction <0, 0, 1.0> // Mray_Direct2' write (2,1000) 'up y/Frame_Scale right x/Frame_Scale ' write (2,1000) 'look_at <0,0,0> // Mray_Look2' write (2,1000) 'orthographic // Mray_Ortho2' write (2,1000) '}' write (2,1000) '// Mray_EndCamera' write (2,1000) '// Mray_InsertCamera' write (2,1000) '//' write (2,1000) '#declare right_s = union {' write (2,1000) 'object { onomol' write (2,1000) 'rotate x*000 // Mray_Xrot' write (2,1000) 'rotate y*000 // Mray_Yrot' write (2,1000) 'rotate z*000 // Mray_Zrot' write (2,1000) 'translate x*000 // Mray_Xtrans' write (2,1000) 'translate y*000 // Mray_Ytrans' write (2,1000) 'translate z*000 // Mray_Ztrans' write (2,1000) '}' write (2,1000) 'fixtures' write (2,1000) ' ' write (2,1000) '#if (Stereo_Sep)' write (2,1000) 'rotate y*180 // Why, oh, why ?? // Mray_Silvertape' write (2,1000) 'matrix<1,0,0,0,1,0,0,0,-1,0,0,0>// Mray_Silvertape' write (2,1000) '#end' write (2,1000) '}' write (2,1000) 'object {right_s' write (2,1000) 'rotate y*-Stereo_Angle' write (2,1000) 'translate x*-Stereo_Sep' write (2,1000) '}' write (2,1000) '#end' write (2,1000) '//' end if C --------------------------------- kamra stuff ----------------------- C-- Added extra brackets here, and I5 format for Linux MRH 27nov02 if ((megapov_flag .eq. 1) .and. (kamra_count .gt. 0)) then write (2,1000) '//' write (2,1000) '//Mray_StartSpline' write (2,1000) '#declare DummySpline = create_spline (' write (2,1008) 'array[',kamra_count,'] {' do 887 k = 1,kamra_count-1 write (2,1088) '<',kamra(1,k),',',kamra(2,k),',',kamra(3,k),'>,' 887 continue k = kamra_count write (2,1088) '<',kamra(1,k),',',kamra(2,k),',',kamra(3,k),'>' write (2,1000) '},' write (2,1000) 'spline_tension(-1))' write (2,1000) '//Mray_EndSpline' write (2,1000) '//' end if C ----------------------------- end kamra stuff ----------------------- 9999 continue 1000 format(a) 1001 format(1x,a) 1008 format(a,i5,a) 1088 format(a,f7.2,a,f7.2,a,f7.2,a) 1009 format(1x,a,$) cc2222 format(f) 1015 format(1x,80a1) stop end c======================================================================= subroutine lwcase (text) c --- LoWer_CASE c --- Return lowercase equivalent c --- Written by Alwyn Jones 11-Nov-89 character*(*) text c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ n = len(text) if(n .le. 0)return do 100 i =1,n j = ichar(text(i:i)) if(j .ge. 65 .and. j .le. 90) text(i:i) = char(j+32) 100 continue return end c======================================================================= c23456789012345678901234567890123456789012345678901234567890123456789012 subroutine dcdwrd (line, ct, c) c --- DeCoDe_WoRD c --- Decode a word in a line of text. c --- Results are returned aligned LEFT. c --- If there are more then dimensioned characters, they are c truncated. c --- If first non-space is ' then use between quotes as string. c --- Allowed word delimiters are ' ', ',' c --- A blank can be defined with ';' as 1st char. c --- Line = a line of text c ct = index to first character in line from which to start c decoding. Returned as index to start next decoding. c c = the returned text c --- Written by Alwyn Jones implicit none character line*(*), c*(*) integer ct c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character endlin*1 integer i, i1, i2, max, l max = len(line) l = len(c) endlin = ';' c(1:l) = ' ' if (ct .ge. max) goto 1000 c --- Find first non space. If it is a quote then use this to delimit input. 100 if (line(ct:ct) .eq. ' ') then ct = ct+1 if (ct .ge. max) goto 1000 goto 100 end if 1000 continue c --- If it is a quote, mark as end-of-line indicator and move to next space. c$$$ if (line(ct:ct) .eq. '''') then c$$$ endlin = '''' if (line(ct:ct) .eq. '"') then endlin = '"' ct = ct+1 200 if (line(ct:ct) .eq. ' ')then ct = ct+1 if (ct .ge. max) return goto 200 end if end if i1 = ct c --- We are positioned at the first non-space character. 300 if (line(ct:ct) .eq. endlin .or. line(ct:ct) .eq. ' ') then if (ct .eq. i1) goto 400 i2 = min(i1+l-1,ct-1) c(1:l) = line(i1:i2) call alignl (c(1:l)) goto 400 end if ct = ct+1 if (ct .ge. max )then i2 = min(i1+l-1,ct) if (i2 .gt. max) i2 = max c(1:l) = line(i1:i2) call alignl (c(1:l)) return end if goto 300 c --- This is the regular exit. Skip to end of ' if that is how the c text was defined. c$$$400 if (endlin .ne. '''') goto 420 400 if (endlin .ne. '"') goto 420 if (line(ct:ct) .eq. endlin) goto 420 c --- We have an end line as a quote but the last character was not a quote. 410 ct = ct+1 if (ct .ge. max) return if (line(ct:ct) .ne. endlin) goto 410 420 ct = ct+1 return end c======================================================================= subroutine dcdffi (line, ct, n, ir, errcod) c --- DeCoDe_Free_Format_Integer c --- Decode integer values in a line of text. c --- If first non-space is ' then use between quotes as string. c --- Allowed word delimiters are ' ', ',' c --- Character ';' terminates input. c --- Line = a line of text c ct = index to first character in line from which to start c decoding. Returned as index to start next decoding. c n = number of integers c ir = array in which to return integers c errcod = 0 OK,26 error in decoding c --- Written by Alwyn Jones implicit none character line*(*) integer ct, n, ir(1), errcod c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character word*20, spacer*1 integer i, j, k, i1, i2, ctmax, ctvar dimension spacer(2) data spacer /' ', ','/ do 200 i=1,n 200 ir(i) = 0 ct = ct-1 ctmax = len(line) ctvar = 0 if (ct .gt. ctmax) goto 1000 c --- scan for start of a number or ',' or ';' 100 ct = ct+1 if (ct .ge. ctmax) return if (line(ct:ct) .eq. ';') then ct = ct+1 return end if if (line(ct:ct) .eq. ',') then ct = ct+1 goto 100 end if if (line(ct:ct) .eq. ' ') goto 100 c --- scan for spacer i1 = ct 140 ct = ct+1 if (ct .gt. ctmax .or. line(ct:ct) .eq. ';') goto 130 do 150 k=1,2 if(line(ct:ct) .eq. spacer(k)) goto 130 150 continue goto 140 130 i2 = ct-1 j = i2-i1+1 ctvar = ctvar+1 if (j .gt. 20)then call prompt(' Integer> 20 digits') goto 2000 end if if (j .eq. 20) then word = line(i1:i2) else word(1:20-j) = ' ' word(21-j:20) = line(i1:i2) end if read (word,'(i20)',err=1000) ir(ctvar) if (ctvar .eq. n .or. line(ct:ct) .eq. ';') then ct = ct+1 goto 2000 end if if (ct .le. ctmax) goto 100 ct = ct+1 goto 2000 1000 errcod = 26 cccccc call prompt(' Error in decoding integer.') ir(ctvar) = 0 return 2000 errcod = 0 return end c======================================================================= subroutine dcdfff (line, ct, n, r, errcod) c --- DeCoDe_Free_Format_Float c --- Decode integer values in a line of text. c --- If first non-space is ' then use between quotes as string. c --- Allowed word delimiters are ' ', ',' c --- Character ';' terminates input. c --- Line = a line of text c ct = index to first character in line from which to start c decoding. Returned as index to start next decoding. c n = number of integers c r = array in which to return reals c errcod = 0 OK,26 error in decoding c --- Written by Alwyn Jones implicit none character line*(*) integer ct, n, errcod real r(1) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character word*20, spacer*1 integer i, j, k, i1, i2, ctmax, ctvar, ichar dimension spacer(2) data spacer /' ', ','/ do 200 i=1,n 200 r(i) = 0.0 ct = ct-1 ctmax = len(line) ctvar = 0 if (ct .gt. ctmax) then goto 1000 end if c --- scan for start of a number or ',' or ';' 100 ct = ct+1 if (ct .ge. ctmax) return if (line(ct:ct) .eq. ';') then ct = ct+1 return end if if (line(ct:ct) .eq. ',') then ct = ct+1 goto 100 end if if (line(ct:ct) .eq. ' ') goto 100 c --- scan for spacer i1 = ct 140 ct = ct+1 if (ct .gt. ctmax .or. line(ct:ct) .eq. ';') goto 130 do 150 k=1,2 if(line(ct:ct) .eq. spacer(k)) goto 130 150 continue goto 140 130 i2 = ct-1 j = i2-i1+1 ctvar = ctvar+1 if (j .gt. 20)then call prompt(' Real> 20 digits') goto 2000 end if if (j .eq. 20) then word = line(i1:i2) else word(1:20-j) = ' ' word(21-j:20) = line(i1:i2) end if read (word,'(f20.1)',err=1000) r(ctvar) if (ctvar .eq. n .or. line(ct:ct) .eq. ';') then ct = ct+1 goto 2000 end if if (ct .le. ctmax) goto 100 ct = ct+1 goto 2000 1000 errcod = 26 call prompt (word) cccccc call prompt(' Error in decoding real.') r(ctvar) = 0 return 2000 errcod = 0 return end c======================================================================= subroutine alignl(a) c --- character align left,i.e. remove all spaces and shove left character* (*) a c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ length = len(a) j = 0 do 100 i=1,length if(a(i:i) .ne. ' ')then j = j+1 a(j:j) = a(i:i) end if 100 continue if(j .lt. length)then do 200 i=j+1,length 200 a(i:i) = ' ' end if return end subroutine prompt (text) implicit none character*(*) text write (6,10) text(1:len(text)) 10 format (1x,a) return end C---------------------------------------------------------- subroutine out_line (ct, xa) ! MRH mods for dashes implicit none integer ct, i, j, k, debug, dashed_flag, dash_size, ribbon_flag integer depth_flag real xa(3,1000) real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) real x1(3), x2(3), x3(3), x4(3), dist debug = 1 dash_size = 5 ! (dashes per angstrom) do 100 i=1,ct-1 cc print * cc print 999, (xa(k,1),k=1,3),(xa(k,2),k=1,3) do 110 j=1,3 x1(j) = (xa(1,i)*r(j,1)+xa(2,i)*r(j,2)+xa(3,i)*r(j,3)+t(j))*scale 110 x2(j) = (xa(1,i+1)*r(j,1)+xa(2,i+1)*r(j,2)+xa(3,i+1)*r(j,3)+ $ t(j))*scale if (x1(1) .lt. bounds(1)) goto 100 if (x1(1) .gt. bounds(2)) goto 100 if (x1(2) .lt. bounds(3)) goto 100 if (x1(2) .gt. bounds(4)) goto 100 if (x1(3) .lt. slab(1)) goto 100 if (x1(3) .gt. slab(2)) goto 100 if (x2(1) .lt. bounds(1)) goto 100 if (x2(1) .gt. bounds(2)) goto 100 if (x2(2) .lt. bounds(3)) goto 100 if (x2(2) .gt. bounds(4)) goto 100 if (x2(3) .lt. slab(1)) goto 100 if (x2(3) .gt. slab(2)) goto 100 call depth_cue(colour_cue,(x1(3)+x2(3))/2) cc print 999, (x1(k),k=1,3), (x2(k),k=1,3),slab(1),slab(2), scale cc 999 format(3f7.2,3x,3f7.2,5x,3f7.2) if ( (abs(x1(1)-x2(1)) .lt. 0.01) .and. 1 (abs(x1(2)-x2(2)) .lt. 0.01) .and. 1 (abs(x1(3)-x2(3)) .lt. 0.01) ) goto 100 if (dashed_flag .eq. 1) then ! dashed dist = sqrt( (x1(1)-x2(1))**2+ 1 (x1(2)-x2(2))**2+ 1 (x1(3)-x2(3))**2 ) j = int(dash_size*dist) do k = 0, j-1,2 x3(1) = x1(1)+((x2(1)-x1(1))/j)*k x3(2) = x1(2)+((x2(2)-x1(2))/j)*k x3(3) = x1(3)+((x2(3)-x1(3))/j)*k x4(1) = x1(1)+((x2(1)-x1(1))/j)*(k+1) x4(2) = x1(2)+((x2(2)-x1(2))/j)*(k+1) x4(3) = x1(3)+((x2(3)-x1(3))/j)*(k+1) cc print *, k, x1(1),x2(1), x3(1), x4(1) write (2,1000) 'cylinder {' write (2,1018) '<', 1 x3(1),',', 2 x3(2),',', 2 x3(3),'>,<', 1 x4(1),',', 2 x4(2),',', 2 x4(3),'> Line_Width', 3 ' texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Lines} } }' 1018 format(a,6(f7.2,a),a,3f5.2,a) end do else if (dashed_flag .eq. 2) then ! dotted dist = sqrt( (x1(1)-x2(1))**2+ 1 (x1(2)-x2(2))**2+ 1 (x1(3)-x2(3))**2 ) j = int(dash_size*dist) do k = 0, j-1,2 x4(1) = x1(1)+((x2(1)-x1(1))/j)*(k+0.5) x4(2) = x1(2)+((x2(2)-x1(2))/j)*(k+0.5) x4(3) = x1(3)+((x2(3)-x1(3))/j)*(k+0.5) cc print *, k, x1(1),x2(1), x3(1), x4(1) write (2,1000) 'sphere {' write (2,1038) '<', 1 x4(1),',', 2 x4(2),',', 2 x4(3),'> Hb_Dot_Size', 3 ' texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Balls} } }' 1038 format(a,3(f7.2,a),a,3f5.2,a) end do else ! plain line write (2,1000) 'cylinder {' write (2,1018) '<', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'>,<', 1 x2(1),',', 2 x2(2),',', 2 x2(3),'> Line_Width', 3 ' texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Lines} } }' end if if (debug .gt. 5) PRINT *,'not clipped' ccc return 100 continue if (debug .gt. 5) PRINT *,'clipped' 1000 format(a) return end c-------------------------------------------------------------------- subroutine write_smooth_poly (contig_poly_flag, smooth_flag, tri_col) c-------------------------------------------------------------------- c NB Assumes all polygons are triangles at present. MRH May '99 c Calculates normals for each vertex of each triangle in an object, c then finds adjacent edges, and averages normals between these c pairs of edges to allow Gouraud shading. c c array org : all_polys(Cx:Cy:Cz:Nx:Ny:Nz:Mx:My:Mz:A:B:C,9000) c edges are associated with vertices as follows : 1=1:2 2=2:3 3=3:1 c-------------------------------------------------------------------- implicit none real find_normal integer ct, i, j, k, k2, l, m, dashed_flag, contig_poly_flag, ierr integer debug, ie, ie2, it, smooth_flag, point_flag, ribbon_flag integer mate_list(2,100), mate_count, norm_orig_flag, ip, iq integer depth_flag real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) real xa(9,3), av_normal(3), mated_flags(3,9000) common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2), tri_col(3,9000) real x1(9), x2(3), n1(3), n2(3), dist debug = 2 norm_orig_flag = 1 point_flag = 1 ! chooses algorithm, temporary c find normals c ------------ if (smooth_flag .gt. 0) then print *, 'Smoothing surface' do i = 1,contig_poly_flag ierr=find_normal(all_polys(1,1,i),all_polys(1,2,i),all_polys(1,3,i), 1 all_polys(4,1,i) ) all_polys(4,1,i)=all_polys(4,1,i)+all_polys(1,1,i) all_polys(5,1,i)=all_polys(5,1,i)+all_polys(2,1,i) all_polys(6,1,i)=all_polys(6,1,i)+all_polys(3,1,i) all_polys(4,2,i)=all_polys(4,1,i)-all_polys(1,1,i)+all_polys(1,2,i) all_polys(5,2,i)=all_polys(5,1,i)-all_polys(2,1,i)+all_polys(2,2,i) all_polys(6,2,i)=all_polys(6,1,i)-all_polys(3,1,i)+all_polys(3,2,i) all_polys(4,3,i)=all_polys(4,1,i)-all_polys(1,1,i)+all_polys(1,3,i) all_polys(5,3,i)=all_polys(5,1,i)-all_polys(2,1,i)+all_polys(2,3,i) all_polys(6,3,i)=all_polys(6,1,i)-all_polys(3,1,i)+all_polys(3,3,i) c normals based on origin if (norm_orig_flag .gt. 0) then ierr=find_normal(all_polys(1,1,i),all_polys(1,2,i),all_polys(1,3,i), 1 all_polys(4,1,i) ) all_polys(4,2,i)=all_polys(4,1,i) all_polys(5,2,i)=all_polys(5,1,i) all_polys(6,2,i)=all_polys(6,1,i) all_polys(4,3,i)=all_polys(4,1,i) all_polys(5,3,i)=all_polys(5,1,i) all_polys(6,3,i)=all_polys(6,1,i) end if c set mean normal to normal value for now do j = 1, 3 do k = 1,3 all_polys(k+6,j,i)=all_polys(k+3,j,i) end do end do if (debug .gt. 1) then dist = sqrt((all_polys(1,1,i)-all_polys(4,1,i))**2 + 1 (all_polys(2,1,i)-all_polys(5,1,i))**2 + 1 (all_polys(3,1,i)-all_polys(6,1,i))**2 ) print *, '============================================',i print *,'p:',all_polys(1,1,i), all_polys(2,1,i), all_polys(3,1,i) print *,'p:',all_polys(1,2,i), all_polys(2,2,i), all_polys(3,2,i) print *,'p:',all_polys(1,3,i), all_polys(2,3,i), all_polys(3,3,i) print *,'pn:',all_polys(4,1,i), all_polys(5,1,i), all_polys(6,1,i) print *,'pn:',all_polys(4,2,i), all_polys(5,2,i), all_polys(6,2,i) print *,'pn:',all_polys(4,3,i), all_polys(5,3,i), all_polys(6,3,i), 1 dist end if mated_flags(1,i) = 0 mated_flags(2,i) = 0 mated_flags(3,i) = 0 end do c find neighbours c --------------- c Aggh! Just realised I can do this point for point, don't need to match edges. c Should average normals of all coincident points. See below if (point_flag .eq. 0) then do 500 i = 1,contig_poly_flag ! triangle 1 do 450 ie = 1,3 ! each edge if (mated_flags(ie,i) .gt. 0) goto 450 ! skip deflowered edges do 400 j = i+1, contig_poly_flag ! triangle 2 do 300 k = 1, 3 ! each vertex on t2 do 201 m = 1,3 ! xyz if (abs(all_polys(m,ie,i)-all_polys(m,k,j)) 1 .gt. 0.01) goto 300 201 continue print *, 'coincident points :',i,ie,' ',j,k cc ie2 = mod(ie,3)+1 do 284 ie2 = 1,3 if (ie2 .eq. ie) goto 284 ! (skip same vertex) do 280 k2 = 1,3 ! vertex 2 if (k2 .eq. k) goto 280 ! (skip same vertex) do 260 m = 1,3 ! xyz if(abs(all_polys(m,ie2,i) - all_polys(m,k2,j)) 1 .gt. 0.01) goto 280 260 continue print *, 'coincident pair :',i,ie2,' ',j,k2 print * mated_flags(ie,i) = 1 mated_flags(ie2,i) = 1 mated_flags(k,j) = 1 mated_flags(k2,j) = 1 ! check vectors face same way, else swap whole tri dist = sqrt( (all_polys(4,ie,i)-all_polys(4,k,j))**2 + 1 (all_polys(5,ie,i)-all_polys(5,k,j))**2 + 1 (all_polys(6,ie,i)-all_polys(6,k,j))**2) if (dist .gt. 1.0) then all_polys(4,1,j) = -all_polys(4,1,j) all_polys(5,1,j) = -all_polys(5,1,j) all_polys(6,1,j) = -all_polys(6,1,j) all_polys(4,2,j) = -all_polys(4,2,j) all_polys(5,2,j) = -all_polys(5,2,j) all_polys(6,2,j) = -all_polys(6,2,j) all_polys(4,3,j) = -all_polys(4,3,j) all_polys(5,3,j) = -all_polys(5,3,j) all_polys(6,3,j) = -all_polys(6,3,j) c and don't forget to fix default mean normal too do ip = 1, 3 do iq = 1,3 all_polys(ip+6,iq,j)=all_polys(ip+3,iq,j) end do end do end if all_polys(7,ie,i) = 1 (all_polys(4,ie,i)+all_polys(4,k,j))/2.0 all_polys(8,ie,i) = 1 (all_polys(5,ie,i)+all_polys(5,k,j))/2.0 all_polys(9,ie,i) = 1 (all_polys(6,ie,i)+all_polys(6,k,j))/2.0 ! and move to vertex. Should I ??? all_polys(7,ie2,i) =all_polys(7,ie,i)+all_polys(1,ie2,i) all_polys(8,ie2,i) =all_polys(8,ie,i)+all_polys(2,ie2,i) all_polys(9,ie2,i) =all_polys(9,ie,i)+all_polys(3,ie2,i) all_polys(7,k,j) = all_polys(7,ie,i)+all_polys(1,k,j) all_polys(8,k,j) = all_polys(8,ie,i)+all_polys(2,k,j) all_polys(9,k,j) = all_polys(9,ie,i)+all_polys(3,k,j) all_polys(7,k2,j) = all_polys(7,ie,i)+all_polys(1,k2,j) all_polys(8,k2,j) = all_polys(8,ie,i)+all_polys(2,k2,j) all_polys(9,k2,j) = all_polys(9,ie,i)+all_polys(3,k2,j) ! must be last ? all_polys(7,ie,i) = all_polys(7,ie,i)+all_polys(1,ie,i) all_polys(8,ie,i) = all_polys(8,ie,i)+all_polys(2,ie,i) all_polys(9,ie,i) = all_polys(9,ie,i)+all_polys(3,ie,i) cc print *, 'i,ie,ie2 : ',i,ie,ie2 cc print *, 'j,k,k2 : ',j,k,k2 print *,'pm1:',all_polys(7,1,i), all_polys(8,1,i), all_polys(9,1,i) print *,'pm2:',all_polys(7,2,i), all_polys(8,2,i), all_polys(9,2,i) print *,'pm3:',all_polys(7,3,i), all_polys(8,3,i), all_polys(9,3,i) print *,'pmb1:',all_polys(7,1,j), all_polys(8,1,j), all_polys(9,1,j) print *,'pmb2:',all_polys(7,2,j), all_polys(8,2,j), all_polys(9,2,j) print *,'pmb3:',all_polys(7,3,j), all_polys(8,3,j), all_polys(9,3,j) goto 500 280 continue 284 continue print *, 'no pair' print * goto 500 300 continue 400 continue print *, 'no matching point :',i 450 continue 500 continue else ! (point code) do 1500 i = 1,contig_poly_flag ! triangle 1 do 1450 ie = 1,3 ! each corner mate_count = 1 ! NB counts itself mate_list(1,mate_count) = ie mate_list(2,mate_count) = i if (mated_flags(ie,i) .gt. 0) goto 1450 ! skip deflowered corners do 1400 j = i+1, contig_poly_flag ! triangle 2 do 1300 k = 1, 3 ! each vertex on t2 do 1201 m = 1,3 ! xyz if (abs(all_polys(m,ie,i)-all_polys(m,k,j)) 1 .gt. 0.01) goto 1300 1201 continue if (debug .gt. 0) print *, 'coincident points :',i,ie,' ',j,k mate_count = mate_count + 1 mate_list(1,mate_count) = k mate_list(2,mate_count) = j 1300 continue 1400 continue if (mate_count .lt. 2) goto 1450 if (debug .gt. 0) print *, 'Mate count =', mate_count ! Find average normal av_normal(1) = 0 av_normal(2) = 0 av_normal(3) = 0 do j = 1, mate_count mated_flags( 1 mate_list(1,j),mate_list(2,j))= 1 av_normal(1) = av_normal(1) + 1 (all_polys(4,mate_list(1,j), 2 mate_list(2,j)))/mate_count av_normal(2) = av_normal(2) + 1 (all_polys(5,mate_list(1,j), 2 mate_list(2,j)))/mate_count av_normal(3) = av_normal(3) + 1 (all_polys(6,mate_list(1,j), 2 mate_list(2,j)))/mate_count c Put in normal normals here. c av_normal(1)=all_polys(4,mate_list(1,j),mate_list(2,j)) c av_normal(2)=all_polys(5,mate_list(1,j),mate_list(2,j)) c av_normal(3)=all_polys(6,mate_list(1,j),mate_list(2,j)) end do ! Set average normal do j = 1, mate_count all_polys(7,mate_list(1,j), 2 mate_list(2,j)) = av_normal(1) all_polys(8,mate_list(1,j), 2 mate_list(2,j)) = av_normal(2) all_polys(9,mate_list(1,j), 2 mate_list(2,j)) = av_normal(3) print *,'p:',all_polys(1,1,i), all_polys(2,1,i), all_polys(3,1,i) print *,'pn:',all_polys(4,1,i), all_polys(5,1,i), all_polys(6,1,i) print *,'pm :',all_polys(7,1,i), all_polys(8,1,i), all_polys(9,1,i) print *,'pm :',all_polys(7,2,i), all_polys(8,2,i), all_polys(9,2,i) print *,'pm :',all_polys(7,3,i), all_polys(8,3,i), all_polys(9,3,i) end do 1450 continue 1500 continue end if else print *, 'Not smoothing surface' end if write (2,1000) 'union {' do 101 it=1,contig_poly_flag ! triangle do 100 i=1,3 ! vertex do 103 j = 1,9 xa(j,i) = all_polys(j,i,it) cc print *, i, j, (xa(j,i),k=1,3) 103 continue cc print * do 110 j=1,3 x1(j) = (xa(1,i)*r(j,1)+xa(2,i)*r(j,2)+xa(3,i)*r(j,3)+t(j))*scale x1(j+6) = (xa(7,i)*r(j,1)+xa(8,i)*r(j,2)+xa(9,i)*r(j,3)+t(j))*scale ccc print *, 'x1j', j, (x1(j),k=1,3) 110 continue do 120 j=1,3 120 xa(j,i) = x1(j) if (x1(1) .lt. bounds(1)) goto 101 if (x1(1) .gt. bounds(2)) goto 101 if (x1(2) .lt. bounds(3)) goto 101 if (x1(2) .gt. bounds(4)) goto 101 if (x1(3) .lt. slab(1)) goto 101 if (x1(3) .gt. slab(2)) goto 101 100 continue if (smooth_flag .ne. 0) then write (2,1000) 'smooth_triangle {' write (2,1028) '<', 1 xa(1,1),',', 2 xa(2,1),',', 2 xa(3,1),'>,','<', 1 xa(7,1),',', 2 xa(8,1),',', 2 xa(9,1),'>,','<', 3 1 xa(1,2),',', 2 xa(2,2),',', 2 xa(3,2),'>,','<', 1 xa(7,2),',', 2 xa(8,2),',', 2 xa(9,2),'>,','<', 3 1 xa(1,3),',', 2 xa(2,3),',', 2 xa(3,3),'>,','<', 1 xa(7,3),',', 2 xa(8,3),',', 2 xa(9,3),'>',' ', 3 3 'texture {pigment {color rgb <', 4 tri_col(1,it),tri_col(2,it),tri_col(3,it), 2 '>}} finish {Plastic_Ribbons} }' 1028 format(a,3(2(3(f7.2,a),/,a)),a,3f5.2,a) else write (2,1000) 'triangle {' write (2,1029) '<', 1 xa(1,1),',', 2 xa(2,1),',', 2 xa(3,1),'>,','<', 3 1 xa(1,2),',', 2 xa(2,2),',', 2 xa(3,2),'>,','<', 3 1 xa(1,3),',', 2 xa(2,3),',', 2 xa(3,3),'>',' ', 3 3 'texture {pigment {color rgb <', 4 tri_col(1,it),tri_col(2,it),tri_col(3,it), 2 '>}} finish {Plastic_Ribbons} }' 1029 format(a,3(1(3(f7.2,a),/,a)),a,3f5.2,a) end if 101 continue write (2,1000) '}' 1000 format(a) 200 return end c-------------------------------------------------------------------- subroutine out_poly (ct, xa) implicit none integer ct, i, j, dashed_flag, ribbon_flag, depth_flag c-- Increased (6,3) to (6,4) for Linux MRH 27nov02 real xa(6,4) real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) c NB Assumes all polygons are triangles at present. MRH May '99 c Now fixed so that at least rectangles are recognised MRH July '01 real x1(6), x2(3), n1(3), n2(3) cc print 778, 'ct:',ct,' ',(xa(1,i),xa(2,i),xa(3,i),i=1,3) cc 778 format(a,i4,a,3(3f7.2,2x)) cc ct = 3 do 100 i=1,ct do 110 j=1,3 x1(j) = (xa(1,i)*r(j,1)+xa(2,i)*r(j,2)+xa(3,i)*r(j,3)+t(j)) $ *scale 110 continue cc print *, 'x1',ct,i,' ',x1(1),x1(2),x1(3) cc print *, 'ss',slab(1),slab(2),scale do 120 j=1,3 120 xa(j,i) = x1(j) if (x1(1) .lt. bounds(1)) goto 200 if (x1(1) .gt. bounds(2)) goto 200 if (x1(2) .lt. bounds(3)) goto 200 if (x1(2) .gt. bounds(4)) goto 200 if (x1(3) .lt. slab(1)) goto 200 if (x1(3) .gt. slab(2)) goto 200 100 continue cc print *, '1000' call depth_cue(colour_cue,(xa(3,1)+xa(3,2)+xa(3,3))/2) write (2,1000) 'triangle {' write (2,1028) '<', 1 xa(1,1),',', 2 xa(2,1),',', 2 xa(3,1),'>,<', 1 xa(1,2),',', 2 xa(2,2),',', 2 xa(3,2),'>,<', 1 xa(1,3),',', 2 xa(2,3),',', 2 xa(3,3),'>' c 3 ' ,texture {pigment {color rgb <', c 1 colour_cue(1),colour_cue(2),colour_cue(3), c 2 '>} finish {Plastic_Ribbons} } }' if (trans_flag .lt. 0) then write (2,1029) 'texture {pigment {color rgb <', 4 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Ribbons} } }' else write (2,1030) 'texture {pigment {color rgbt <', 4 colour_cue(1),colour_cue(2),colour_cue(3),' Trans_Map', 2 '>} finish {Plastic_Ribbons} } }' end if 1028 format(a,9(f7.2,a),a,3f5.2,a) if (ct .eq. 4) then ! MRH Jul 2001 write (2,1000) 'triangle {' write (2,1028) '<', 1 xa(1,1),',', 2 xa(2,1),',', 2 xa(3,1),'>,<', 1 xa(1,3),',', 2 xa(2,3),',', 2 xa(3,3),'>,<', 1 xa(1,4),',', 2 xa(2,4),',', 2 xa(3,4),'>' c 3 ,' texture {pigment {color rgb <', c 1 colour_cue(1),colour_cue(2),colour_cue(3), c 2 '>} finish {Plastic_Ribbons} } }' if (trans_flag .lt. 0) then write (2,1029) 'texture {pigment {color rgb <', 4 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Ribbons} } }' else write (2,1030) 'texture {pigment {color rgbt <', 4 colour_cue(1),colour_cue(2),colour_cue(3),' Trans_Map', 2 '>} finish {Plastic_Ribbons} } }' end if end if 1029 format(a,3f5.2,a,a,a) 1030 format(a,3f5.2,a,a,a,a) 1000 format(a) 200 return end c-------------------------------------------------------------------- subroutine out_poly_normal (ct, xa) implicit none integer ct, i, j, dashed_flag, ribbon_flag, depth_flag, nblen real xa(6,100) real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) character*132 texture_type common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) c NB Assumes all polygons are triangles at present. MRH May '99 real x1(6), x2(6), n1(3), n2(3), junk(3) c print *, 'ct:',ct ! ???? Seems to be one ??? c ct = 3 texture_type = 'Plastic_Maps' if (ribbon_flag .gt. 0) texture_type = 'Plastic_Ribbons' do 100 i=1,ct 66 format (1x,a,6f7.2) do 110 j=1,3 x1(j) = (xa(1,i)*r(j,1)+xa(2,i)*r(j,2)+xa(3,i)*r(j,3)+t(j)) $ *scale x2(j) = (xa(1,i+1)*r(j,1)+xa(2,i+1)*r(j,2)+xa(3,i+1)*r(j,3)+ $ t(j))*scale 110 continue do 111 j=1,3 ! normals (rot but no trans or scale ??) x1(j+3) = (xa(4,i)*r(j,1)+xa(5,i)*r(j,2)+xa(6,i)*r(j,3)) x2(j+3) = (xa(4,i+1)*r(j,1)+xa(5,i+1)*r(j,2)+xa(6,i+1)*r(j,3)+ $ t(j))*scale 111 continue do 120 j=1,6 120 xa(j,i) = x1(j) if (x1(1) .lt. bounds(1)) goto 200 if (x1(1) .gt. bounds(2)) goto 200 if (x1(2) .lt. bounds(3)) goto 200 if (x1(2) .gt. bounds(4)) goto 200 if (x1(3) .lt. slab(1)) goto 200 if (x1(3) .gt. slab(2)) goto 200 100 continue call depth_cue(colour_cue,(xa(6,1)+xa(6,2)+xa(6,3))/3) write (2,1000) 'smooth_triangle {' write (2,1028) '<', 1 xa(1,1),',', 2 xa(2,1),',', 2 xa(3,1),'>,','<', 1 xa(4,1),',', 2 xa(5,1),',', 2 xa(6,1),'>,','<', 3 1 xa(1,2),',', 2 xa(2,2),',', 2 xa(3,2),'>,','<', 1 xa(4,2),',', 2 xa(5,2),',', 2 xa(6,2),'>,','<', 3 1 xa(1,3),',', 2 xa(2,3),',', 2 xa(3,3),'>,','<', 1 xa(4,3),',', 2 xa(5,3),',', 2 xa(6,3),'>',' ' 1028 format(a,3(2(3(f7.2,a),/,a))) if (trans_flag .lt. 0) then write (2,1029) 'texture {pigment {color rgb <', 4 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>}} finish {', 3 texture_type(1:nblen(texture_type)),'} }' else write (2,1030) 'texture {pigment {color rgbt <', 4 colour_cue(1),colour_cue(2),colour_cue(3),' Trans_Map', 2 '>}} finish {', 3 texture_type(1:nblen(texture_type)),'} }' end if 1029 format(a,3f5.2,a,a,a) 1030 format(a,3f5.2,a,a,a,a) 1000 format(a) 200 return end c-------------------------------------------------------------------- subroutine out_colour (colour) implicit none real colour_cue(3),colour(3) c write (2,10)colour c10 format (' colour',(3f10.2)) return end c----------------------------------------------------------------------- subroutine out_sph (sph) implicit none real sph(4) integer i, j, dashed_flag, ribbon_flag, depth_flag real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000), no_trans common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) real x1(3), x2(3),x,y,z,d cc print 778, 'st:',1,' ',sph(2),sph(3),sph(4) 778 format(a,i4,a,3(3f7.2,2x)) cc print * cc print *, 'slab', slab(1),slab(2) cc print *, 'scale, dist =', scale, sqrt(sph(2)**2+sph(3)**2+sph(4)**2) do 110 j=1,3 x1(j) = (sph(2)*r(j,1)+sph(3)*r(j,2)+sph(4)*r(j,3)+t(j)) $ *scale cc x1(j) = (sph(2)*r(j,1)+sph(3)*r(j,2)+sph(4)*r(j,3))/scale+t(j) 110 continue x = r(1,1)+r(1,2)+r(1,3) y = r(2,1)+r(2,2)+r(2,3) z = r(3,1)+r(3,2)+r(3,3) cc print *, 'trans,det:',t(1),t(2),t(3),sqrt(x*x+y*y+z*z) cc print *, 'dist =', scale, sqrt(x1(1)**2+x1(2)**2+x1(3)**2) sph(1) = sph(1)*scale if (x1(1) .lt. bounds(1)) goto 200 if (x1(1) .gt. bounds(2)) goto 200 if (x1(2) .lt. bounds(3)) goto 200 if (x1(2) .gt. bounds(4)) goto 200 if (x1(3) .lt. slab(1)) goto 200 if (x1(3) .gt. slab(2)) goto 200 call depth_cue(colour_cue,x1(3)) if (trans_flag .le. 0) then write (2,1000) 'sphere {' write (2,1038) '<', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'> ', sph(1), 3 ' texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Balls} } }' else write (2,1000) 'sphere {' write (2,1039) '<', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'> ', sph(1), 3 ' texture {pigment {color rgbt <', 1 colour_cue(1),colour_cue(2),colour_cue(3),' Trans_Ball', 2 '>} finish {Plastic_Balls} } }' end if 1038 format(a,3(f7.2,a),f5.2,a,3f5.2,a) 1039 format(a,3(f7.2,a),f5.2,a,3f5.2,a,a) 1000 format(a) 200 return end c-------------------------------------------------------------------- subroutine out_cyl (cyl) implicit none real cyl(7) integer dashed_flag, ribbon_flag, depth_flag real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) real x1(3), x2(3) integer j do 110 j=1,3 x1(j) = (cyl(1)*r(j,1)+cyl(2)*r(j,2)+cyl(3)*r(j,3)+t(j))*scale 110 x2(j) = (cyl(4)*r(j,1)+cyl(5)*r(j,2)+cyl(6)*r(j,3)+ $ t(j))*scale cyl(7) = cyl(7)*scale if (x1(1) .lt. bounds(1)) goto 100 if (x1(1) .gt. bounds(2)) goto 100 if (x1(2) .lt. bounds(3)) goto 100 if (x1(2) .gt. bounds(4)) goto 100 if (x1(3) .lt. slab(1)) goto 100 if (x1(3) .gt. slab(2)) goto 100 if (x2(1) .lt. bounds(1)) goto 100 if (x2(1) .gt. bounds(2)) goto 100 if (x2(2) .lt. bounds(3)) goto 100 if (x2(2) .gt. bounds(4)) goto 100 if (x2(3) .lt. slab(1)) goto 100 if (x2(3) .gt. slab(2)) goto 100 if ( (abs(x1(1)-x2(1)) .lt. 0.01) .and. 1 (abs(x1(2)-x2(2)) .lt. 0.01) .and. 1 (abs(x1(3)-x2(3)) .lt. 0.01) ) goto 100 call depth_cue(colour_cue,(x1(3)+x2(3))/2) if (trans_flag .le. 0) then write (2,1000) 'cylinder {' write (2,1078) '<', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'>,<', 1 x2(1),',', 2 x2(2),',', 2 x2(3),'> ',cyl(7), 3 ' texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} finish {Plastic_Sticks} } }' else write (2,1000) 'cylinder {' write (2,1079) '<', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'>,<', 1 x2(1),',', 2 x2(2),',', 2 x2(3),'> ',cyl(7), 3 ' texture {pigment {color rgbt <', 1 colour_cue(1),colour_cue(2),colour_cue(3),' Trans_Stick', 2 '>} finish {Plastic_Sticks} } }' end if 1078 format(a,6(f7.2,a),f5.2,a,3f5.2,a) 1079 format(a,6(f7.2,a),f5.2,a,3f5.2,a,a) 1000 format(a) 100 return end c-------------------------------------------------------------------- subroutine out_text (text_crds,text) implicit none real text_crds(3) character*(*)text integer dashed_flag, jlen, ribbon_flag, depth_flag real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) character*1024 buffer common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2) integer i, j, nbln, nblen real x1(3) do 110 j=1,3 x1(j) = (text_crds(1)*r(j,1)+ 1 text_crds(2)*r(j,2)+ 2 text_crds(3)*r(j,3)+ 3 t(j))*scale if (x1(1) .lt. bounds(1)) goto 100 if (x1(1) .gt. bounds(2)) goto 100 if (x1(2) .lt. bounds(3)) goto 100 if (x1(2) .gt. bounds(4)) goto 100 if (x1(3) .lt. slab(1)) goto 100 if (x1(3) .gt. slab(2)) goto 100 110 continue call depth_cue(colour_cue,x1(3)) c MRH find last quote do j = len(text), 1, -1 if (text(j:j) .eq. '"') then nbln = j goto 111 end if end do 111 continue write (2,1000) 'text {' buffer = 'ttf Ttf_File '//text(1:nbln)//' 0,0' write (2,1000) buffer(1:nblen(buffer)) C !!! NB can't translate text in z write (2,1098) 'scale Text_Scale translate <', 1 x1(1),',', 2 x1(2),',', 2 x1(3),'>',' ', 3 'texture {pigment {color rgb <', 1 colour_cue(1),colour_cue(2),colour_cue(3), 2 '>} } }' 1098 format(a,3(f7.2,a),a,/,a,3f5.2,a) 1000 format(a) 100 return end c-------------------------------------------------------------------- subroutine depth_cue (colour2,z) implicit none real z integer dashed_flag, ribbon_flag, depth_flag real colour_cue(3),colour(3),bounds(4), trans_flag, all_polys(9,3,9000) real colour2(3), slab_width, depth, fade, fade2 common /mrh/ ribbon_flag, colour, bounds, trans_flag, all_polys common /ops/ depth_flag, r, t, scale, slab, dashed_flag real r(3,3), t(3), scale, slab(2), h,s,v,old colour2(1) = colour(1) colour2(2) = colour(2) colour2(3) = colour(3) if (depth_flag .eq. 0) return slab_width = (slab(2)-slab(1)) call rgbhsv(colour(1),colour(2),colour(3),h,s,v) depth = (slab(2)-z) fade =(depth/slab_width) fade = min(1.0,fade) fade = max(0.0,fade) if (depth_flag .gt. 0) then cc Fade to black v = v*(1.0-depth_flag*fade/5.0) else cc Fade to white s = s*(1.0+depth_flag*fade/5.0) v = v-(1-v)*(depth_flag*fade/5.0) end if call hsvrgb(h,s,v,colour2(1),colour2(2),colour2(3)) 100 return end c======================================================================= subroutine find_objs (list_channel,nblacks,black_list) c --- Find all objects in plt file c --- Written by Mark Harris June '99 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer list_channel integer nblen, istart, iend, ilen, i, j, k, nnotes, nobjs character*1024 lowcase, upcase, string, object, black_list(100), notes character*1024 notes_list(2,100), parent, parent2, replace_string nnotes = 6 notes_list(1,1) = "s_" notes_list(2,1) = "Stick figure of object " notes_list(1,2) = "cpk_" notes_list(2,2) = "CPK figure of object " notes_list(1,3) = "o$" notes_list(2,3) = "Sketch figure, object " notes_list(1,4) = "_dot" notes_list(2,4) = "Surface of object " notes_list(1,5) = "_mmm" notes_list(2,5) = "Map of object " notes_list(1,6) = "n$" notes_list(2,6) = "Notes object " nobjs = 0 C***************************************************************************** C Write out header C***************************************************************************** print *, 'Objects found in file :' print * 10 read (1,100,end=99,err=98) string 100 format(a) cc string = replace_string(string,'_MAP','_MMM') ! Not so simple as this... string=lowcase(string) istart = index(string,"begin ") iend = nblen(string) ilen = iend+istart-6 if (iend .lt. istart+6) goto 10 object = string(istart+6:iend) if (istart .ne. 0) then ! skip over keywords do i = 1, nblacks c print *, ':'//object(1:ilen)//':' c print *, ':'//black_list(i)(1:nblen(black_list(i)))//':' c print *, index(object,black_list(i)(1:nblen(black_list(i)))) if(index(object,black_list(i)(1:nblen(black_list(i)))) 1 .ne. 0) goto 10 end do notes = ' ' ! interpret object name do j = 1, nnotes c print *, 'nnotes : ',nnotes, ' ',object(1:10) istart = index(object,notes_list(1,j)(1:nblen(notes_list(1,j)))) ilen = nblen(notes_list(1,j)) iend = nblen(object) if(istart .gt. 0) then parent = object ! remove the keyword from object name do k = istart,istart+ilen-1 parent(k:k) = ' ' parent2 = upcase(parent(nbstart(parent):nblen(parent))) end do c print *, parent2 notes = '('//notes_list(2,j)(1:nblen(notes_list(2,j))+1)// 1 parent2(1:nblen(parent2))//')' goto 20 end if end do notes = '(Unmodified object)' 20 continue print *, object(1:15),notes(1:nblen(notes)) nobjs = nobjs + 1 if (list_channel .gt. 0) then write (list_channel,666) 1 "&",nobjs,"=",object(1:15),notes(1:nblen(notes)) 666 format(a,i2,a,a,a) end if end if goto 10 98 print *, 'Error looking for objects' 99 continue rewind(1) if (nobjs .eq. 0) then print *, 'Error - No objects found in plot file, aborting...' print *, 'Check your plot file from O.' print * call exit() end if print * return end c======================================================================= subroutine write_header (object_name, trans_flag) c --- Write POV-Ray header c --- Written by Mark Harris May '99 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ real trans_flag character*1024 date_string, object_name call date_and_time(date_string) C***************************************************************************** C Write out header C***************************************************************************** write (2,1000) 1 '// =================================================' write (2,1000) 1 '// POV-Ray input file generated by plt_pov '//date_string(1:10) write (2,1000) 1 '// =================================================' write (2,1000) '// ' write (2,1000) 1 '// This file needs to be included in a POV-Ray ' write (2,1000) 1 '// template such as plt_pov.pov' write (2,1000) '// ' write (2,1000) 1 '// =================================================' write (2,1007) ' ' write (2,1000) ' ' 1000 format(a) 1007 format(a,3(f7.1,a)) return end c======================================================================= subroutine write_tail(trans_flag,object_name,obj_count,obj_list) c --- Write POV-Ray tail c --- Written by Mark Harris May '99 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer obj_count character*(*) object_name, obj_list(*) character*1024 obj_nam, obj_clean, tmp_string integer fm,fm_flag,err,ifm,nfm,i,j real trans_flag C character*1 prefix = '_' C***************************************************************************** C Write out tail C***************************************************************************** if (trans_flag .lt. 0) then tmp_string = '#declare '//object_name(1:nblen(object_name))// 1 ' = union {' write (2,1000) tmp_string(1:nblen(tmp_string)) else tmp_string = '#declare '//object_name(1:nblen(object_name))// 1 ' = merge {' write (2,1000) tmp_string(1:nblen(tmp_string)) end if nfm = 0 do i = 1,obj_count ifm = index(obj_list(i),'fm') if ((ifm .gt. 0) .and. (obj_list(i)(ifm+2:ifm+2) .ge. '0') 1 .and. (obj_list(i)(ifm+2:ifm+2) .le. '9') 1 .and. (obj_list(i)(ifm+3:ifm+3) .le. '9')) then read (obj_list(i)(ifm+2:ifm+3),222,iostat=err) fm nfm = max(fm,nfm) end if end do do i = 1,obj_count fm_flag = 0 fm = 0 ifm = index(obj_list(i),'fm') if ((ifm .gt. 0) .and. (obj_list(i)(ifm+2:ifm+2) .ge. '0') 1 .and. (obj_list(i)(ifm+2:ifm+2) .le. '9') 1 .and. (obj_list(i)(ifm+3:ifm+3) .le. '9')) then read (obj_list(i)(ifm+2:ifm+3),222,iostat=err) fm 222 format(i2) tmp_string = '+999) //Mray_FM_'//obj_list(i)(1:nblen(obj_list(i))) write (2,333) '#if (int(clock*',(nfm-1),'+1.5) != ', 1 fm,tmp_string(1:nblen(tmp_string)) 333 format(a,i2.2,a,i2,a) fm_flag = 1 end if obj_clean = obj_list(i) do j = 1,nblen(obj_list(i)) if (obj_clean(j:j) .eq. '$') obj_clean(j:j) = '_' end do c POV-Ray doesn't like leading numeric if (obj_clean(1:1) .eq. '1') obj_clean(1:1) = 'Q' if (obj_clean(1:1) .eq. '2') obj_clean(1:1) = 'R' if (obj_clean(1:1) .eq. '3') obj_clean(1:1) = 'S' if (obj_clean(1:1) .eq. '4') obj_clean(1:1) = 'T' if (obj_clean(1:1) .eq. '5') obj_clean(1:1) = 'U' if (obj_clean(1:1) .eq. '6') obj_clean(1:1) = 'V' if (obj_clean(1:1) .eq. '7') obj_clean(1:1) = 'W' if (obj_clean(1:1) .eq. '8') obj_clean(1:1) = 'X' if (obj_clean(1:1) .eq. '9') obj_clean(1:1) = 'Y' if (obj_clean(1:1) .eq. '0') obj_clean(1:1) = 'Z' if (obj_clean(1:5) .ne. 'kamra') then write (2,1000) 'object {'//obj_clean(1:nblen(obj_clean))//'}' end if if (fm_flag .eq. 1) write (2,1000) '#end' end do write (2,1007) '}' 1000 format(a) 1007 format(a,3(f7.1,a)) return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C RGB/HSV Routines C***************************************************************************** c c c subroutine rgbhsv (r, g, b, h, s, v) c c Translate a colour given in the (R,G,B) triplet into hue, saturation, c and value (intensity) as required by the PS300. c See Foley & Van Dam p. 615. c implicit none c real r, g, b, h, s, v c c When ------- Who ---------------- What ------------------------------- c 10-May-1990 Morten Kjeldgaard Written, in Dallas. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c real rgbmax, rgbmin, q, rc, gc, bc c code ... c rgbmax = max (r,g,b) rgbmin = min (r,g,b) q = rgbmax - rgbmin v = rgbmax if (rgbmax .ne. 0.0) then s = q/rgbmax else s = 0.0 end if if (abs(s) .lt. 0.0001) then cmrh h = 0.0 h = -1.0 else c --- rc measures the distance of color from red rc = (rgbmax - r)/q gc = (rgbmax - g)/q bc = (rgbmax - b)/q if (r .eq. rgbmax) then c --- resulting color between yellow and magenta h = bc - gc else if (g .eq. rgbmax) then c --- resulting color between cyan and yellow h = 2.0 + rc - bc else if (b .eq. rgbmax) then c --- resulting color between magenta and cyan h = 4.0 + gc - rc else print *, 'Agghhh Fallen through rgb colour test in rgbhsv' end if c --- convert to degrees h = h * 60.0 + 120.0 if (h .lt. 0.0) h = h + 360.0 if (h .gt. 360.0) h = h - 360.0 end if c return end c c c subroutine hsvrgb (qh, s, v, r, g, b) c c Translate a colour given in hue, saturation and value (intensity) as c given by the PS300 into an (R,G,B) triplet. c This routine is not used in O, it is just here because I wrote it c for the conversion of the program to rgb colours. c See Foley & Van Dam p. 615. c implicit none c real qh, s, v, r, g, b c c When ------- Who ---------------- What ------------------------------- c 11-May-1990 Morten Kjeldgaard Written, in Dallas. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c real f, p, q, t, h integer i c code ... c h = qh if (abs(s) .lt. 0.0001) then r = v g = v b = v return end if h = h - 120.0 if (h .lt. 0.0) h = h + 360.0 if (h .ge. 360.0) h = h - 360.0 h = h/60. i = int(h) f = h - float(i) p = v * (1.0 - s) q = v * (1.0 - (s*f)) t = v * (1.0 - (s*(1.0 - f))) if (i .eq. 0) then r = v g = t b = p else if (i .eq. 1) then r = q g = v b = p else if (i .eq. 2) then r = p g = v b = t else if (i .eq. 3) then r = p g = q b = v else if (i .eq. 4) then r = t g = p b = v else if (i .eq. 5) then r = v g = p b = q end if c return end C***************************************************************************** C MRH_lib routines C***************************************************************************** C****************************************************************************** integer function lib_get_foreign(cmd_buff) C****************************************************************************** implicit none integer nblen, iargc integer str_len cc integer iget integer i, curr_pos character*(*) cmd_buff cc character*40 prompt ccc character*1024 upcase character*1024 next_word cmd_buff = ' ' curr_pos = 1 do 10 i = 1, iargc() call getarg(i,next_word) cmd_buff(curr_pos:) = next_word(1:max(1,nblen(next_word)))//' ' curr_pos=curr_pos+nblen(next_word)+1 10 continue ccc cmd_buff = upcase(cmd_buff) ! MRH 16-Nov-94 str_len = curr_pos-2 lib_get_foreign = 1 return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character*(*) function get_option(buffer,option) C***************************************************************************** C C Name : get_option() C C Description : Gets word following option string in buffer C C Created : 16-Oct-92 Mark Harris C C Modified : 16-Nov-94 MRH C C Copyright : Symbicom AB, Uppsala, Sweden, 1992 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer Character*(*) C Buffer to test C option Character*(*) C Option for which to test C C Arguments out : retcode Word following option, C null_string = next word not fnd. C 'NOT__FOUND' = option not found. C C Dependencies : upcase(), extract_word() C C Notes : If called with option string "OPTIONS__LEFT", C options so-far unused are printed with a warning. C If called with option string "NON__INTRODUCED", C a parameter that is not associated with an option C is returned. C C The syntax for program invocation is : C C $ PROGRAM /MODIFIER=PARAMETER NON_INTRODUCED_PARAM or C % program -modifier=parameter non_introduced_param ... C C Under UNIX, modifiers must start with "-", while C under VMS they may start with "-" or "/". C C White space in compound parameters can be protected by C enclosing in double quotes ("). C C BUFF_COPY is a copy of BUFFER with most spaces removed. C BUFF_COPY2 is a copy of BUFF_COPY with real negatives removed. C TMP_OPT is an uppercase copy of option with sep_char prepended, C TMP_STR is an uppercase copy of BUFF_COPY. C BUFF_MIXED is an uppercase copy of BUFF_COPY, except quotes. C SAVED_SPACES notes the positions of spaces within quotes, and C COPY_SPACES notes these positions after other spaces are removd. C C============================================================================= C***************************************************************************** C Declare parameters C***************************************************************************** implicit none character*(*) buffer character*(*) option C***************************************************************************** C Declare various local variables and functions C***************************************************************************** integer nblen, mod_beg, mod_end, par_end, i, j, k, nwords integer mod_positions(1024), word_starts(25), word_ends(25) integer non_intro_flag, protected_space integer find_words, i_am_unix character*1 sep_char character*10 not_found_flag character*1024 tmp_str, tmp_opt, buff_copy2, buff_copy, buff_mixed character*1024 saved_negs, saved_spaces, copy_spaces, return_string character*1024 quote_positions, copy_quotes character*1024 upcase, extract_word, replace_string save mod_positions data mod_positions /1024*0/ ! NB assumes same buffer sep_char = '/' saved_negs = ' ' saved_spaces = ' ' copy_spaces = ' ' quote_positions=' ' copy_quotes = ' ' not_found_flag = 'NOT__FOUND' non_intro_flag = 0 protected_space = 0 if (i_am_unix() .gt. 0) sep_char = '-' ! Force UNIX syntax under UNIX C***************************************************************************** C Look for compound strings bound by quotes C***************************************************************************** j = 0 do 3 i = 1, len(buff_copy) j = j+1 if (j .ge. nblen(buffer)) goto 4 if (buffer(j:j) .eq. '"') then ! Binding starts do 2 k = j+1,nblen(buffer) j=j+1 if (buffer(k:k) .eq. '"') goto 3 ! Binding ends if (buffer(k:k) .eq. ' ') saved_spaces(k:k) = '_' ! a bound space quote_positions(k:k) = '"' 2 continue print *, '%GET_OPTION-E-Unclosed brackets found' end if 3 continue 4 continue ccc print *, buffer(1:60) ccc print *, '1234567890123456789012345678901234567890' ccc print *, quote_positions(1:60) C***************************************************************************** C Look for unintroduced options and protect space before it. C***************************************************************************** nwords = find_words(buffer,word_starts,word_ends) do 5 i = nwords, 1, -1 ! if word is not an option and not preceeded by "=" etc if (buffer(word_starts(i):word_starts(i)) .ne. sep_char .and. & buffer(word_starts(i): & word_starts(i)) .ne. '-' .and. & buffer(word_starts(i): & word_starts(i)) .ne. '=' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))) .ne. '=' .and. & buffer(word_starts(i): & word_starts(i)) .ne. ',' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))) .ne. ',' .and. & saved_spaces(max(1,word_starts(i)-1): & max(1,word_starts(i)-1)) .ne. '_' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))).ne.sep_char) then protected_space = word_starts(i)-1 end if 5 continue C***************************************************************************** C Remove spaces from buffer, unless protected, or bound. C***************************************************************************** j = 0 buff_copy = ' ' do 10 i = 1, nblen(buffer) if ( (buffer(i:i) .eq. ' ' .or. & buffer(i:i) .eq. ' ') .and. & (i .ne. protected_space .and. & saved_spaces(i:i) .ne. '_') ) goto 10 j = j+1 if (saved_spaces(i:i) .eq. '_') then ! Spaces within quotes buff_copy(j:j) = '_' copy_spaces(j:j) = '_' else buff_copy(j:j) = buffer(i:i) end if copy_quotes(j:j) = quote_positions(i:i) 10 continue C***************************************************************************** C Change separator character if we are using unix syntax under VMS, C determined by if we have a '-' not followed by a number, C nor preceeded by an equals, nor preceeded by a comma. C If we do have UNIX syntax, then save any real minus sign in saved_negs. C***************************************************************************** do 20 i = 1, nblen(buff_copy) if (buff_copy(i:i) .eq. '-') then if (i.gt. 1) then if ( buff_copy(i+1:i+1) .gt. '9' .and. & buff_copy(i-1:i-1) .ne. '=' .and. & buff_copy(i-1:i-1) .ne. ',') then sep_char = '-' ! It's UNIX syntax else saved_negs(i:i) = '-' ! Store real negatives end if end if end if 20 continue C***************************************************************************** C***************************************************************************** C Look for option and following word C***************************************************************************** C***************************************************************************** get_option = ' ' tmp_opt = sep_char//upcase(option) ! Fold option to upcase and add sep. buff_copy2 = buff_copy ! copy buff_copy do 30 i = 1, nblen(buff_copy2) ! Replace real negs if (saved_negs(i:i) .eq. '-') buff_copy2(i:i) = '+' 30 continue mod_beg=index( upcase(buff_copy), tmp_opt(1:nblen(tmp_opt)) ) ! find opt if (mod_beg .gt. 0) then ! Option found tmp_str = upcase(replace_string(buff_copy,sep_char,' ')) ! "sep" to' ' buff_mixed = replace_string(buff_copy,sep_char,' ') ! "sep" to' ' do 35 i = 1, nblen(buff_mixed) ! Upper case except for quoted strings if (copy_quotes(i:i) .ne. '"') then buff_mixed(i:i) = upcase(buff_mixed(i:i)) end if 35 continue mod_end = index(upcase(tmp_str(mod_beg:)),'=') par_end = index(buff_copy2(mod_beg+1:),sep_char) do 40 i = 1, nblen(tmp_str) if (saved_negs(i:i) .eq. '-') tmp_str(i:i) = '-' ! Replace real negs if (tmp_str(i:i) .eq. '"') tmp_str(i:i) = ' ' ! Remove quotes if (saved_negs(i:i) .eq. '-') buff_mixed(i:i) = '-' ! Repl real negs if (buff_mixed(i:i) .eq. '"') buff_mixed(i:i) = ' ' ! Remove quotes 40 continue if ((par_end .gt. mod_end .or. par_end .eq. 0) & .and. mod_end .gt. 0) then ccc return_string = extract_word(tmp_str(mod_beg+mod_end:),1) ! upcase return_string = extract_word(buff_mixed(mod_beg+mod_end:),1) do 45 i = 1, nblen(return_string) ! Replace bound spaces if (copy_spaces(i+mod_beg+mod_end:i+mod_beg+mod_end).eq.'_')then return_string(i:i) = ' ' end if 45 continue get_option = return_string end if mod_positions(mod_beg) = 1 ! Flag that we've used this opt return ! and go home else ! or flag if option not present get_option = not_found_flag end if C***************************************************************************** C Check for special flags C***************************************************************************** C***************************************************************************** C 1) Look for unused options ('OPTIONS__LEFT') C***************************************************************************** if (nblen(option) .ge. 13) then if (upcase(option(1:13)) .eq. 'OPTIONS__LEFT' ) then get_option = ' ' tmp_str = ': ' do 50 i = 1, nblen(buff_copy) if (buff_copy(i:i) .eq. sep_char .and. & mod_positions(i) .eq. 0 .and. & saved_negs(i:i) .ne. '-' ) then buff_copy2 = replace_string(buff_copy,sep_char,' ')! "sep" to' ' tmp_str = tmp_str(1:nblen(tmp_str))//sep_char// & extract_word(buff_copy2(i+1:),1) end if 50 continue if (nblen(tmp_str) .gt. 1) then if (index(tmp_str,'NO_OP') .eq. 0) then print * print *, '%GET_OPTION-W-Unrecognised or duplicated options ', & tmp_str(1:nblen(tmp_str)) print * end if end if end if end if C***************************************************************************** C 2) Look for unintroduced options ('NON__INTRODUCED') C***************************************************************************** if (nblen(option) .ge. 15) then if (upcase(option(1:15)) .eq. 'NON__INTRODUCED' ) then nwords = find_words(buffer,word_starts,word_ends) do 60 i = nwords, 1, -1 ! if word is not an option and not preceeded by "=" or sep_char j = max(1,word_starts(i)-1) if (buffer(word_starts(i):word_starts(i)) .ne. sep_char .and. & buffer(word_starts(i): & word_starts(i)) .ne. '=' .and. & buffer(word_starts(i): & word_starts(i)) .ne. '-' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))) .ne. '=' .and. & buffer(word_starts(i): & word_starts(i)) .ne. ',' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))) .ne. ',' .and. & buffer(word_ends(max(1,i-1)): & word_ends(max(1,i-1))).ne.sep_char.and. & saved_spaces(j:j) .ne. '_') then ! don't go past a separator if (index(buffer(word_starts(i):word_ends(i)), & sep_char) .gt. 1) then word_ends(i) = word_starts(i)+ & index(buffer(word_starts(i):word_ends(i)),sep_char)-2 end if get_option = buffer(word_starts(i):word_ends(i)) if (non_intro_flag .gt. 0) then print * print *, & '%GET_OPTION-W-Multiple non-introduced parameters '// & 'ignored : ', buffer(word_starts(non_intro_flag): & word_ends(non_intro_flag)) print * end if non_intro_flag = i end if 60 continue end if end if C***************************************************************************** C And home C***************************************************************************** continue return end C----------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer function nblen(buffer) C***************************************************************************** C C Name : nblen() C C Description : Finds non-blank length of buffer C C Created : 19-Sep-90 Mark Harris C C Modified : 1-Jul-92 C C Copyright : Symbicom AB, Uppsala, Sweden, 1991 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer character*(*) C buffer in C C Arguments out : retcode Length of buffer C C Dependencies : None C C Notes : C C============================================================================= C***************************************************************************** C Declare various local variables C***************************************************************************** implicit none character*(*) buffer integer ichr C***************************************************************************** C Find last non-blank C***************************************************************************** ichr = len(buffer) if( (buffer(1:1) .eq. ' ' .or. & ichar(buffer(1:1)) .eq. 0 .or. & buffer(1:1) .eq. ' ') .and. ichr .eq. 1) & ichr = 0 if (ichr .le. 1) goto 20 do 10 ichr = len(buffer), 1, -1 if(buffer(ichr:ichr) .ne. ' ' .and. & ichar(buffer(ichr:ichr)) .ne. 0 .and. & buffer(ichr:ichr) .ne. ' ') goto 20 10 continue 20 continue nblen = ichr return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer function nbstart(buffer) C***************************************************************************** C C Name : nbstart() C C Description : Finds non-blank starting point of buffer. C C Created : 2-Jul-92 Mark Harris C C Modified : C C Copyright : Symbicom AB, Uppsala, Sweden, 1992 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer character*(*) C buffer in C C Arguments out : retcode Start of string, zero = null str C C Dependencies : None C C Calls : None C C Notes : C C============================================================================= C***************************************************************************** C Declare various local variables C***************************************************************************** implicit none character*(*) buffer integer ichr C***************************************************************************** C Find first non-blank C***************************************************************************** do 10 ichr = 1, len(buffer) if(buffer(ichr:ichr) .ne. ' ' .and. & ichar(buffer(ichr:ichr)) .ne. 0 .and. & buffer(ichr:ichr) .ne. ' ') goto 20 10 continue ichr = 0 20 continue nbstart = ichr return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer function find_words(buffer,starts,ends) C***************************************************************************** C C Name : find_words() C C Description : Finds starts and ends of words in buffer C C Created : 15-Sep-92 Mark Harris C C Modified : C C Copyright : Symbicom AB, Uppsala, Sweden, 1992 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer Character*(*) C buffer in C starts Integer(*) C starting points C ends Integer(*) C ending points C C Arguments out : retcode Number of words found C C Dependencies : None C C Notes : C C============================================================================= C***************************************************************************** C Declare parameters C***************************************************************************** implicit none integer starts(*), ends(*) character*(*) buffer C***************************************************************************** C Declare various local variables C***************************************************************************** integer ichr, inext, icount icount = 0 inext = 1 C***************************************************************************** C Find length of buffer C***************************************************************************** ichr = len(buffer) C***************************************************************************** C Find start of word C***************************************************************************** if (ichr .le. 1) goto 20 5 continue do 10 ichr = inext, len(buffer) if(buffer(ichr:ichr) .ne. ' ' .and. & ichar(buffer(ichr:ichr)) .ne. 0 .and. & buffer(ichr:ichr) .ne. ' ') then icount = icount + 1 ! word started starts(icount) = ichr inext = ichr+1 goto 20 end if 10 continue goto 50 ! end of buffer 20 continue do 30 ichr = inext, len(buffer) if(buffer(ichr:ichr) .eq. ' ' .or. & ichar(buffer(ichr:ichr)) .eq. 0 .or. & buffer(ichr:ichr) .eq. ' ') then ends(icount) = ichr-1 ! word ended inext = ichr goto 5 end if 30 continue ends(icount) = ichr-1 ! buffer ended 50 find_words = icount return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character*(*) function upcase(buffer) C***************************************************************************** C C Name : upcase() C C Description : Folds buffer to upper case C C Created : 19-Sep-90 Mark Harris C C Modified : 22-Apr-93 C C Copyright : Symbicom AB, Uppsala, Sweden, 1991 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer character*(*) C buffer in C C Arguments out : retcode character*(*) C buffer out C C Dependencies : None C C Calls : None C C Notes : I think I should be able to do better than this C C============================================================================= C***************************************************************************** C Declare various local variables C***************************************************************************** implicit none character*(*) buffer byte ibuffer(256) integer ichar character*1024 buffer_out equivalence (buffer_out, ibuffer) C***************************************************************************** C Fold buffer C***************************************************************************** buffer_out = ' ' do 10 ichar = 1, len(buffer) buffer_out(ichar:ichar) = buffer(ichar:ichar) if (buffer(ichar:ichar).ge.'a'.and.buffer(ichar:ichar).le.'z') then ibuffer(ichar) = ibuffer(ichar) - 32 end if if (ibuffer(ichar) .eq. -27) ibuffer(ichar) = -59 if (ibuffer(ichar) .eq. -28) ibuffer(ichar) = -60 if (ibuffer(ichar) .eq. -10) ibuffer(ichar) = -42 10 continue upcase = buffer_out return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character*(*) function lowcase(buffer) C***************************************************************************** C C Name : lowcase() C C Description : Folds buffer to lower case C C Created : 13-Oct-92 Mark Harris C C Modified : 22-Apr-93 C C Copyright : Symbicom AB, Uppsala, Sweden, 1991 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer character*(*) C buffer in C C Arguments out : retcode character*(*) C buffer out C C Dependencies : None C C Calls : None C C Notes : I think I should be able to do better than this C C============================================================================= C***************************************************************************** C Declare various local variables C***************************************************************************** implicit none character*(*) buffer byte ibuffer(256) integer ichar character*1024 buffer_out equivalence (buffer_out, ibuffer) C***************************************************************************** C Fold buffer C***************************************************************************** buffer_out = ' ' do 10 ichar = 1, len(buffer) buffer_out(ichar:ichar) = buffer(ichar:ichar) if (buffer(ichar:ichar).ge.'A'.and.buffer(ichar:ichar).le.'Z') then ibuffer(ichar) = ibuffer(ichar) + 32 end if if (ibuffer(ichar) .eq. -59) ibuffer(ichar) = -27 if (ibuffer(ichar) .eq. -60) ibuffer(ichar) = -28 if (ibuffer(ichar) .eq. -42) ibuffer(ichar) = -10 10 continue lowcase = buffer_out return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ integer function i_am_unix() C***************************************************************************** C C Name : i_am_unix() C C Description : Indicates whether or not program is running under UNIX. C C Created : 8-Jul-93 Mark Harris C C Modified : C C Copyright : Symbicom AB, Uppsala, Sweden, 1993 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : None C C Arguments out : retcode 1 = UNIX, 0 = not UNIX C C Dependencies : C C Notes : Looks for lowercase letters in the return from C the date() function. VMS is all uppercase. C C Must be called as function "i_am_unix()", C as it always returns zero without the parenthesis. C C============================================================================= C***************************************************************************** C Declare various local variables and functions C***************************************************************************** character*80 date_string C***************************************************************************** C See if we have UNIX. C***************************************************************************** i_am_unix = 0 ! assume VMS call date_and_time(date_string) if (date_string(6:6) .ge. 'a' .and. & date_string(6:6) .le. 'z') then i_am_unix = 1 ! UNIX end if C***************************************************************************** C And home C***************************************************************************** return end C----------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character*(*) function extract_word(buffer,word_number) C***************************************************************************** C C Name : extract_word() C C Description : Extracts the Nth word from a string C C Created : 15-Oct-92 Mark Harris C C Modified : 24-Feb-93 C C Copyright : Symbicom AB, Uppsala, Sweden, 1992 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer Character*(*) C buffer in C word_number Integer(*) C Word to extract C C Arguments out : retcode Word found, or null if not C C Dependencies : None C C Notes : C C============================================================================= C***************************************************************************** C Declare parameters C***************************************************************************** implicit none integer word_number character*(*) buffer C***************************************************************************** C Declare various local variables C***************************************************************************** integer ichr, inext, icount, start, end start = 0 end = 0 icount = 0 inext = 1 extract_word = ' ' C***************************************************************************** C Find length of buffer C***************************************************************************** ichr = len(buffer) C***************************************************************************** C Find start of word C***************************************************************************** if (ichr .le. 1) goto 20 5 continue do 10 ichr = inext, len(buffer) if(buffer(ichr:ichr) .ne. ' ' .and. & ichar(buffer(ichr:ichr)) .ne. 0 .and. & buffer(ichr:ichr) .ne. ' ') then icount = icount + 1 ! word started start = ichr inext = ichr+1 goto 20 end if 10 continue goto 999 ! end of buffer 20 continue do 30 ichr = inext, len(buffer) if(buffer(ichr:ichr) .eq. ' ' .or. & ichar(buffer(ichr:ichr)) .eq. 0 .or. & buffer(ichr:ichr) .eq. ' ') then end = ichr-1 ! word ended inext = ichr if (icount .ge. word_number) goto 50 goto 5 end if 30 continue end = ichr-1 ! buffer ended goto 999 50 if (start .gt. 0 .and. end .ge. start) then extract_word = buffer(start:end) end if 999 return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ character*(*) function replace_string(buffer,old_string,new_string) C***************************************************************************** C C Name : replace_string() C C Description : Removes every occurance of a string with new string C C Created : 7-Feb-92 Mark Harris C C Modified : 18-Feb-93 C C Copyright : Symbicom AB, Uppsala, Sweden, 1992 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C Arguments in : buffer character*(*) C buffer_in C C Char character*(*) C Char_in C C Arguments out : retcode character*(*) C buffer_out C C Dependencies : None C C Calls : nblen C C Notes : If called with option string "RECURSIVE__REPLACE" C as the NEW_STRING field, the old_string is replaced C with the first character of OLD_STRING, and this is C done recursively until no occurances are left. C The idea is to replace multiple adjacent characters C with one character, usually a string of spaces C to one space. C C============================================================================= C***************************************************************************** C Declare passed variables C***************************************************************************** implicit none character*(*) buffer character*(*) old_string, new_string C***************************************************************************** C Declare various local variables C***************************************************************************** integer i, j, istart, buff_length, str_start, recursive_flag integer old_str_length, new_str_length, nblength, nblen integer max_length character*1024 in_buff, out_buff, new_string_copy, old_string_copy C***************************************************************************** C Check for recursive flag C***************************************************************************** recursive_flag = 0 if (nblen(new_string) .ge. 18) then if (new_string(1:18) .eq. 'RECURSIVE__REPLACE') then recursive_flag = 1 end if end if C***************************************************************************** C Find last non-blank to avoid infinite loop with blank replacements C***************************************************************************** max_length = len(buffer) buff_length = nblen(buffer) nblength = buff_length if (buff_length .lt. 1) goto 999 C***************************************************************************** C Make copies of strings, find lengths, and check for passed single spaces C***************************************************************************** old_str_length = len(old_string) new_str_length = len(new_string) new_string_copy = new_string old_string_copy = old_string if (len(new_string) .eq. 0) then ! probably a space passed new_string_copy = ' ' new_str_length = 1 end if if (len(old_string) .eq. 0) then ! probably a space passed old_string_copy = ' ' old_str_length = 1 end if if (recursive_flag .gt. 0) then ! Use first of old_string as new new_string_copy = old_string_copy(1:1) new_str_length = 1 end if in_buff = buffer 3 continue j = buff_length out_buff = in_buff str_start = 1 C***************************************************************************** C Swap the offending string C***************************************************************************** 5 continue buff_length = nblen(in_buff) istart = index(in_buff(str_start:buff_length), & old_string_copy(1:old_str_length)) if (istart .gt. 0) then istart = istart+str_start-1 str_start = istart+1 j=0 if (istart .gt. 1) then ! copy start of in_buff do 10 i = 1, istart-1 j = j+1 out_buff(j:j) = in_buff(i:i) 10 continue end if if (new_str_length .gt. 0) then ! copy in new string do 20 i = 1, new_str_length j = j+1 ccc if (j .le. max_length) out_buff(j:j) = new_string_copy(i:i) out_buff(j:j) = new_string_copy(i:i) 20 continue end if out_buff(j+1:) = ' ' ! terminate it do 30 i = istart+old_str_length, buff_length ! copy rest of string j = j+1 out_buff(j:j) = in_buff(i:i) 30 continue in_buff = out_buff str_start = str_start+new_str_length -1 nblength = nblength +new_str_length-old_str_length if (str_start .le. nblength) goto 5 ! look for more occurs end if ! loop if recursive flag if (recursive_flag .gt. 0 .and. & index(out_buff(1:nblen(out_buff)), & old_string_copy(1:old_str_length)).gt.0) then buff_length = max(1,min(j,buff_length)) in_buff = out_buff(1:max(1,min(j,buff_length))) goto 3 end if 999 continue ccc replace_string = out_buff(1:max(1,min(j,max_length))) replace_string = out_buff(1:max(1,j)) return end C---------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ real function matrix_determinant(matrix) C***************************************************************************** C C Name : matrix_determinant() C C Description : Finds determinant of a matrix C C Created : 12-Aug-92 MRH C C Modified : C C Copyright : Symbicom AB, Uppsala, Sweden, 1991 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C C Arguments in : C Reals(3,3) matrix C C Arguments out: Return code determinant of matrix C C C Dependencies : None C C Calls : None C C Notes : C C============================================================================= C***************************************************************************** C Declare parameters C***************************************************************************** implicit none integer norder parameter (norder=3) ! Matrix size real matrix(norder,norder) C***************************************************************************** matrix_determinant = & & matrix(1,1)*matrix(2,2)*matrix(3,3) + & matrix(1,2)*matrix(2,3)*matrix(3,1) + & matrix(1,3)*matrix(2,1)*matrix(3,2) - & matrix(1,3)*matrix(2,2)*matrix(3,1) - & matrix(1,1)*matrix(2,3)*matrix(3,2) - & matrix(1,2)*matrix(2,1)*matrix(3,3) C***************************************************************************** return end C----------------------------------------------------------------------------- C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ real function find_normal(coords1, coords2, coords3, normal) C***************************************************************************** C C Name : find_normal() C C Description : C Calculates the normal to three given points, C with origin on the first point. C C Created : 31-May-99 MRH C C Modified : C C Copyright : UU, Uppsala, Sweden, 1999 C C Language : C Fortran 77, extended with C 16-char variables, 'implicit none' C C C Arguments in : C Reals(3) coord1, coord2, coord3, normal C C Arguments out: Real determinant of system C C C Dependencies : None C C Calls : matrix_invert, matrix_determinant C C Notes : Based on code by MK. C C============================================================================= C***************************************************************************** C Declare parameters C***************************************************************************** implicit none real coords1(*), coords2(*), coords3(*), normal(*) C***************************************************************************** C Declare local variables C***************************************************************************** integer iaxis real matrix_determinant real matrix(3,3), inverse(3,3), very_small, determinant real dist, dist_a, dist_b, dist_c, a(3),b(3),c(3) C***************************************************************************** C Initialise some variables C***************************************************************************** very_small = 0.00001 C***************************************************************************** C Check input C***************************************************************************** dist_a = sqrt( (coords2(1)-coords1(1))*(coords2(1)-coords1(1)) + & (coords2(2)-coords1(2))*(coords2(2)-coords1(2)) + & (coords2(3)-coords1(3))*(coords2(3)-coords1(3)) ) if (dist_a .lt. very_small) then print *, '%FIND_NORAML-W-Arbitrary normal due to coincident points A' endif dist_b = sqrt( (coords2(1)-coords3(1))*(coords2(1)-coords3(1)) + & (coords2(2)-coords3(2))*(coords2(2)-coords3(2)) + & (coords2(3)-coords3(3))*(coords2(3)-coords3(3)) ) if (dist_b .lt. very_small) then print *, '%FIND_NORAML-W-Arbitrary normal due to coincident points B' endif dist_c = sqrt( (coords3(1)-coords1(1))*(coords3(1)-coords1(1)) + & (coords3(2)-coords1(2))*(coords3(2)-coords1(2)) + & (coords3(3)-coords1(3))*(coords3(3)-coords1(3)) ) if (dist_c .lt. very_small) then print *, '%FIND_NORAML-W-Arbitrary normal due to coincident points C' end if cc print *, 'dd', dist_a, dist_b, dist_c a(1) = coords2(1)-coords1(1) a(2) = coords2(2)-coords1(2) a(3) = coords2(3)-coords1(3) b(1) = coords3(1)-coords1(1) b(2) = coords3(2)-coords1(2) b(3) = coords3(3)-coords1(3) normal(1) = a(2)*b(3) - a(3)*b(2) normal(2) = a(3)*b(1) - a(1)*b(3) normal(3) = a(1)*b(2) - a(2)*b(1) c normalise dist = sqrt(normal(1)**2+normal(2)**2+normal(3)**2) normal(1) = normal(1)/dist normal(2) = normal(2)/dist normal(3) = normal(3)/dist cc print *, 'norm', normal(1),normal(2),normal(3) cc dist = sqrt(normal(1)**2+normal(2)**2+normal(3)**2) cc print *, 'dist', dist C***************************************************************************** C And home C***************************************************************************** find_normal = 1 return end C----------------------------------------------------------------------------- c c for SGI, uncomment c c subroutine date_and_time(date_string) c character*1024 date_string c call date(date_string) c return c end