PROGRAMA “ASOP”
DECLARE SUB ElegirArchivo (directorio$, pattern$, nombrearchivo$)
CONST pi = 3.14159265#
'define directorio de sistemas
CONST DirSistemas$ = ".\SISTEMAS\"
'define directorio de vidrios
CONST DirVidrios$ = ".\VIDRIOS\"
'define la trampa de errore
DIM SHARED UltimoError AS INTEGER
ON ERROR GOTO Errores
nray = 1500
DIM rcu(50), cur(50), rcl(50), ros(50), dis(50), vid$(51), cad$(50),
cci(50)
DIM co6(50), co8(50), co4(50), x(50), n(50), xpc(50), xpb(50), ypb(50)
DIM k(nray, 3), l(nray, 3), m(nray, 3), y0(nray, 3), z0(nray, 3)
DIM y(nray, 3), z(nray, 3), perdido%(nray, 3), ind(50, 3)
lon(1) = 4861: lon(2) = 5893: lon(3) =
6563
vid$(0) = "1"
SCREEN 12 'PROGRAMA
PRINCIPAL
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
CLS
1
GOSUB carsva
'cartel"S-V-A"
a$ = INPUT$(1)
CLS
SELECT CASE a$
CASE
"s"
GOSUB defsop 'define
sistema optico
GOSUB edisop 'edita
sistema optico
GOTO 4
CASE "v"
PRINT a$
GOSUB defvid 'define
vidrio
GOSUB edivid 'edita
vidrio
GOTO 3
CASE "a"
PRINT a$
GOTO 2 'lee archivo
CASE ELSE
END
END SELECT
2
CLS
COLOR 1
LOCATE 1, 1: PRINT "2"; : FOR i = 2 TO 70: PRINT
"Û"; : NEXT i
COLOR 15
'elige archivos de entrada
LOCATE 2, 58: PRINT "s: lista de sistemas"
LOCATE 3, 58: PRINT "v: lista de vidrios"
LOCATE 4, 58: PRINT CHR$(24); CHR$(25);
": busca"
LOCATE 5, 58: PRINT "enter: acepta"
LOCATE 1, 58: PRINT ; "Nombre a leer";
arch$ = ""
DO
LOCATE 1, 71: INPUT ; a$
a$ = LCASE$(a$)
IF a$ = "s" THEN
LOCATE 1, 58
ElegirArchivo DirSistemas$, "*.", arch$
ELSEIF a$ = "v" THEN
LOCATE 1, 58
ElegirArchivo DirVidrios$, "*.", arch$
ELSE
arch$ = a$
END IF
LOOP WHILE arch$ = ""
SELECT CASE VAL(LEFT$(arch$, 1))
CASE
IS = 0
GOSUB leevid 'lee archivo
de vidrio
'verifica si hay un error de lectura de
archivo
IF UltimoError > 0 THEN
UltimoError = 0
CLS
LOCATE 14, 36: PRINT "No hay "; arch$
SLEEP
CLS
GOTO 2
END IF
GOSUB edivid 'edita
vidrio
GOTO 3
CASE ELSE
GOSUB leesop 'lee
archivo de sistema optico
'verifica si hay un error de lectura de
archivo
IF UltimoError > 0 THEN
UltimoError = 0
CLS
LOCATE 14, 36: PRINT "No hay "; arch$;
SLEEP
GOTO 2
END IF
GOSUB edisop 'edita
sistema optico
GOTO 4
END SELECT
3
GOSUB cartgi 'cartel
"G-I"
a$ = INPUT$(1)
SELECT CASE a$
CASE
"i"
GOSUB indvid 'calcula
indices de vidrio en /\ cualquiera
GOSUB edivid 'edita
vidrio
GOTO 3
CASE "g"
PRINT a$
GOSUB gravid 'graba
vidrio
GOSUB edivid 'edita
vidrio
GOTO 3
CASE ELSE
GOTO 1
END SELECT
4
GOSUB cargid
a$ = INPUT$(1)
SELECT CASE a$
CASE "g"
PRINT a$
GOSUB grasop 'graba
sistema optico
GOTO 4
CASE "d"
PRINT a$
GOSUB dibsop 'dibuja
sistema optico
GOTO 4
CASE "i"
GOSUB indsop
'calcula indices de los vidrios en /\F, /\D, /\C
GOTO 5
CASE ELSE
GOTO 1
END SELECT
5
GOSUB ovfdce 'cartel
"O-V-F-D-C-E"
a$ = INPUT$(1)
SELECT CASE a$
CASE "f"
k = 1
GOSUB colind
'imprime columna de indices en /\F
GOTO 5
CASE "d"
k = 2
GOSUB colind 'imprime
columna de indices en /\D
GOTO 5
CASE "c"
k = 3
GOSUB colind 'imprime
columna de indices en /\C
GOTO 5
CASE "e"
GOSUB indexp 'pide
valores explicitos de los indices
GOTO 5
CASE "v"
GOSUB parvid
'imprime parametros de los vidrios
GOTO 5
CASE "o"
GOSUB trayos 'traza rayos
GOTO 6
CASE ELSE
GOTO 1
END SELECT
6
COLOR 1
LOCATE 1, 1: PRINT "6"; : FOR i = 2 TO 80: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 31: PRINT " bjeto"
LOCATE 1, 42: PRINT "Focos:"
LOCATE 1, 71: PRINT " xpl¡citos";
COLOR 12
LOCATE 1, 31: PRINT "O"
COLOR 9
LOCATE 1, 53: PRINT "F"
COLOR 14
LOCATE 1, 59: PRINT "D"
COLOR 12
LOCATE 1, 65: PRINT "C"
LOCATE 1, 71: PRINT "E"
COLOR 15
a$ = INPUT$(1)
SELECT CASE a$
CASE
"o"
GOSUB trayos 'traza rayos
GOTO 6
CASE "e"
LOCATE 1, 46
PRINT " ";
LOCATE 1, 47
PRINT " x ="; fexp;
INPUT a$: IF a$ <> "" THEN fexp = VAL(a$)
foco = fexp
GOSUB progra 'propaga y
grafica imagen en x explicito
GOTO 6
CASE "f"
foco = fpm(1)
GOSUB progra 'propaga y
grafica imagen en x = xF
GOTO 6
CASE "d"
foco = fpm(2)
GOSUB progra 'propaga y
grafica imagen en x = xD
GOTO 6
CASE "c"
foco = fpm(3)
GOSUB progra 'propaga y
grafica imagen en x = xC
GOTO 6
CASE ELSE
GOSUB edisop 'edita
el sistema optico
GOTO 4
END SELECT
'FIN
DEL PROGRAMA PRINCIPAL
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
defsop: 'define sistema optico
wid = 0
COLOR 1
LOCATE 1, 1: PRINT "1"; : FOR i = 2 TO 70: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 59: PRINT "nsu-Nombre: ";
LOCATE 1, 71: PRINT arch$; : INPUT a$
IF a$ <> "" THEN arch$ = a$
ypu = 0: rpu = 0
'inicializa pupila
nsu = VAL(arch$): 'fija Nø de
superficies
FOR i = 1 TO 8 'entrada de
comentarios
CLS
PRINT : PRINT "Comentario"; i; " (M ximo 3 renglones)"
PRINT : PRINT
PRINT cos$(i)
PRINT : PRINT
INPUT a$
IF a$ <> "" THEN cos$(i) = a$
IF cos$(i) = "" THEN EXIT FOR
NEXT i
CLS
PRINT : PRINT
PRINT "Vidrio"; 0
PRINT
PRINT vid$(0); : INPUT a$
IF a$ <> "" THEN vid$(0) = a$
CLS
FOR i = 1 TO nsu:
PRINT : PRINT
PRINT "Radio de curvatura"; i; " (mm)"
PRINT
PRINT rcu(i); : INPUT a$
IF a$ <> "" THEN rcu(i) = VAL(a$)
PRINT
PRINT "Radio claro"; i; " (mm)"
PRINT
PRINT rcl(i); : INPUT a$
IF a$ <> "" THEN rcl(i) = VAL(a$)
PRINT
PRINT "Radio oscuro"; i; " (mm)"
PRINT
PRINT ros(i); : INPUT a$
IF a$ <> "" THEN ros(i) = VAL(a$)
PRINT
PRINT "Distancia"; i; " (mm)"
PRINT
PRINT dis(i); : INPUT a$
IF a$ <> "" THEN dis(i) = VAL(a$)
PRINT
PRINT "Vidrio"; i
PRINT
PRINT vid$(i); : INPUT a$
IF a$ <> "" THEN vid$(i) = a$
PRINT
PRINT "a,d "; cad$(i);
: INPUT a$
IF a$ <> "" THEN cad$(i) = a$
'sud = superficie
que es diafragma
IF RIGHT$(cad$(i), 1) = "d" THEN
sud = i
IF LEFT$(cad$(i), 1) = "a" THEN
nas = nas + 1
GOSUB defasf
END IF
CLS
NEXT
i
'listado largo va con mas filas
IF nas + nsu > 18 THEN wid = 1
RETURN 'de defsop
defasf: 'define asferico
CLS
PRINT "
Asf‚ricos en superficie"; i
PRINT : PRINT
PRINT "Constante C¡trica"; i
PRINT : PRINT
PRINT cci(i); : INPUT a$
IF a$ <> "" THEN cci(i) = VAL(a$)
PRINT : PRINT
PRINT "Asf‚rico de 4§ orden"; i
PRINT : PRINT
PRINT co4(i); : INPUT a$
IF a$ <> "" THEN co4(i) = VAL(a$)
PRINT : PRINT
PRINT "Asf‚rico de 6§ orden"; i
PRINT : PRINT
PRINT co6(i); : INPUT a$
IF a$ <> "" THEN co6(i) = VAL(a$)
PRINT : PRINT
PRINT "Asf‚rico de 8§ orden"; i
PRINT : PRINT
PRINT co8(i); : INPUT a$
IF a$ <> "" THEN co8(i) = VAL(a$)
CLS
RETURN 'de
defasf
edisop: 'edita sistema optico
IF wid = 1 THEN WIDTH 80, 60
CLS
COLOR 15
lea = LEN(arch$) 'imprime
titulo subrayado
lin = 40 - INT(lea / 2)
LOCATE 3, lin
PRINT arch$
LOCATE 4, lin
FOR i = lin TO lin + lea - 1: PRINT "Ä"; : NEXT i
PRINT 'imprime
comentarios
FOR i = 0 TO 8
PRINT cos$(i)
NEXT i
DO: LOOP WHILE INKEY$ = ""
CLS
GOSUB cargid 'imprime
cartel "G-I-D"
ediso1: 'parte de edisop para ensamblar despues de
"V-idrios"
PRINT
PRINT " S³ Radio
Curv. ³
Radio Clr. Osc.³ Distancia ³ Vidrio ³ a,d"
sur$ =
"ÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄ-"
PRINT sur$;
LOCATE 5, 62: PRINT UCASE$(vid$(0))
nas = 0
FOR i = 1 TO nsu
PRINT i; TAB(7); USING "#######.###"; rcu(i);
PRINT TAB(23); USING "####.#"; rcl(i); TAB(32); ros(i);
PRINT TAB(43); USING "#######.##"; dis(i);
PRINT TAB(62); UCASE$(vid$(i)); TAB(78); cad$(i)
IF rcu(i) = 0 THEN cur(i) = 0:
ELSE cur(i) = 1 / rcu(i)
IF LEFT$(cad$(i), 1) = "a" THEN nas = nas + 1
NEXT
i
'si alguna superficie es asferica
IF nas <> 0 THEN GOSUB ediasf
WIDTH
80, 30
RETURN 'de
edisop y de ediso1
grasop:
CLS
PRINT "Nombre a grabar:
"; arch$;
INPUT a$: IF a$ <> "" THEN arch$ = a$
nsu = VAL(arch$)
OPEN DirSistemas$ + arch$ FOR OUTPUT AS 1
FOR i = 1 TO 8
WRITE #1, cos$(i)
NEXT i
FOR i = 1 TO nsu
WRITE #1, rcu(i), rcl(i), ros(i), dis(i), vid$(i), cad$(i), cci(i),
co4(i), co6(i), co8(i)
NEXT i
WRITE #1, dio, alo, lon(1), lon(2), lon(3), uni$, sud, wid, vid$(0)
CLOSE #1
GOSUB
ediso1
RETURN 'de grasop
leesop: 'lee
sistema optico
OPEN DirSistemas$ + arch$ FOR INPUT AS 1
FOR i = 1 TO 8
INPUT #1, cos$(i)
NEXT i
nsu = VAL(arch$)
FOR i = 1 TO nsu
INPUT #1, rcu(i), rcl(i), ros(i), dis(i), vid$(i), cad$(i), cci(i),
co4(i), co6(i), co8(i)
NEXT i
INPUT #1, dio, alo, lon(1), lon(2), lon(3), uni$, sud, wid, vid$(0)
CLOSE #1
RETURN 'de leesop
defvid: 'define vidrio
COLOR 1
LOCATE 1, 1: PRINT "1"; : FOR i = 2 TO 70: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 55: PRINT "Nombre: "; arch$;
INPUT a$: IF a$ <> "" THEN arch$ = a$
CLS
PRINT "c¢digo
"; : PRINT cod$;
INPUT a$
IF a$ <> "" THEN cod$ = a$
PRINT
PRINT "Comentario"; " (M ximo 3 renglones)"
PRINT
PRINT cov$
PRINT
PRINT
INPUT a$: IF a$ <> "" THEN cov$ = a$
CLS
PRINT "Coeficientes de la f¢rmula de dispersi¢n de Schott"
PRINT : PRINT : PRINT
FOR i = 1 TO 6
PRINT "A"; i - 1; "= ";
PRINT cfs(i);
INPUT a$
PRINT : PRINT
IF a$ <> "" THEN cfs(i) = VAL(a$)
NEXT
i
CLS 'entrada de
otros datos del vidrio
GOSUB nombre
PRINT cd1$; : PRINT cd1
INPUT a$: IF a$ <> "" THEN cd1 = VAL(a$)
PRINT
PRINT cd2$; : PRINT cd2
INPUT a$: IF a$ <> "" THEN cd2 = VAL(a$)
PRINT
PRINT tdi$; : PRINT tdi
INPUT a$: IF a$ <> "" THEN tdi = VAL(a$)
PRINT
PRINT tda$; : PRINT tda
INPUT a$: IF a$ <> "" THEN tda = VAL(a$)
PRINT
PRINT cei$; : PRINT cei
INPUT a$: IF a$ <> "" THEN cei = VAL(a$)
PRINT
PRINT cot$; : PRINT cot
INPUT a$: IF a$ <> "" THEN cot = VAL(a$)
PRINT
PRINT den$; : PRINT den
INPUT a$: IF a$ <> "" THEN den = VAL(a$)
PRINT
PRINT moy$; : PRINT moy
INPUT a$: IF a$ <> "" THEN moy = VAL(a$)
PRINT
PRINT rep$; : PRINT rep
INPUT a$: IF a$ <> "" THEN rep = VAL(a$)
PRINT
PRINT duk$; : PRINT duk
INPUT a$: IF a$ <> "" THEN duk = VAL(a$)
PRINT
PRINT ccb$; : PRINT ccb
INPUT a$: IF a$ <> "" THEN ccb = VAL(a$)
PRINT
PRINT crc$; : PRINT crc
INPUT a$: IF a$ <> "" THEN crc = VAL(a$)
PRINT
PRINT crt$; : PRINT crt
INPUT a$: IF a$ <> "" THEN crt = VAL(a$)
PRINT
PRINT cra$; : PRINT cra
INPUT a$: IF a$ <> "" THEN cra = VAL(a$)
PRINT
PRINT crk$; : PRINT crk
INPUT a$: IF a$ <> "" THEN crk = VAL(a$)
PRINT
PRINT ti5$; : PRINT ti5
INPUT a$: IF a$ <> "" THEN ti5 = VAL(a$)
PRINT
PRINT t25$; : PRINT t25
INPUT a$: IF a$ <> "" THEN t25 = VAL(a$)
PRINT
PRINT peb$; : PRINT peb
INPUT a$: IF a$ <> "" THEN peb = VAL(a$)
PRINT
RETURN 'de defvid
edivid: 'edita vdrio
CLS
'imprime titulo subrayado
lea = LEN(arch$ + cod$)
lin = 40 - INT(lea / 2)
LOCATE 3, lin
PRINT UCASE$(arch$) + cod$
LOCATE 4, lin
FOR i = lin TO lin + lea - 1: PRINT "Ä"; : NEXT i
PRINT
PRINT cov$ 'imprime
comentario
PRINT
GOSUB nombre
PRINT cd1$; cd1: PRINT cd2$; cd2: PRINT
tdi$; tdi: PRINT tda$; tda
PRINT cei$; cei: PRINT cot$; cot: PRINT den$; den: PRINT moy$; moy
PRINT rep$; rep: PRINT duk$; duk: PRINT ccb$; ccb: PRINT crc$; crc
PRINT crt$; crt: PRINT cra$; cra: PRINT crk$; crk: PRINT ti5$; ti5
PRINT t25$; t25: PRINT peb$; peb
DO: LOOP WHILE INKEY$ = ""
CLS
lea = LEN(arch$ + cod$)
lin = 40 - INT(lea / 2)
LOCATE 3, lin
PRINT UCASE$(arch$) + cod$
LOCATE 4, lin
FOR i = lin TO lin + lea - 1
PRINT "Ä";
NEXT i
PRINT : PRINT
PRINT "
Coeficientes de la f¢rmula de dispersi¢n de Schott"
PRINT : PRINT : PRINT
FOR i = 1 TO 6
PRINT " A"; i - 1; "= ";
cfs(i)
PRINT
NEXT i
RETURN
'de edivid
gravid: 'graba vidrio
CLS
COLOR 15
PRINT "Nombre a grabar:
"; arch$;
INPUT a$: IF a$ <> "" THEN arch$ = a$
OPEN DirVidrios$ + arch$ FOR OUTPUT AS 1
WRITE #1, cov$, cfs(1), cfs(2), cfs(3), cfs(4), cfs(5), cfs(6), cd1
WRITE #1, cd2, tdi, tda, cei, cot, den, moy, rep, duk, ccb
WRITE #1, crc, crt, cra, crk, ti5, t25, peb, cod$
CLOSE #1
RETURN 'de gravid
leevid: 'lee vidrio
PRINT "lee vidrio"
OPEN DirVidrios$ + arch$ FOR INPUT AS 1
INPUT #1, cov$, cfs(1), cfs(2), cfs(3), cfs(4), cfs(5), cfs(6), cd1
INPUT #1, cd2, tdi, tda, cei, cot, den, moy, rep, duk, ccb
INPUT #1, crc, crt, cra, crk, ti5, t25, peb, cod$
CLOSE #1
RETURN
'de leevid
indvid: 'calcula indice de vidrio en /\ cualquiera
COLOR 15
CLS
PRINT "/\ desde 3650 hasta 10140 (SI ES DE SCHOTT). Si sale
rojo es extrapolado"
PRINT
DO
PRINT
COLOR 15
INPUT "/\ = "; lon
IF lon = 0 THEN EXIT DO
'w = (lon / 10000) ^ 2
'ecuacion (4.50), formula de Schott
'ind = SQR(cfs(1) + cfs(2) * w + cfs(3) / w + cfs(4) / w ^ 2 + cfs(5) /
w ^ 3 + cfs(6) / w ^ 4)
'forma para mas velocidad
w = lon * lon / 100000000
ind = SQR(w * (w * (w * (w * (w * cfs(2) + cfs(1)) + cfs(3)) + cfs(4)) +
cfs(5)) + cfs(6)) / (w * w)
ind = INT(100000 * ind + .5) / 100000
IF lon < 3650 OR lon > 10140 THEN COLOR 12
PRINT
PRINT "n ="; ind
LOOP
RETURN 'de indvid
dibsop: 'dibuja sistema optico
CLS
PRINT "Las unidades pueden ser: mm, cm, m. Son "; uni$;
INPUT a$: IF a$ <> "" THEN uni$ = a$
'coordenadas x(i)
para cada superficie i
'si hay espejos no est n ordenadas de
menor a mayor
FOR i = 1 TO nsu
x(i + 1) = x(i) + dis(i)
NEXT
i
'm xima y m¡nima x(i) y su i
correspondiente
xma = -10000: xmi = 10000
FOR
i = 1 TO nsu
IF x(i) > xma THEN xma = x(i): ima = i
IF x(i) < xmi THEN xmi = x(i): imi = i
NEXT i
PRINT : PRINT
'primera y £ltima
flecha.
'las flechas se calculan con la ecuaci¢n
de la
'superficie
evaluada en r = rcl
'prf = primera flecha
prf = cur(imi) * rcl(imi) ^ 2 / (1 + SQR(1 - cur(imi) ^ 2 * (1 +
cci(imi)) * rcl(imi) ^ 2)) + co4(imi) * rcl(imi) ^ 4 + co6(imi) * rcl(imi) ^ 6
'si
es positiva se ignora
'si es negativa se la toma positiva
IF prf > 0 THEN prf = 0: ELSE prf = -prf
'ulf = £ltima
flecha
ulf = cur(ima) * rcl(ima) ^ 2 / (1 + SQR(1 - cur(ima) ^ 2 * (1 + cci(ima))
* rcl(ima) ^ 2)) + co4(ima) * rcl(ima) ^ 4 + co6(ima) * rcl(ima) ^ 6
'si es negativa se ignora
IF ulf < 0 THEN ulf = 0
'lto = longitud
total
lto = prf + ulf + x(ima) - x(imi)
'rma = radio claro m ximo
rma = -1E+10
FOR i = 1 TO nsu
IF rcl(i) > rma THEN rma = rcl(i)
NEXT
i
'si lto > rma el dibujo se limita
horizontalmenmte
'si lto < rma el dibujo se limita
verticalmente
'xpa = a*x+b, ypa = a*y
IF lto > rma THEN
'para que quede
limitado horizontalmente
a = 639 / (x(ima) - x(imi) + ulf + prf)
b = -a * (x(imi) - prf)
'x0 es la x en la que empieza el dibujo,
aqui cero
x0 = 0
ELSE
'para que quede limitado verticalmente
a = 239 / rma
b = 0
'aqu¡ x0 coloca al sistema en el centro
x0 = 639 * rma / 479 - lto / 2
END IF
CLS
SELECT
CASE uni$ 'unidades de longitud en
el dibujo
CASE IS = "mm"
uni = 1
CASE IS = "cm"
uni = 10
CASE IS = "m"
uni = 1000
END SELECT
'dibuja el marco
LINE (0, 0)-(639, 478), 2, B
IF lto < rma THEN stp = 239 * uni / rma: ELSE stp = 639 * uni / lto
'escala graduada
horizontal
FOR x = 0 TO 639 STEP stp
LINE (x, 0)-(x, 3), 2
LINE (x, 475)-(x, 478), 2
NEXT
x
'escala graduada vertical centrada en el
eje
FOR y = 0 TO 239 STEP stp
LINE
(0, 239 + y)-(3, 239 + y), 2
LINE (0, 239 - y)-(3, 239 - y), 2
LINE (636, 239 + y)-(639, 239 + y), 2
LINE (636, 239 - y)-(639, 239 - y), 2
NEXT y
'se dibujan las superficies
FOR i = 1 TO nsu
FOR y = ros(i) TO rcl(i) STEP rcl(i) / 1000
x = x0 + x(i) + cur(i) * y ^ 2 / (1 + SQR(1 - cur(i) ^ 2 * (1 + cci(i))
* y ^ 2)) + co4(i) * y ^ 4 + co6(i) * y ^ 6
xpa = a * x + b
ypa = a * y
PSET (xpa, 239 + ypa), 15
PSET (xpa, 239 - ypa), 15
'xpc es la xpa del centro
IF y = 0 THEN xpc(i) = xpa
NEXT
y
'xpb, ypb son las xpa, ypa del borde en
las que
'termin¢ el FOR...TO de y
xpb(i) = xpa: ypb(i) = ypa
IF i = sud THEN LINE (xpb(i), 239 - ypb(i))-(xpb(i), 0)
NEXT
i
'se usan las xpc, xpb, ypb para dibujar
los bordes
'de las lentes, el diafragma, o el eje si
el espacio
'es
de aire
FOR i = 1 TO nsu - 1
'se dibujan los
bordes
IF ABS(VAL(vid$(i))) = 1 THEN
LINE (xpc(i), 239)-(xpc(i + 1), 239), 15
ELSE
LINE (xpb(i), 239 + ypb(i))-(xpb(i + 1), 239 + ypb(i + 1)), 15
LINE (xpb(i), 239 - ypb(i))-(xpb(i + 1), 239 - ypb(i + 1)), 15
END IF
NEXT i
LINE (0, 239)-(x0 * 239 / rma, 239), 15
LINE (640, 239)-(640 - x0 * 239 / rma, 239), 15
'se dibuja el
diafragma
LINE (xpb(sud), 239 + ypb(sud))-(xpb(sud), 239 -
ypb(sud)), 0
LINE (xpb(sud), 239 - ypb(sud))-(xpb(sud), 0)
LINE (xpb(sud), 239 + ypb(sud))-(xpb(sud), 478)
LINE (xpb(sud) + 1, 239 - ypb(sud) - 2)-(xpb(sud) + 1, 0)
LINE (xpb(sud) + 1, 239 + ypb(sud) + 2)-(xpb(sud) + 1, 478)
LINE (xpb(sud) + 2, 239 - ypb(sud) - 4)-(xpb(sud) + 2, 0)
LINE (xpb(sud) + 2, 239 + ypb(sud) + 4)-(xpb(sud) + 2, 478)
'imprime la
unidad de medida
COLOR 15: LOCATE 29, 4: PRINT "1 " + uni$;
'imprime el
nombre del sistema optico
LOCATE 2, 4: PRINT arch$;
DO: LOOP WHILE INKEY$ = ""
CLS
PRINT
GOSUB ediso1
RETURN 'de dibsop
indsop: 'indsop: calcula indices de los vidrios en las 3
/\
COLOR 1
LOCATE 1, 1: FOR i = 1 TO 80: PRINT "Û"; : NEXT i
LOCATE 1, 62: PRINT " ";
LOCATE 1, 62
COLOR 9
PRINT "/\F ="; lon(1);
INPUT a$: IF a$ <> "" THEN lon(1) = VAL(a$)
LOCATE 1, 62: PRINT " ";
COLOR 14
LOCATE 1, 62
PRINT "/\D ="; lon(2);
INPUT
a$: IF a$ <> "" THEN lon(2) = VAL(a$)
LOCATE 1, 62: PRINT " ";
COLOR 12
LOCATE 1, 62
PRINT "/\C ="; lon(3);
INPUT a$: IF a$ <> "" THEN lon(3) = VAL(a$)
'calcula indices
desde el catalogo si no es aire
FOR i = 0 TO nsu
signo$ = ""
SELECT CASE ABS(VAL(vid$(i)))
CASE
IS = 0
'maneja los signos "-" para leer
vidrios
IF LEFT$(vid$(i), 1) = "-" THEN
vid$(i) = RIGHT$(vid$(i), LEN(vid$(i)) - 1): signo$ = "-"
OPEN DirVidrios$ + vid$(i) FOR INPUT AS 1
'repone el
"-" si lo habia
IF signo$ = "-" THEN vid$(i) =
"-" + vid$(i)
INPUT #1, basura$ 'perdon,
archivo secuencial mal armado
FOR j = 1 TO 6
INPUT #1, cfs(j)
NEXT j
FOR k = 1 TO 3
'w = (lon(k) / 10000) ^ 2
'ecuacion (4.50),
formula de Schott
'ind(i, k) = SQR(cfs(1) + cfs(2) * w +
cfs(3) / w + cfs(4) / w ^ 2 + cfs(5) / w ^ 3 + cfs(6) / w ^ 4)
'forma para mas velocidad
w = lon(k) * lon(k) / 100000000
ind(i, k) = SQR(w * (w * (w * (w * (w * cfs(2) + cfs(1)) + cfs(3)) +
cfs(4)) + cfs(5)) + cfs(6)) / (w * w)
ind(i, k) = INT(100000 * ind(i, k) + .5) / 100000
IF signo$ = "-" THEN ind(i, k) = -ind(i, k)
NEXT k
CLOSE #1
CASE IS = 1
FOR k = 1 TO 3
ind(i, k) = VAL(vid$(i))
NEXT k
END SELECT
NEXT i
RETURN 'de indsop
indexp:
FOR i = 0 TO nsu
COLOR 9
LOCATE 1, 48: PRINT " ";
LOCATE 1, 48: PRINT " n"; i; "="; : PRINT ind(i, 1);
INPUT a$: IF a$ <> "" THEN ind(i, 1) = VAL(a$)
LOCATE 1, 48: PRINT " ";
COLOR 14
LOCATE 1, 48: PRINT " ";
LOCATE 1, 48: PRINT " n"; i; "="; : PRINT ind(i, 2);
INPUT a$: IF a$ <> "" THEN ind(i, 2) = VAL(a$)
LOCATE 1, 48: PRINT " ";
COLOR 12
LOCATE 1, 48: PRINT " ";
LOCATE 1, 48: PRINT " n"; i; "="; : PRINT ind(i, 3);
INPUT a$: IF a$ <> "" THEN ind(i, 3) = VAL(a$)
LOCATE 1, 48: PRINT " ";
NEXT i
RETURN 'de indexp
parvid:
CLS
COLOR 15
PRINT " Valores en: ";
COLOR 9: LOCATE 1, 43: PRINT lon(1)
COLOR 14: LOCATE 1, 53: PRINT lon(2)
COLOR 12: LOCATE 1, 63: PRINT lon(3)
COLOR 15
PRINT
PRINT " Vidrio N£mero de Abbe Dispersion parcial"
PRINT
FOR i = 0 TO nsu
'si es aire (=
"1") pasa de largo
SELECT CASE ABS(VAL(vid$(i)))
CASE IS = 0
'numero de Abbe
nab = (ABS(ind(i, 2)) - 1) / (ABS(ind(i, 1)) - ABS(ind(i, 3)))
nab = INT(100 * nab + .5) / 100
'dispersion parcial
dpa = (ind(i, 1) - ind(i, 2)) / (ind(i, 1) - ind(i, 3))
dpa = INT(100000 * dpa + .5) / 100000
PRINT TAB(10); UCASE$(vid$(i)); TAB(33); nab; TAB(61); dpa
CASE ELSE
END SELECT
NEXT i
DO: LOOP WHILE INKEY$ = ""
CLS
PRINT
GOSUB ediso1
RETURN 'de parvid
colind: 'imprime columna de indices en /\F,/\D,/\C
SELECT CASE k
CASE 1
COLOR 9
CASE 2
COLOR 14
CASE 3
COLOR 12
END SELECT
FOR i = 0 TO nsu
LOCATE i + 5, 62
PRINT " "
LOCATE i + 5, 62
PRINT ind(i, k)
NEXT i
COLOR 15
RETURN 'de colind
trayos:
CLS
COLOR 1
LOCATE 1, 1
PRINT " Si el objeto
est en el infinito, va 0"
LOCATE 5, 1
FOR i = 1 TO 80: PRINT "Û"; : NEXT i
COLOR 15
LOCATE 5, 10
PRINT "Distancia objeto ="; dio;
INPUT a$: IF a$ <> "" THEN
dio = VAL(a$)
LOCATE 1, 1
PRINT " "
LOCATE 7, 1
COLOR 1
FOR i = 1 TO 80: PRINT "Û"; : NEXT i
COLOR 15
LOCATE 7, 10
SELECT CASE dio
CASE IS = 0
PRINT "Semicampo en grados ="; alo;
INPUT a$: IF a$ <> "" THEN alo = VAL(a$)
scr = alo * pi / 180 'semicampo en radianes
CASE ELSE
PRINT "Altura objeto"; alo;
INPUT a$: IF a$ <> "" THEN alo = VAL(a$)
END SELECT
'seccion rayos paraxiales
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
'1 -
determinacion de x de la pupila de entrada
'en color medio (D). Parametros iniciales
del rayo:
u = 1 'pendiente
arbitraria = 1
y = 0 'sale del
eje
n = ind(sud - 1, 2) 'indice
inicial es el anterior al diafragma
FOR s = sud TO 1 STEP -1'invierte parte del sistema optico
r = -rcu(s): d = dis(s - 1): n1 = ind(s - 1, 2)
GOSUB paraxi
NEXT s
xpe
= -y1 / u1 'xpe = x de la pupila
de entrada respecto de sup 1
'va signo - porque el rayo se traza de der
<- izq
rpe = rcl(sud) * ind(sud - 1, 2) / (ind(0, 2) * u1)
'rpe
= radio de la pupila de entrada por invariante
'de Lagrange
'2 - determinacion de la pupila de salida
u
= 1 'como antes
y = 0
n
= ind(sud, 2)
FOR s = sud TO nsu
r
= rcu(s): d = dis(s): n1 = ind(s, 2)
GOSUB paraxi
NEXT s
xps
= y1 / u1 'xps = x de la pupila
de salida respecto de sup nsu
rps = rcl(sud) * ind(sud, 2) / (ind(nsu, 2) * u1)
'rps = radio de
la pupila de salida por invariante
'de Lagrange
'3 - distancia imagen (focal) posterior y
equivalente
'paraxial en los 3 colores (focal para
objeto remoto)
FOR col = 1 TO 3
y =
1
n = ind(0, col)
IF dio = 0 THEN u = 0: ELSE u =
1 / dio
FOR s = 1 TO nsu
r = rcu(s): d = dis(s): n1 = ind(s, col)
GOSUB paraxi
NEXT s
fep(col)
= 1 / u1 'foco efectivo paraxial
fpp(col) = y1 / u1 'foco
posterior paraxial
IF dio = 0 THEN
yp(col) = -scr * ABS(fep(col))
ELSE 'y paraxial por invariante
de Lagrange
yp(col) = alo * ind(0, col) / (dio * ind(nsu, col) * u1)
END IF
NEXT col
y =
1 'plano principal
imagen
u
= 0 'solo objeto remoto
n
= ind(0, 2) 'en color medio
FOR s = 1 TO nsu
r = rcu(s): d = dis(s): n1 = ind(s, 2)
GOSUB paraxi
NEXT s
'distancia ultima
superficie-plano principal imagen
xppi = 1 / u1 - y1 / u1
y
= 1 'plano principal
objeto
u
= 0 'solo objeto remoto
n
= ind(nsu, 2) 'en color medio
FOR s = nsu TO 1 STEP -1'invierte el sistema optico
r = -rcu(s): d = dis(s - 1): n1 = ind(s - 1, 2)
GOSUB paraxi
NEXT
s
xppo
= 1 / u1 - y1 / u1 'distancia primera superficie-plano principal objeto
'4 - perdidas por reflexion de Fresnel
FOR col = 1 TO 3
'inicializacion de transmision
tfres(col) = 1
NEXT col
FOR s = 1 TO nsu
FOR col = 1 TO 3
'reflexion de
Fresnel (no vale para espejos)
numerador = (ABS(ind(s, col)) - ABS(ind(s
- 1, col)))
denominador = (ABS(ind(s, col)) + ABS(ind(s - 1, col)))
'ecuacion (1.87)
y (1.84)
rfres = (numerador / denominador) ^ 2
'transmision
tfres(col) = tfres(col) * (1 - rfres)
NEXT col
NEXT s
LOCATE 9, 10
PRINT arch$
COLOR
14
LOCATE 11, 1
PRINT " XPE ="; xpe;
TAB(25); "Distancia de superficie 1 a pupila de entrada"
PRINT " RPE ="; rpe;
TAB(25); "Radio de pupila de entrada"
PRINT " XPS ="; xps;
TAB(25); "Distancia de superficie"; nsu; "a pupila de
salida"
PRINT " RPS ="; rps;
TAB(25); "Radio de pupila de salida"
PRINT " XPPO =";
xppo; TAB(25); "Distancia de superficie 1 a plano principal objeto"
'el signo - en xppi es para que coincida
con OSLO (?)
PRINT " XPPI =";
-xppi; TAB(25); "Distancia de superficie"; nsu; "a plano
principal imagen"
COLOR 15
PRINT
PRINT " En el gr
fico est n los datos:"
PRINT
PRINT " x = posici¢n
del foco actual"
PRINT " LO = Longitud de
Onda en "
PRINT " FEP = distancia
Focal Efectiva Paraxial"
PRINT " FPP = distancia
Focal Posterior Paraxial"
PRINT " FPM = distancia
Focal Posterior Media"
PRINT " YP = altura
Paraxial de la imagen"
PRINT " YM = altura
Media de la imagen"
PRINT " LT = fraccion de
Luz Transmitida = 1 - (vi¤eteo + obstrucci¢n + Fresnel)"
'seccion rayos
generales
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
FOR ray = 1 TO nray 'los
calculos se hacen para todos los rayos
DO
yun = -1 + 2 * RND
'coordenadas y,z aleatorias en el circulo unitario
zun = -1 + 2 * RND
'LOOP WHILE yun ^ 2 + zun ^ 2 >= 1
'forma para mas
velocidad
LOOP WHILE yun * yun + zun * zun >= 1
FOR
col = 1 TO 3 'los calculos se hacen
para los 3 colores
ype = rpe * yun 'coordenadas
y,z aleatorias sobre pupila de entrada
zpe = rpe * zun
IF dio = 0 THEN
k = COS(scr)
'cosenos directores iniciales para objeto remoto
l = -SIN(scr)
m = 0
ELSE
'distancia del objeto a punto en la pupila
de entrada
'ro = SQR((xpe - dio) ^ 2 + (ype - alo) ^ 2 + zpe ^ 2)
'forma para mas velocidad
ro = SQR((xpe - dio) * (xpe - dio) + (ype - alo) * (ype - alo) + zpe *
zpe)
'cosenos directores iniciales para objeto
cercano
k = (xpe - dio) / ro
l = (ype - alo) / ro
m = zpe / ro
END IF
'coordenadas
sobre el primer plano tangente polar
y0 = ype - xpe * l / k
z0 = zpe - xpe * m / k
'este rayo todavia no se perdio
perdido%(ray, col) = 0
FOR s = 1 TO nsu 'los
calculos se hacen para todas las superficies
'si no hay asfericos de orden superior a 2
then
'IF co4(s) ^ 2 + co6(s) ^ 2 + co8(s) ^ 2 =
0 THEN
'forma
para mas velocidad
IF co4(s) * co4(s) + co6(s) * co6(s) +
co8(s) * co8(s) = 0 THEN
GOSUB incuad
'interseccion con cuadrica
ELSE
GOSUB inasup 'interseccion
con asferico superior
END IF
'refraccion
'ÄÄÄÄÄÄÄÄÄÄ
n = ind(s - 1, col) 'redefinicion para comparar las formulas
np = ind(s, col)
'ecuacion (4.94)
cosi = alfa * k + beta * l + gama * m
cosip2 = (1 - n ^ 2 * (1 - cosi ^ 2) / np ^ 2)
'forma para mas velocidad
cosip2 = (1 - n * n * (1 - cosi * cosi) / (np * np))
'perdido por reflexion total
IF cosip2 < 0 THEN
perdido%(ray, col) = 4
EXIT FOR
END IF
cosip = SQR(cosip2) 'ecuacion (4.95)
'ecuacion (4.96)
omega = cosip - n * cosi / np
'ecuacion (4.97)
k = k * n / np + omega * alfa
'ecuacion (4.98)
l = l * n / np + omega * beta
'ecuacion (4.99)
m = m * n / np + omega * gama
'transporte
'ÄÄÄÄÄÄÄÄÄÄ
dx = dis(s) 'redefinicion
para comparar las formulas
'ecuacion (4.103), lambda para transporte
lambda = (dx - x) / k
y0 = y + lambda * l 'ecuacion (4.101) en el siguiente plano
z0 = z + lambda * m 'tangente polar
NEXT s
l(ray, col) = l / k 'posicion y
direccion de todos los rayos
m(ray, col) = m / k 'en el
ultimo plano tangente polar
y0(ray, col) = y0 'definicion
despues de la ecuacion (4.109)
z0(ray, col) = z0 'este
paquete de 4 lineas contiene toda
NEXT col 'la informacion
del trazado
7 NEXT ray
'sumas estadisticas para buscar los focos
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
FOR col = 1 TO 3
'inicializacion de las sumas
sy0 = 0: sz0 = 0: sl = 0: sm = 0
sy0l = 0: sz0m = 0: sll = 0: smm = 0
sob(col)
= 0 'inicializacion de los
rayos sobrevivientes
FOR ray = 1 TO nray
IF perdido%(ray, col) <> 0 THEN 8
sy0 = sy0 + y0(ray, col)
sz0 = sz0 + z0(ray, col)
sl = sl + l(ray, col)
sm = sm + m(ray, col)
sy0l = sy0l + y0(ray, col) * l(ray, col)
sz0m = sz0m + z0(ray, col) * m(ray, col)
sll = sll + l(ray, col) * l(ray, col)
smm = smm + m(ray, col) * m(ray, col)
sob(col)
= sob(col) + 1
8 NEXT ray
numerador = sy0 * sl + sz0 * sm - sob(col) * (sy0l + sz0m)
denominador = sl * sl + sm * sm - sob(col) * (sll + smm)
'x del foco en
cada color
'ecuacion (4.188)
fpm(col) = -numerador / denominador
NEXT col
RETURN 'de trayos
progra: 'propagacion hasta la imagen y grafico
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
'inicializacionmes
yma = -1E+10: ymi = 1E+10
zma = -1E+10: zmi = 1E+10
FOR col = 1 TO 3
ym(col) = 0
sob(col) = 0
FOR ray = 1 TO nray
'los perdidos se
descartan
IF perdido%(ray, col) <> 0 THEN 9
'rayos en la
imagen en cada color
y(ray, col) = y0(ray, col) + foco * l(ray, col)
z(ray, col) = z0(ray, col) + foco * m(ray,
col)
'para calcular y media
ym(col) = ym(col) + y(ray, col)
'rayos extremos
IF y(ray, col) > yma THEN yma = y(ray,
col)
IF y(ray, col) < ymi THEN ymi = y(ray, col)
IF z(ray, col) > zma THEN zma = z(ray, col)
IF z(ray, col) < zmi THEN zmi = z(ray, col)
'rayos
sobrevivientes
sob(col) = sob(col) + 1
9
NEXT ray
'y media
ym(col) = ym(col) / sob(col)
NEXT col
deltay = yma - ymi
deltaz
= zma - zmi
'lado del marco
IF deltay > deltaz THEN lado = deltay: ELSE lado = deltaz
'grafica la imagen
CLS
'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
FOR ray = 1 TO nray
FOR col = 1 TO 3
IF perdido%(ray, col) <> 0 THEN 10
IF col = 1 THEN COLOR 9
IF col = 2 THEN COLOR 14
IF col = 3 THEN COLOR 12
'punto blanco si
no hay dispersion cromatica
IF y(ray, 3) = y(ray, 2) AND z(ray, 3) =
z(ray, 2) THEN COLOR 15
'coordenadas en
el diagrama
yd(col) = 479 * (y(ray, col) - ymi) / lado
zd(col) = 240 + 479 * z(ray, col) / lado
'punto del diagrama
PSET (yd(col), zd(col))
'punto simetrico
respecto del plano x-y
PSET (yd(col), 479 - zd(col))
NEXT col
10 NEXT ray
COLOR
15
LOCATE 2, 4
PRINT arch$ 'imprime
nombre del sistema optico
COLOR 15
LOCATE 28, 1
IF dio = 0 THEN 'imprime
datos del objeto
PRINT " Objeto a ";
alo; CHR$(248)
ELSE
PRINT " Objeto en x
="; dio; "mm , y ="; alo; "mm"
END IF
'dibuja la flechita
LOCATE 29, 1: PRINT CHR$(17); : LOCATE 29, 60: PRINT CHR$(16);
LINE
(1, 454)-(478, 454)
'lado del marco en micrones
ladomi = INT(10000 * lado + .5) / 10
'lado del marco en arcsegundos
ladoas = INT(lado * 2.06265E+07 / ABS(fep(2))) / 100
LOCATE 29, 3
PRINT ladomi; CHR$(230) + "m"; " , "; ladoas;
"''";
'dibuja el marco
LINE (0, 0)-(479, 479), 2, B
'dibuja los diametros de los discos de
Airy
FOR col = 1 TO 3
IF col = 1 THEN COLOR 9: hh = 467
IF col = 2 THEN COLOR 14: hh = 471
IF col = 3 THEN COLOR 12: hh = 475
airy(col) = ABS(1.22E-07 * lon(col) * fep(col) / rpe)
airy = 479 * airy(col) / lado
LINE (1, hh)-(airy, hh + 2), , BF
NEXT
col
'x
para foco explicito
IF foco = fpm(1) THEN COLOR 9
IF foco = fpm(2) THEN COLOR 14
IF foco = fpm(3) THEN COLOR 12
IF fpm(1) = fpm(2) THEN COLOR 15
IF foco = fexp THEN COLOR 15
LOCATE 1, 65: PRINT "x ="; foco
'datos
asociados a la imagen en cada color
COLOR 9
'azul
'longitud de onda en angstroms
LOCATE 4, 64: PRINT "LO ="; lon(1)
'foco efectivo paraxial
LOCATE 5, 63: PRINT "FEP ="; fep(1)
'foco posterior
paraxial
LOCATE 6, 63: PRINT "FPP ="; fpp(1)
'foco posterior
medio
LOCATE 7, 63: PRINT "FPM ="; fpm(1)
LOCATE 8, 64: PRINT "YP ="; yp(1)
'pone 0 para
evitar cifras sin sentido
IF alo = 0 THEN ym(1) = 0
'y media
LOCATE 9, 64: PRINT "YM ="; ym(1)
'fraccion de luz transmitida
ltran(1) = sob(1) * tfres(1) / nray
LOCATE 10, 64: PRINT "LT ="; USING
".####"; ltran(1);
COLOR
14 'amarillo
LOCATE 13, 64: PRINT "LO ="; lon(2)
LOCATE 14, 63: PRINT "FEP ="; fep(2)
LOCATE 15, 63: PRINT "FPP ="; fpp(2)
LOCATE 16, 63: PRINT "FPM ="; fpm(2)
LOCATE 17, 64: PRINT "YP ="; yp(2)
IF
alo = 0 THEN ym(2) = 0
LOCATE 18, 64: PRINT "YM ="; ym(2)
ltran(2)
= sob(2) * tfres(2) / nray
LOCATE 19, 64: PRINT "LT ="; USING
".####"; ltran(2);
COLOR 12
'rojo
LOCATE 22, 64: PRINT "LO ="; lon(3)
LOCATE 23, 63: PRINT "FEP ="; fep(3)
LOCATE 24, 63: PRINT "FPP ="; fpp(3)
LOCATE 25, 63: PRINT "FPM ="; fpm(3)
LOCATE 26, 64: PRINT "YP ="; yp(3)
IF
alo = 0 THEN ym(3) = 0
LOCATE 27, 64: PRINT "YM ="; ym(3)
ltran(3)
= sob(3) * tfres(3) / nray
LOCATE 28, 64: PRINT "LT ="; USING
".####"; ltran(3);
DO: LOOP WHILE INKEY$ = ""
RETURN
incuad:
x
= 0 'el rayo parte del
plano normal tangente
y
= y0
z
= z0
b
= cci(s) 'redefinicion para
comparar las formulas
c = cur(s)
'ecuacion (4.59)
'aa = c * (1 + b * k ^ 2)
'forma para mas velocidad
aa = c * (1 + b * k * k)
'ecuacion (4.60)
bb = k - c * (l * y + m * z)
'ecuacion (4.61)
'dd = c * (y ^ 2 + z ^ 2)
'forma para mas velocidad
dd = c * (y * y + z * z)
'perdido por no intersectar conica
IF bb * bb - aa * dd < 0 THEN
perdido%(ray, col) = 2
s = nsu
END IF
'ecuacion (4.63),
lambda para conica
lambda = dd / (bb + SQR(bb * bb - aa * dd))
'coordenadas de interseccion
x
= lambda * k 'ecuacion (4.53)
y
= y + lambda * l 'ecuacion (4.54)
z
= z + lambda * m 'ecuacion (4.55)
h
= y * y + z * z 'cantidad auxiliar
'perdido por vi¤eteo
IF h > rcl(s) * rcl(s) OR h < ros(s) * ros(s)
THEN perdido%(ray, col) = 1
'ecuacion (4.69),
derivadas parciales en conica
fx = 1 - c * (1 + b) * x
fy =
-c * y 'ecuacion (4.70)
fz = -c * z 'ecuacion
(4.71)
'ecuacion (4.68)
norma = SQR(fx * fx + fy * fy + fz * fz)
'cosenos directores de la normal en conica
alfa = fx / norma 'ecuacion
(4.65)
beta = fy / norma 'ecuacion
(4.66)
gama = fz / norma 'ecuacion
(4.67)
RETURN 'de incuad
inasup:
x
= 0 'el rayo parte del
plano normal tangente
y
= y0
z
= z0
b
= cci(s) 'redefinicion para
comparar las formulas
c = cur(s)
d
= co4(s)
e
= co6(s)
f
= co8(s)
DO 'comienzo de la
interseccion iterada
'h = y ^ 2 + z ^ 2 'cantidades
auxiliares
'rac2 = 1 - (1 + b) * c ^ 2 * h
'formas para mas
velocidad
h = y * y + z * z
rac2 = 1 - (1 + b) * c * c * h
'perdido por no
intersectar asferico
IF rac2 < 0 THEN
perdido%(ray, col) = 3
s = nsu
END IF
rac = SQR(rac2)
'formula
4.79
'g = c / rac + 4 * d * h + 6 * e * h ^ 2 + 8 * f * h ^ 3
'forma para mas velocidad
g = c / rac + 2 * h * (2 * d + h * (3 * e + 4 * f *
h))
'formula (4.80)
'norma = SQR(1 + g ^ 2 * h)
'forma para mas velocidad
norma = SQR(1 + g * g * h)
'cosenos directores de la normal iterada
alfa = 1 / norma 'ecuacion
(4.65) para el asferico
beta = -g * y / norma 'ecuacion (4.66) para el asferico
gama = -g * z / norma 'ecuacion (4.67) para el asferico
'ecuacion (4.73), x sobre el asferico
'xasf = (c * h / (1 + rac)) + d * h ^ 2 + e * h ^ 3 +
f * h ^ 4
'forma para mas
velocidad
xasf = (c / (1 + rac) + (d + (e + f * h) * h) * h) * h
'ecuacion (4.85),
lambda para asferico
lambda = (xasf - x) * alfa / (alfa * k + beta * l + gama * m)
x = x + lambda * k 'ecuacion
(4.81)
y = y + lambda * l 'ecuacion
(4.82)
z = z + lambda * m 'ecuacion
(4.83)
'perdido por vi¤eteo
IF h > rcl(s) * rcl(s) OR h < ros(s) * ros(s)
THEN perdido%(ray, col) = 1
'fin de la
interseccion iterada
LOOP UNTIL ABS(lambda) < 1E-10
RETURN 'de inasup
cartgi:
'punto 3. Cartel G-I
CLS
COLOR 1
LOCATE 1, 1: PRINT "3"; : FOR i = 2 TO 80: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 61: PRINT " rabacion"
LOCATE 1, 75: PRINT " ndice"
COLOR 12
LOCATE 1, 61: PRINT "G"
LOCATE 1, 75: PRINT "I"
RETURN 'de cartgi
cargid: 'punto 4. Cartel G-I-D.
COLOR 1
LOCATE 1, 1: PRINT "4"; : FOR i = 2 TO 80: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 50: PRINT " rabacion"
LOCATE 1, 64: PRINT " magen"
LOCATE 1, 75: PRINT " ibujo";
COLOR 12
LOCATE 1, 50: PRINT "G"
LOCATE 1, 64: PRINT "I"
LOCATE 1, 75: PRINT "D"
COLOR 15
RETURN 'de cargid
ediasf: 'edita asferico
PRINT : PRINT "Asf‚ricos": PRINT
"ÄÄÄÄÄÄÄÄÄ"
PRINT " S³ Const. C¡trica
³ Asf‚rico (4) ³
Asf‚rico (6) ³ Asf‚rico (8) ³"
PRINT sur$
FOR i = 1 TO nsu
IF LEFT$(cad$(i), 1) = "a" THEN
PRINT i; TAB(7); USING "####.###"; cci(i);
PRINT USING "##.#####^^^^"; TAB(25); co4(i); TAB(43); co6(i);
TAB(61); co8(i)
END IF
NEXT i
RETURN 'de ediasf
nombre: cd1$ = "
Coeficiente de dilataci¢n entre -30øC y 70øC en 10^6/øC ="
cd2$ = " Coeficiente
de dilataci¢n entre 20øC y 300øC en 10^6/øC ="
tdi$ = " Temperatura
de distensi¢n en øC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
tda$ = " Temperatura
de ablandamiento en øC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
cei$ = " Calor
espec¡fico isob rico en J/gøC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
cot$ = "
Conductividad t‚rmica en W/møC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
den$ = " Densidad en
g/cm^3 ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
moy$ = " M¢dulo de Young en 10^-3 N/mm^2
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
rep$ = " Relaci¢n de
Poisson ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
duk$ = " Dureza
Knoop ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
ccb$ = " Clase de contenido
de burbujas (de 0 a 3) ÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
crc$ = " Clase de
resistencia clim tica (de 1 a 4) ÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
crt$ = " Clase de
resistencia al te¤ido (de 0 a 5) ÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
cra$ = " Clase de
resistencia a cidos (de 1 a 4 o de 51 a
53) - ="
crk$ = " Clase de
resistencia a los lkalis (de 1 a 4)
ÄÄÄÄÄÄÄÄÄ ="
ti5$ = "
Transmitancia interna en 4000 A sobre 5 mm ÄÄÄÄÄÄÄÄÄÄÄÄ ="
t25$ = "
Transmitancia interna en 4000 A sobre 25 mm ÄÄÄÄÄÄÄÄÄÄÄ ="
peb$ = " Precio
estimado respecto del BK7 ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="
RETURN 'de nombre
carsva: 'carsva: cartel "S-V-A"
COLOR 15
CLS
COLOR 1
PRINT : PRINT
FOR i = 1 TO 9
PRINT "ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ"
NEXT i
COLOR 12
LOCATE 4, 2: PRINT "S"
LOCATE 7, 2: PRINT "V"
LOCATE 10, 2: PRINT "A"
COLOR 15
LOCATE 4, 3: PRINT "istema ¢ptico"
LOCATE 7, 3: PRINT "idrio"
LOCATE 10, 3: PRINT "rchivo"
RETURN 'de carsva
ovfdce:
COLOR 1
LOCATE 1, 1: PRINT "5"; : FOR i = 2 TO 80: PRINT
"Û"; : NEXT i
COLOR 15
LOCATE 1, 17: PRINT " bjeto"
LOCATE 1, 28: PRINT " idrios"
LOCATE 1, 40: PRINT "Indices:"
LOCATE 1, 71: PRINT " xpl¡citos";
COLOR 12
LOCATE 1, 17: PRINT "O"
LOCATE 1, 28: PRINT "V"
COLOR 9
LOCATE 1, 53: PRINT "F"
COLOR 14
LOCATE 1, 59: PRINT "D"
COLOR 12
LOCATE 1, 65: PRINT "C"
LOCATE 1, 71: PRINT "E"
RETURN 'de
ovfdce
paraxi:
IF
r <> 0 THEN c = 1 / r: ELSE c = 0
'ecuacion (4.11)
u1
= n * u / n1 + (1 - n / n1) * y * c
y1
= y - d * u1 'ecuacion (4.10)
u
= u1: y = y1: n = n1
RETURN 'de paraxi
Errores:
UltimoError = ERR
RESUME NEXT
SUB ElegirArchivo (directorio$, pattern$,
nombrearchivo$)
DIM files$(500)
row = CSRLIN
col = POS(0)
SHELL "dir " + directorio$ +
pattern$ + " /b /a-d /on >
dir.lst"
archi = FREEFILE
OPEN "dir.lst" FOR INPUT AS
#archi
i = 0
DO
INPUT #archi, files$(i)
i = i + 1
LOOP UNTIL EOF(archi)
CLOSE archi
KILL "dir.lst"
ntot = i - 1
i = 0
DO
LOCATE row, col
PRINT USING "### de ### es \ \"; i; ntot; files$(i)
a$ = INKEY$
a$ = RIGHT$(a$, 1)
IF a$ = "H" THEN
i = i - 1
ELSEIF a$ = "P" THEN
i = i + 1
END IF
IF i < 0 THEN i = 0
IF i > ntot THEN i = ntot
LOOP UNTIL a$ = CHR$(13)
nombrearchivo$ = files$(i)
END SUB