'********************************************************
'* NOT FINISHED YET - VARIANT FOR TESTING               *
'* CYLARB2.bas is a DeltaCad macro for producing a      *
'* Cylinder Sundial with a hole or nodus at the top     *
'* and hour lines readable from inside or outside       *
'* with Longitude Correction and EOT Correction.        *
'* Created by Valentin Hristov (valhrist@bas.bg) in the *
'* beginning of August 2008.                            *
'* (www.math.bas.bg/complan/valhrist/mystuff.htm)       *
'* I was inspired by Mac Oglesby to use the             *
'* North American Sundial Society DeltaCad programs     *
'* as tutorials (http://sundials.org)                   *
'* and made with DeltaCad (www.deltacad.com)            *
'* different types of sundials.                         *
'********************************************************

'* This is a Cylinder Sundial with arbitrary orientation, but the normal
'* position is vertical cylinder, in particular a bay on the wall.
'* The light goes through a concentric hole in the top cover or
'* you can use an arbitrary point of the cover as nodus point.
'* You can read the time from inside or from outside of the surface if
'* the surface is transparent.
'* The rectangle on the drawing represents the whole surface. You have
'* to curve it until the left and the right boundaries coincide.
'* In the case of hole, it is concentric with the upper circle.
'* If the radius of the cylinder is R, then you can give a value for the
'* radius r of the hole between 0 and R. In particular r=0 means
'* that only a small hole at the centre is used, i.e. this is only a
'* nodal point. If r=R, then the cylinder is open from above with the
'* lowest shadow point of the edge giving the time.
'* Choose a suitable value of the radius of the hole depending on the
'* latitude.
'* This type of sundial is most suitable for latitudes between the
'* tropic and the polar circle. For polar latitudes the drawing contains
'* unwanted horizontal lines if the Longitude and EOT corrections are
'* included if you use splines for the drawing and the "jump" from one
'* side of the rectangle to the other becomes vizible. In such cases
'* choose the option for drawing with short segments.

'* Different layers are drawn when you run the macro. To switch them ON
'* or OFF go to the "View-Layers" menu.

'* Before printing switch OFF the not needed layers.

'* Some parts of the macro code are not needed but I do not remove them
'* and only make the lines non-active using '.

'* You can see the picture of another type of sundial generated by one
'* of my DeltaCad macros at
'* www.flickr.com/photos/Valentin_Hristov/261303801/
'* Click on the button "All sizes" to see a bigger photo with details.
'* I am very grateful to my friends Daniela (www.danyo.net) and
'* Todor (www.todor.org) who converted my drawing into a real art piece!!!

'* There is a Demo version of DeltaCad at www.deltacad.com.
'* Use the menu "Options - Macro - Run..." or the separate "Macro"
'* button - "Edit Macro List", add the file, and "Run Macro".
'* In the dialog box use DECIMAL DEGREES. Negative values indicate
'* South for latitude and West for longitude and central meridian.

'* E N J O Y !!!

Option Explicit ' Force all variables to be declared before they are used. No adhoc variables

dcSetLineParms dcBlack, dcSolid, dcThin

Dim l,p,lon,cm,rot,i,pi,d2r,r2d,splin,dm,dmr,w,ll,ud,lol,cs,j As Double
Dim ha,xe,ye,xb,yb,lc,ham,ham1,hac,hacr As Double
Dim d,h,lcr,slc,dc,clc,lr,sl,cl,dr,sd,cd,ir,si,ci,xx,yy,x,y As Double
Dim rr,sr,cr,dsr,sds,cds,surf,high,feot,flon,bar,ear As Double
Dim x0,y0,z0,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,shac,chac As Double
Dim r,at,ab,al,ar,per,Time_int,eot_c,lon_c,rrrr,rrr,spring,bb,ee As Double
Dim xnod,ynod,rnod,an,anr,aaa,bbb,ccc,phi,lambda,z,nod As Double
Dim xx1,yy1,xx2,yy2,xlabel,ylabel,sur,abb,att,jj,ang,a,b,lb,la,ba,ea As Double

Dim decl(366),eot(366),spl(732) As Double

Dim button,count,nl,bm(13),ind(37),nom,ind1 As Integer

Dim action,outtext As String

Dim datetext(13),dirs(4) As String

Dim hhv,hhb,hhe,nlcheck As Boolean


dcSetLineParms dcBLACK, dcSOLID, dcTHIN
dcSetCircleParms dcBLACK, dcSOLID, dcTHIN
dcSetTextParms dcPurple, "Tahoma","Bold",0,12,21,0,0

'Establish the 5 standard line thicknesses in thousands of an inch.
dcSetDrawingData dcLineThin,   .003
dcSetDrawingData dcLineNormal, .008
dcSetDrawingData dcLineThick,  .012
dcSetDrawingData dcLineHeavy,  .024
dcSetDrawingData dcLineWide,   .048

'Maximize the window, close any existing drawing without saving, and start a new drawing.
dcSetDrawingWindowMode dcMaximizeWin
dcCloseWithoutSaving
dcNew ""


'**************************************

'Start of program
Call Sundial
'**********
Sub Sundial
init_constants
Input_constants_of_sundial
If button=0 Then GoTo cncl
Angles
Main
Scheme
dcViewAll
cncl:
End Sub
'End of program


'**************************************
'Start of subroutines
'''''''''''''''''''''''''''''''''''''''
Sub Input_constants_of_sundial

Begin Dialog CONSTANTS_INPUT 10,25,295,220, "Input data for the sundial"
 Text 15,0,220,10, "CYLINDER SUNDIAL (shadows from the top circular base)"
 Text 15,10,250,10, "with longitude and EOT corrections and arbitrary orientation"
 Text 15,20,150,10, "Place"
 TextBox 88,20,99,10, .p
 Text 15,30,180,10, "Latitude(N>0)  Longitude(E>0)  Central meridian(E>0)"
 TextBox 15,40,30,10, .l
 TextBox 65,40,30,10, .lon
 TextBox 115,40,30,10, .cm
 Text 15,50,150,10, "  Use decimal degrees !!!"
 Text 15,60,150,10, "Declination of the base plane"
 TextBox 150,60,37,10, .d
 Text 15,70,150,10, "   (S=0, W>0, E<0, N=180 or -180)"
 Text 15,80,150,10, "Inclination of the base plane"
 TextBox 150,80,37,10, .i
 Text 15,90,180,10, "   (vertical = 90, from you < 90, towards you >90)"
 Text 15,100,150,10, "Rotation in the base plane"
 TextBox 150,100,37,10, .rot
 Text 15,110,180,10, "   (vertical = 0, clockwise < 0, anticlockwise > 0)"

 Text 15,130,50,10, "Period"
 OptionGroup .per
 OptionButton 38,120,85,10, "21 Dec - 21 Jun"
 OptionButton 38,130,85,10, "21 Jun - 21 Dec"
 OptionButton 38,140,85,10, "Whole year"

 Text 105,130,80,10, "Time interval"
 OptionGroup .time_int
 OptionButton 150,120,35,10, "15 min"
 OptionButton 150,130,35,10, "30 min"
 OptionButton 150,140,35,10, "60 min"

 Text 15,155,80,10, "EOT correction"
 OptionGroup .eot_c
 OptionButton 65,150,30,10, "Yes"
 OptionButton 65,160,30,10, "No"

 Text 95,155,80,10, "Longitude correction"
 OptionGroup .lon_c
 OptionButton 165,150,30,10, "Yes"
 OptionButton 165,160,30,10, "No"

 Text 15,170,150,10, "Cylinder radius"
 TextBox 68,170,20,10, .r
 Text 95,170,150,10, "Maximal length below "
 TextBox 168,170,20,10, .lb
 Text 188,170,200,10, " and above "
 TextBox 225,170,20,10, .la
 Text 245,170,250,10, " the base"

 Text 15,185,80,10, "Read time from"
 OptionGroup .surf
 OptionButton 70,180,80,10, "inside"
 OptionButton 70,190,80,10, "outside (transparent)"

 Text 200,20,80,10, "Type of top circular base"
 OptionGroup .nod
 OptionButton 200,30,80,10, "Concentric hole"
 OptionButton 200,90,80,10, "Nodus point"

  Text 210,40,150,10, "Hole radius"
  TextBox 250,40,30,10, .rrrr
  Text 210,50,80,10, "Time at the"
  OptionGroup .high
  OptionButton 215,60,80,10, "highest"
  OptionButton 215,70,80,10, "lowest"
  Text 210,80,80,10, "point of the light spot"

  Text 210,100,150,10, "Radius"
  TextBox 250,100,30,10, .rnod
  Text 210,110,150,10, "Angle"
  TextBox 250,110,30,10, .an
  Text 220,120,150,10, "(like azimuth - from"
  Text 220,130,150,10, "central line to right)"

  Text 200,140,80,10, "How to draw:"
  OptionGroup .splin
  OptionButton 200,150,80,10,"short segments"
  OptionButton 200,160,80,10,"splines"

  Text 200,180,80,10, "Angles between:"
  Text 235,190,80,10, "and"
  TextBox 200,190,30,10, .ba
  TextBox 250,190,30,10, .ea

 OKButton 75,202,37,12
 CANCELButton 180,202,37,12
End Dialog

'Initialize 
Dim prompt As constants_input

prompt.p = "Pinawa - Manitoba"
prompt.l = 50.1488
prompt.lon = -95.89
prompt.cm = -90
prompt.d = 0
prompt.i = 0
prompt.rot = 0
prompt.per = 0
prompt.time_int = 0
prompt.eot_c = 0
prompt.lon_c = 0
prompt.r = 1
prompt.lb = 10
prompt.la = 0
prompt.rrrr = .5
prompt.surf = 0
prompt.high = 1
prompt.nod = 1
prompt.rnod = 0
prompt.an = 0
prompt.splin = 1
prompt.ba = -120
prompt.ea = 60

repeat_until_inputcorrect: 'label to return if input is not correct

button = Dialog(prompt)    'get the input

If (button=0) Then GoTo End_input

If test("Latitude",prompt.l,-90,90) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Longitude",prompt.lon,-180,180) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("CentralMeridian",prompt.cm,-180,180) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Declination",prompt.d,-180,180) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Inclination",prompt.i,0,180) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Rotation",prompt.rot,-180,180) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Cylinder radius",prompt.r,0,10) = false Then
  GoTo repeat_until_inputcorrect
End If
If test("Hole radius",prompt.rrrr,0,prompt.r) = false Then
  GoTo repeat_until_inputcorrect
End If

'Set program variables with input variables, angles in degrees
p = prompt.p
l = CDbl(prompt.l)
lon = CDbl(prompt.lon)
cm = CDbl(prompt.cm)
d = CDbl(prompt.d)
'if l>=0 then d=0 else d=180
i = CDbl(prompt.i)
'i = 0
rot = CDbl(prompt.rot)
'rot = 0
'a = CDbl(prompt.a)
'b = CDbl(prompt.b)
'at = CDbl(prompt.at)
'ab = CDbl(prompt.ab)
'al = CDbl(prompt.al)
'ar = CDbl(prompt.ar)
per = prompt.per
Time_int=prompt.time_int
eot_c=prompt.eot_c
lon_c=prompt.lon_c
r=CDbl(prompt.r)
al=-r*pi
ar=r*pi
'h=CDbl(prompt.h)
lb=CDbl(prompt.lb)
la=CDbl(prompt.la)
rrrr=CDbl(prompt.rrrr)
high=CDbl(prompt.high)
If high=0 Then rrr=r-rrrr Else rrr=r+rrrr
'at=0
at=la
ab=-lb-.3
surf=prompt.surf

nod=prompt.nod
rnod=CDbl(prompt.rnod)
an=CDbl(prompt.an)
splin=prompt.splin

If Time_int=0 Then nl=4
If Time_int=1 Then nl=2
If Time_int=2 Then nl=1
If eot_c=0 Then feot=1 Else feot=0
If lon_c=0 Then flon=1 Else flon=0
If at<=ab Or at<0 Or ab>0 Then GoTo repeat_until_inputcorrect
If ar<=al Or al>0 Or ar<0 Then GoTo repeat_until_inputcorrect

ba=CDbl(prompt.ba)
ea=CDbl(prompt.ea)

End_input:

End Sub

'''''''''''''''''''''''''''''''''''''''
Sub init_constants
pi = 4 * Atn(1)
d2r = pi/180
r2d = 180/pi
dm = 23.43954
dmr = dm*d2r

ind( 1)=355
ind( 2)=  1 '1Jan
ind( 3)= 11
ind( 4)= 21
ind( 5)= 32 '1Feb
ind( 6)= 42
ind( 7)= 52
ind( 8)= 60 '1Mar
ind( 9)= 70
ind(10)= 80
ind(11)= 91 '1Apr
ind(12)=101
ind(13)=111
ind(14)=121 '1May
ind(15)=131
ind(16)=141
ind(17)=152 '1Jun
ind(18)=162
ind(19)=172
ind(20)=182 '1Jul
ind(21)=192
ind(22)=202
ind(23)=213 '1Aug
ind(24)=223
ind(25)=233
ind(26)=244 '1Sep
ind(27)=254
ind(28)=264
ind(29)=274 '1Oct
ind(30)=284
ind(31)=294
ind(32)=305 '1Nov
ind(33)=315
ind(34)=325
ind(35)=335 '1Dec
ind(36)=345
ind(37)=355

'ind( 1)=  1 '1Jan
'ind( 2)= 11
'ind( 3)= 21
'ind( 4)= 32 '1Feb
'ind( 5)= 42
'ind( 6)= 52
'ind( 7)= 60 '1Mar
'ind( 8)= 70
'ind( 9)= 80
'ind(10)= 91 '1Apr
'ind(11)=101
'ind(12)=111
'ind(13)=121 '1May
'ind(14)=131
'ind(15)=141
'ind(16)=152 '1Jun
'ind(17)=162
'ind(18)=172
'ind(19)=182 '1Jul
'ind(20)=192
'ind(21)=202
'ind(22)=213 '1Aug
'ind(23)=223
'ind(24)=233
'ind(25)=244 '1Sep
'ind(26)=254
'ind(27)=264
'ind(28)=274 '1Oct
'ind(29)=284
'ind(30)=294
'ind(31)=305 '1Nov
'ind(32)=315
'ind(33)=325
'ind(34)=335 '1Dec
'ind(35)=345
'ind(36)=355
'ind(37)=366 '1Jan

bm( 1)=  1 '1jan
bm( 2)= 32 '1feb
bm( 3)= 60
bm( 4)= 91
bm( 5)=121
bm( 6)=152
bm( 7)=182
bm( 8)=213
bm( 9)=244
bm(10)=274
bm(11)=305
bm(12)=335 '1dec
bm(13)=366 '1jan

For count=1 To 365
w=.017202792*(count-(cm-15)/360)
decl(count)=.367402-23.275*Cos(w+.178044)-.38506*Cos(2*w+.0687076)-.16046*Cos(3*w+.451301)+.00315469*Cos(4*w+.876643)
Next count
decl(366)=decl(1)

For count=1 To 365
w=.017202792*(count-(cm-15)/360)
eot(count)=.00884207-7.36034*Cos(w+1.49487)+9.91068*Cos(2*w-1.21808)-.306344*Cos(3*w+1.82055)+.204774*Cos(4*w-.875115)
Next count
eot(366)=eot(1)

datetext( 1) = "JAN"
datetext( 2) = "FEB"
datetext( 3) = "MAR"
datetext( 4) = "APR"
datetext( 5) = "MAY"
datetext( 6) = "JUN"
datetext( 7) = "JUL"
datetext( 8) = "AUG"
datetext( 9) = "SEP"
datetext(10) = "OCT"
datetext(11) = "NOV"
datetext(12) = "DEC"
datetext(13) = "JAN"

'datetext( 1) = "J"
'datetext( 2) = "F"
'datetext( 3) = "M"
'datetext( 4) = "A"
'datetext( 5) = "M"
'datetext( 6) = "J"
'datetext( 7) = "J"
'datetext( 8) = "A"
'datetext( 9) = "S"
'datetext(10) = "O"
'datetext(11) = "N"
'datetext(12) = "D"
'datetext(13) = "J"

'datetext( 1) = "jan"
'datetext( 2) = "feb"
'datetext( 3) = "mar"
'datetext( 4) = "apr"
'datetext( 5) = "may"
'datetext( 6) = "jun"
'datetext( 7) = "jul"
'datetext( 8) = "aug"
'datetext( 9) = "sep"
'datetext(10) = "oct"
'datetext(11) = "nov"
'datetext(12) = "dec"
'datetext(13) = "jan"
End Sub

Sub Angles

lc=lon-cm    'longitude correction
lcr=lc*d2r   'longitude correction in radians
slc=Sin(lcr) 'sin(longitude correction)
clc=Cos(lcr) 'cos(longitude correction)

lr=l*d2r     'longitude in radians
sl=Sin(lr)   'sin(latitude)
cl=Cos(lr)   'cos(latitude)

dr=d*d2r     'declination in radians
sd=Sin(dr)   'sin(declination)
cd=Cos(dr)   'cos(declination)

ir=i*d2r     'inclination in radians
si=Sin(ir)   'sin(inclination)
ci=Cos(ir)   'cos(inclination)

rr=rot*d2r   'rotation in radians
sr=Sin(rr)   'sin(rotation)
cr=Cos(rr)   'cos(rotation)

End Sub

Sub Convert

'rotation to horizontal plane
x1=x0
y1=sl*y0+cl*z0
z1=-cl*y0+sl*z0
'rotation for declination of the plane
x2=cd*x1-sd*y1
y2=sd*x1+cd*y1
z2=z1
'rotation for the inclination of the plane
x3=x2
y3=ci*y2+si*z2
z3=-si*y2+ci*z2
'rotation of the box in its plane
x4=cr*x3+sr*y3
y4=-sr*x3+cr*y3
z4=z3

End Sub

Sub Main

anr=an*d2r  'in radians
xnod=rnod*Sin(anr) 'nodus point
ynod=rnod*Cos(anr)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'dcAddLayer "ShadowCastingPoints"
dcAddLayer "DateLines"
dcAddLayer "Scheme"
dcSetLineParms dcBlack, dcSolid, dcThin

abb=0
att=0
If per=0 Then
 spring=1
 Drawing
End If
If per=1 Then
 spring=0
 Drawing
End If
If per=2 Then
 spring=1
 Drawing
 spring=0
 Drawing
End If

ab=abb-.3
at=att

dcSetLineParms dcBlack, dcSolid, dcThin

dcCreateLine 0,ab,0,at
dcCreateLine ar/2,ab,ar/2,at
dcCreateLine al/2,ab,al/2,at
dcCreateLine al,0,ar,0
dcCreateLine al,ab,al,at
dcCreateLine al,at,ar,at
dcCreateLine ar,at,ar,ab
dcCreateLine ar,ab,al,ab

bar=ba*d2r
ear=ea*d2r
While bar<-pi
 bar=bar+2*pi
Wend
While bar>pi
 bar=bar-2*pi
Wend
If surf=1 Then bar=-bar
While ear<-pi
 ear=ear+2*pi
Wend
While ear>pi
 ear=ear-2*pi
Wend
If surf=1 Then ear=-ear

dcSetLineParms dcPurple, dcSolid, dcThick
dcCreateLine r*bar,ab,r*bar,at
dcCreateLine r*ear,ab,r*ear,at
dcSetLineParms dcBlack, dcSolid, dcThin


'dcSetLineParms dcBlack, dcStitch, dcThin

'dcCreateLine 0,ab-a,0,ab
'dcCreateLine 0,ab-a,0-a,ab
'dcCreateLine 0,ab-a,a,ab

'dcCreateLine 0,at+a,0,at
'dcCreateLine 0,at+a,0-a,at
'dcCreateLine 0,at+a,a,at

'dcCreateLine al-b,0,al,0
'dcCreateLine al-b,0,al,0-b
'dcCreateLine al-b,0,al,b

'dcCreateLine ar+b,0,ar,0
'dcCreateLine ar+b,0,ar,0-b
'dcCreateLine ar+b,0,ar,b

'dcSetCurrentLayer "default"

'dcCreateCircle 0,ab-a,.05
'dcCreateCircle 0,at+a,.05
'dcCreateCircle al-b,0,.05
'dcCreateCircle ar+b,0,.05

If l>=0 Then
 ll=CStr(l)+" N"
 ud=0
Else
 ll=CStr(-Val(l))+" S"
 ud=180
End If
If lon>=0 Then lol=CStr(lon)+" E" Else lol=CStr(-Val(lon))+" W"
dcSetTextParms dcDarkPurple, "Tahoma","Bold",0,8,21,0,0
dcCreateText (al+ar)/2,ab-0.2,0,p
dcCreateText (al+ar)/2-2.5*r,ab-0.2,0,"Latitude "+ll
dcCreateText (al+ar)/2+2.5*r,ab-0.2,0,"Longitude "+lol
dcCreateText (al+ar)/2,ab-0.4,0,"Declination "+CStr(d)
dcCreateText (al+ar)/2,ab-0.55,0,"Inclination "+CStr(i)
dcCreateText (al+ar)/2,ab-0.7,0,"Rotation "+CStr(rot)
If flon=1 Then
 dcCreateText (al+ar)/2,ab-.85,0,"With Longitude correction"
Else
 dcCreateText (al+ar)/2,ab-.85,0,"Without Longitude correction"
End If
If feot=1 Then
 dcCreateText (al+ar)/2,ab-1,0,"With EOT correction"
Else
 dcCreateText (al+ar)/2,ab-1,0,"Without EOT correction"
End If

dcSetLineParms dcBlack, dcSolid, dcThin

dcSetTextParms dcBlack,"Tahoma","Bold",0,8,21,0,0
dcCreateText (al+ar)/2,ab-1.2,0,"Author: Valentin Hristov, Sofia, Bulgaria"
dcCreateText (al+ar)/2,ab-1.35,0,"E-mail: valhrist@bas.bg"
dcCreateText (al+ar)/2,ab-1.5,0,"Web page: www.math.bas.bg/complan/valhrist/mystuff.htm"


End Sub 'Main

Sub Drawing
' hour lines
cs=0                         'counter for spline
For ha=0 To 23.999 Step 1/nl
 ' civil and daylight savings labels
 ham=ha-1
 ham=ham-Int(ham/12)*12+1 'ha (12)
 ham1=ham
 ham1=ham1-Int(ham1/12)*12+1 'ha+1 (12)

 hhv=False
 hhb=True
 hhe=False
 If spring=1 Then nom=183 Else nom=184
 For ind1=1 To nom
  If spring=1 Then
   If ind1<12 Then count=354+ind1 Else count=ind1-11
  Else
   count=171+ind1
  End If
  hac=ha*15+flon*lc-feot*eot(count)/4
  hacr=hac*d2r
  shac=Sin(hacr)
  chac=Cos(hacr)
  dsr=decl(count)*d2r
  sds=Sin(-dsr)
  cds=Cos(-dsr)
  x0=-shac*cds
  y0=-chac*cds
  z0=sds

  convert

If nod=1 Then
 Nodus
Else
If x4>0 Then
 xx=r*(pi/2-arcsin(y4/Sqr(x4*x4+y4*y4)))
Else
 xx=r*(-pi/2-arcsin(-y4/Sqr(x4*x4+y4*y4)))
End If
yy=rrr*z4/Sqr(x4*x4+y4*y4)
End If
If surf=1 Then xx=-xx

'  cylinder

  If (z1<0 _
      And xx>al And xx<ar _
      And yy>ab And yy<at) Then 'illuminated rectangle
   cs=cs+1
   spl(2*cs-1)=xx
   spl(2*cs)=yy
   If yy<abb Then abb=yy
   If yy>att Then att=yy

'   dcCreateCircle xx,yy,.002

   xe=xx
   ye=yy
   If hhb=True Then
    xb=xx
    yb=yy
    hhb=False
    hhv=True
   End If
  Else
   If cs>2 Then
    If spring=1 Then
     If ha=Int(ha) Then
      dcSetLineParms dcBlue, dcSOLID, dcTHICK
      dcSetSplineParms dcBlue, dcSOLID, dcTHICK
     Else
      dcSetLineParms dcBlue, dcSOLID, dcTHIN
      dcSetSplineParms dcBlue, dcSOLID, dcTHIN
     End If
    Else
     If ha=Int(ha) Then
      dcSetLineParms dcRed, dcSOLID, dcTHICK
      dcSetSplineParms dcRed, dcSOLID, dcTHICK
     Else
      dcSetLineParms dcRed, dcSOLID, dcTHIN
      dcSetSplineParms dcRed, dcSOLID, dcTHIN
     End If
    End If

'    dcCreateSpline spl(1),cs,False
    Draw

    cs=0
   Else
    If cs=2 Then
     dcCreateLine spl(1),spl(2),spl(3),spl(4)
    'else
     'dcCreateCircle spl(1),spl(2),.02
    End If
    cs=0
   End If
  End If ' illuminated
 Next ind1

 hhe=False
 If cs>2 Then                       'if the hour line finishes at 365
  If spring=1 Then
   If ha=Int(ha) Then
    dcSetLineParms dcBlue, dcSOLID, dcTHICK
    dcSetSplineParms dcBlue, dcSOLID, dcTHICK
   Else
    dcSetLineParms dcBlue, dcSOLID, dcTHIN
    dcSetSplineParms dcBlue, dcSOLID, dcTHIN
   End If
  Else
   If ha=Int(ha) Then
    dcSetLineParms dcRed, dcSOLID, dcTHICK
    dcSetSplineParms dcRed, dcSOLID, dcTHICK
   Else
    dcSetLineParms dcRed, dcSOLID, dcTHIN
    dcSetSplineParms dcRed, dcSOLID, dcTHIN
   End If
  End If
'  dcCreateSpline spl(1),cs,False
  Draw
 Else
  If cs=2 Then
   dcCreateLine spl(1),spl(2),spl(3),spl(4)
  'else
   'dcCreateCircle spl(1),spl(2),.02
  End If
 End If
 If (spring=1 And l>=0) Or (spring=0 And l<0) Then
  If ha=Int(ha) And hhe=False And hhv=True Then
   dcSetTextParms dcBlue, "Tahoma","Bold",0,8,21,0,0
   dcCreateText xe,ye-.1,0,CStr(ham)
   dcSetTextParms dcRed, "Tahoma","Bold",0,8,21,0,0
   dcCreateText xe,ye-.2,0,CStr(ham1)
  End If
 Else
  If ha=Int(ha) And hhe=False And hhv=True Then
   dcSetTextParms dcBlue, "Tahoma","Bold",0,8,21,0,0
   dcCreateText xb,yb-.1,0,CStr(ham)
   dcSetTextParms dcRed, "Tahoma","Bold",0,8,21,0,0
   dcCreateText xb,yb-.2,0,CStr(ham1)
  End If
 End If
 cs=0

Next ha

''''''''''''''''''''''''''''''''''''''''''''''''
dcSetCurrentLayer "DateLines"
''''''''''''''''''''''''''''''''''''''''''''''''
'Date lines
cs=0                         'counter for spline
If spring=1 Then
 bb=1
 ee=19
Else
 bb=19
 ee=37
End If

For j=bb To ee
 xlabel=0
 ylabel=0
 count=ind(j)
 hhv=False
 hhb=True
 hhe=False
 For ha=0 To 23.999 Step .1
  hac=ha*15+flon*lc-feot*eot(count)/4
  hacr=hac*d2r
  shac=Sin(hacr)
  chac=Cos(hacr)
  dsr=decl(count)*d2r
  sds=Sin(-dsr)
  cds=Cos(-dsr)
  x0=-shac*cds
  y0=-chac*cds
  z0=sds

  convert

If nod=1 Then
 Nodus
Else
 If x4>0 Then
  xx=r*(pi/2-arcsin(y4/Sqr(x4*x4+y4*y4)))
 Else
  xx=r*(-pi/2-arcsin(-y4/Sqr(x4*x4+y4*y4)))
 End If
 yy=rrr*z4/Sqr(x4*x4+y4*y4)
End If

If surf=1 Then xx=-xx

  If (z1<0 _
      And xx>al And xx<ar _
      And yy>ab And yy<at) Then 'illuminated rectangle
   cs=cs+1
   If yy<ylabel Then
    xlabel=xx
    ylabel=yy
   End If
   spl(2*cs-1)=xx
   spl(2*cs)=yy
   If yy<abb Then abb=yy
   If yy>att Then att=yy

'   dcCreateCircle xx,yy,.002

   xe=xx
   ye=yy
   If hhb=True Then
    xb=xx
    yb=yy
    hhb=False
    hhv=True
   End If
  Else
   If cs>2 Then
    If j+1=Int((j+1)/3)*3 Then
     If spring=1 Then
      dcSetLineParms dcBlue, dcSOLID, dcTHICK
      dcSetSplineParms dcBlue, dcSOLID, dcTHICK
     Else
      dcSetLineParms dcRed, dcSOLID, dcTHICK
      dcSetSplineParms dcRed, dcSOLID, dcTHICK
     End If
    Else
     If spring=1 Then
      dcSetLineParms dcBlue, dcSOLID, dcTHIN
      dcSetSplineParms dcBlue, dcSOLID, dcTHIN
     Else
      dcSetLineParms dcRed, dcSOLID, dcTHIN
      dcSetSplineParms dcRed, dcSOLID, dcTHIN
     End If
    End If

   ' dcCreateSpline spl(1),cs,False
   Draw
    cs=0
   Else
    If cs=2 Then
     dcCreateLine spl(1),spl(2),spl(3),spl(4)
    'else
     'dcCreateCircle spl(1),spl(2),.02
    End If
    cs=0
   End If
  End If
 Next ha



 hhe=False
 If cs>2 Then
    If j+1=Int((j+1)/3)*3 Then
     If spring=1 Then
      dcSetLineParms dcBlue, dcSOLID, dcTHICK
      dcSetSplineParms dcBlue, dcSOLID, dcTHICK
     Else
      dcSetLineParms dcRed, dcSOLID, dcTHICK
      dcSetSplineParms dcRed, dcSOLID, dcTHICK
     End If
    Else
     If spring=1 Then
      dcSetLineParms dcBlue, dcSOLID, dcTHIN
      dcSetSplineParms dcBlue, dcSOLID, dcTHIN
     Else
      dcSetLineParms dcRed, dcSOLID, dcTHIN
      dcSetSplineParms dcRed, dcSOLID, dcTHIN
     End If
    End If
 ' dcCreateSpline spl(1),cs,False
  Draw
 Else
  If cs=2 Then
   dcCreateLine spl(1),spl(2),spl(3),spl(4)
  'else
   'dcCreateCircle spl(1),spl(2),.02
  End If
 End If
 cs=0
 dcSetTextParms dcBlack, "Tahoma","Bold",0,8,21,0,0
  If j+1=Int((j+1)/3)*3 Then
' if nod=1 then
  If 0>ylabel And ylabel>-lb Then
   dcCreateText xlabel,ylabel,0,"1 "+datetext((j+1)/3)
  End If
' else
'   mmm=rrr*tan(((90-abs(l))+l/abs(l)*decl(count))*d2r)
'   if 0<mmm and mmm<la then
'    dcCreateText 0,0-mmm,0,"1 "+datetext((j+1)/3)
'   end if
' end if
  End If

Next j

dcSetCurrentLayer "default"

End Sub 'Drawing

Sub Scheme

dcSetCurrentLayer "Scheme"

dcSetLineParms dcBlack, dcSolid, dcThin
dcCreateLine 0,.9*r,0,3.1*r
dcCreateLine -1.1*r,2*r,1.1*r,2*r
dcSetLineParms dcBlue, dcSolid, dcThick
dcCreateCircle 0,2*r,r
If nod=0 Then
 dcSetCircleParms dcYellow, dcFill, dcNormal
 dcCreateCircle 0,2*r,Abs(rrr-r)
 dcSetCircleParms dcBLACK, dcSOLID, dcTHIN
 If rrrr<0.02 Then
  dcCreateCircle 0,2*r,.02
 Else
  dcCreateCircle 0,2*r,rrrr
 End If
End If
If surf=1 Then sur=-1 Else sur=1
If nod=1 Then
 dcSetLineParms dcBLACK, dcSOLID, dcTHIN
 dcSetCircleParms dcDarkPurple, dcFill, dcNormal
' dcCreateLine -.2,2,.2,2
' dcCreateLine 0,1.8,0,2.2
 dcCreateLine sur*r*Sin(anr),2*r+sur*r*Cos(anr),sur*xnod,2*r+sur*ynod
 dcCreateLine sur*r*anr,0,sur*r*anr,r-rnod
 dcCreateCircle sur*xnod,2*r+sur*ynod,.05
 dcCreateCircle sur*r*anr,r-rnod,.05
 dcSetCircleParms dcBLACK, dcSOLID, dcTHIN
End If

dcSetTextParms dcGreen, "Tahoma","Bold",0,12,21,0,0
dcSetLineParms dcGreen, dcArrow, dcNormal
dcSetCircleParms dcGreen, dcArrow, dcNormal

dcCreateLine r*pi/2,.45*r,-r*pi/2,.45*r

If surf=1 Then
 dcCreateCircleEx 0,2*r,-r*1.05,2*r,r*1.05,2*r,1.05*r,1.05*r,0,2
Else
 dcCreateCircleEx 0,2*r,r*.92,2*r,-r*.92,2*r,.92*r,.92*r,0,1
End If
dcSetTextParms dcDarkPurple,"Tahoma","Bold",0,12,21,0,0
If i=0 Then    ' horisontal top cicle base
 dirs(1)="N"
 dirs(2)="W"
 dirs(3)="S"
 dirs(4)="E"
 ang=(d-rot)*d2r
 dcSetLineParms dcBLACK, dcSOLID, dcTHIN
 For j=1 To 4
  a=sur*Cos(ang+j*pi/2)
  b=sur*Sin(ang+j*pi/2)
  x=1.2*r*a
  y=2*r+1.2*r*b
  dcCreateText x,y,0,dirs(j)
  x1=r*a
  y1=2*r+r*b
  x2=1.1*r*a
  y2=2*r+1.1*r*b
  dcCreateLine x1,y1,x2,y2
 Next j
End If

dcSetTextParms dcBlack,"Tahoma","Bold",0,12,21,0,0
dcSetCircleParms dcBLACK,dcSOLID,dcTHIN

If nod=0 And rrrr>=.25*r Then
 dcCreateText 0,4.6*r,0,"Aligning a thick base"
 dcCreateLine -2*r,4.3*r,-rrrr,4.3*r
 dcCreateLine rrrr,4.3*r,2*r,4.3*r
 If high=0 Then
  dcCreateLine -r,4.5*r,-rrrr,4.5*r
  dcCreateLine rrrr,4.5*r,r,4.5*r
  dcCreateLine -r,3.5*r,-r,4.5*r
  dcCreateLine r,3.5*r,r,4.5*r
  dcCreateLine -rrrr,4.3*r,-rrrr,4.5*r
  dcCreateLine rrrr,4.3*r,rrrr,4.5*r
  dcSetLineParms dcYELLOW,dcARROW,dcTHICK
  dcCreateLine r,3.5*r,rrrr,4.3*r
 Else
  dcCreateLine -r,4.1*r,-rrrr,4.1*r
  dcCreateLine rrrr,4.1*r,r,4.1*r
  dcCreateLine -r,3.5*r,-r,4.3*r
  dcCreateLine r,3.5*r,r,4.3*r
  dcCreateLine -rrrr,4.3*r,-rrrr,4.1*r
  dcCreateLine rrrr,4.3*r,rrrr,4.1*r
  dcSetLineParms dcYELLOW,dcARROW,dcTHICK
  dcCreateLine r,3.5*r,-rrrr,4.3*r
  End If
End If

dcSetCurrentLayer "default"

End Sub 'Scheme

'''''''''''''''''''''''''''''''''''''''
Function arcsin(ByVal x) As Double
If Abs(x) > 0.999999999999 Then x = sgn(x)*0.999999999999
  arcsin = Atn(x/Sqr(1-x*x))
End Function

Function arccos(ByVal x) As Double
  arccos = pi/2-arcsin(x)
End Function

Function test(varname,x,minval,maxval) As boolean
If IsNumeric(x) = false Then
test = false
outtext = varname & " must be numeric"
MsgBox outtext
exit Function
End If
If x < minval Or x > maxval Then
outtext = varname & " must be between " & chr$(13) & minval & "  and  " & maxval
MsgBox outtext
exit Function
End If
test = true
End Function

Sub Draw

'splin=1  'does not work properly if lat > 66.5
'splin=0  'draws only the short segments

If splin=0 Then
 For jj=1 To cs-1
  xx1=spl(2*jj-1)
  yy1=spl(2*jj)
  xx2=spl(2*jj+1)
  yy2=spl(2*jj+2)
  If Abs(xx2-xx1)<.2 Then     'only short segments
   dcCreateLine xx1,yy1,xx2,yy2
  End If
 Next jj
Else
 dcCreateSpline spl(1),cs,False
End If
End Sub 'Draw

Sub Nodus
'Variant "azimuth like" angle

aaa=x4*x4+y4*y4        'coefficients of the quadratic equation
bbb=xnod*x4+ynod*y4
ccc=xnod*xnod+ynod*ynod-r*r

'if z4<0 then
lambda=(-bbb+Sqr(bbb*bbb-aaa*ccc))/aaa 'solution of the quadratic equation
'else
'lambda=(-bbb-sqr(bbb*bbb-aaa*ccc))/aaa 'solution of the quadratic equation
'end if
x=xnod+lambda*x4   'intersection of the beam with the cylinder
y=ynod+lambda*y4
z=lambda*z4

'cases
If y=0 Then
 If x>0 Then xx=r*pi/2
 If x<0 Then xx=-r*pi/2
Else
 phi=Atn(x/y)
 If y<0 Then
  If x=0 Then phi=r*pi
  If x>0 Then phi=phi+pi
  If x<0 Then phi=phi-pi
 End If
 xx=r*phi     'flat surface of the cylinder
End If

yy=z

End Sub 'Nodus