NavList:
A Community Devoted to the Preservation and Practice of Celestial Navigation and Other Methods of Traditional Wayfinding
Re: The Bygrave
From: Dave Walden
Date: 2009 Jul 23, 16:41 -0700
From: Dave Walden
Date: 2009 Jul 23, 16:41 -0700
A plain text version:
--~--~---------~--~----~------------~-------~--~----~
NavList message boards: www.navlist.net
Or post by email to: NavList@navlist.net
To , email NavList-@navlist.net
-~----------~----~----~----~------~----~------~--~---
PROGRAM CSR_MAIN
IMPLICIT NONE
! - - - local declarations - - -
integer i,j,k,outfile,it,nlines
REAL*4 theta,sinphi,expx,tdw,r2,r3,tla,tlb,tlc,xc,yc,r
real*4 dr,rstart,xi,xt
real*4 y,pi,d2r
c7 real*8 needed for increment accuracy in 1 min tic do loop
real*8 x
CHARACTER*32 label
pi=4.*atan(1.)
d2r=pi/180.
print*,'pi= ',pi
tla=0.1875
tlb=0.125
tlc=0.0625
tla=.14
tlb=.11
tlc=.08
7 r=1.5
rstart=3.6
r=rstart
dr=0.30
dr=.25
! - - - begin - - -
write (6,901) " antik lapook Computer "
write (6,901) " Generating PostScript output (dwantik1.ps)"
cdw outfile = FOPEN("poorlop1.ps","w")
outfile=22
open(unit=outfile,file="dwantik1.ps")
WRITE (outfile,903) "%!"
WRITE (outfile,903) "/inch {72 mul} def %inches->points (1/72 inch)"
WRITE (outfile,903) "0 setlinewidth % hairline"
WRITE (outfile,903) "1 setlinewidth % hairline"
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 10 ," scalefont "
! WRITE (outfile,905) 9 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
WRITE (outfile,903) "0 inch 5.0 inch translate"
WRITE (outfile,903) "90 rotate"
xc=-4.5
yc=-8.2
write(label,'("COTANGENT SCALE")')
call drawlabelxy(label,2.,.25,outfile)
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 5 +xc," inch ",.2+yc," inch moveto"
WRITE (outfile,904) 10+xc ," inch ",.2+yc," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
do y=.4,7.4,.2
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 0 +xc," inch ",y+yc," inch moveto"
WRITE (outfile,904) 10+xc ," inch ",y+yc," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
Enddo
c7 NEW for antik
WRITE (outfile,903) ".5 setlinewidth % hairline"
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 5 +xc," inch ",.2+yc+.05," inch moveto"
WRITE (outfile,904) 10+xc ," inch ",.2+yc+.05," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
do y=.4,7.4,.2
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 0 +xc," inch ",y+yc+.05," inch moveto"
WRITE (outfile,904) 10+xc ," inch ",y+yc+.05," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
Enddo
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 0 +xc," inch ",7.6+yc+.05," inch moveto"
WRITE (outfile,904) 5+xc ," inch ",7.6+yc+.05," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
WRITE (outfile,903) "1 setlinewidth % hairline"
c7 NEW end new for antik
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 0 +xc," inch ",7.6+yc," inch moveto"
WRITE (outfile,904) 5+xc ," inch ",7.6+yc," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
nlines=40
923 format(i2,"\35355'")
924 format(i2,"\35305'")
925 format(i2,"\35310'")
do x=1,89,1
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
write(label,'(i2,"\353")')int(x)
it=int(xt/5)
xt=xt-it*5.
c7 NEW
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
call drawtickxy(xt,it*.2,-.14,outfile)
call drawtickxy(xt+5,(it-1)*.2,-.14,outfile)
c7 NEW end
921 format(i2," 20'")
922 format(i2," 40'")
enddo
c7 NEW .5 (30 min) ticks
WRITE (outfile,903) ".5 setlinewidth % hairline"
do x=1,89,.5
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
call drawtickxy(xt,it*.2,-.09,outfile)
call drawtickxy(xt,it*.2+.11,-.02,outfile)
call drawtickxy(xt+5,(it-1)*.2,-.09,outfile)
call drawtickxy(xt+5,(it-1)*.2+.11,-.02,outfile)
enddo
WRITE (outfile,903) "1. setlinewidth % hairline"
c7 NEW end
c7 NEW 30 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 8 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
do x=1.5,88.5,1
if (x.lt.15 .or. x.gt.75)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,920)int(x)
920 format(i2,"\353","30'")
call drawlabelxy(label,xt-.02 +.2-.03,it *.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.2-.03,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 10 min ticks
WRITE (outfile,903) ".5 setlinewidth % hairline"
do x=1,89+20./60.,10./60
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
call drawtickxy(xt,it*.2,-.08,outfile)
call drawtickxy(xt+5,(it-1)*.2,-.08,outfile)
enddo
WRITE (outfile,903) "1. setlinewidth % hairline"
c7 NEW end
c7 NEW 5,15,25,35,45,55 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 6 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
c 5
do x=2.-55./60.,89.+5./60.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,937)int(x)
937 format(i2,"\35305'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c 15
do x=2.-45./60.,89.+15./60.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,936)int(x)
936 format(i2,"\35315'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c 25
do x=2.-35./60.,89.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,935)int(x)
935 format(i2,"\35325'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c 35
do x=2.-25./60.,89.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,934)int(x)
934 format(i2,"\35335'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c 45
do x=2.-15./60.,89.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,933)int(x)
933 format(i2,"\35345'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c 55
do x=1.-5./60.,89.,1
if (x.lt.2 .or. x.gt.88)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,923)int(x)
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 10 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 6 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
do x=1.+10./60.,89.+11./60.,1.
if (x.lt.5 .or. x.gt.85)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,925)int(x)
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 20 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 6 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
do x=1.+20./60.,89.,1
if (x.lt.5 .or. x.gt.85)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,926)int(x)
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 40 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 6 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
do x=1.+40./60.,89.,1
if (x.lt.5 .or. x.gt.85)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,932)int(x)
932 format(i2,"\35340'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 50 min labels
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 6 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
do x=1.+50./60.,89.,1
if (x.lt.5 .or. x.gt.85)then
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
write(label,931)int(x)
931 format(i2,"\35350'")
call drawlabelxy(label,xt-.02+.13,it*.2+0.1,outfile)
call drawlabelxy(label,xt-.02+5+.13,(it-1)*.2+0.1,outfile)
endif
enddo
c7 NEW 5 min ticks
WRITE (outfile,903) ".5 setlinewidth % hairline"
do x=1.-5./60.,89.+20./60.,5./60
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
call drawtickxy(xt,it*.2,-.05,outfile)
call drawtickxy(xt+5,(it-1)*.2,-.05,outfile)
enddo
WRITE (outfile,903) "1. setlinewidth % hairline"
c7 NEW end
c7 NEW 1 min ticks
WRITE (outfile,903) ".25 setlinewidth % hairline"
do x=1.-5./60.,89+17./60.,1./60.
xt=nlines*5./4.*(log10(tan(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
c7 print*,'dw 1 min step x,xt=',x,xt
call drawtickxy(xt,it*.2,-.03,outfile)
call drawtickxy(xt+5,(it-1)*.2,-.03,outfile)
enddo
WRITE (outfile,903) "1. setlinewidth % hairline"
c7 NEW end
928 format(i2,"\35305'")
927 format(i2,"\35310'")
930 format(i2,x,i2,"'")
926 format(i2,"\35320'")
WRITE (outfile,903) "showpage"
CLOSE (outfile)
!DRAW THE Cosine PAGE
open(unit=outfile,file="dwantik2.ps")
WRITE (outfile,903) "%!"
WRITE (outfile,903) '/inch {72 mul} def %inches->points (1/72 inch)'
WRITE (outfile,903) '1 setlinewidth % hairline'
WRITE (outfile,903) "/Times-Roman findfont % Get the basic font"
WRITE (outfile,905) 10 ," scalefont "
WRITE (outfile,901) "setfont % Make it the current font",""
WRITE (outfile,903) "gsave"
WRITE (outfile,903) "0 inch 5.0 inch translate"
WRITE (outfile,903) "90 rotate"
write(outfile,901)"1 0 0 setrgbcolor"
write(label,'("COSINE SCALE")')
call drawlabelxy(label,2.,.25,outfile)
do y=.6,4.2,.2
WRITE (outfile,903) "newpath"
WRITE (outfile,904) 0 +xc," inch ",y+yc," inch moveto"
WRITE (outfile,904) 5+xc ," inch ",y+yc," inch lineto"
WRITE (outfile,903) "stroke"
WRITE (outfile,903) ""
Enddo
do i=1,556
x=80.+i*1./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
call drawtickxy(xt,(it-17)*.2,.03,outfile)
enddo
do i=1,111
x=80.+i*5./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
call drawtickxy(xt,(it-17)*.2,.05,outfile)
enddo
do x=0,30,5
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,'(i2)')int(x)
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.08,outfile)
call drawtickxy(xt,(it-17)*.2,.07,outfile)
do i=-5,5
xt=nlines*5./4.*(log10(1/cos((x+i)*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
if(xt.gt.0)call drawtickxy(xt,(it-17)*.2,.03,outfile)
enddo
enddo
do x=31,89,1
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,'(i2)')int(x)
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.08,outfile)
call drawtickxy(xt,(it-17)*.2,.07,outfile)
if(x.lt.89.)then
do i=-5,5
xt=nlines*5./4.*(log10(1/cos((x+i/6.)*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5.
if(xt.gt.0 .and. xt.lt.5)
& call drawtickxy(xt,(it-17)*.2,.03,outfile)
enddo
endif
enddo
do x=78,88,1
xt=nlines*5./4.*(log10(1/cos((x+.5)*d2r))+2.)+.1
it=int(xt/5)
xt=xt-it*5
write(label,920)int(x)
call drawlabelxy(label,xt-.06,(it-17)*.2+0.05,outfile)
enddo
x=87.+10./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)87,10
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=87.+20./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)87,20
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=87.+40./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)87,40
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=87.+50./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)87,50
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=88.+10./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)88,10
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=88.+20./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)88,20
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=88.+40./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)88,40
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=88.+50./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)88,50
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=88.+55./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)88,55
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=89.+5./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)89,5
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=89.+10./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)89,10
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
x=89.+15./60.
xt=nlines*5./4.*(log10(1/cos(x*d2r))+2.)+.1
write(label,930)89,15
it=int(xt/5)
xt=xt-it*5.
call drawlabelxy(label,xt-.02,(it-17)*.2+0.05,outfile)
WRITE (outfile,903) "showpage"
CLOSE (outfile)
write (6,903) "Finished."
901 FORMAT (A/A)
902 FORMAT (A////A)
903 FORMAT (99A)
904 FORMAT (f10.6,A,f10.6,A)
905 format(i2,a,i1)
906 format(f6.3,' inch ',f6.3,' inch ',f6.3
& ,' inch 0 360 arc closepath')
END PROGRAM
! --------------------------------------------------
SUBROUTINE drawtickxy(r1,r2,theta_,outfile)
cdw USE CSR_MAIN_1
IMPLICIT NONE
! - - - arg types - - -
integer outfile
REAL*4 r1,r2,theta_,theta
! - - - local declarations - - -
REAL*4 x1,y1,x2,y2,xc,yc
! - - - begin - - -
xc=-4.5
yc=-8.2
theta = theta_
theta = -theta
x1 = r1*COS(theta) + xc
y1 = r1*SIN(theta) + yc
x2 = r2*COS(theta) + xc
y2 = r2*SIN(theta) + yc
ccc print*,'r1,r2,theta,outfile', r1,r2,theta_,outfile
!cdw print*,theta_,x1,y1,x2,y2
WRITE (outfile,901) "newpath"
WRITE (outfile,902) r1+xc," inch ",r2+yc," inch moveto"
WRITE (outfile,902) r1+xc," inch ",r2+yc-theta_," inch lineto"
WRITE (outfile,901) "stroke"
901 FORMAT (99A)
902 FORMAT (f10.6,A,f10.6,A)
END SUBROUTINE
! --------------------------------------------------
SUBROUTINE drawlabelxy(text,xi,yi,outfile)
cdw USE CSR_MAIN_1
IMPLICIT NONE
! - - - arg types - - -
integer outfile
REAL*4 r,theta_,theta
CHARACTER (LEN=32):: text
! - - - local declarations - - -
REAL*4 x,y,deg,xc,yc,xi,yi
! - - - begin - - -
xc=-4.5
yc=-8.2
theta = theta_
theta = -theta
deg = (theta * 180.0/ 3.1415927 )-90.0
c x = r*COS(theta) + xc
c y = r*SIN(theta) + yc
x=xi+xc
y=yi+yc-.03
deg=0.0
WRITE (outfile,901) "newpath"
WRITE (outfile,901) "gsave"
WRITE (outfile,902) x," inch ",y," inch moveto"
WRITE (outfile,903) deg," rotate"
WRITE (outfile,901) "(",text(1:len_trim(text)),") stringwidth"
WRITE (outfile,901) "pop 2.0 div neg 0.0 % dx dy -> -dx/2 0.0"
WRITE (outfile,901) "rmoveto"
WRITE (outfile,901) "(",text(1:len_trim(text)),") show"
WRITE (outfile,901) "grestore"
901 FORMAT (99A)
902 FORMAT (f12.6,A,f12.6,A)
903 FORMAT (f12.6,A)
END SUBROUTINE
! --------------------------------------------------
