PROGRAM “OPSA”

 

DECLARE SUB ElegirArchivo (directorio$, pattern$, nombrearchivo$)

  

    CONST pi = 3.14159265#

                         'define systems directory

    CONST DirSistemas$ = ".\SISTEMAS\"

                         'define glass directory

    CONST DirVidrios$ = ".\VIDRIOS\"

                       

                         'define error trap        

    DIM SHARED UltimoError AS INTEGER

    ON ERROR GOTO Errores

 

    nray = 1500

    DIM rcu(50), cur(50), rcl(50), ros(50), dis(50), gla$(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), lost%(nray, 3), ind(50, 3)

    wln(1) = 4861: wln(2) = 5893: wln(3) = 6563

    gla$(0) = "1"

 

    SCREEN 12            'MAIN PROGRAM

                         'ÄÄÄÄÄÄÄÄÄÄÄÄ

    CLS

 

1   GOSUB labogf        'label"O-G-F"

    a$ = INPUT$(1)

    CLS

  SELECT CASE a$

   CASE "s"

    GOSUB defops         'define optical system

    GOSUB ediops         'edit optical system

    GOTO 4

   CASE "g"

    PRINT a$

    GOSUB defgla         'define glass

    GOSUB edigla         'edit glass

    GOTO 3

   CASE "f"

    PRINT a$

    GOTO 2               'read file

   CASE ELSE

    END

  END SELECT

 

2   CLS

    COLOR 1

    LOCATE 1, 1: PRINT "2"; : FOR i = 2 TO 70: PRINT "Ū"; : NEXT i

    COLOR 15

                         'select input files

    LOCATE 2, 58: PRINT "s: list of systems"

    LOCATE 3, 58: PRINT "g: list of glasses"

    LOCATE 4, 58: PRINT CHR$(24); CHR$(25); ": search"

    LOCATE 5, 58: PRINT "enter: accept"

    LOCATE 1, 58: PRINT ; "Name to read ";

    arch$ = ""

    DO

     LOCATE 1, 71: INPUT ; a$

     a$ = LCASE$(a$)

     IF a$ = "s" THEN

       LOCATE 1, 58

       ElegirArchivo DirSistemas$, "*.", arch$

      ELSEIF a$ = "g" 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 readgl         'read glass file

                         'verify if there is read error

    IF UltimoError > 0 THEN

        UltimoError = 0

        CLS

        LOCATE 14, 33: PRINT "There is no  "; arch$

        SLEEP

        CLS

        GOTO 2

    END IF

    GOSUB edigla         'edit glass

    GOTO 3

   CASE ELSE

    GOSUB reados         'read optical system file

                         'verify if there is read error

    IF UltimoError > 0 THEN

        UltimoError = 0

        CLS

        LOCATE 14, 33: PRINT "There is no  "; arch$;

        SLEEP

        GOTO 2

    END IF

    GOSUB ediops         'edit optical system

    GOTO 4

  END SELECT

 

3   GOSUB labsai         'label "S-I"

    a$ = INPUT$(1)

  SELECT CASE a$

   CASE "i"

    GOSUB indgla         'compute index of glass in any /\

    GOSUB edigla         'edit glass

    GOTO 3

   CASE "s"

    PRINT a$

    GOSUB savgla         'save glass

    GOSUB edigla         'edit glass

    GOTO 3

   CASE ELSE

    GOTO 1

  END SELECT

 

4   GOSUB labsid

    a$ = INPUT$(1)

  SELECT CASE a$

   CASE "s"

    PRINT a$

    GOSUB savops         'save optical system

    GOTO 4

   CASE "d"

    PRINT a$

    GOSUB drawos         'draw optical system

    GOTO 4

   CASE "i"

    GOSUB indops         'compute index of glass /\F, /\D, /\C

    GOTO 5

   CASE ELSE

    GOTO 1

  END SELECT

 

5   GOSUB ogfdce         'label "O-G-F-D-C-E"

    a$ = INPUT$(1)

  SELECT CASE a$

   CASE "f"

    k = 1

    GOSUB colind         'print column of index in /\F

    GOTO 5

   CASE "d"

    k = 2

    GOSUB colind         'print column of index in /\D

    GOTO 5

   CASE "c"

    k = 3

    GOSUB colind         'print column of index in /\C

    GOTO 5

   CASE "e"

    GOSUB indexp         'ask for explicit values of index

    GOTO 5

   CASE "g"

    GOSUB pargla         'print glass parameters

    GOTO 5

   CASE "o"

    GOSUB trays          'trace rays

    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, 33: PRINT " bject"

    LOCATE 1, 44: PRINT "Focus:"

    LOCATE 1, 73: PRINT " xplicit";

    COLOR 12

    LOCATE 1, 33: PRINT "O"

    COLOR 9

    LOCATE 1, 55: PRINT "F"

    COLOR 14

    LOCATE 1, 61: PRINT "D"

    COLOR 12

    LOCATE 1, 67: PRINT "C"

    LOCATE 1, 73: PRINT "E"

    COLOR 15

    a$ = INPUT$(1)

  SELECT CASE a$

   CASE "o"

    GOSUB trays          'trace rays

    GOTO 6

   CASE "e"

    LOCATE 1, 44

    PRINT "                                   ";

    LOCATE 1, 46

    PRINT " x ="; fexp;

    INPUT a$: IF a$ <> "" THEN fexp = VAL(a$)

    foco = fexp

    GOSUB progra         'propagate and print image in explicit x

    GOTO 6

   CASE "f"

    foco = fpm(1)

    GOSUB progra         'propagate and print image in x = xF

    GOTO 6

   CASE "d"

    foco = fpm(2)

    GOSUB progra         'propagate and print image in x = xD

    GOTO 6

   CASE "c"

    foco = fpm(3)

    GOSUB progra         'propagate and print image in x = xC

    GOTO 6

   CASE ELSE

    GOSUB ediops         'edit optical system

    GOTO 4

   END SELECT

                         'END OF MAIN PROGRAM

                         'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ

defops:                  'define optical system

    wid = 0

    COLOR 1

    LOCATE 1, 1: PRINT "1"; : FOR i = 2 TO 70: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 1, 61: PRINT "nsu-Name: ";

    LOCATE 1, 71: PRINT arch$; : INPUT a$

    IF a$ <> "" THEN arch$ = a$

    ypu = 0: rpu = 0     'initialize pupil

    nsu = VAL(arch$):    'set Nų of surfaces

   FOR i = 1 TO 8        'input of comments

    CLS

    PRINT : PRINT "Comment"; i; "      (Up to 3 lines)"

    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 "Glass 0"

    PRINT

    PRINT gla$(0); : INPUT a$

    IF a$ <> "" THEN gla$(0) = a$

    CLS

   FOR i = 1 TO nsu:

    PRINT : PRINT

    PRINT "Radius of curvature"; i; " (mm)"

    PRINT

    PRINT rcu(i); : INPUT a$

    IF a$ <> "" THEN rcu(i) = VAL(a$)

    PRINT

    PRINT "Clear radius"; i; " (mm)"

    PRINT

    PRINT rcl(i); : INPUT a$

    IF a$ <> "" THEN rcl(i) = VAL(a$)

    PRINT

    PRINT "Dark radius"; i; " (mm)"

    PRINT

    PRINT ros(i); : INPUT a$

    IF a$ <> "" THEN ros(i) = VAL(a$)

    PRINT

    PRINT "Distance"; i; " (mm)"

    PRINT

    PRINT dis(i); : INPUT a$

    IF a$ <> "" THEN dis(i) = VAL(a$)

    PRINT

    PRINT "Glass"; i

    PRINT

    PRINT gla$(i); : INPUT a$

    IF a$ <> "" THEN gla$(i) = a$

    PRINT

    PRINT "a,d  "; cad$(i); : INPUT a$

    IF a$ <> "" THEN cad$(i) = a$

                         'sud = surface that is diaphragm

    IF RIGHT$(cad$(i), 1) = "d" THEN sud = i

    IF LEFT$(cad$(i), 1) = "a" THEN

     nas = nas + 1

     GOSUB deasph

    END IF

    CLS

   NEXT i

                         'long listing with more rows

   IF nas + nsu > 18 THEN wid = 1

RETURN                   'from defops

 

deasph:                  'define aspheric

   CLS

   PRINT "                        Aspherics in surface"; i

   PRINT : PRINT

   PRINT "Citric constant"; i

   PRINT : PRINT

   PRINT cci(i); : INPUT a$

   IF a$ <> "" THEN cci(i) = VAL(a$)

   PRINT : PRINT

   PRINT "4§ order aspheric"; i

   PRINT : PRINT

   PRINT co4(i); : INPUT a$

   IF a$ <> "" THEN co4(i) = VAL(a$)

   PRINT : PRINT

   PRINT "6§ order aspheric"; i

   PRINT : PRINT

   PRINT co6(i); : INPUT a$

   IF a$ <> "" THEN co6(i) = VAL(a$)

   PRINT : PRINT

   PRINT "8§ order aspheric"; i

   PRINT : PRINT

   PRINT co8(i); : INPUT a$

   IF a$ <> "" THEN co8(i) = VAL(a$)

   CLS

RETURN                   'from deasph

 

ediops:                  'edit optical system

   IF wid = 1 THEN WIDTH 80, 60

   CLS

   COLOR 15

   lea = LEN(arch$)      'print underlined title

   lin = 40 - INT(lea / 2)

   LOCATE 3, lin

   PRINT arch$

   LOCATE 4, lin

   FOR i = lin TO lin + lea - 1: PRINT "Ä"; : NEXT i

   PRINT                 'print comments

  FOR i = 0 TO 8

   PRINT cos$(i)

  NEXT i

   DO: LOOP WHILE INKEY$ = ""

   CLS

   GOSUB labsid          'print label "S-I-D"

edios1:                  'part of ediops to assemble after "G-lass"

   PRINT

   PRINT " S³  Radius curv.   ³ Radius clr. drk.³    Distance     ³      Glass      ³ a,d"

   sur$ = "ÄÄĮÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĮÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĮÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĮÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĮÄÄÄÄ-"

   PRINT sur$;

   LOCATE 5, 62: PRINT UCASE$(gla$(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$(gla$(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

                         'if any surface is aspheric

   IF nas <> 0 THEN GOSUB edasph

  WIDTH 80, 30

RETURN                   'from ediops and edios1

 

savops:

    CLS

    PRINT "Name to save:  "; 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), gla$(i), cad$(i), cci(i), co4(i), co6(i), co8(i)

   NEXT i

    WRITE #1, dio, alo, wln(1), wln(2), wln(3), uni$, sud, wid, gla$(0)

  CLOSE #1

 GOSUB edios1

RETURN                   'from savops

 

reados:                  'read optical system

  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), gla$(i), cad$(i), cci(i), co4(i), co6(i), co8(i)

   NEXT i

    INPUT #1, dio, alo, wln(1), wln(2), wln(3), uni$, sud, wid, gla$(0)

  CLOSE #1

RETURN                   'de reados

 

defgla:                  'define glass

 

    COLOR 1

    LOCATE 1, 1: PRINT "1"; : FOR i = 2 TO 70: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 1, 65: PRINT "Name: "; arch$;

    INPUT a$: IF a$ <> "" THEN arch$ = a$

    CLS

    PRINT "code               "; : PRINT cod$;

    INPUT a$

    IF a$ <> "" THEN cod$ = a$

    PRINT

    PRINT "Comment"; "           (Up to 3 lines)"

    PRINT

    PRINT cov$

    INPUT a$: IF a$ <> "" THEN cov$ = a$

    CLS

    PRINT "Coefficients of Schott dispersion formula"

    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                  'input other data of glass

    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                   'from defgla

 

edigla:                  'edit glass

    CLS

                         'print underlined title

    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$           'print comment

    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 "               Coefficients of Schott dispersion formula"

    PRINT : PRINT : PRINT

   FOR i = 1 TO 6

    PRINT "                               A"; i - 1; "= "; cfs(i)

    PRINT

   NEXT i

RETURN                   'from edigla

 

savgla:                  'save glass

    CLS

    COLOR 15

    PRINT "Name to save:   "; 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                   'from savgla

 

readgl:                  'read glass

   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                   'from readgl

 

indgla:                  'compute index of glass in any /\   

    COLOR 15

    CLS

    PRINT "/\ from 3650 ¸ to 10140 ¸ (IF IT IS FROM SCHOTT). Red means extrapolated"

    PRINT

   DO

    PRINT

    COLOR 15

    INPUT "/\ = "; lon

    IF lon = 0 THEN EXIT DO

    'w = (lon / 10000) ^ 2

                         'equation (4.50), Schott formula

    'ind = SQR(cfs(1) + cfs(2) * w + cfs(3) / w + cfs(4) / w ^ 2 + cfs(5) / w ^ 3 + cfs(6) / w ^ 4)

                         'form for speed

                         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 indgla

 

drawos:                  'draw optical system

  CLS

  PRINT "Units may be: mm, cm, m. Are they "; uni$;

  INPUT a$: IF a$ <> "" THEN uni$ = a$

                         'coordinates x(i) for each surface i

                         'if there are mirrors they are not sorted from low to high

 FOR i = 1 TO nsu

  x(i + 1) = x(i) + dis(i)

 NEXT i

                         'highest and lowest x(i) and its correspondig i

  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

                         'first and last sagitta

                         'sagittas are computed from the equation of the

                         'surface evaluated in r = rcl

                         'fsa = first sagitta

  fsa = 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

                         'if it is positive is ignored

                         'if it is negative is taken as positive

  IF fsa > 0 THEN fsa = 0:  ELSE fsa = -fsa

                         'lsa = last sagitta

  lsa = 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

                         'if it is negative is ignored

  IF lsa < 0 THEN lsa = 0

                         'lto = total length

  lto = fsa + lsa + x(ima) - x(imi)

                         'rma = clear radius max

  rma = -1E+10

 FOR i = 1 TO nsu

  IF rcl(i) > rma THEN rma = rcl(i)

 NEXT i

                         'if lto > rma the drawing is limited horizontally

                         'if lto < rma the drawing is limited vertically

                         'xpa = a*x+b, ypa = a*y

  IF lto > rma THEN

                         'to be limited horizontally

   a = 639 / (x(ima) - x(imi) + lsa + fsa)

   b = -a * (x(imi) - fsa)

                         'x0 is the x where the drawing begins, here zero

   x0 = 0

   ELSE

                         'to be limited vertically

   a = 239 / rma

   b = 0

                         'here x0 places the system at the center

   x0 = 639 * rma / 479 - lto / 2

  END IF

   CLS

  SELECT CASE uni$       'units of length in the drawing

   CASE IS = "mm"

    uni = 1

   CASE IS = "cm"

    uni = 10

   CASE IS = "m"

    uni = 1000

  END SELECT

                         'draw the frame

   LINE (0, 0)-(639, 478), 2, B

   IF lto < rma THEN stp = 239 * uni / rma:  ELSE stp = 639 * uni / lto

                         'horizontal graduated scale

  FOR x = 0 TO 639 STEP stp

   LINE (x, 0)-(x, 3), 2

   LINE (x, 475)-(x, 478), 2

  NEXT x

                         'vertical graduated scale centered on axis

  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

                         'draw the surfaces

  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 is the xpa of the center

    IF y = 0 THEN xpc(i) = xpa

   NEXT y

                         'xpb, ypb are the xpa, ypa of the rim where

                         'FOR...TO of y ended

   xpb(i) = xpa: ypb(i) = ypa

   IF i = sud THEN LINE (xpb(i), 239 - ypb(i))-(xpb(i), 0)

  NEXT i

                         'xpc, xpb, ypb are used to draw the rims

                         'of the lenses, or the diaphragm, or the axis if the

                         'space is of air

  FOR i = 1 TO nsu - 1

                         'draw the rims

   IF ABS(VAL(gla$(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

                         'draw the diaphragm

   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)

                         'print the unit of length

   COLOR 15: LOCATE 29, 4: PRINT "1 " + uni$;

                         'print the name of the optical system

   LOCATE 2, 4: PRINT arch$;

   DO: LOOP WHILE INKEY$ = ""

   CLS

   PRINT

   GOSUB edios1

RETURN                   'from drawos

 

indops:                  'indops: compute indices of system in 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 ="; wln(1);

 INPUT a$: IF a$ <> "" THEN wln(1) = VAL(a$)

 LOCATE 1, 62: PRINT "                   ";

 COLOR 14

 LOCATE 1, 62

 PRINT "/\D ="; wln(2);

 INPUT a$: IF a$ <> "" THEN wln(2) = VAL(a$)

 LOCATE 1, 62: PRINT "                   ";

 COLOR 12

 LOCATE 1, 62

 PRINT "/\C ="; wln(3);

 INPUT a$: IF a$ <> "" THEN wln(3) = VAL(a$)

                         'compute index from catalog if it is not air

 FOR i = 0 TO nsu

  signo$ = ""

  SELECT CASE ABS(VAL(gla$(i)))

   CASE IS = 0

                         'manage signs "-" to read glasses

    IF LEFT$(gla$(i), 1) = "-" THEN gla$(i) = RIGHT$(gla$(i), LEN(gla$(i)) - 1): signo$ = "-"

    OPEN DirVidrios$ + gla$(i) FOR INPUT AS 1

                         'restore the "-" if there was one

      IF signo$ = "-" THEN gla$(i) = "-" + gla$(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 = (wln(k) / 10000) ^ 2

                         'equation (4.50), Schott formula

      'ind(i, k) = SQR(cfs(1) + cfs(2) * w + cfs(3) / w + cfs(4) / w ^ 2 + cfs(5) / w ^ 3 + cfs(6) / w ^ 4)

                         'form for speed

      w = wln(k) * wln(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(gla$(i))

    NEXT k

  END SELECT

 NEXT i

RETURN                   'from indops

  

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                   'from indexp

 

pargla:

    CLS

    COLOR 15

    PRINT "                            Values in:                                ¸";

    COLOR 9: LOCATE 1, 43: PRINT wln(1)

    COLOR 14: LOCATE 1, 53: PRINT wln(2)

    COLOR 12: LOCATE 1, 63: PRINT wln(3)

    COLOR 15

    PRINT

    PRINT "         Glass              Abbe number              Partial dispersion"

    PRINT

    FOR i = 0 TO nsu

                         'si es aire (= "1") pasa de largo

     SELECT CASE ABS(VAL(gla$(i)))

      CASE IS = 0

                         'Abbe number

       nab = (ABS(ind(i, 2)) - 1) / (ABS(ind(i, 1)) - ABS(ind(i, 3)))

       nab = INT(100 * nab + .5) / 100

                         'partial dispersion

       dpa = (ind(i, 1) - ind(i, 2)) / (ind(i, 1) - ind(i, 3))

       dpa = INT(100000 * dpa + .5) / 100000

       PRINT TAB(10); UCASE$(gla$(i)); TAB(33); nab; TAB(61); dpa

      CASE ELSE

     END SELECT

    NEXT i

    DO: LOOP WHILE INKEY$ = ""

    CLS

    PRINT

    GOSUB edios1

RETURN                   'from pargla

 

colind:                  'print column of indices in /\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                   'from colind

 

trays:

    CLS

    COLOR 1

    LOCATE 1, 1

    PRINT "         For object at infinity, put 0"

    LOCATE 5, 1

    FOR i = 1 TO 80: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 5, 10

    PRINT "Object distance ="; 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 "Semifield in degrees ="; alo;

       INPUT a$: IF a$ <> "" THEN alo = VAL(a$)

                         'semifield in radians

       scr = alo * pi / 180

      CASE ELSE

       PRINT "Object height"; alo;

       INPUT a$: IF a$ <> "" THEN alo = VAL(a$)

     END SELECT

                         'paraxial rays section

                         'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ

                         '1 - determination of x of entrance pupil

                         'in middle color (D). Initial ray parameters:

    u = 1                'arbitrary slope = 1

    y = 0                'start from axis

    n = ind(sud - 1, 2)  'initial index is the anterior to diaphragm

 FOR s = sud TO 1 STEP -1'reverse part of the optical system

  r = -rcu(s): d = dis(s - 1): n1 = ind(s - 1, 2)

  GOSUB paraxi

 NEXT s

  xep = -y1 / u1         'xep = x of entrance pupil from surface 1

                         'goes sign - because ray traces from right <- left

  rep = rcl(sud) * ind(sud - 1, 2) / (ind(0, 2) * u1)

                         'rep = radius of entrance pupil by Lagrange invariant

                         '2 - determination of exit pupil

  u = 1                  'as before:

  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

  xxp = y1 / u1          'xxp = x of exit pupil from surface nsu

  rxp = rcl(sud) * ind(sud, 2) / (ind(nsu, 2) * u1)

                         'rxp = radius of exit pupil by Lagrange invariant

                         '3 - back and effective paraxial image distance

                         'in three colors (focal for remote object)

  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     'paraxial effective focus

   fpp(col) = y1 / u1    'paraxial back focus

   IF dio = 0 THEN

    yp(col) = -scr * ABS(fep(col))

   ELSE                  'paraxial y by Lagrange invariant

    yp(col) = alo * ind(0, col) / (dio * ind(nsu, col) * u1)

   END IF

  NEXT col

  y = 1                  'principal image plane

  u = 0                  'remote object only

  n = ind(0, 2)          'in middle color

  FOR s = 1 TO nsu

   r = rcu(s): d = dis(s): n1 = ind(s, 2)

   GOSUB paraxi

  NEXT s

                         'distance last surface - principal image plane

  xppi = 1 / u1 - y1 / u1

  y = 1                  'object principal plane

  u = 0                  'only remote object

  n = ind(nsu, 2)        'in middle color

                         'reverse optical system

                         FOR s = nsu TO 1 STEP -1

   r = -rcu(s): d = dis(s - 1): n1 = ind(s - 1, 2)

   GOSUB paraxi

  NEXT s                 'distance first surface - principal object plane

   xppo = 1 / u1 - y1 / u1

                         '4 - losses by Fresnel reflection

  FOR col = 1 TO 3       'initialization of transmission

   tfres(col) = 1

  NEXT col

  FOR s = 1 TO nsu

   FOR col = 1 TO 3

                         'Fresnel reflection (not valid for mirrors)

    numerador = (ABS(ind(s, col)) - ABS(ind(s - 1, col)))

    denominador = (ABS(ind(s, col)) + ABS(ind(s - 1, col)))

                         'equation (1.87) and (1.84)

    rfres = (numerador / denominador) ^ 2

                         'transmission

    tfres(col) = tfres(col) * (1 - rfres)

   NEXT col

  NEXT s

  LOCATE 9, 10

  PRINT arch$

  COLOR 14

  LOCATE 11, 1

  PRINT "    xep ="; xep; TAB(25); "Distance from surface 1 to entrance pupil"

  PRINT "    rep ="; rep; TAB(25); "Radius of entrance pupil"

  PRINT "    xxp ="; xxp; TAB(25); "Distance from surface"; nsu; "to exit pupil"

  PRINT "    rxp ="; rxp; TAB(25); "Radius of exit pupil"

  PRINT "   XPPO ="; xppo; TAB(25); "Distance from surface 1 to object principal plane"

                         'sign - in xppi is for agreement with OSLO (?)

  PRINT "   XPPI ="; -xppi; TAB(25); "Distance from surface"; nsu; "to principal image plane"

  COLOR 15

  PRINT

  PRINT "         In the diagram there are the data:"

  PRINT

  PRINT "      x = actual focus position"

  PRINT "    WL¸ = Wavelength in ¸"

  PRINT "    PEF = Paraxial Effective Focal distance"

  PRINT "    PBF = Paraxial Back Focal distance"

  PRINT "    ABF = Average Back Focal distance"

  PRINT "     YP = Paraxial image height"

  PRINT "     YA = Average image height"

  PRINT "     TL = ratio of Transmitted light = 1 - (vignetting + obstruction + Fresnel)"

                         'general rays section

                         'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ

  FOR ray = 1 TO nray    'calculations are made for all rays

   DO

   yun = -1 + 2 * RND    'y,z random coordinates in unit circle

   zun = -1 + 2 * RND

   'LOOP WHILE yun ^ 2 + zun ^ 2 >= 1

                         'form for speed

   LOOP WHILE yun * yun + zun * zun >= 1

   FOR col = 1 TO 3      'calculations are made for 3 colors

    ype = rep * yun      'y,z random coordinates on entrance pupil

    zpe = rep * zun

    IF dio = 0 THEN

     k = COS(scr)        'initial direction cosines for remote object

     l = -SIN(scr)

     m = 0

    ELSE

                         'distance from object to point in entrance pupil

     'ro = SQR((xep - dio) ^ 2 + (ype - alo) ^ 2 + zpe ^ 2)

                         'form for speed

     ro = SQR((xep - dio) * (xep - dio) + (ype - alo) * (ype - alo) + zpe * zpe)

                         'initial direction cosines for near object

     k = (xep - dio) / ro

     l = (ype - alo) / ro

     m = zpe / ro

    END IF

                         'coordinates over first polar tangent

    y0 = ype - xep * l / k

    z0 = zpe - xep * m / k

                         'this ray is still not lost

    lost%(ray, col) = 0

    FOR s = 1 TO nsu     'calculations are made for all surfaces

                         'if there are no higher order aspherics then

     'IF co4(s) ^ 2 + co6(s) ^ 2 + co8(s) ^ 2 = 0 THEN

                         'form for speed

     IF co4(s) * co4(s) + co6(s) * co6(s) + co8(s) * co8(s) = 0 THEN

      GOSUB inquad       'intersection with quadric

     ELSE

      GOSUB inasph       'intersection with higher order aspheric

     END IF

                         'refraction

                         'ÄÄÄÄÄÄÄÄÄÄ

     n = ind(s - 1, col) 'redefinition to compare formulas

     np = ind(s, col)

                         'equation (4.94)

     cosi = alfa * k + beta * l + gama * m

     cosip2 = (1 - n ^ 2 * (1 - cosi ^ 2) / np ^ 2)

                         'form for speed

     cosip2 = (1 - n * n * (1 - cosi * cosi) / (np * np))

                         'lost by total reflection

     IF cosip2 < 0 THEN

        lost%(ray, col) = 4

        EXIT FOR

     END IF

     cosip = SQR(cosip2) 'equation (4.95)

                         'equation (4.96)

     omega = cosip - n * cosi / np

                         'equation (4.97)

     k = k * n / np + omega * alfa

                         'equation (4.98)

     l = l * n / np + omega * beta

                         'equation (4.99)

     m = m * n / np + omega * gama

                         'transport

                         'ÄÄÄÄÄÄÄÄÄ

     dx = dis(s)         'redefinition to compare formulas

                         'equation (4.103), lambda for transport

     lambda = (dx - x) / k

     y0 = y + lambda * l 'equation (4.101) in the following polar tangent

     z0 = z + lambda * m 'plane

    NEXT s

    l(ray, col) = l / k  'position and direction of all rays

    m(ray, col) = m / k  'in the last polar tangent plane

    y0(ray, col) = y0    'definition after equation (4.109)

    z0(ray, col) = z0    'this packet of 4 lines contains all information

   NEXT col              'about trace

7 NEXT ray

                         'statistical sums to find focus

                         'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ

 FOR col = 1 TO 3        'initialization of sums

  sy0 = 0: sz0 = 0: sl = 0: sm = 0

  sy0l = 0: sz0m = 0: sll = 0: smm = 0

  sob(col) = 0           'initialization of surviving rays

  FOR ray = 1 TO nray

   IF lost%(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 of focus in each color

                         'equation (4.188)

  fpm(col) = -numerador / denominador

 NEXT col

RETURN                   'from trays

 

progra:                  'propagation to image and graphic

                         'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ

                         'initializations

  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

                         'lost rays are deleted

    IF lost%(ray, col) <> 0 THEN 9

                         'rays in the image in each color

    y(ray, col) = y0(ray, col) + foco * l(ray, col)

    z(ray, col) = z0(ray, col) + foco * m(ray, col)

                         'to calculate y average

    ym(col) = ym(col) + y(ray, col)

                         'extreme rays

    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)

                         'surviving rays

    sob(col) = sob(col) + 1

9  NEXT ray

                         'y average

   ym(col) = ym(col) / sob(col)

  NEXT col

   deltay = yma - ymi

   deltaz = zma - zmi

                         'side of frame

   IF deltay > deltaz THEN side = deltay:  ELSE side = deltaz

                         'plot image

  CLS                    'ÄÄÄÄÄÄÄÄÄÄ

   FOR ray = 1 TO nray

    FOR col = 1 TO 3

     IF lost%(ray, col) <> 0 THEN 10

     IF col = 1 THEN COLOR 9

     IF col = 2 THEN COLOR 14

     IF col = 3 THEN COLOR 12

                         'white dot if there is no chromatic dispersion

     IF y(ray, 3) = y(ray, 2) AND z(ray, 3) = z(ray, 2) THEN COLOR 15

                         'coordinates in the diagram

     yd(col) = 479 * (y(ray, col) - ymi) / side

     zd(col) = 240 + 479 * z(ray, col) / side

                         'dot in the diagram

     PSET (yd(col), zd(col))

                         'symmetric dot respect to x-y plane

     PSET (yd(col), 479 - zd(col))

    NEXT col

10 NEXT ray

   COLOR 15

   LOCATE 2, 4

   PRINT arch$           'print name of optical system

   COLOR 15

   LOCATE 28, 1

   IF dio = 0 THEN       'print data about object

    PRINT "   Object at "; alo; CHR$(248)

   ELSE

    PRINT "   Object in x ="; dio; "mm , y ="; alo; "mm"

   END IF

                         'draw the little arrow

   LOCATE 29, 1: PRINT CHR$(17); : LOCATE 29, 60: PRINT CHR$(16);

   LINE (1, 454)-(478, 454)

                         'side of frame in microns

   sidemi = INT(10000 * side + .5) / 10

                         'side of frame in arcseconds

   sideas = INT(side * 2.06265E+07 / ABS(fep(2))) / 100

   LOCATE 29, 3

   PRINT sidemi; CHR$(230) + "m"; " , "; sideas; "''";

                         'draw frame

   LINE (0, 0)-(479, 479), 2, B

                         'draw diameters of Airy disks

   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 * wln(col) * fep(col) / rep)

    airy = 479 * airy(col) / side

    LINE (1, hh)-(airy, hh + 2), , BF

   NEXT col

                         'x for explicit focus

   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

                         'data related to image in each color

 COLOR 9                 'blue

                         'wavelength in angstroms

 LOCATE 4, 63: PRINT "WL¸ ="; wln(1)

                         'paraxial effective focus

 LOCATE 5, 63: PRINT "PEF ="; fep(1)

                         'paraxial back focus

 LOCATE 6, 63: PRINT "PBF ="; fpp(1)

                         'average back focus

 LOCATE 7, 63: PRINT "ABF ="; fpm(1)

 LOCATE 8, 64: PRINT "YP ="; yp(1)

                         'put 0 to avoid senseless figures

 IF alo = 0 THEN ym(1) = 0

                         'y average

 LOCATE 9, 64: PRINT "YA ="; ym(1)

                         'fraction of transmitted light

 ltran(1) = sob(1) * tfres(1) / nray

 LOCATE 10, 64: PRINT "TL ="; USING ".####"; ltran(1);

 COLOR 14                'yellow

 LOCATE 13, 63: PRINT "WL¸ ="; wln(2)

 LOCATE 14, 63: PRINT "PEF ="; fep(2)

 LOCATE 15, 63: PRINT "PBF ="; fpp(2)

 LOCATE 16, 63: PRINT "ABF ="; fpm(2)

 LOCATE 17, 64: PRINT "YP ="; yp(2)

 IF alo = 0 THEN ym(2) = 0

 LOCATE 18, 64: PRINT "YA ="; ym(2)

 ltran(2) = sob(2) * tfres(2) / nray

 LOCATE 19, 64: PRINT "TL ="; USING ".####"; ltran(2);

 COLOR 12                'red

 LOCATE 22, 63: PRINT "WL¸ ="; wln(3)

 LOCATE 23, 63: PRINT "PEF ="; fep(3)

 LOCATE 24, 63: PRINT "PBF ="; fpp(3)

 LOCATE 25, 63: PRINT "ABF ="; fpm(3)

 LOCATE 26, 64: PRINT "YP ="; yp(3)

 IF alo = 0 THEN ym(3) = 0

 LOCATE 27, 64: PRINT "YA ="; ym(3)

 ltran(3) = sob(3) * tfres(3) / nray

 LOCATE 28, 64: PRINT "TL ="; USING ".####"; ltran(3);

DO: LOOP WHILE INKEY$ = ""

RETURN

 

inquad:

  x = 0                  'ray start from polar tangent plane

  y = y0

  z = z0

  b = cci(s)             'redefinition to compare formulas

  c = cur(s)

                         'equation (4.59)

  'aa = c * (1 + b * k ^ 2)

                         'form for speed

  aa = c * (1 + b * k * k)

                         'equation (4.60)

  bb = k - c * (l * y + m * z)

                         'equation (4.61)

  'dd = c * (y ^ 2 + z ^ 2)

                         'form for speed

  dd = c * (y * y + z * z)

                         'lost by don't intersect quadric

  IF bb * bb - aa * dd < 0 THEN

        lost%(ray, col) = 2

        s = nsu

  END IF

                         'equation (4.63), lambda for quadric

  lambda = dd / (bb + SQR(bb * bb - aa * dd))

                         'coordinates of intersection

  x = lambda * k         'equation (4.53)

  y = y + lambda * l     'equation (4.54)

  z = z + lambda * m     'equation (4.55)

  h = y * y + z * z      'auxiliary quantity

                         'lost by vignetting

  IF h > rcl(s) * rcl(s) OR h < ros(s) * ros(s) THEN lost%(ray, col) = 1

                         'equation (4.69), partial derivatives in quadric

  fx = 1 - c * (1 + b) * x

  fy = -c * y            'equation (4.70)

  fz = -c * z            'equation (4.71)

                         'equation (4.68)

  norma = SQR(fx * fx + fy * fy + fz * fz)

                         'direction cosines of normal to quadric

  alfa = fx / norma      'equation (4.65)

  beta = fy / norma      'equation (4.66)

  gama = fz / norma      'equation (4.67)

RETURN                   'from inquad

 

inasph:

  x = 0                  'ray start from polar tangent plane

  y = y0

  z = z0

  b = cci(s)             'redefinition to compare formulas

  c = cur(s)

  d = co4(s)

  e = co6(s)

  f = co8(s)

  DO                     'start iterated intersection

   'h = y ^ 2 + z ^ 2    'auxiliary quantities

   'rac2 = 1 - (1 + b) * c ^ 2 * h

                         'forms for speed

   h = y * y + z * z

   rac2 = 1 - (1 + b) * c * c * h

                         'lost by don't intersect aspheric

   IF rac2 < 0 THEN

        lost%(ray, col) = 3

        s = nsu

   END IF

   rac = SQR(rac2)

                         'equation (4.79)

   'g = c / rac + 4 * d * h + 6 * e * h ^ 2 + 8 * f * h ^ 3

                         'form for speed

   g = c / rac + 2 * h * (2 * d + h * (3 * e + 4 * f * h))

                         'equation (4.80)

   'norma = SQR(1 + g ^ 2 * h)

                         'form for speed

   norma = SQR(1 + g * g * h)

                         'direction cosines of iterated normal

   alfa = 1 / norma      'equation (4.65) for aspheric

   beta = -g * y / norma 'equation (4.66) for aspheric

   gama = -g * z / norma 'equation (4.67) for aspheric

                         'equation (4.73), x on aspheric

   'xasf = (c * h / (1 + rac)) + d * h ^ 2 + e * h ^ 3 + f * h ^ 4

                         'form para speed

   xasf = (c / (1 + rac) + (d + (e + f * h) * h) * h) * h

                         'equation (4.85), lambda for aspheric

   lambda = (xasf - x) * alfa / (alfa * k + beta * l + gama * m)

   x = x + lambda * k    'equation (4.81)

   y = y + lambda * l    'equation (4.82)

   z = z + lambda * m    'equation (4.83)

                         'lost by vignetting

   IF h > rcl(s) * rcl(s) OR h < ros(s) * ros(s) THEN lost%(ray, col) = 1

                         'end of iterated intersection

  LOOP UNTIL ABS(lambda) < 1E-10

RETURN                   'from inasph

 

labsai:

                         'point 3. Label S-I

    CLS

    COLOR 1

    LOCATE 1, 1: PRINT "3"; : FOR i = 2 TO 80: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 1, 66: PRINT " ave"

    LOCATE 1, 76: PRINT " ndex"

    COLOR 12

    LOCATE 1, 66: PRINT "S"

    LOCATE 1, 76: PRINT "I"

RETURN                   'from labsai

 

labsid:                  'point 4. Label "S-I-D"

    COLOR 1

    LOCATE 1, 1: PRINT "4"; : FOR i = 2 TO 80: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 1, 51: PRINT " ave"

    LOCATE 1, 62: PRINT " mage"

    LOCATE 1, 74: PRINT " rawing";

    COLOR 12

    LOCATE 1, 51: PRINT "S"

    LOCATE 1, 62: PRINT "I"

    LOCATE 1, 74: PRINT "D"

    COLOR 15

RETURN                   'from labsid

 

edasph:                  'edit aspheric

    PRINT : PRINT "Aspherics": PRINT "ÄÄÄÄÄÄÄÄÄ"

    PRINT " S³ Citric constant ³   Aspheric (4)  ³   Aspheric (6)  ³   Aspheric (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                   'from edasph

 

nombre:      

    cd1$ = "         Dilatation coefficient, (-30ųC - 70ųC) in 10^6/ųC ÄÄÄÄÄ ="

    cd2$ = "         Dilatation coefficient, (20ųC - 300ųC) in 10^6/ųC ÄÄÄÄÄ ="

    tdi$ = "         Distension temperature in ųC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    tda$ = "         Softening temperature in ųC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    cei$ = "         Isobaric specific heat in J/gųC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    cot$ = "         Thermal conductivity in W/mųC ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    den$ = "         Density in g/cm^3 ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    moy$ = "         Young modulus in 10^-3 N/mm^2 ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    rep$ = "         Poisson ratio ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    duk$ = "         Knoop hardness ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    ccb$ = "         Class of bubble content (0 - 3) ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    crc$ = "         Class of weather resistance (1 - 4) ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    crt$ = "         Class of stain resistance (0 - 5) ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    cra$ = "         Class of acid resistance (1 - 4 or 51 - 53) ÄÄÄÄÄÄÄÄÄÄÄ ="

    crk$ = "         Class of alkali resistance (1 - 4) ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

    ti5$ = "         Internal transmittance at 4000 A over 5 mm ÄÄÄÄÄÄÄÄÄÄÄÄ ="

    t25$ = "         Internal transmittance at 4000 A over 25 mm ÄÄÄÄÄÄÄÄÄÄÄ ="

    peb$ = "         Estimated price related to BK7 ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ ="

RETURN                   'from nombre

 

labogf:                  'labogf: label "O-G-F"

    CLS

    COLOR 1

    PRINT : PRINT

    FOR i = 1 TO 9

    PRINT "ŪŪŪŪŪŪŪŪŪŪŪŪŪŪŪŪŪ"

    NEXT i

    COLOR 15

    LOCATE 4, 2: PRINT "Optical  ystem"

    LOCATE 7, 3: PRINT "lass"

    LOCATE 10, 3: PRINT "ile"

    COLOR 12

    LOCATE 4, 10: PRINT "s"

    LOCATE 7, 2: PRINT "G"

    LOCATE 10, 2: PRINT "F"

    COLOR 15

 

RETURN                   'from labogf

  

ogfdce:      

    COLOR 1

    LOCATE 1, 1: PRINT "5"; : FOR i = 2 TO 80: PRINT "Ū"; : NEXT i

    COLOR 15

    LOCATE 1, 23: PRINT " bject"

    LOCATE 1, 34: PRINT " lass"

    LOCATE 1, 44: PRINT "Index:"

    LOCATE 1, 73: PRINT " xplicit";

    COLOR 12

    LOCATE 1, 23: PRINT "O"

    LOCATE 1, 34: PRINT "G"

    COLOR 9

    LOCATE 1, 55: PRINT "F"

    COLOR 14

    LOCATE 1, 61: PRINT "D"

    COLOR 12

    LOCATE 1, 67: PRINT "C"

    LOCATE 1, 73: PRINT "E"

RETURN                   'from ogfdce

 

paraxi:

 IF r <> 0 THEN c = 1 / r:  ELSE c = 0

                         'equation (4.11)

 u1 = n * u / n1 + (1 - n / n1) * y * c

 y1 = y - d * u1         'equation (4.10)

 u = u1: y = y1: n = n1

RETURN                   'from 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 "### of ### is \            \"; 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