character ans*1,name(4)*10,psfile*65 logical exists data name/'kilometers','miles ','meters ','feet '/ print 100 100 format (' MAPSCALE, PLOUFF, 7-94. Program to create a Post', 1 'Script file for a map scale.',/,' If you do not know the ', 2 'scale, it will be calculated from your measurements.',/, 3 ' Default units of miles or kilometers will be provided un', 4 'less the scale is',/,' too large. A default scale occupies', 5 ' about 3.75 inches, is centered on a',/,' 8.5-inch page ', 6 'width, and starts 1.00 inch from the bottom of the page',/, 7 ' (varies slightly with printer).') print 600 600 format (' TYPE a name for a PostScript file:') read (5,565) psfile 565 format (a65) inquire (file=psfile,exist=exists) if (exists) then print 601 601 format (' That file exists and will be overwritten.',/,' DO ', 1 'YOU WANT TO STOP TO RENAME IT?') read (5,501) ans 501 format (a1) if (ans .eq. 'y' .or. ans .eq. 'Y' .or. ans .eq. ' ') stop end if print 101 101 format(' TYPE the reciprocal of the map scale (0, if unknown):') read (5,*) scal if (scal .ne. 0.0) go to 2 print 102 102 format (' TYPE the latitude at the south edge of the map (DEG,', 1 'MIN):') read (5,*) sd,sm bd=sd+sm/60.0 print 103 103 format (' TYPE the latitude at the north edge of the map (DEG,', 1 'MIN):') read (5,*) sd,sm td=sd+sm/60.0 c average latitude in radians cs=cos(3.1415927*(bd+td)/360.0)**2 c length of a degree of a meridian in meters (Plouff, 1968, p. C175) deg=111699.34-1141.70*cs+9.60*cs*cs y=deg*(td-bd) ykm=0.001*y print 104, ykm 104 format(' The length along your central meridian is',f7.2,' km.', 1 /,' What is that length in inches on your map?') read (5,*) c scal=y*12.0/(c*0.3048) iscal=scal+0.5 print 105, iscal 105 format (' Your scale is 1:',i8) 2 if (scal .lt. 11000.) then print 170 170 format (' Your scale is too large to show miles or kilo', 1 'meters.',/,' Are your distance units meters?') read (5,501) ans if (ans .eq. 'y' .or. ans .eq. 'Y' .or. ans .eq. ' ') then iunit=3 c kilometers per inch; inches for half Helvetica-6.5 word plus space finch=0.3048*scal/12 halfword=0.20 else iunit=4 finch=scal/12 halfword=0.13 print 117 117 format (' Therefore, your distance units are feet.') end if c Length of one meter or foot in inches. Scale occupies 3.75-inch c half-page with 0.75-inch margins. unit=1.0/finch halfpage=(3.75-halfword)/unit maxd=halfpage+0.1 print 118, maxd,name(iunit) 118 format (' You can have a scale that extends to',i5,1x,a10,/, 1 ' You will be asked for rounded values of scale ', 2 'intervals and the maximum span.') go to 3 end if print 106 106 format (' Are your distance units kilometers?') read (5,501) ans if (ans .eq. 'y' .or. ans .eq. 'Y' .or. ans .eq. ' ') then iunit=1 c kilometers per inch; inches for half Helvetica-6.5 word plus space finch=0.3048*scal/(12000) halfword=0.3 else iunit=2 finch=scal/(12*5280) halfword=0.14 print 107 107 format (' Therefore, your distance units are miles.') end if c Length of one kilometer or mile in inches. Scale occupies 3.75-inch c half-page with 0.75-inch margins. unit=1.0/finch halfpage=(3.75-halfword)/unit maxd=halfpage+0.1 c Finest distance interval to show if (scal .lt. 90000.) then c intc, coarse interval in units intc=1 c Fine interval in 0.1 units; former "fine"=0.1 * "ifinet" ifinet=1 c Total distance along scale, in units, including fine part maxd=2 if (scal .lt. 19000.) maxd=1 if (scal .gt. 26000.) maxd=halfpage+0.1 else if (scal .lt. 133333.) then intc=1 ifinet=2 else if (scal .lt. 266667.) then intc=5 ifinet=10 maxd=intc*(maxd/intc) else if (scal .lt. 1050000.) then intc=10 ifinet=10 maxd=intc*(maxd/intc) else if (scal .lt. 2900000.) then intc=50 ifinet=50 maxd=intc*(maxd/intc) else if (scal .lt. 6500000.) then intc=50 ifinet=100 maxd=intc*(maxd/intc) else c Smallest scale has coarse interval of 100 km/mi, fine 10 km/mi intc=100 ifinet=100 maxd=intc*(maxd/intc) end if end if end if end if end if end if fine=0.1*ifinet finein=unit*fine coarsein=unit*float(intc) fmaxin=unit*float(maxd) maxn=maxd-intc print 108, fmaxin,maxd,name(iunit),maxn,name(iunit),fine,finein, 1 intc,coarsein,name(iunit) 108 format (' The scale extends',f6.2,' inches to a maximum span ', 1 'of ',i5,1x,a10,/,' The right end of the scale is marked',i5,1x, 2 a10,/,' Fine intervals are',f5.1,' (',f6.3,' inch) and ', 3 'coarse are',i4,' (',f5.2,' inch) ',a10,/,' Are these ', 4 'values okay?') read (5,501) ans if (ans .eq. 'y' .or. ans .eq. 'Y' .or. ans .eq. ' ') go to 6 3 print 109 109 format (' If fine intervals are not wanted (rarely), type 0.',/, 1 ' TYPE the length of a fine interval (units, decimal number):') read (5,*,err=3) fine ifinet=10*fine+0.1 4 print 110 110 format (' The coarse interval is the length of the total number', 1 ' of fine intervals.') if (ifinet .eq. 0) print 171 171 format (' In your case of no fine elements, it is another ', 1 'value.') print 172 172 format (' TYPE the coarse interval (units, no decimal point, ', 1 'non-zero):') read (5,*,err=4) intc if (intc .le. 0.0) then print 173 173 format (' Do not set coarse interval=0. If no coarse inter', 1 'vals are wanted, set = to',/,' sum of fine intervals and ', 2 'later set distance span = coarse interval.') go to 4 end if intc10=intc*10 itest=intc10/ifinet if ((ifinet*itest) .eq. intc10) go to 5 print 111 111 format (' The fine interval must divide into the coarse inter', 1 'val with no remainder.') go to 3 5 print 112 112 format (' The requested maximum distance includes the fine ', 1 'intervals.',/,' TYPE the span of the scale (units, no deci', 2 'mal point):') read (5,*,err=5) maxd itest=maxd/intc if ((intc*itest) .eq. maxd) go to 6 print 113 113 format (' Coarse interval must divide into maximum distance ', 1 'with no remainder.') go to 5 6 if (maxn .gt. 9999) then print 700 700 format (' **STOP. Maximum distance exceeds 9999.') stop end if ymin=1.0 fmaxin=unit*float(maxd) xmin=0.5*(8.5-(fmaxin+halfword+halfword)) print 114, xmin 114 format (' The lower left corner of the scale is 1.0 inch from ', 1 'the bottom of the paper',/,' and',f5.2,' inches from the ', 2 'left edge.',/,' Are these values okay?') read (5,501) ans if (ans .eq. 'y' .or. ans .eq. 'Y' .or. ans .eq. ' ') go to 9 7 print 115 115 format (' TYPE the distance in inches from the bottom:') read (5,*,err=7) ymin 8 print 116 116 format (' TYPE the distance in inches from the left edge:') read (5,*,err=8) xmin 9 open (9,file=psfile,form='formatted',status='unknown') c Initialize the PostScript file parameters. c Number fonts are about 7 pts and uppercase about 6.5 pts to be = ht write (9,900) 900 format ('%!PS',/,'/L {lineto} def /M {moveto} def /ST ', 1 '{stroke} def',/,'72.0 72.0 scale % So that measurement ', 2 'units are inches, not points',/,'/Helvetica findfont 0.097 ', 3 'scalefont setfont % number size',/,'0.003 setlinewidth') c Increment for drawing alternating midlines; leftmost is drawn. mid=1 c Base of bar, midline, top, bottom of numbers above bar y=ymin ym=y+0.02778 yp=y+0.05556 ypp=yp+0.021 x=xmin c Zero above left end of fine intervals if no coarse intervals. ival=0 ncint=maxd/intc c Bypass if no fine increments are wanted if (ifinet .eq. 0) go to 11 c Normal case of both fine and coarse intervals if (maxd .ne. intc) ival=intc c Write number above left end if fine values call valplot (xmin,ypp,ival,0) c Number of fine intervals for DO-loop nfint=(10*intc)/ifinet dxf=0.1*float(ifinet)*unit do 10 i=1,nfint xp=x+dxf c Draw rectangular box for one cell write (9,910) x,y,xp,y,xp,yp,x,yp,x,y 910 format ('newpath ',2f7.3,' M ',2f7.3,' L ',2f7.3,' L',/, 1 1x,2f7.3,' L ',2f7.3,' L ST') if (mid .eq. 1) write (9,911) x,ym,xp,ym 911 format ('newpath ',2f7.3,' M ',2f7.3,' L ST') x=xp 10 mid=-mid c Number of coarse intervals minus first fine interval for loop ncint=ncint-1 c Entry point if no fine intervals 11 dxc=unit*float(intc) c Number at end in case no coarse intervals ival=intc if (ncint .le. 0) go to 13 c Value in km or mi always is zero at left end of the coarse scale c and right end of fine scale despite style of 1:100,000 maps ival=0 c Pick up x and midline need where fine left off do 12 i=1,ncint xp=x+dxc write (9,910) x,y,xp,y,xp,yp,x,yp,x,y if (mid .eq. 1) write (9,911) x,ym,xp,ym call valplot (x,ypp,ival,0) ival=ival+intc x=xp 12 mid=-mid c Plot name of units at end of bar 13 call valplot (x,ypp,ival,iunit) print 199 199 format (' If this PostScript file is combined with a plot, ', 1 'delete the first %!PS line,',/,' delete the last showpage ', 2 'line, and insert after line one %!PS in the plot',/,' file.', 3 ' Rotated plots and slight translation shifts of paper ori', 4 'gins will',/,' need special treatment.') close (9) stop end subroutine valplot (x,ypp,ival,last) c Plot numbers and unit name dimension dm(4),dp(4) character caps*10,name(4)*10,nam(4)*10 data dm/0.024,0.05556,0.0796,0.1036/ data dp/0.048,0.0796,0.1112,0.1428/ data name/'KILOMETERS','MILES ','METERS ','FEET '/ data nam /'KILOMETER ','MILE ','METER ','FOOT '/ c Find number of digits in number to be written if (ival .lt. 10) then ifig=1 else if (ival .lt. 100) then ifig=2 else if (ival .lt. 1000) then ifig=3 else ifig=4 end if end if end if xm=x-dm(ifig) go to (21,22,23,24) ifig 21 write (9,901) xm,ypp,ival 901 format (2f7.3,' M (',i1,') show') go to 25 22 write (9,902) xm,ypp,ival 902 format (2f7.3,' M (',i2,') show') go to 25 23 write (9,903) xm,ypp,ival 903 format (2f7.3,' M (',i3,') show') go to 25 24 write (9,904) xm,ypp,ival 904 format (2f7.3,' M (',i4,') show') 25 if (last .eq. 0) return c Write units, including case of 1 unit (ival=1) singular xp=x+dp(ifig) caps=name(last) if (ival .eq. 1) caps=nam(last) write (9,909) xp,ypp,caps 909 format ('/Helvetica findfont 0.090 scalefont setfont % Upper', 1 'case size to match numbers',/,2f7.3,' M (',a10,') show',/, 2 'showpage') return end