10 REM ***   PROGRAM HALO  DOTTED HALOS IN COLOR  ***
20 REM ***   VERSION 11 JUNE 1993   ***

30 REM ***   CONSTANTS    ***
40 RT3 = SQR(3)
50 DN = -.0333: NVIOLET = 1.317
60 PI = 3.141593: DRC = PI / 180
70 KRAY = 8.25 * 10 ^ (-3): RAYIN = -1
80 RANDOMIZE TIMER
99 REM ***   INPUT DATA   ***
100 GOSUB 4500

299 REM ***   SUN BEAM  DIRECTIONS AND SCATTERING FACTORS   ***
300 ASUN = SIN(Z): BSUN = 0: CSUN = -COS(Z)
310 IF ABS(CSUN) < .025 THEN CSUN2 = -.025 ELSE CSUN2 = CSUN
320 PSKY1 = EXP(KRAY * BETA * PCLD / CSUN2)
330 PSKY2 = EXP(-KRAY * BETA * (1 - PCLD))
340 TAU2 = -TAU / CSUN2
350 ZSUN = ATN(-CSUN / SQR(1.0001 - CSUN ^ 2)) * 2 / PI - 1
360 IF CHVW = 0 THEN ZMIN = -1 ELSE ZMIN = ZSUN - XVW * 3 / 4

400 CLS : SCREEN 12: PALETTE 7, 4671
410 WINDOW (-XVW, ZMIN)-(XVW, ZMIN + 1.5 * XVW)
420 CIRCLE (0, ZSUN), .0044, 12: PAINT (0, ZSUN), 12
425 COLOR 8
430 LOCATE 1, 20: PRINT "Z ="; Z / DRC; "     ç ="; TAU; "     á ="; BETA
432 LOCATE 2, 20: PRINT "   P CLOUD = "; PCLD * 1000

439 REM ***   ENTER CALCULATION LOOPS   ***
440 FOR II = 1 TO NCT
CHTLT = CHTLTN(II): CTLT = CTLTN(II)
MTLT = MTLTN(II): MTLT1 = MTLT1N(II)
RTLT = RTLTN(II)
RASP = RASPN(II): KSP = KSPN(II)
RCTA = RCTAN(II): HXA = HXAN(II)
NDOTS = NDOTSN(II)

450 FOR IDOT = 1 TO NDOTS
460 AS2 = ASUN: BS2 = BSUN: CS2 = CSUN

499 REM ***   CHOOSE COLOR   ***
500 LRAY = RND * .3 + .4
510 IF AA = 1 THEN PRAY = 1 - EXP(KRAY / (LRAY ^ 4))
520 IF LRAY < .43 THEN HUE = 1: GOTO 590
530 IF LRAY > .43 AND LRAY < .46 THEN HUE = 9: GOTO 590
540 IF LRAY > .46 AND LRAY < .5 THEN HUE = 3: GOTO 590
550 IF LRAY > .5 AND LRAY < .56 THEN HUE = 2: GOTO 590
560 IF LRAY > .56 AND LRAY < .59 THEN HUE = 14: GOTO 590
570 IF LRAY > .59 AND LRAY < .62 THEN HUE = 7: GOTO 590
580 HUE = 4
590 NRAY = NVIOLET + DN * (LRAY - .4)

599 REM ***   SCATTERING ABOVE CLOUD   ***
600 IF AA = 1 THEN PCT1 = PSKY1 ^ (1 / LRAY ^ 4) ELSE 700
610 IF RND > PCT1 THEN 2990

699 REM ***   CRYSTAL TOP (7) AND BOTTOM (8) FACE DIRECTIONS   ***
700 THTA(7) = 2 * PI * RND
710 RAYIN = -1
720 IF CHTLT = 1 THEN PHI(7) = CTLT: GOTO 760
730 X = RND
740 IF CHTLT = 2 THEN PHI(7) = MTLT1 + MTLT * COS(X * PI / 2): GOTO 760
750 PHI(7) = PI / 2 - ATN(X / SQR(1 - X ^ 2))
760 A(7) = SIN(PHI(7)) * COS(THTA(7))
770 B(7) = SIN(PHI(7)) * SIN(THTA(7))
780 C(7) = COS(PHI(7))
800 A(8) = -A(7): B(8) = -B(7): C(8) = -C(7)
810 PHI(8) = PI - PHI(7): THTA(8) = THTA(7) + PI
820 CSZ(7) = A(7) * ASUN + C(7) * CSUN: CSZ(8) = -CSZ(7)
830 PA(7) = -HXA * CSZ(7)
840 IF PA(7) > 0 THEN CHIN(7) = 0 ELSE CHIN(7) = 1
850 PA(8) = -PA(7): CHIN(8) = 1 - CHIN(7)
860 HEN = 7 + CHIN(7): HEX = 8 - CHIN(7)

900 REM ***   CRYSTAL SIDE (1-6) DIRECTIONS   ***
910 LMD = -PI / 3 + RTLT * (2 * RND - 1): REM FOR FACE 1
920 FOR I = 1 TO 3
930 LMDA(I) = LMD + (I - 1) * PI / 3
IF COS(PHI(7)) = 0 THEN THTA(I) = THTA(7) + PI / 2 * SGN(SIN(LMDA(I))): GOTO 980
940 GOTO 970: REM IF I < 3 THEN 970
950 THTA(I) = THTA(7) - ATN(TAN(LMDA(I)) / COS(PHI(7)))
960 GOTO 980
970 THTA(I) = PI + THTA(7) + ATN(TAN(LMDA(I)) / COS(PHI(7)))
980 QQ = SQR(1 - SIN(PHI(7)) ^ 2 * COS(LMDA(I)) ^ 2)
990 A(I) = QQ * COS(THTA(I))
1000 B(I) = QQ * SIN(THTA(I))
1010 C(I) = SIN(PHI(7)) * COS(LMDA(I))
1020 A(I + 3) = -A(I): B(I + 3) = -B(I): C(I + 3) = -C(I)
1030 THTA(I + 3) = THTA(I) - PI
1040 CSZ(I) = A(I) * ASUN + C(I) * CSUN
1050 PA(I) = -RCTA * CSZ(I)
1060 IF PA(I) > 0 THEN CHIN(I) = 0 ELSE CHIN(I) = 1
1070 PA(I + 3) = -PA(I): CHIN(I + 3) = 1 - CHIN(I)
1080 CSZ(I + 3) = -CSZ(I)
1090 NEXT I

1100 REM ***   CHOOSE ENTRY FACE  -  CSZ(I) < 0  ***
1110 TPA = ABS(PA(7)): CIN = 0
1120 PRND = RND
1130 IF PRND <= TPA THEN CIN = 7 + CHIN(7): GOTO 1190
1135 CTPA = 0
1140 FOR I = 1 TO 3
1150 IF CTPA = 1 THEN 1170
1160 TPA = TPA + ABS(PA(I))
1162 IF PRND < TPA THEN CIN = I + 3 * CHIN(I) ELSE 1170
1164 CTPA = 1
1170 NEXT I
1180 IF CIN = 0 THEN 700: REM MISS - GET ANOTHER CRYSTAL
1190 CSZ12 = CSZ(CIN)

1199 REM ***   ORDER OF ENTRY AND EXIT FACES   ***
1200 SEX1 = 1: MXCSZ = CSZ(1)
1210 FOR I = 2 TO 6
1220 IF CSZ(I) > MXCSZ THEN MXCSZ = CSZ(I): SEX1 = I
1230 NEXT I
1240 SEX2 = SEX1 MOD 6 + 1: SEX3 = (SEX1 - 1)
1250 IF SEX3 = 0 THEN SEX3 = 6
1260 IF CSZ(SEX2) < CSZ(SEX3) THEN SWAP SEX2, SEX3
1270 IF SEX1 > 3 THEN SEN1 = SEX1 - 3 ELSE SEN1 = SEX1 + 3
1280 IF SEX2 > 3 THEN SEN2 = SEX2 - 3 ELSE SEN2 = SEX2 + 3
1290 IF SEX3 > 3 THEN SEN3 = SEX3 - 3 ELSE SEN3 = SEX3 + 3

1300 REM ***   ANGLE BETWEEN RAY PLANE AND CRYSTAL NORMAL PLANE   ***
1310 AS1 = A(CIN): BS1 = B(CIN): CS1 = C(CIN)
1320 GOSUB 4000: REM GET NORMAL TO RAY PLANE
1330 ANR = AN: BNR = BN: CNR = CN
1340 GOSUB 3000
1350 IF RAYIN = -1 THEN S2 = 0: GOTO 2400: REM EXTERNAL REFLECTION

1399 REM ***   COMPONENT ANGLES BETWEEN RAY AND CRYSTAL   ***
1400 IF CIN < 7 THEN 1440
1410 XX = ABS(ANR * A(SEX1) + BNR * B(SEX1) + CNR * C(SEX1))
1420 THTAR = ATN(XX / SQR(1 - XX ^ 2))
1430 GOTO 2000

1440 ZRRAY = COS(RRAY)
1450 YRRAY = ABS(A(7) * AS2 + B(7) * BS2 + C(7) * CS2)
1452 XRAD = SIN(RRAY) ^ 2 - YRRAY ^ 2: IF XRAD < 0 THEN 2990
1454 XRRAY = SQR(XRAD)
1460 TNPR = YRRAY / ZRRAY: REM COULD BE IRAY
1470 PSIR = ATN(TNPR)
1480 TNTR = XRRAY / ZRRAY
1490 THTAR = ATN(TNTR)

1499 REM ***   SECOND CRYSTAL SIDE   ***
1500 IF ABS(THTAR) > PI / 6 THEN 1700
1510 PCTADJ = 0
1520 FCT1 = RT3 * TNTR
1530 IF RASP > 100 THEN PCTOPP = 1 - FCT1: PCTALT = FCT1: GOTO 1800
1540 FCT2 = (1 - RT3 / 2 / RASP * TNPR)
1550 PCTOPP = (1 - FCT1) * FCT2
1560 IF PCTOPP < 0 THEN PCTOPP = 0
1570 FCT3 = (1 - (RT3 / 2 - .375 * TNTR) / RASP * TNPR)
1580 IF FCT3 < 0 THEN PCTALT = 0: REM NEED MORE CAREFUL CRITERION
1590 PCTALT = FCT1 * FCT3
1600 PCTBOT = 1 - (PCTOPP + PCTALT)
1610 GOTO 1800

1700 FCT1 = (3 - RT3 * TNTR) / 2
1710 FCT2 = (1 - RT3 / 4 / RASP * (1 + (3 - RT3 * TNTR) / 4)) * TNPR
1720 PCTALT = FCT1 * FCT2
1730 IF PCTALT < 0 THEN PCTALT = 0
1740 FCT3 = (RT3 * TNTR - 1) / 2
1750 FCT4 = (1 - RT3 / 8 / RASP * (1 + FCT1 / 2)) * TNPR
1760 PCTADJ = FCT3 * FCT4
1770 IF PCTADJ < 0 THEN PCTADJ = 0
1780 PCTBOT = 1 - (PCTADJ + PCTALT): REM ALL WILL BE REFLECTED
1785 REM **  FROM ADJACENT SIDE SO MORE WILL STRIKE BOTTOM
1790 PCTOPP = 0

1800 YY = RND
1810 IF CIN = SEN1 THEN CROT = SEN1 - SEN2: GOTO 1830
1820 CROT = CIN - SEN1
1830 SADJ = (CIN + CROT) MOD 6: IF SADJ < 1 THEN SADJ = SADJ + 6
1840 SALT = (CIN + 2 * CROT) MOD 6: IF SALT < 1 THEN SALT = SALT + 6
1850 SOPP = (CIN + 3) MOD 6: IF SOPP < 1 THEN SOPP = SOPP + 6
1860 IF YY <= PCTADJ THEN S2 = SADJ: GOTO 2200
1870 IF YY <= PCTADJ + PCTALT THEN S2 = SALT: GOTO 2200
1880 IF YY <= PCTADJ + PCTALT + PCTOPP THEN S2 = SOPP: GOTO 2200
1890 S2 = HEX: GOTO 2200

1999 REM ***   HEXAGONAL FACE   ***
2000 FCT1 = RASP * TAN(RRAY) / (3 * RT3)
2010 IF FCT1 > 1 / (2 * RT3) THEN 2060
2020 PCTAC = FCT1 * COS(THTAR)
2030 PCTAL = FCT1 * SIN(PI / 6 - THTAR) / 2
2040 PCTAR = FCT1 * SIN(PI / 6 + THTAR) / 2
2050 PCTAB = 1 - (PCTAC + PCTAL + PCTAR)
2055 GOTO 2100
2060 PCTAC = 2 / 3 - THTAR / PI
2070 PCTAL = 1 / 6 - THTAR / PI
2080 PCTAR = 1 / 6 + 2 * THTAR / PI
2090 PCTAB = 0
2100 YY = RND
2110 IF YY <= PCTAC THEN S2 = SEX1: GOTO 2200
2120 IF YY <= PCTAC + PCTAL THEN S2 = SEX2: GOTO 2200
2130 IF YY <= PCTAC + PCTAL + PCTAR THEN S2 = SEX3: GOTO 2200
2140 S2 = HEX

2199 REM ***   RAY DIRECTION AFTER HITTING SECOND FACE   ***
2200 IF CIN > 6 AND S2 > 6 THEN 2990
2205 IF CIN < 7 AND S2 < 7 AND ABS(CIN - S2) = 3 THEN 2990
2210 AS1 = A(S2): BS1 = B(S2): CS1 = C(S2)
2220 CSZ12 = AS1 * AS2 + BS1 * BS2 + CS1 * CS2
2230 GOSUB 4000: REM GET NORMAL TO RAY PLANE
2240 ANR = AN: BNR = BN: CNR = CN
2250 GOSUB 3000

2270 IF RAYIN = 1 THEN 2990 ELSE 2400: REM STILL NEED SECOND DEVIATION
REM ***   INTERNALLY REFLECTED RAY - USE SOME SIMPLE CRITERIA   ***
             
2399 REM ***   SCATTERING EFFECTS ON HALO RAY   ***
2400 IF CS2 * VUP > 0 THEN 2990
2410 IF AA = 0 AND AA2 = 0 THEN 2800
2420 IF ABS(CS2) < .025 THEN CTRANS = SGN(CS2) * .025 ELSE CTRANS = CS2
2430 IF CS2 < 0 THEN 2500
2440 IF CTRANS = 0 THEN 2990 ELSE DSEC = 1 / CTRANS - 1 / CSUN2
2450 PCT2 = -(1 / CSUN2) / DSEC * (1 - EXP(TAU * DSEC))
2460 IF RND > PCT THEN 2990 ELSE 2800

2500 IF AA = 0 THEN 2530
2510 PCT3 = PSKY2 ^ (-1 / (LRAY ^ 4 * CTRANS))
2520 IF RND > PCT3 THEN 2990: REM SCATTERED BELOW CLOUD BASE
2530 IF AA2 = 0 THEN 2800
2540 IF ABS(CS2 - CSUN) < .01 THEN PCT2 = TAU2 * EXP(-TAU2): GOTO 2600
2550 DSEC = 1 / CTRANS - 1 / CSUN2
2560 PCT2 = -1 / CTRANS / DSEC * EXP(-TAU2) * (EXP(TAU * DSEC) - 1)
2600 IF RND > PCT2 THEN 2990

2800 REM ***   PLOT HALO DOTS   ***
2810 IF ABS(CS2) > 1 THEN RCOMP = 0: GOTO 2900
2820 RCOMP = ATN(ABS(CS2) / SQR(1 - CS2 ^ 2)) * 2 / PI - 1
2830 THCOMP = ATN(BS2 / AS2)
2840 XCOMP = RCOMP * SIN(THCOMP)
2850 YCOMP = SGN(AS2) * RCOMP * COS(THCOMP)
2900 PSET (XCOMP, YCOMP), HUE
2990 NEXT IDOT
2992 NEXT II
2995 CIRCLE (0, ZSUN), .0044, 14: PAINT (0, ZSUN), 14
WHILE INKEY$ = "": WEND
2999 END

3000 REM ***   REFLECTION AND REFRACTION COEFFICIENTS   ***
3010 IF ABS(CSZ12) < 1 THEN 3040
3020 IRAY = 0: RRAY = 0
3030 FR = ((NRAY - 1) / (NRAY + 1)) ^ 2
3035 GOTO 3100
3040 IRAY = PI / 2 - ATN(ABS(CSZ12 / SQR(1 - CSZ12 ^ 2)))
3050 XX = SIN(IRAY) * NRAY ^ RAYIN
3055 IF XX >= 1 THEN 3160
3060 RRAY = ATN(XX / (SQR(1 - XX ^ 2)))
3070 FR1 = (TAN(ABS(IRAY - RRAY)) / TAN(IRAY + RRAY)) ^ 2
3080 FR2 = (SIN(ABS(IRAY - RRAY)) / SIN(IRAY + RRAY)) ^ 2
3090 FR = .5 * (FR1 + FR2)
3100 RFRND = RND
3110 IF FR > RFRND THEN 3160
3120 RAYIN = -RAYIN
3130 QS2 = COS(ABS(IRAY - RRAY))
3140 QS1 = -COS(RRAY) * RAYIN
3150 GOTO 3500
3160 QS2 = COS(PI - 2 * IRAY)
3170 QS1 = -COS(IRAY) * RAYIN

3500 REM ***   DIRECTION OF REFRACTED OR REFLECTED RAYS   ***
3510 D1 = BS1 * CNR - CS1 * BNR
3520 D2 = AS1 * CNR - CS1 * ANR
3530 D3 = AS1 * BNR - BS1 * ANR
3540 DDET = AS2 * D1 - BS2 * D2 + CS2 * D3
3550 DM1 = BS2 * CNR - CS2 * BNR
3560 DM2 = AS2 * CNR - CS2 * ANR
3570 DM3 = AS2 * BNR - BS2 * ANR
3600 REM ***   NEW DIRECTION OF RAY   ***
3610 AS2 = (QS2 * D1 - QS1 * DM1) / DDET
3620 BS2 = -(QS2 * D2 - QS1 * DM2) / DDET
3630 CS2 = (QS2 * D3 - QS1 * DM3) / DDET
3690 RETURN

4000 REM ***   NORMAL DIRECTION TO PLANES   ***
4010 XN = BS1 * CS2 - CS1 * BS2
4020 YN = CS1 * AS2 - AS1 * CS2
4030 ZN = AS1 * BS2 - BS1 * AS2
4040 Q = SQR(XN ^ 2 + YN ^ 2 + ZN ^ 2)
4050 AN = XN / Q
4060 BN = YN / Q
4070 CN = ZN / Q
4080 RETURN

4500 REM SUBROUTINE FOR FRAMEWORK
4510 CLS : SCREEN 12
4520 GOSUB 5500
4530 COLOR 10: LOCATE 3, 34: PRINT "PROGRAM HALO"
4540 LOCATE 4, 29: PRINT "STANLEY DAVID GEDZELMAN"
4550 COLOR 15: LOCATE 7, 5: PRINT "THIS PROGRAM MAKES HALOS BY AIMING SUNLIGHT AT A CLOUD OF ICE CRYSTALS"
4560 COLOR 9: LOCATE 10, 15: PRINT "THE TYPE OF HALOS AND THEIR BRIGHTNESS DEPEND ON"
4570 COLOR 12: LOCATE 13, 7: PRINT "1. SOLAR ZENITH ANGLE"
4580 LOCATE 14, 7: PRINT "2. NUMBER OF DIFFERENT CRYSTALS"
4582 LOCATE 15, 7: PRINT "3. CRYSTAL RELATIVE DIMENSIONS"
4584 LOCATE 16, 7: PRINT "4. CRYSTAL ORIENTATIONS"
4586 LOCATE 17, 7: PRINT "5. ATMOSPHERIC TURBIDITY"
4588 LOCATE 18, 7: PRINT "6. HEIGHT OF CLOUD"
4589 LOCATE 19, 7: PRINT "7. OPTICAL DEPTH OF CLOUD"
4590 COLOR 14: LOCATE 23, 20: PRINT "HIT ANY KEY TO BEGIN MAKING YOUR CHOICES"
4600 WHILE INKEY$ = "": WEND
4610 CLS : GOSUB 5500
4620 COLOR 9: LOCATE 5, 24: PRINT "SOLAR ZENITH ANGLE AND HALO TYPES"
4630 COLOR 12: LOCATE 9, 5: PRINT "HIGH SUN (Z < 45ø) PRODUCES"
4632 COLOR 10: LOCATE 10, 7: PRINT "1. CIRCUMSCRIBED HALOS"
4634 LOCATE 11, 7: PRINT "2. CIRCUMHORIZONTAL ARCS   Z < 30ø"
4636 LOCATE 12, 7: PRINT "3. COMPLETE PARHELIC CIRCLES"
4640 COLOR 12: LOCATE 15, 5: PRINT "LOW SUN (Z > 45ø) PRODUCES"
4642 COLOR 10: LOCATE 16, 7: PRINT "1. SUN PILLARS AND SUN DOGS"
4644 LOCATE 17, 7: PRINT "2. CIRCUMZENITHAL ARCS   Z > 60ø"
4646 LOCATE 18, 7: PRINT "3. TANGENT ARCS"
4650 COLOR 13: LOCATE 21, 29: INPUT "SOLAR ZENITH ANGLE = ", Z
4660 Z = Z * DRC
4680 CLS : GOSUB 5500
4700 COLOR 9: LOCATE 4, 20: PRINT "IMPACT OF CLOUD THICKNESS AND ATMOSPHERE"
4710 COLOR 13: LOCATE 7, 5: PRINT "ATMOSPHERE"
4712 COLOR 10: LOCATE 8, 7: PRINT "1. DULLS HALO EVERYWHERE"
4714 LOCATE 9, 7: PRINT "2. DULLS AND REDDENS HALO AND SUNLIGHT NEAR HORIZON"
4720 COLOR 13: LOCATE 11, 5: PRINT "EFFECTS OF CLOUD THICKNESS"
4722 COLOR 10: LOCATE 12, 7: PRINT "1. THIN CLOUD (ç << 1)  = FAINT HALO WITH BRIGHTER BOTTOM"
4724 LOCATE 13, 7: PRINT "2. THICK CLOUD (ç >> 1) = WASHED OUT HALO WITH BRIGHTER TOP"
4730 COLOR 12: LOCATE 16, 5: PRINT "TYPE  0   FOR HALO IN VACUUM"
4732 LOCATE 17, 5: PRINT "TYPE  1   FOR HALO IN ATMOSPHERE"
4734 LOCATE 17, 50: INPUT "YOUR CHOICE = ", AA
4735 IF AA = 0 THEN 4760
4740 LOCATE 18, 5: INPUT "ENTER ATMOSPHERIC TURBIDITY   1 < á < 5                á = ", BETA
4750 LOCATE 19, 5: INPUT "ENTER CLOUD PRESSURE (MB)                              P = ", PCLD
4755 PCLD = PCLD / 1000
4760 COLOR 3: LOCATE 21, 5: PRINT "TYPE 0 FOR PERFECT HALO CLOUD"
4762 LOCATE 22, 5: PRINT "TYPE 1 FOR REAL HALO CLOUD"
4764 LOCATE 22, 50: INPUT "YOUR CHOICE = ", AA2
4765 IF AA2 = 0 THEN 4780
4770 LOCATE 23, 5: INPUT "ENTER CLOUD OPTICAL DEPTH                              ç = ", TAU
4780 CLS : GOSUB 5500

4800 COLOR 9: LOCATE 4, 23: PRINT "HALO TYPES AND CRYSTAL ORIENTATION"
4810 COLOR 12: LOCATE 7, 5: PRINT "RANDOMLY ORIENTED CRYSTALS PRODUCE"
4812 COLOR 10: LOCATE 8, 7: PRINT "1. CIRCULAR HALOS"
4820 COLOR 12: LOCATE 10, 5: PRINT "HORIZONTAL PENCILS PRODUCE"
4822 COLOR 10: LOCATE 11, 7: PRINT "1. TANGENT ARCS AND CIRCUMSCRIBED HALOS"
4824 LOCATE 12, 7: PRINT "2. SUN PILLARS"
4830 COLOR 12: LOCATE 14, 5: PRINT "HORIZONTAL PLATES PRODUCE"
4832 COLOR 10: LOCATE 15, 7: PRINT "1. CIRCUMHORIZONTAL AND CIRCUMZENITHAL ARCS"
4834 LOCATE 16, 7: PRINT "2. SUNDOGS"
4836 LOCATE 17, 7: PRINT "3. SUN PILLARS, SUBSUNS AND BOTTLINGLER'S RINGS"
4840 COLOR 15: LOCATE 24, 30: PRINT "HIT ANY KEY TO CHOOSE"
4850 WHILE INKEY$ = "": WEND
4855 CLS : GOSUB 5500
4860 COLOR 10: LOCATE 4, 33: PRINT "CRYSTAL CHOICES"
4870 COLOR 6: LOCATE 6, 5: INPUT "ENTER NUMBER OF DIFFERENT TYPE CRYSTALS (<5) = ", NCT
4880 COLOR 11: LOCATE 8, 34: PRINT "TILT OPTIONS"
4890 COLOR 9: LOCATE 9, 12: PRINT "FOR HEXAGONAL FACES"
4892 LOCATE 10, 6: PRINT "1 = CONST   2 = SWING   3 = RANDOM"
4894 COLOR 12: LOCATE 9, 52: PRINT "FOR RECTANGULAR SIDES"
4896 LOCATE 10, 48: PRINT "1 = ALMOST LEVEL   2 = RANDOM"
4900 COLOR 3: LOCATE 12, 5: PRINT "CRYSTAL ASPECT RATIO   PLATES << 1    PENCILS >> 1"
4910 COLOR 10: LOCATE 14, 33: PRINT "YOUR CHOICES"
4920 COLOR 6: LOCATE 16, 5: PRINT "CRYSTAL TYPE"
4930 COLOR 3: LOCATE 17, 5: PRINT "ASPECT RATIO"
4940 COLOR 13: LOCATE 18, 5: PRINT "1000'S OF CRYSTALS (<100)"
4950 COLOR 9: LOCATE 19, 5: PRINT "HEXAGON TILT OPTION"
4960 LOCATE 20, 5: PRINT "HEXAGON TILT (ø)"
4970 COLOR 12: LOCATE 21, 5: PRINT "RECTANGLE TILT OPTION"
4980 LOCATE 22, 5: PRINT "RECTANGLE TILT (<30ø)"
4990 FOR I = 1 TO NCT
5000 COLOR 6: LOCATE 16, 25 + 10 * I: PRINT "TYPE "; I
5010 COLOR 3: LOCATE 17, 25 + 10 * I: INPUT "= ", RASPN(I)
5020 KSPN(I) = 8 * RASPN(I) / (3 * SQR(3))
5030 MXPAN(I) = SQR(1 + KSPN(I) ^ 2): REM MAXIMUM PROJECTED AREA
5040 HXAN(I) = 1 / MXPAN(I): RCTAN(I) = KSPN(I) / (2 * MXPAN(I))
5050 COLOR 13: LOCATE 18, 25 + 10 * I: INPUT "= ", NDOTSN(I)
5055 NDOTSN(I) = NDOTSN(I) * 1000
5060 COLOR 9: LOCATE 19, 25 + 10 * I: INPUT "= ", CHTLTN(I)
5070 IF CHTLTN(I) = 3 THEN 5150
5080 IF CHTLTN(I) = 2 THEN 5120
5090 LOCATE 20, 25 + 10 * I: INPUT "= ", CTLTN(I)
5100 CTLTN(I) = CTLTN(I) * DRC
5110 IF RASPN(I) > 1 THEN CTLTN(I) = PI / 2 - CTLTN(I)
5115 GOTO 5150
5120 LOCATE 20, 25 + 10 * I: INPUT "= ", MTLTN(I)
5130 MTLTN(I) = MTLTN(I) * DRC
5140 IF RASPN(I) > 1 THEN MTLT1N(I) = PI / 2 ELSE MTLT1N(I) = 0
5145 IF RASPN(I) > 1 THEN MTLTN(I) = -MTLTN(I)
5150 COLOR 12: LOCATE 21, 25 + 10 * I: INPUT "= ", CHPARN(I)
5160 IF CHPARN(I) = 2 THEN RTLTN(I) = PI / 6: GOTO 5190
5170 IF CHPARN(I) = 1 THEN LOCATE 22, 25 + 10 * I: INPUT "= ", RTLTN(I)
5185 RTLTN(I) = RTLTN(I) * DRC
5190 NEXT I
5200 CLS : GOSUB 5500

5250 COLOR 9: LOCATE 4, 33: PRINT "VIEWING FIELD"
5260 COLOR 12: LOCATE 7, 33: PRINT "POINT OF VIEW"
LOCATE 9, 5: PRINT "LOOKING DOWN = 0"
5262 LOCATE 10, 5: PRINT "LOOKING UP   = 1"
5264 LOCATE 10, 45: INPUT "YOUR CHOICE = ", VUP
5266 IF VUP = 0 THEN VUP = -1
5270 COLOR 10: LOCATE 13, 27: PRINT "WIDTH OF VIEWING FIELD (%)"
5272 LOCATE 15, 5: PRINT " 50% SHOWS 30ø EACH SIDE OF SUN"
5274 LOCATE 16, 5: PRINT "100% SHOWS 90ø EACH SIDE OF SUN"
5276 LOCATE 16, 45: INPUT "YOUR CHOICE (%) = ", XVW: XVW = XVW / 100
5280 COLOR 13: LOCATE 19, 34: PRINT "PERSPECTIVE"
LOCATE 21, 5: PRINT "HORIZON FIXED VIEW = 0"
5282 LOCATE 22, 5: PRINT "SUN CENTERED VIEW  = 1"
5290 LOCATE 22, 45: INPUT "YOUR CHOICE = ", CHVW
5320 CLS : RETURN

5500 REM SUBROUTINE FRAME
5510 COLOR 15
5520 LINE (0, 0)-(640, 10), 11, BF
5530 LINE (0, 440)-(640, 450), 11, BF
5540 LINE (0, 0)-(10, 450), 11, BF
5550 LINE (630, 0)-(640, 450), 11, BF
5560 RETURN