00001
00002 c
00003 c Copyright (c) 1986,1987,1988,1989,1990,1991,1992,1993,
00004 c by Steve McMillan, Drexel University, Philadelphia, PA.
00005 c
00006 c All rights reserved.
00007 c
00008 c Redistribution and use in source and binary forms are permitted
00009 c provided that the above copyright notice and this paragraph are
00010 c duplicated in all such forms and that any documentation,
00011 c advertising materials, and other materials related to such
00012 c distribution and use acknowledge that the software was developed
00013 c by the author named above.
00014 c
00015 c THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
00016 c IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
00017 c WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
00018 c
00019
00020 subroutine symbl(rinput,sinput,ht,string,theta,numch)
00021 save
00022 c
00023 c Use the local string drawer to mimic "simbol."
00024 c (Not guaranteed to work in all circumstances!)
00025 c
00026 character*80 device
00027 common /plot device/ device,aspect,idev
00028 common /plot sizes/ xsize,ysize
00029 common /plot origin/ ro,so
00030 common /fontc1/ offx,offy,lastinc,xp,yp,xmax,xmin,ymax,ymin
00031 common /numsym int/ rs,ss,dx,dy,sint,cost
00032 common /str posn/ i pos set,frx,fry
00033 c
00034 common /plain font/ wid
00035 c ( = ratio of character width to height.)
00036 c
00037 common /framesize/ nxpix,nx0,xfac,nypix,ny0,yfac
00038 common /ncar/ nxpix1,nypix1,nx01,ny01,xfac1,yfac1
00039 common /dev init/ init
00040 common /dev status/ idevon,idevpen,idevwt
00041 common /fr int/ iframe
00042 common /numbr on/ inumbr
00043
00044 character*200 temp
00045 c
00046 character*40 font
00047 common /ps font/ font,ifsize
00048 save /ps font/
00049 c
00050 external mcdxtext !$pragma C (mcdxtext)
00051 c
00052 character*(*) string
00053 integer*2 ichars(100)
00054 c
00055 r = rinput
00056 s = sinput
00057 go to 1
00058 c
00059 entry csymbl(ht,string,theta,numch)
00060 call simwhe(r,s)
00061 c
00062 1 if (init.eq.0) then
00063 init = -1
00064 call mcinit
00065 call devon
00066 call clear
00067 end if
00068 c
00069 if (idevon.eq.0)call devon
00070 nn = abs(numch)
00071 if (nn.eq.0)nn = len(string)
00072 if (nn.gt.len(string)) then
00073 do 5 i = 1,len(string)-1
00074 if (string(i:i).eq.'%') then
00075 if (string(i+1:i+1).eq.'%') then
00076 nn = i-1
00077 go to 6
00078 end if
00079 end if
00080 5 continue
00081 6 end if
00082 th = .017453293*theta
00083 sint = sin(th)
00084 cost = cos(th)
00085 c
00086 c Get/estimate size of string.
00087 c
00088 if (idev.eq.15) then
00089 c
00090 c SunCore calls!
00091 c -------------
00092 c
00093 call setcharsize(abs(ht*wid),abs(ht))
00094 call inqtextextent2(string(1:nn),dx,dy)
00095 c
00096 dy = abs(ht)
00097 width = dx/nn
00098 sint = 0.
00099 cost = 1.
00100 c
00101 c (The SUN raster font used has fixed orientation.)
00102 c
00103 else
00104 dy = abs(ht)
00105 width = wid*dy
00106 dx = width*nn
00107 end if
00108 c
00109 if (idev.eq.2) then
00110 c
00111 c NCAR output:
00112 c -----------
00113 c
00114 rs = r+ro
00115 ss = s+so
00116 if (numch.lt.0) then
00117 n = 1
00118 write(ichars(1),'(2a1)')char(-numch),' '
00119 else
00120 n = numch
00121 end if
00122 isiz = yfac1*dy*wid
00123 icent = -1
00124 rs1 = rs
00125 ss1 = ss
00126 if (ht.lt.0..or.(iframe.eq.1.and.i pos set.eq.0)) then
00127 icent = 0
00128 else if (i pos set.ne.0) then
00129 dxs = 0.
00130 if (frx.ge.0..and.frx.le.1.)dxs = dx*frx
00131 dys = 0.
00132 if (fry.ge.0..and.fry.le.1.)dys = dy*fry
00133 rs1 = rs1-(dxs*cost-dys*sint)
00134 ss1 = ss1-(dxs*sint+dys*cost)
00135 end if
00136 rs = rs1
00137 ss = ss1
00138 if (icent.eq.-1) then
00139 rs1 = rs1-.5*dy*sint
00140 ss1 = ss1+.5*dy*cost
00141 end if
00142 ir = nx01+xfac1*rs1
00143 js = ny01+yfac1*ss1
00144 ith = theta
00145 if (numch.ge.0) then
00146 n = min(n,200)
00147 do 209 i = 1,n
00148 209 if (string(i:i).ge.'a'.and.string(i:i).le.'z')
00149 + string(i:i) = char(ichar(string(i:i))-32)
00150 i1 = -1
00151 do 210 i = 1,n/2
00152 i1 = i1+1
00153 i2 = i1+1
00154 write(ichars(i),'(2a1)')string(i1:i1),string(i2:i2)
00155 210 continue
00156 if (i2.lt.n)write(ichars(n/2+1),'(2a1)')string(n:n),' '
00157 end if
00158 c
00159 c NCAR call!!!
00160 c ------------
00161 c
00162 if (n.ne.0) call pwrit(ir,js,ichars,n,isiz,ith,icent)
00163 c
00164 rs = rs-ro
00165 ss = ss-so
00166 c
00167 else
00168 c
00169 c Attempt to determine the offset of the string.
00170 c
00171 fx = 0.
00172 fy = 0.
00173 if (i pos set.ne.0) then
00174 if (frx.gt.0..and.frx.le.1.)fx = frx
00175 if (fry.gt.0..and.fry.le.1.)fy = fry
00176 else if (numch.lt.0.or.(inumbr.eq.1.and.iframe.eq.1)) then
00177 fx = .5
00178 fy = .5
00179 end if
00180 c
00181 dxs = dx*fx
00182 dys = dy*fy
00183 rs = r-(dxs*cost-dys*sint)
00184 ss = s-(dxs*sint+dys*cost)
00185 c
00186 if (idev.eq.15) then
00187 rs = rs-.5*dy*sint
00188 ss = ss+.5*dy*cost
00189 end if
00190 c
00191 c (rs,ss) is the bottom left corner of the output string.
00192 c
00193 if (idev.eq.5.or.idev.eq.6) then
00194 c
00195 c HP plotter:
00196 c ----------
00197 c
00198 l = index(string(1:nn),'%%')
00199 if (l.gt.0)nn = l-1
00200 dx = width*nn
00201 ntilde = 0
00202 if (nn.le.0)go to 700
00203 call plot(rs,ss,3)
00204 fac = 2.5e-4*nxpix
00205 c
00206 c (Each pixel is 1/40 mm, x-width is 10 units, "si"
00207 c below wants string dimensions specified in cm!)
00208 c
00209 write(6,610).6666667*fac*width,fac*dy,cost,sint
00210 610 format(' SI',f8.4,',',f8.4,';DI',f6.4,',',f6.4)
00211 islant = 1
00212 i1 = 1
00213 650 if (i1.gt.nn)go to 700
00214 i2 = index(string(i1:nn),'~')+i1-1
00215 if (i2.lt.i1)i2 = nn+1
00216 i3 = i2-1
00217 if (i2.lt.nn.and.string(i2+1:i2+1).eq.'~')i3 = i2
00218 if (i3.ge.i1)call hp sym out(string(i1:i3),islant)
00219 ntilde = ntilde+1
00220 islant = 1-islant
00221 i1 = i3+2
00222 go to 650
00223 700 dx = dx-width*max(0,ntilde-1)
00224 c
00225 else if (idev.eq.15) then
00226 c
00227 c SunCore:
00228 c -------
00229 c
00230 call plot(rs,ss,3)
00231 call text(string(1:nn))
00232 c
00233 else if (idev.eq.16) then
00234 c
00235 c Postscript:
00236 c ----------
00237 c
00238 c We can do better than the above guesses of string size
00239 c and offset. Recall that r and s still represent the
00240 c input string coordinates, and fx and fy determine the offset.
00241 c
00242 call plot(r,s,3)
00243 write(42,*)
00244 c write(42,*)'gsave %%%% Begin symbl output'
00245 write(42,*)'%%%% Begin symbl output'
00246 c
00247 c The leading factor seems to be necessary to make a
00248 c (say) 72-point font come out 1 inch high...
00249 c
00250 fheight = 0.645*ifsize
00251 scale = abs(ht)*yfac/fheight
00252 c
00253 c Determine the length of the string -- stringlen:
00254 c
00255 write(42,*)'/stringlen'
00256 write(42,800)'(',(string(i:i),i = 1,nn),')'
00257 800 format(500a1)
00258 write(42,*)'stringwidth pop def'
00259 c
00260 c Determine the r and s offsets (relative to string):
00261 c
00262 write(42,810)fx,scale
00263 810 format('/roffset stringlen ',f9.4,' mul ',
00264 & f9.3,' mul def')
00265 c
00266 write(42,820)fheight,fy,scale
00267 820 format('/soffset ',2f9.4,' mul ',f9.3,' mul def')
00268 c
00269 c Determine the x and y offsets (rotated):
00270 c
00271 write(42,830)-cost,' r',sint,' s'
00272 write(42,830)-sint,' r',-cost,' s'
00273 830 format(f9.5,a,'offset mul ',f9.5,a,'offset mul add')
00274 c
00275 c Move to the correct offset point:
00276 c
00277 write(42,*)'rmoveto'
00278 c
00279 c Show the string:
00280 c
00281 write(42,800)'(',(string(i:i),i = 1,nn),')'
00282 c
00283 c Scale the string:
00284 c
00285 write(42,'(2f9.3,'' scale'')')scale,scale
00286 c
00287 c Rotate the string:
00288 c
00289 write(42,'(f9.3,'' rotate'')')theta
00290 c
00291 c Finish up:
00292 c
00293 c write(42,*)'show grestore %%%% End symbl output'
00294 write(42,*)'show %%%% End symbl output'
00295 write(42,*)
00296 c
00297 else if (idev.eq.17) then
00298 c
00299 c X-windows:
00300 c ---------
00301 c
00302 call plot(rs,ss,3)
00303 do i=1,nn
00304 temp(i:i) = string(i:i)
00305 end do
00306 temp(nn+1:nn+1) = char(0)
00307 call mcdxtext(abs(ht),theta,
00308 & temp(1:nn+1))
00309 c
00310 end if
00311 end if
00312 c
00313 call mc sym lims
00314 c
00315 end
