Ask Question

Name:
Title:
Your Question:

Answer Question

Name:
Your Answer:
User Submitted Source Code!


Description:
  mio
Language: BASIC
Code:
DEFDBL A-G, M-Z
DEFINT I-L
DECLARE SUB intesta ()
DECLARE SUB angdir (pi, XS, YS, XT, YT, DZ, TETA, CD, SD)
DECLARE SUB supercoeff (l%, j%, k%, N4, GM, XZERO(), YZERO(), E(), ia%(), CORRO(), NVCO(), ncor, NVC, tp)
DECLARE SUB inversa (A(), corr(), ninc, nnn)
ON ERROR GOTO errore1
npt = 30: n2c = npt - 1: n1a = n2c + CINT(npt / 3): nino = 7
neq = npt * 10: nn = 2 * n2c + n1a: KNQ = 2 * nn + neq: nn1n = nn * (nn + 1) / 2
DIM gmis(neq), sigma(neq), TN(neq)
DIM inpin(neq), inpst(neq), inpav(neq), nsa(neq)
DIM IG(neq), nome(npt), itipo(npt), NVCO(n1a)
DIM E(nino), OG$(4), o$(npt), ia(nino)
DIM XZERO(npt), YZERO(npt)
DIM sqm(nn), corr(nn), CORRO(n1a)
DIM A(nn1n)
CALL intesta
FLAG = 0
pi = 4# * ATN(1#)
rgc = 200! / pi
' ---------------- inizio ciclo elaborazione dati operazione topografica
'  ---------------------------------- Composizione e stampa tabella vertici
CLS 0
INPUT "nome del file destinato a contenere i risultati     "; outfile$
OPEN "o", 11, outfile$
WIDTH #11, 132
PRINT #11, CHR$(15);
PRINT #11, " nome del lavoro "; UCASE$(outfile$)
ON ERROR GOTO errore2
INPUT "nome del file contenente le coordinate approssimate "; file$
PRINT #11, " nome del file delle coordinate approssimate :"; UCASE$(file$)
OPEN file$ FOR INPUT AS #2
i = 0
'xzero=est
'yzero=nord
WHILE NOT EOF(2)
     i = i + 1
     INPUT #2, nome(i), o$(i), XZERO(i), YZERO(i), itipo(i)
WEND
nvert = i
CLOSE #2
IF nvert > npt THEN istop = 3: GOTO uscita
' ordina e conta i vertici posponendo i fissi
i = 0
lo% = 0
DO WHILE i < nvert
     i = i + 1
     IF itipo(i) = 0 THEN
          lo% = 0
          FOR j = i + 1 TO nvert
               IF itipo(j) = 1 THEN
                    SWAP nome(i), nome(j)
                    SWAP XZERO(i), XZERO(j)
                    SWAP YZERO(i), YZERO(j)
                    SWAP o$(i), o$(j)
                    itipo(i) = 1
                    itipo(j) = 0
                    lo% = -1
                    EXIT FOR
               END IF
          NEXT j
          IF NOT lo% THEN EXIT DO
     END IF
LOOP
npfix = 0
FOR i = 1 TO nvert
     IF itipo(i) = 0 THEN npfix = npfix + 1
NEXT i
IF npfix = 0 THEN istop = 1313: GOTO uscita
NVC = nvert - npfix
nvc2 = 2 * NVC
somsig = 0
istop = 0
k = 0
INPUT "nome del file contenete le misure                   "; file$
PRINT #11, " nome del file delle misure :"; UCASE$(file$)
OPEN file$ FOR INPUT AS #2
N1COR = 0
ID = 0
ncor = 0
i = 0
INPUT #2, istudi, iscrit
WHILE NOT EOF(2)
     i = i + 1: INPUT #2, gmis(i), sigma(i), NPIN, npst, npav, nsaa$
     nsaa$ = STR$(npst) + "." + nsaa$
     nsa(i) = VAL(nsaa$)
     somsig = somsig + sigma(i)
     i1 = 0
     IF NPIN <= 0 THEN
          i1 = 1
          inpin(i) = NPIN
     END IF
     i2 = 0
     i3 = 0
     IF npav = 0 THEN
          i3 = 1
          inpav(i) = 0
     END IF
     FOR ii = 1 TO nvert
          IF i1 = 0 THEN
               IF nome(ii) = NPIN THEN
                    inpin(i) = ii
                    i1 = 1
               END IF
          END IF
          IF npst = nome(ii) AND i2 = 0 THEN
               inpst(i) = ii
               i2 = 1
          END IF
          IF i3 = 0 THEN
               IF npav = nome(ii) THEN
                    inpav(i) = ii
                    i3 = 1
               END IF
          END IF
     NEXT ii
     isom = i1 + i2 + i3
     IF isom <> 3 THEN
          istop = 21
          GOTO uscita
     END IF
     IF NPIN = -1 THEN N1COR = N1COR + 1
     IF NPIN = -1 THEN
     '    IF NSA(i)=0 THEN
     '        NSA(I)=NPST 'non c'e' stazione ripetuta
     '    end if
          ice% = (1 = 2)
          FOR j = 1 TO ncor'controllo se nsa esiste gia' in tabella
               IF nsa(i) = NVCO(j) THEN
                    ice% = (1 = 1)'ice% e' vero se esiste
                    EXIT FOR
               END IF
          NEXT j
          IF NOT ice% THEN  'se ice% e' falso
               ncor = ncor + 1
               IF ncor > (n1a - 1) THEN istop = 2: GOTO uscita
               NVCO(ncor) = nsa(i)
               CORRO(ncor) = 0
          END IF
     END IF
WEND
nmis = i
CLOSE #2
IF nmis > neq THEN istop = 1: GOTO uscita
ninc = nvc2 + ncor
IF ninc > nn THEN istop = 4: GOTO uscita
N2IM = 2 * ninc + nmis
NINC1 = ninc + 1
NIM = nmis + ninc
mi = nmis - ninc

irip = 0
nnn = ninc * (ninc + 1) / 2
'  ----------------   inizio ciclo  di reiterazione
pip$ = "Universita' dell'Aquila - TOPOGRAFIA - Copyright R.CARLUCCI 1990 "
PRINT #11, pip$
PRINT #11, "    Dati di input : coordinate dei vertici"
PRINT #11, "    nome         identificativo   tipo           nord            est     "
oo$ = "     "
FOR i = 1 TO nvert
o$(i) = oo$ + o$(i)
RSET o$(i) = o$(i)
tp$ = "var."
IF itipo(i) = 0 THEN tp$ = "fisso"
PRINT #11, USING " \         \      #######         \   \   ########.###    ########.### "; o$(i); nome(i); tp$; YZERO(i); XZERO(i)
IF i / 60 = INT(i / 60) THEN
     PRINT #11, pip$
     PRINT #11, CHR$(12)
     PRINT #11, pip$
     PRINT #11, "    Dati di input : coordinate dei vertici    [segue]"
     PRINT #11, "    nome         identificativo   tipo           nord             est     "
END IF
NEXT i
PRINT #11, pip$
PRINT #11, pip$
PRINT #11, pip$
PRINT #11, "    Dati di input : misure"
PRINT #11, " n     misura [GC o M]   sqm [CC o MM]       tipo           tra i vertici"
FOR i = 1 TO nmis
     IF inpav(i) = 0 THEN
          PRINT #11, USING "###    ######.#####      ####.##          \            \    !#######!#######!"; i; gmis(i); sigma(i); "distanza "; "("; nome(inpst(i)); "-"; nome(inpin(i)); ")";
          EQG = 1
          EQM = 1000#
          IF somsig = 0 THEN sigma(i) = SQR(2)
     ELSE
          IF inpin(i) = -1 THEN
               PRINT #11, USING "###    ######.#####      ####.##          \            \    !#######!#######!"; i; gmis(i); sigma(i); "direzione"; "("; nome(inpst(i)); "-"; nome(inpav(i)); ")";
          ELSEIF inpin(i) = 0 THEN
               PRINT #11, USING "###    ######.#####      ####.##          \            \    !#######!#######!"; i; gmis(i); sigma(i); "azimut   "; "("; nome(inpst(i)); "-"; nome(inpav(i)); ")";
          ELSE
               PRINT #11, USING "###    ######.#####      ####.##          \            \ !#######!#######!#######!"; i; gmis(i); sigma(i); "angolo   "; "("; nome(inpin(i)); ","; nome(inpst(i)); ","; nome(inpav(i)); ")";
          END IF
          EQG = rgc
          EQM = rgc * 10000#
          IF somsig = 0 THEN sigma(i) = SQR(2) / 10
     END IF
     IF sigma(i) = 0 THEN
          sigma(i) = .01#
          PRINT #11, " [sqm nullo : quasi una condizione]"
     ELSE
          PRINT #11,
     END IF
     gmis(i) = gmis(i) / EQG
     sigma(i) = sigma(i) / EQM
     IF i / 60 = INT(i / 60) THEN
          PRINT #11, pip$
          PRINT #11, CHR$(12)
          PRINT #11, pip$
          PRINT #11, "    Dati di input : misure"
          PRINT #11, " n     misura [GC o M]   sqm [CC o MM]       tipo           tra i vertici"
     END IF
NEXT i
'  ----------------  calcolo del  SIGZER
GGG = 0
FOR i = 1 TO (nvert - 1)
     FOR k = (i + 1) TO nvert
          CALL angdir(pi, XZERO(i), YZERO(i), XZERO(k), YZERO(k), DZ, TETA, CD, SD)
          GGG = GGG + DZ
     NEXT k
NEXT i
GGG = GGG / (nvert * (nvert - 1) / 2)
sss = 0
ddd = 0
k = 0
FOR i = 1 TO nmis
     IF inpav(i) <> 0 THEN     'non distanze
          sss = sss + sigma(i)
     ELSE
          k = k + 1
          ddd = ddd + sigma(i)
     END IF
NEXT i
IF nmis <> k THEN sss = sss / (nmis - k)
IF k <> 0 THEN ddd = ddd / k
sigzer = (sss * GGG + ddd) / 2#
PRINT #11, pip$
PRINT #11, CHR$(12)
PRINT #11, pip$
PRINT #11, "  Il calcolo riguarda "; nvert; "vertici dei quali "; npfix; " fissi"
PRINT #11, "  Le incognite lineari (correzioni delle coordinate) sono "; nvc2
IF ncor > 0 THEN
     PRINT #11, "  Le incognite angolari (correzioni d'orientamento) sono "; ncor
END IF
PRINT #11, "  Le misure sono "; nmis
PRINT #11, "  Le equazioni e i termini noti sono moltiplicati per lo sqm a priori "
PRINT #11, " che vale "; INT(sigzer * 10000 + .5) / 10000; " unita' omogenee (radianti o metri)"
DO
     irip = irip + 1
     REDIM A(nnn), corr(ninc)
' -------------  calcolo coefficienti delle incognite e costruzione matrice
FOR i = 1 TO nmis
     LOCATE 22, 60: PRINT "-"; irip; "->"; nmis + 1 - i + ninc
     REDIM E(nino), ia(nino)
     CALL supercoeff(inpin(i), inpst(i), inpav(i), nsa(i), gmis(i), XZERO(), YZERO(), E(), ia(), CORRO(), NVCO(), ncor, NVC, tp)

     'equiponderazione'
     FP = sigzer / sigma(i)
     'determina l'ultimo indice valido
     iu = 0
     FOR j = 1 TO 6
          IF ia(j) > 0 THEN
               iu = iu + 1
          ELSE
               EXIT FOR
          END IF
     NEXT j
     IF iscrit = 1 AND irip = 1 OR irip = 5 THEN
          IF i / 60 = INT(i / 60) OR i = 1 THEN
               PRINT #11, pip$
               PRINT #11, CHR$(12)
               PRINT #11, pip$
               PRINT #11, "    equazioni     relative al ciclo n. "; irip; " t.noti in mm o cc"
          END IF
          PRINT #11, USING "\ \ ### "; "n."; i;
          FOR j = 1 TO iu
               IF ia(j) <= nvc2 THEN
                    IF ia(j) / 2 = INT(ia(j) / 2) THEN 'se ia(j) e' pari
                         PRINT #11, USING "+##.##^^^^ "; E(j);
                         PRINT #11, "Y("; STR$(nome(ia(j) / 2)); ")";
                    ELSE
                         PRINT #11, USING "+##.##^^^^ "; E(j);
                         PRINT #11, "X("; STR$(nome((ia(j) + 1) / 2)); ")";
                    END IF
               ELSE
                    PRINT #11, USING "+##.##^^^^ "; E(j);
                    PRINT #11, "("; STR$(NVCO(ia(j) - nvc2)); ")";
               END IF
          NEXT j
          e1 = 1000
          IF inpav(i) <> 0 THEN
               e1 = rgc * 10000
          END IF
          PRINT #11, USING "_= ##.##^^^^ "; tp * e1
          IF i = nmis THEN
               PRINT #11, pip$
               PRINT #11, CHR$(12)
               PRINT #11, pip$
          END IF
     END IF
     FOR j = 1 TO iu
          E(j) = E(j) * FP
     NEXT j
     E(7) = tp * FP
     FOR j = 1 TO iu
          kk = ia(j) + ninc * (ia(j) - 1) - ia(j) * (ia(j) - 1) / 2
          kkj = kk
          FOR jj = j TO iu
               kk = kkj + ia(jj) - ia(j)
               A(kk) = E(j) * E(jj) + A(kk)
          NEXT jj
          corr(ia(j)) = corr(ia(j)) - E(j) * E(7)
     NEXT j
     SVa = SVa + (tp * FP) ^ 2
NEXT i

'  ------------   calcolo soluzioni
ii = 0
FOR i = 1 TO ninc
     ii = ii + 1
     IF A(ii) <= 0 THEN
          PRINT #11, : PRINT #11, "matrice errata in riga/colonna n.  "; i
          istop = 999: GOTO uscita
     END IF
     ii = ii + ninc - i
NEXT i
A(1) = SQR(A(1))
FOR i = 2 TO ninc
     A(i) = A(i) / A(1)
NEXT i
ii = ninc
FOR i = 2 TO ninc
     ii = ii + 1
     sm = 0#
     kk = i
     ll = i - 1
     FOR k = 1 TO ll
          sm = sm + A(kk) * A(kk)
          kk = kk + ninc - k
     NEXT k
     A(ii) = SQR(A(ii) - sm)
     l = i + 1
     jj = ii
     FOR j = l TO ninc
          sm = 0#
          jj = jj + 1
          kk = i
          jk = j
          FOR k = 1 TO ll
               sm = sm + A(kk) * A(jk)
               kk = kk + ninc - k
               jk = jk + ninc - k
          NEXT k
          A(jj) = (A(jj) - sm) / A(ii)
     NEXT j
     ii = ii + ninc - i
     LOCATE 22, 60: PRINT "-"; irip; "->"; ninc + 1 - i
NEXT i
FOR i = 1 TO ninc
     jj = i
     FOR k = 1 TO i - 1
          corr(i) = corr(i) - corr(k) * A(jj)
          jj = jj + ninc - k
     NEXT k
     corr(i) = corr(i) / A(jj)
NEXT i
jj = nnn + 1
FOR i = ninc TO 1 STEP -1
     FOR k = ninc TO i + 1 STEP -1
          jj = jj - 1
          corr(i) = corr(i) - corr(k) * A(jj)
     NEXT k
     jj = jj - 1
     corr(i) = corr(i) / A(jj)
NEXT i
LOCATE 22, 60: PRINT "-"; irip; "->"; 0
IF irip > 1 THEN  'superato il primo ciclo
     IF SVa >= svp THEN 'se sva e' aumentato  calcola la matrice inversa
          REDIM corr(ninc)
          CALL inversa(A(), corr(), ninc, nnn)
          EXIT DO
     END IF
END IF
svp = SVa
SVa = 0
' ----  sostituisce in tabella vertici le nuove coordinate
'-----  memorizza le correzioni
FOR i = 1 TO NVC
     j = 2 * i - 1
     k = 2 * i
     XZERO(i) = XZERO(i) + corr(j)
     YZERO(i) = YZERO(i) + corr(k)
NEXT i
FOR i = 1 TO ncor
     kk = nvc2 + i
     CORRO(i) = CORRO(i) + corr(kk)
NEXT i
IF irip = 1 THEN
     LOCATE 4, 35
     PRINT "correzioni  "
END IF
LOCATE 5, 1
PRINT " ciclo n. "; irip
PRINT "correzioni alle coordinate [m] :"
FOR i = 1 TO NVC * 2
     PRINT USING "+#.##^^^^ "; corr(i);
     IF i / 8 = INT(i / 8) THEN PRINT
NEXT i
PRINT
IF ncor > 0 THEN
     PRINT "correzioni agli orientamenti [gc] :"
     DO UNTIL i > ninc
          PRINT USING "+#.##^^^^ "; corr(i) * rgc;
          IF i / 8 = INT(i / 8) THEN PRINT
          i = i + 1
     LOOP
END IF
IF irip > 50 THEN
     PRINT #11, "superati i 50 cicli:procedimento non convergente"
          REDIM corr(ninc)
          SVa = svp
          CALL inversa(A(), corr(), ninc, nnn)
     EXIT DO
END IF
LOOP
fine: ' valori definitivi
irip = irip - 1
' -------------  calcolo s.q.m. incognite
varu = sigzer ^ 2
IF mi > 0 AND istudi = 0 THEN
     DMI = mi
     varu = SVa / DMI
END IF
sqmu = SQR(varu)
ii = 0
FOR i = 1 TO ninc
     ii = ii + 1
     sqm(i) = sqmu * SQR(A(ii))
     ii = ii + ninc - i
NEXT i


'  -------------------   stampa tabella risultati
PRINT #11, pip$
PRINT #11, pip$
PRINT #11, "la soluzione e' stata ottenuta dopo ";
PRINT #11, USING " ## "; irip;
PRINT #11, "cicli"
PRINT #11, pip$
PRINT #11, pip$
PRINT #11, "    Risultati : coordinate dei vertici compensate"
PRINT #11, "    nome         identificativo   tipo           nord  +- sqm             est  +- sqm     "
FOR i = 1 TO nvert
tp$ = "var."
IF itipo(i) = 1 THEN
     PRINT #11, USING " \         \      #######         \   \   ########.###_ _+_-##.###    ########.###_ _+_-##.###  "; o$(i); nome(i); tp$; YZERO(i); sqm(2 * i); XZERO(i); sqm(2 * i - 1)
ELSE
     tp$ = "fisso"
     PRINT #11, USING " \         \      #######         \   \   ########.###_ _+_- \  \    ########.###_ _+_- \  \  "; o$(i); nome(i); tp$; YZERO(i); "----"; XZERO(i); "----"
END IF
IF i / 60 = INT(i / 60) THEN
     PRINT #11, pip$
     PRINT #11, CHR$(12)
     PRINT #11, pip$
     PRINT #11, "   Risultati : coordinate dei vertici compensate   [segue]"
     PRINT #11, "    nome         identificativo   tipo           nord  +- sqm             est  +- sqm     "
END IF
NEXT i
PRINT #11, pip$
IF ncor > 0 THEN
     PRINT #11, "    Risultati : orientamenti compensati"
     PRINT #11, "    Identificativo      correzione d'orientamento +/-sqm [GC]"
     ii = nvc2 * (ninc + 1) - nvc2 * (nvc2 + 1) / 2
     FOR i% = 1 TO ncor
          ii = ii + 1
          cori = CORRO(i%) * rgc
          scor = sqm(nvc2 + i%) * rgc
          PRINT #11, USING "     #######.###                    ####.####_+_/_- ##.####"; NVCO(i%); cori; scor
          ii = ii + ncor - i%
     NEXT i%
     PRINT #11, pip$
     PRINT #11, CHR$(12)
     PRINT #11, pip$
END IF
IF mi = 0 THEN
     PRINT #11, " il problema Š risolto col minimo numero di misure"
     PRINT #11, " i parametri di errore sono in funzione degli sqm delle misure"
END IF
IF istudi = 1 THEN
     PRINT #11, " rete di progetto: "
     PRINT #11, " i parametri di errore sono in funzione degli sqm delle misure"
     IF mi = 0 THEN mi = 1
     sqmu = SQR(varu / mi)
END IF
PRINT #11,
PRINT #11, USING " s.q.m. a priori     :######.#####"; sigzer
PRINT #11, USING " s.q.m. a posteriori :######.#####"; sqmu

IF iscrit = 1 THEN
     PRINT #11,
     PRINT #11, "        MATRICE DI VARIANZA-COVARIANZA": PRINT #11,
     k = 0
     FOR j = 1 TO ninc
          PRINT #11, USING "\    \ ### "; "RIGA N."; j;
          FOR i = j TO ninc
                    k = k + 1
                    PRINT #11, USING "##.##^^^^ "; A(k) * varu;
                    IF (i - j + 1) MOD 8 = 0 THEN
                         PRINT #11,
                         PRINT #11, "           ";
                    END IF
          NEXT i
          PRINT #11,
          IF j / 60 = INT(j / 60) THEN
               PRINT #11, pip$
               PRINT #11, CHR$(12)
               PRINT #11, pip$
               PRINT #11, "        MATRICE DI VARIANZA-COVARIANZA  [segue]": PRINT #11,
          END IF
     NEXT j
     PRINT #11, pip$
     PRINT #11, CHR$(12)
END IF
IF NVC > 0 THEN
     PRINT #11, pip$
     PRINT #11, "   ELEMENTI CARATTERISTICI DELLE ELLISSI D' ERRORE": PRINT #11,
     PRINT #11, "   NOME  DIREZIONE ASSE   SEMIAS.MAG.      SEMIAS.MIN."
     PRINT #11, "             [GC]            [M]               [M]"
     k = 0
     FOR l = 1 TO NVC
     i = 2 * l - 1
          k = k + 1
          sx = A(k) * varu
          sxy = A(k + 1) * varu
          k = k + ninc - i + 1
          sy = A(k) * varu
          i = i + 1
          k = k + ninc - i
          PR = (sy + sx)
          RA = SQR((sy - sx) ^ 2 + 4 * sxy ^ 2)
          AR1 = (PR + RA) / 2
          AR2 = (PR - RA) / 2
          deltas = sy - sx
          IF deltas <> 0 THEN
               ta = -sxy / deltas
               at = ATN(ABS(ta)) / 2
               IF ta >= 0 THEN
                    IF syx >= 0 THEN
                         An = at
                    ELSE
                         An = at + pi / 2
                    END IF
               ELSE
                    IF sxy < 0 THEN
                         An = pi - at
                    ELSE
                         An = pi / 2 - at
                    END IF
               END IF
          ELSE
               An = 0
          END IF
          An = An * rgc
          IF AR1 > 0 AND AR2 > 0 THEN
               ASSA = SQR(AR1)
               ASSB = SQR(AR2)
               PRINT #11, USING "######     ###.####        ##.####"; nome(l); An; ASSA;
               PRINT #11, USING "          ##.####"; ASSB
          ELSE
               PRINT #11, nome(l); " *** argomenti negativi ***  "; AR1; "   "; AR2
          END IF
          IF l / 60 = INT(l / 60) THEN
               PRINT #11, pip$
               PRINT #11, CHR$(12)
               PRINT #11, pip$
               PRINT #11, "   NOME  DIREZIONE ASSE   SEMIAS.MAG.      SEMIAS.MIN."
               PRINT #11, "             [GC]            [M]               [M]"
          END IF
     NEXT l
     PRINT #11, CHR$(12)
END IF
ON ERROR GOTO errore
END
REM --------------------------------------------------------  F I N E -----
'        
uscita:
 IF istop = 666 THEN PRINT #11, " --------- superati 50 cicli"
 IF istop = 21 THEN
     PRINT #11, "il punto ";
     IF (i1 = 0) THEN PRINT #11, nome(inpin(i));
     IF (i2 = 0) THEN PRINT #11, nome(inpst(i));
     IF (i3 = 0) THEN PRINT #11, nome(inpav(i));
     PRINT #11, " non esiste nella tabella dei vertici'"
 END IF
 IF istop = 1 THEN PRINT #11, "La rete ha troppe misure :"; nmis; " max = "; neq
 IF istop = 2 THEN PRINT #11, "La rete ha troppe incognite d'orientamento :"; ncor; " max = "; n1a - 1
 IF istop = 3 THEN PRINT #11, "La rete ha troppi vertici :"; nvert; " max = "; npt
 IF istop = 4 THEN PRINT #11, "La rete ha troppe incognite :"; ninc; " max = "; nn - 1
 IF istop = 999 THEN PRINT #11, "Probabile incongruenza geometrica"
 IF istop = 1313 THEN PRINT #11, "La rete non ha punti fissi"
 END
errore:
IF istop = 0 THEN
     PRINT #11, " --------------- verificato errore codice :"; -ERR - 2
     RESUME NEXT
END IF
END

errore1:
OPEN "$$cal.err" FOR OUTPUT AS 12
PRINT #12, " --------------- verificato errore codice :"; -ERR - 2
CLOSE 11
PRINT " --------------- verificato errore ---------- :"
PRINT "maggiori dettagli nel file $$cal.err "
END

errore2:
     PRINT #11, " --------------- verificato errore codice :"; -ERR - 2
END

'-------------------------------------------
SUB angdir (pi, XS, YS, XT, YT, DZ, TETA, CD, SD) STATIC
DX = XT - XS
DY = YT - YS
DZ2 = DX ^ 2 + DY ^ 2
DZ = SQR(DZ2)
DE = DY + DZ
TETA = pi
IF DE <> 0 THEN TETA = 2 * ATN(DX / DE)
IF DZ > 0 THEN
     CD = COS(TETA) / DZ
     SD = SIN(TETA) / DZ
ELSE
     CD = 0
     SD = 0
     TETA = 0
END IF
IF TETA < 0 THEN TETA = TETA + 2 * pi
END SUB

SUB intesta STATIC
CLS
PRINT "  Programma per il calcolo di compensazione planimetrica"
PRINT "  Versione didattica 1.00 - UNIV. AQ. TOPOGRAFIA (R.CARLUCCI) 1990"
LOCATE 22, 1
PRINT " <premere i per leggere le istruzioni oppure s per eseguire il calcolo>"
DO UNTIL (A$ = "i" OR A$ = "I" OR A$ = "s" OR A$ = "S")
     A$ = INKEY$
LOOP
SELECT CASE A$
CASE "s", "S"
     EXIT SUB
CASE ELSE
END SELECT
CLS
PRINT "  Formato dei dati di ingresso :file delle coordinate approssimate"
PRINT "                     ogni record:identificativo,nome,nord,est,tipo"
PRINT "                     identificativo = intero positivo "
PRINT "                     nome           = stringa di caratteri "
PRINT "                     est            = reale                "
PRINT "                     nord           = reale                "
PRINT "                     tipo           = 0 oppure 1           "
PRINT "                     tipo = 1 : il vertice e' da compensare"
PRINT "                     tipo = 0 : il vertice e' fisso"
LOCATE 22, 12
PRINT " <premere c per continuare oppure s per terminare>"
A$ = ""
DO UNTIL (A$ = "c" OR A$ = "C" OR A$ = "s" OR A$ = "S")
     A$ = INKEY$
LOOP
SELECT CASE A$
CASE "s", "S"
     END
CASE ELSE
END SELECT
A:
CLS 0
PRINT "  Formato dei dati di ingresso :file delle misure"
PRINT "  primo record : indicatore di studio [is],indicatore di stampa [os]"
PRINT "        [is] = 0 oppure 1"
PRINT "                     [is] = 1 : calcolo di progetto della rete"
PRINT "                     [is] = 0 : calcolo della rete misurata"
PRINT "        [os] = 0 oppure 1"
PRINT "                     [os] = 1 : stampa estesa dei risultati "
PRINT "                     [os] = 0 : stampa ridotta dei risultati "
PRINT "  successivi record : m,s,in,st,av,or"
PRINT "        m = misura"
PRINT "                     [se angolare in GC ,se di distanza in metri]"
PRINT "        s = scarto quadratico medio"
PRINT "                     [in decimillesimi di GC o in millimetri    ]"
PRINT "                     [se sono noti i pesi p allora s=radice(1/p)]"
PRINT "       in = identificativo o codice"
PRINT "       st = identificativo"
PRINT "       av = identificativo o codice"
PRINT "       or = stringa di caratteri"
LOCATE 22, 1
PRINT "<premere c per continuare oppure s per terminare oppure r per rileggere>"
A$ = ""
DO UNTIL (A$ = "c" OR A$ = "C" OR A$ = "s" OR A$ = "S" OR A$ = "r" OR A$ = "R")
     A$ = INKEY$
LOOP
SELECT CASE A$
CASE "s", "S"
     END
CASE "r", "R"
 GOTO A
CASE ELSE
END SELECT
CLS 0
PRINT " Codifica del tipo di misura:"
PRINT " - identificativo = intero positivo"
PRINT " - codice         = 0 oppure -1"
PRINT " - st  e' l'identificativo della stazione"
PRINT " - in  e' l'identificativo del punto a sinistra dell'osservatore nelle"
PRINT "       misure di angoli [angoli minori di 200 GC ]"
PRINT "       se in = 0  la misura e' di tipo azimut assoluto"
PRINT "       se in = -1 la misura e' di tipo direzione"
PRINT " - av  e' l'identifiativo del punto a destra dell'osservatore nelle"
PRINT "       misure di angoli [angoli minori di 200 GC ]"
PRINT "       se av = 0 la misura e'di tipo distanza"
PRINT " - or  e' il nome della stazione ripetuta"
PRINT "       nomi diversi corrispondono a diversi orientamenti della stessa"
PRINT "       stazione"
LOCATE 22, 1
PRINT "<premere c per continuare oppure s per terminare oppure r per rileggere>"
A$ = ""
DO UNTIL (A$ = "c" OR A$ = "C" OR A$ = "s" OR A$ = "S" OR A$ = "r" OR A$ = "R")
     A$ = INKEY$
LOOP
SELECT CASE A$
CASE "s", "S"
     END
CASE "r", "R"
 GOTO A
CASE ELSE
END SELECT
CLS 0
END SUB

SUB inversa (A(), corr(), ninc, nnn) STATIC
BEEP: BEEP
A(nnn) = 1 / A(nnn) / A(nnn)
FOR l = 2 TO ninc
     i = ninc + 1 - l
     ii = i + (i - 1) * ninc - i * (i - 1) / 2
     ll = i + 1
     FOR j = ll TO ninc
          corr(j) = A(ii + j - i)
     NEXT j
     FOR j = ll TO ninc
          ij = j + (j - 1) * ninc - j * (j - 1) / 2
          sm = 0#
          FOR k = ll TO j
               ik = k + (k - 1) * ninc - k * (k - 1) / 2
               sm = sm + corr(k) * A(ik + j - k)
          NEXT k
          kk = j + 1
          FOR k = kk TO ninc
               sm = sm + corr(k) * A(ij + k - j)
          NEXT k
          A(ii + j - i) = -sm / A(ii)
     NEXT j
     sm = 0#
     FOR k = ll TO ninc
          sm = sm + corr(k) * A(ii + k - i)
     NEXT k
     A(ii) = (1 / A(ii) - sm) / A(ii)
     LOCATE 22, 60: PRINT "*"; irip; "->"; ninc + 1 - l
NEXT l
LOCATE 22, 60: PRINT "*"; irip; "->"; 0
END SUB

SUB supercoeff (l, j, k, N4, GM, XZERO(), YZERO(), E(), ia(), CORRO(), NVCO(), ncor, NVC, tp) STATIC
     DEFDBL A-G, M-Z
     DEFINT I-L
     pi = 4# * ATN(1#)
     IF l <= 0 THEN 'equazione di direzione o azimut
          x2 = XZERO(j)
          y2 = YZERO(j)
          x3 = XZERO(k)
          y3 = YZERO(k)
          CALL angdir(pi, x2, y2, x3, y3, DZ, TETA, CD, SD)
          DGM = 0
          IF j <= NVC THEN
               nr = 2 * j - 1
               ia(1) = nr
               E(1) = -CD
               nr = nr + 1
               E(2) = SD
               ia(2) = nr
          END IF
          IF k <= NVC THEN
               nr = 2 * k - 1
               ia(3) = nr
               E(3) = CD
               nr = nr + 1
               ia(4) = nr
               E(4) = -SD
          END IF
          IF k < j THEN 'swap
               SWAP ia(1), ia(3)
               SWAP E(1), E(3)
               SWAP ia(2), ia(4)
               SWAP E(2), E(4)
          END IF
          IF l = -1 THEN 'direz con orr. orient.
               FOR ii = 1 TO ncor
                    IF N4 = NVCO(ii) THEN
                         nr = 2 * NVC + ii
                         IF ia(1) = 0 THEN
                              ia(1) = nr
                              E(1) = -1
                         ELSEIF ia(3) = 0 THEN
                              ia(3) = nr
                              E(3) = -1
                         ELSEIF ia(5) = 0 THEN
                              ia(5) = nr
                              E(5) = -1
                         END IF
                         DGM = CORRO(ii)
                         EXIT FOR
                    END IF
               NEXT ii
'  ------------------------   calcolo termine noto
          END IF
          GMV = GM + DGM
          IF GMV < 0 THEN GMV = GMV + 2 * pi
          dan = TETA - GMV
          DO UNTIL (0 <= dan AND dan < 2 * pi)
               IF dan < 0 THEN dan = dan + 2 * pi
               IF dan >= 2 * pi THEN dan = dan - 2 * pi
          LOOP
          IF 3 * pi / 2 < dan OR dan < pi / 2 THEN
               tp = SIN(dan)
               tp = ATN(tp / SQR(1 - tp * tp))
          ELSE
               tp = dan
          END IF
     ELSEIF k = 0 THEN    'coefficienti equazioni distanze
          x1 = XZERO(l)
          y1 = YZERO(l)
          x2 = XZERO(j)
          y2 = YZERO(j)
          CALL angdir(pi, x2, y2, x1, y1, DZ, TETA, CD, SD)
          IF j <= NVC THEN
               nr = 2 * j - 1
               ia(1) = nr
               E(1) = -SD * DZ
               nr = nr + 1
               ia(2) = nr
               E(2) = -CD * DZ
          END IF
          IF l <= NVC THEN
               nr = 2 * l - 1
               ia(3) = nr
               E(3) = SD * DZ
               nr = nr + 1
               ia(4) = nr
               E(4) = CD * DZ
          END IF
          IF l < j THEN 'swap
               SWAP ia(1), ia(3)
               SWAP E(1), E(3)
               SWAP ia(2), ia(4)
               SWAP E(2), E(4)
          END IF
'  ------------------------   calcolo termine noto
          tp = DZ - GM
     ELSE      'coefficienti equazioni angolari
          x1 = XZERO(l)
          y1 = YZERO(l)
          x2 = XZERO(j)
          y2 = YZERO(j)
          x3 = XZERO(k)
          y3 = YZERO(k)
          CALL angdir(pi, x2, y2, x3, y3, DZ, TETA, CD, SD)
          TET3 = TETA
          C3 = CD
          S3 = SD
          D3 = DZ
          CALL angdir(pi, x2, y2, x1, y1, DZ, TETA, CD, SD)
          TET1 = TETA
          C1 = CD
          S1 = SD
          D1 = DZ
          IF l <= NVC THEN
               nr = 2 * l - 1
               ia(1) = nr
               E(1) = -C1
               nr = nr + 1
               ia(2) = nr
               E(2) = S1
          END IF
          IF j <= NVC THEN
               nr = 2 * j - 1
               ia(3) = nr
               E(3) = C1 - C3
               nr = nr + 1
               ia(4) = nr
               E(4) = S3 - S1
          END IF
          IF k <= NVC THEN
               nr = 2 * k - 1
               ia(5) = nr
               E(5) = C3
               nr = nr + 1
               ia(6) = nr
               E(6) = -S3
          END IF
          'mette in ordine crescente i vettori e e ia
          l1 = l
          j1 = j
          k1 = k
          DO UNTIL l < j AND j < k
          IF l > j THEN 'swap
               SWAP l, j
               SWAP ia(1), ia(3)
               SWAP E(1), E(3)
               SWAP ia(2), ia(4)
               SWAP E(2), E(4)
          END IF
          IF l > k THEN
               SWAP l, k
               SWAP ia(1), ia(5)
               SWAP E(1), E(5)
               SWAP ia(2), ia(6)
               SWAP E(2), E(6)
          END IF
          IF j > k THEN
               SWAP j, k
               SWAP ia(3), ia(5)
               SWAP E(3), E(5)
               SWAP ia(4), ia(6)
               SWAP E(4), E(6)
          END IF
          LOOP
          l = l1
          j = j1
          k = k1
'  ------------------------   calcolo termine noto
          TETA = TET3 - TET1
          IF TETA < 0 THEN TETA = TETA + 2 * P1
          dan = TETA - GM
          DO UNTIL (0 <= dan AND dan < 2 * pi)
               IF dan < 0 THEN dan = dan + 2 * pi
               IF dan >= 2 * pi THEN dan = dan - 2 * pi
          LOOP
          IF 3 * pi / 2 < dan OR dan < pi / 2 THEN
               tp = SIN(dan)
               tp = ATN(tp / SQR(1 - tp * tp))
          ELSE
               tp = dan
          END IF
     END IF
END SUB

Comments: