REM *************************************************************************
REM *   HMO Programm                    24.11.1987                          *
REM *************************************************************************
'
$%I+
$%3
$*&
$S&
$S>
$F<
'
IF FRE(0)<100000
  ALERT 3,"Keine Chance!|Viel zu wenig Speicher frei.|Schaff erst einmal Platz.",1," Pech ",dummy%
  STOP
ENDIF
RESERVE 150000
ke_max%=14
'
DIM ue(30),m(30,30),a(30,30),b(30,30),om(30,30),ad(30),e(30),u(30,30),he(160)
DIM bl(30,30),x_mol(30),y_mol(30),x1(30),y1(30),x_wert(128),y_wert(128)
DIM kette$(ke_max%),alpha$(ke_max%),beta$(ke_max%)
'
REM ------------ wichtige Variablen ----------------------------------------
'   Ue() - šberschrift �ber die Spalten der Matrix bei der Ausgabe
'   M()  - Matrix in die die jeweilige darzustellende Matrix �bertragen wird
'   Om() - H�ckelmatrix
'   U()  - MO-Koeffizienten
'   B()  - Pi-Ladungsdichten und Bindungsordnungen
'   Bl() - Bindungsl„ngen zw. gebundenen Atomen
'   E()  - Freie Valenzen
'   A()  - Diagonalmatrix
'   Ad() - MO-Energien
'   X_mol() - X-Koordinaten des Molek�ls
'   Y_mol() - Y-Koordinaten des Molek�ls
REM ------------------------------------------------------------------------
'
DIM leiste$(50)
'
FOR i%=0 TO 50
  READ leiste$(i%)
  EXIT IF leiste$(i%)="--"
NEXT i%
leiste$(i%)=""
leiste$(i%+1)=""
'
DATA Desk,  Prg Info,--------------------,1,2,3,4,5,6,""
DATA Eingabe,  Molek�l,  neue Rechnung ,  Ende,""
DATA Ausgabe,  H�ckelmatrix,  HMO Koeffizienten,  Bindungsordnung,  Ges.Energie/freie Valenzen ,  Bindungsl„ngen,  Drucker,""
DATA Parameter,  Schriftgr”že ,  Radius,  Tabelle,  Druckercodes ,""
DATA Grafik,  Molek�l zeichnen ,  MO's zeichnen,  Niveaus,  N_Eck,  Hardcopy ,""
DATA --
'
REM ---------- Konstanten festlegen ----------------
info$="H�ckelrechnung|"+CHR$(189)+" Kollmannsberger WS 85/86 |  ge„ndert J.D. 24.11.1987|     Errare humanum est"
fo$=" -#.####"
alpha$="à"
beta$="|á|"
pi$="ã"
bell$=CHR$(7)
angstroem$="�"
eps=3.0E-10
tl=2.0E-38
max_spalte%=8
max_zeile%=11
sg%=1
schrift%=13
wurz_3=SQR(3)
x0%=50
radius%=50
aktiv%=3     !Men�punkt w„hlbar
inaktiv%=2   !          nicht w„hlbar
c_set%=1     !Checkmark setzen
c_reset%=0   !          zur�cksetzen
mehrfach%=1
laufw$=CHR$(GEMDOS(25)+65)
numbers!=FALSE   !Nummern nicht einzeichnen
REM ------------------------------------------------
'
REM ----------------- Druckerbefehle -----------------------
rand$=CHR$(27)+"l"+CHR$(7)         !Linker Rand bei Spalte 7
elite$=CHR$(27)+"M"                !Elite Schriftart
schmal$=CHR$(27)+CHR$(15)          !Schmalschrift
dpplt_ein$=CHR$(27)+"G"            !Doppelter Anschlag ein
dpplt_aus$=CHR$(27)+"H"            !                   aus
init$=CHR$(27)+"@"                 !Druckerinitialisierung
gr_ein$="27,42,5"                  !Grafik ein f�r eine Zeile
gr_vor$="27,74"                    !Einmaliger Zeilenvorschub um n/216 Zoll
REM --------------------------------------------------------
'
REM ----------------- Men�punkte -------------------
m_ein=11      !Eingabe des Molek�ls
m_neu=12      !Neue Rechnung
m_hue=16      !Ausgabe H�ckelmatrix
m_hmo=17      !        HMO-Koeffizienten
m_bio=18      !        Pi Bindungsordnunge und Ladungsdichte
m_ene=19      !        Ges. Energie und freie Valenzen
m_bil=20      !        Bindungsl„ngen
m_dru=21      !Drucker ein/aus
m_mol=30      !Molek�l zeichnen
m_mos=31      !MO's zeichnen
m_niv=32      !Niveaus zeichnen
m_nec=33      !N-Ecke zeichnen
REM ------------------------------------------------
CLS
rcs_verwaltung
CLS
'
MENU leiste$()
OPENW 0
ON MENU GOSUB menue
neustart
programmende!=FALSE
'
DO
  ON MENU
LOOP UNTIL programmende!=TRUE
'
programmende:
~RSRC_FREE()
RESERVE
'
> PROCEDURE menue
  '
  LOCAL a%
  '
  a%=MENU(0)
  ON a%-10 GOSUB eingabe,neustart,ende
  ON a%-15 GOSUB hueckel_mat,hmo_koeff,bindungso,ges_energie,bdg_laenge,drucker
  ON a%-23 GOSUB schriftgr,radius,tabelle,druck_param
  ON a%-29 GOSUB mol_zeichnen,mos_malen,niveau,n_eck,hard_copy
  ON a% GOSUB prginfo
  '
  MENU OFF
  '
RETURN
> PROCEDURE ende
  '
  LOCAL erg%
  '
  ALERT 3,"Programm beenden",1,"ja|nein",erg%
  IF erg%=1
    programmende!=TRUE
  ENDIF
  '
RETURN
> PROCEDURE prginfo
  '
  LOCAL erg%
  '
  ALERT 0,info$,1,"weiter",erg%
  '
RETURN
> PROCEDURE drucker
  '
  LOCAL erg%
  '
  IF drucken!=FALSE
    IF OUT?(0)=TRUE
      drucken!=TRUE
      LPRINT init$
      LPRINT rand$
      LPRINT elite$
      MENU m_dru,c_set%
    ELSE
      ALERT 2,"Drucker einschalten,|sonst geht nichts !",1,"weiter|Abbruch",erg%
      IF erg%=1
        drucker
      ENDIF
    ENDIF
  ELSE
    drucken!=FALSE
    MENU m_dru,c_reset%
  ENDIF
  '
RETURN
> PROCEDURE neustart
  '
  LOCAL i&
  '
  init_felder
  FOR i&=1 TO ke_max%
    kette$(i&)=""
    alpha$(i&)=""
    beta$(i&)=""
  NEXT i&
  na$=""
  n%=0
  ne%=0
  CHAR{{OB_SPEC(eingabe_adr%,einmolek&)}}=""
  CHAR{{OB_SPEC(eingabe_adr%,einzentr&)}}=""
  CHAR{{OB_SPEC(eingabe_adr%,einelekt&)}}=""
  '
  drucken!=FALSE
  '
  REM -------------------Men�punkte desaktivieren
  '
  MENU m_ein,aktiv%
  MENU m_neu,inaktiv%
  MENU m_hue,inaktiv%
  MENU m_hmo,inaktiv%
  MENU m_bio,inaktiv%
  MENU m_ene,inaktiv%
  MENU m_bil,inaktiv%
  MENU m_dru,c_reset%
  MENU m_mol,inaktiv%
  MENU m_mos,inaktiv%
  MENU m_niv,inaktiv%
  MENU m_nec,inaktiv%
  '
RETURN
> PROCEDURE init_felder
  '
  ARRAYFILL ue(),0
  ARRAYFILL m(),0
  ARRAYFILL a(),0
  ARRAYFILL b(),0
  ARRAYFILL bl(),0
  ARRAYFILL om(),0
  ARRAYFILL ad(),0
  ARRAYFILL e(),0
  ARRAYFILL u(),0
  ARRAYFILL he(),0
  '
RETURN
> PROCEDURE rcs_verwaltung
  '
  LOCAL fehler%,dummy%,schalter%,path$,leer$,font$,i&
  '
  LET menue&=0 !RSC_TREE
  LET eingabe&=1 !RSC_TREE
  LET radius&=2 !RSC_TREE
  LET textsize&=3 !RSC_TREE
  LET einmolek&=1 !Obj in #1
  LET einzentr&=2 !Obj in #1
  LET einelekt&=3 !Obj in #1
  LET einkett1&=7 !Obj in #1
  LET einkett7&=13 !Obj in #1
  LET einkettm&=6 !Obj in #1
  LET einhoch1&=16 !Obj in #1
  LET eindown1&=17 !Obj in #1
  LET einslid1&=15 !Obj in #1
  LET einmoth1&=14 !Obj in #1
  LET einalph1&=21 !Obj in #1
  LET einalph7&=27 !Obj in #1
  LET einhoch3&=28 !Obj in #1
  LET eindown3&=31 !Obj in #1
  LET einslid3&=30 !Obj in #1
  LET einmoth3&=29 !Obj in #1
  LET einalphm&=20 !Obj in #1
  LET einab&=50 !Obj in #1
  LET einok&=46 !Obj in #1
  LET einbeta1&=35 !Obj in #1
  LET einbeta7&=41 !Obj in #1
  LET einbetam&=34 !Obj in #1
  LET einhoch2&=42 !Obj in #1
  LET eindown2&=45 !Obj in #1
  LET einslid2&=44 !Obj in #1
  LET einmoth2&=43 !Obj in #1
  LET raddec&=5 !Obj in #2
  LET radinc&=6 !Obj in #2
  LET radval&=4 !Obj in #2
  LET textnorm&=2 !Obj in #3
  LET texticon&=3 !Obj in #3
  LET radmoth&=3 !Obj in #2
  LET radok&=7 !Obj in #2
  LET param&=4 !RSC_TREE
  LET grein&=4 !Obj in #4
  LET grvor&=5 !Obj in #4
  LET doppelt&=6 !Obj in #4
  LET paramok&=8 !Obj in #4
  '
  path$="HMO.RSC"
  REPEAT
    DEFMOUSE 2
    PRINT AT(5,2);path$+" WIRD GELADEN"
    fehler%=RSRC_LOAD(path$)
    DEFMOUSE 0
    IF fehler%=0
      ALERT 3,"Resource nicht gefunden !|Bitte Pfad angeben.",1," sowas ",dummy%
      path$=laufw$+":\*.RSC"
      VOID FSEL_INPUT(path$,leer$,schalter%)
      CLS
      IF schalter%=0
        programmende!=TRUE
      ENDIF
      leer$="HMO.RSC"
      i&=RINSTR(path$,"\")
      path$=LEFT$(path$,i&)+leer$
    ENDIF
  UNTIL fehler%<>0 OR schalter%=0
  IF programmende!=FALSE
    ~RSRC_GADDR(0,eingabe&,eingabe_adr%)
    ~RSRC_GADDR(0,radius&,radius_adr%)
    ~RSRC_GADDR(0,textsize&,textsize_adr%)
    ~RSRC_GADDR(0,param&,param_adr%)
    '    DIM message_buffer%(3)
    '    mes_adr%=V:message_buffer%(0)
    '    ABSOLUTE mes_type&,mes_adr%
    '    ABSOLUTE m_titel&,mes_adr%+6
    '    ABSOLUTE m_eintrag&,mes_adr%+8
  ENDIF
RETURN
> PROCEDURE eingabe
  '
  LOCAL x&,y&,w&,h&,buffer$,exit_obj%,change%
  LOCAL i&,dummy%
  LOCAL delta_sc1%,delta_sm1%,von1&,bis1&
  LOCAL delta_sc2%,delta_sm2%,von2&,bis2&
  LOCAL delta_sc3%,delta_sm3%,von3&,bis3&
  '
  ~FORM_CENTER(eingabe_adr%,x&,y&,w&,h&)
  GET x&,y&,x&+w&,y&+h&,buffer$
  von1&=1
  von2&=1
  von3&=1
  delta_slider(einmoth1&,delta_sm1%,delta_sc1%)
  delta_slider(einmoth2&,delta_sm2%,delta_sc2%)
  delta_slider(einmoth3&,delta_sm3%,delta_sc3%)
  OB_H(eingabe_adr%,einslid1&)=delta_sc1%
  OB_H(eingabe_adr%,einslid2&)=delta_sc2%
  OB_H(eingabe_adr%,einslid3&)=delta_sc3%
  ~OBJC_DRAW(eingabe_adr%,0,2,x&,y&,w&,h&)
  y_slider(einslid1&,delta_sm1%,delta_sc1%,von1&,bis1&)
  y_slider(einslid2&,delta_sm2%,delta_sc2%,von2&,bis2&)
  y_slider(einslid3&,delta_sm3%,delta_sc3%,von3&,bis3&)
  kette(von1&,bis1&,FALSE)      !FALSE heižt schreiben
  beta(von2&,bis2&,FALSE)
  alpha(von3&,bis3&,FALSE)
  ~OBJC_DRAW(eingabe_adr%,einkettm&,3,x&,y&,w&,h&)
  ~OBJC_DRAW(eingabe_adr%,einbetam&,3,x&,y&,w&,h&)
  ~OBJC_DRAW(eingabe_adr%,einalphm&,3,x&,y&,w&,h&)
  init_felder
  DO
    exit_obj%=FORM_DO(eingabe_adr%,0)
    ~OBJC_CHANGE(eingabe_adr%,exit_obj%,0,x&,y&,w&,h&,0,1)
    SELECT exit_obj%
    CASE einhoch1&
      kette(von1&,bis1&,TRUE)        !TRUE heižt lesen
      DEC von1&
    CASE eindown1&
      kette(von1&,bis1&,TRUE)
      INC von1&
    CASE einmoth1&
      kette(von1&,bis1&,TRUE)
      shift_slider(einslid1&,von1&)
    CASE einslid1&
      kette(von1&,bis1&,TRUE)
      slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth1&,einslid1&,1)
      von1&=FN s_back(slide_back%)
    CASE einhoch2&
      beta(von2&,bis2&,TRUE)
      DEC von2&
    CASE eindown2&
      beta(von2&,bis2&,TRUE)
      INC von2&
    CASE einmoth2&
      beta(von2&,bis2&,TRUE)
      shift_slider(einslid2&,von2&)
    CASE einslid2&
      beta(von2&,bis2&,TRUE)
      slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth2&,einslid2&,1)
      von2&=FN s_back(slide_back%)
    CASE einhoch3&
      alpha(von3&,bis3&,TRUE)
      DEC von3&
    CASE eindown3&
      alpha(von3&,bis3&,TRUE)
      INC von3&
    CASE einmoth3&
      alpha(von3&,bis3&,TRUE)
      shift_slider(einslid3&,von3&)
    CASE einslid3&
      alpha(von3&,bis3&,TRUE)
      slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth3&,einslid3&,1)
      von3&=FN s_back(slide_back%)
    ENDSELECT
    SELECT exit_obj%
    CASE einhoch1&,eindown1&,einmoth1&,einslid1&
      manager(einslid1&,delta_sm1%,delta_sc1%,von1&,bis1&)
      kette(von1&,bis1&,FALSE)
      ~OBJC_DRAW(eingabe_adr%,einkettm&,3,x&,y&,w&,h&)
    CASE einhoch2&,eindown2&,einmoth2&,einslid2&
      manager(einslid2&,delta_sm2%,delta_sc2%,von2&,bis2&)
      beta(von2&,bis2&,FALSE)
      ~OBJC_DRAW(eingabe_adr%,einbetam&,3,x&,y&,w&,h&)
    CASE einhoch3&,eindown3&,einmoth3&,einslid3&
      manager(einslid3&,delta_sm3%,delta_sc3%,von3&,bis3&)
      alpha(von3&,bis3&,FALSE)
      ~OBJC_DRAW(eingabe_adr%,einalphm&,3,x&,y&,w&,h&)
    ENDSELECT
  LOOP UNTIL exit_obj%=einok& OR exit_obj%=einab&
  PUT x&,y&,buffer$
  IF exit_obj%=einok&
    kette(von1&,bis1&,TRUE)
    beta(von2&,bis2&,TRUE)
    alpha(von3&,bis3&,TRUE)
    na$=CHAR{{OB_SPEC(eingabe_adr%,einmolek&)}}
    n%=VAL(CHAR{{OB_SPEC(eingabe_adr%,einzentr&)}})
    ne%=VAL(CHAR{{OB_SPEC(eingabe_adr%,einelekt&)}})
    ~OBJC_CHANGE(eingabe_adr%,exit_obj%,0,x&,y&,w&,h&,0,0)
    IF n%=0
      ALERT 3," Ohne Zentren| |keine Rechnung!",1,"klar?",dummy%
    ELSE IF ne%=0
      ALERT 3,"Ohne Elektronen| |keine Rechnung!",1,"klar?",dummy%
    ELSE
      molekuel
    ENDIF
  ENDIF
  '
RETURN
> PROCEDURE molekuel
  '
  LOCAL ke%,k%,i1%,i2%,zeile%,k$,kk%,we
  '
  masstab%=540/n%
  m%=INT(ne%/2+0.6)
  radikal!=ODD(ne%)       ! Radikal!=True wenn Ne ungerade
  FOR ke%=1 TO 14
    k$=alpha$(ke%)
    EXIT IF k$=""
    i1%=VAL(LEFT$(k$,2))
    om(i1%,i1%)=VAL(RIGHT$(k$,5))
  NEXT ke%
  FOR ke%=1 TO 14
    k$=kette$(ke%)
    EXIT IF k$=""
    kk%=1
    i1%=VAL(MID$(k$,1))
    DO
      kk%=INSTR(k$,"-",kk%)+1
      EXIT IF kk%=1
      i2%=VAL(MID$(k$,kk%))
      om(i1%,i2%)=1
      om(i2%,i1%)=1
      i1%=i2%
    LOOP
  NEXT ke%
  FOR ke%=1 TO 14
    k$=beta$(ke%)
    EXIT IF k$=""
    i1%=VAL(LEFT$(k$,2))
    i2%=VAL(MID$(k$,3,2))
    om(i1%,i2%)=VAL(RIGHT$(k$,5))
    om(i2%,i1%)=VAL(RIGHT$(k$,5))
  NEXT ke%
  diag_vorbereitung
  diagonalisierung
  PRINT AT(5,22);"Einen Moment Geduld, die restlichen Berechnungen laufen noch"
  bind_ordnung
  bind_laenge
  freie_valenzen
  PRINT AT(5,22);"                                                            "
  PRINT bell$;
  MENU m_neu,aktiv%
  MENU m_hue,aktiv%
  MENU m_hmo,aktiv%
  MENU m_bio,aktiv%
  MENU m_ene,aktiv%
  MENU m_bil,aktiv%
  MENU m_mol,aktiv%
  MENU m_nec,aktiv%
  '
RETURN
> PROCEDURE matrix_list
  '
  LOCAL spalte%,zeile%,von_s%,bis_s%,von_z%,k3%,i%,j%,a$,as%
  '
  IF drucken!=TRUE
    LPRINT dpplt_ein$
    LPRINT na$
    LPRINT dpplt_aus$
    LPRINT ueberschrift$
    IF n%>9
      LPRINT schmal$
      spalte%=14
    ELSE
      LPRINT
      spalte%=8
    ENDIF
    von_s%=1
    k3%=1
    '
    DO
      '
      bis_s%=von_s%+spalte%
      IF bis_s%>n%
        bis_s%=n%
      ENDIF
      LPRINT SPACE$(3);
      FOR i%=von_s% TO bis_s%
        LPRINT USING uefo$,ue(i%);
      NEXT i%
      LPRINT
      LPRINT
      FOR i%=1 TO n%
        LPRINT USING " ##",i%;
        FOR j%=von_s% TO bis_s%
          LPRINT USING fo$,m(i%,j%);
        NEXT j%
        LPRINT
        INC k3%
        IF k3%>3
          k3%=1
          LPRINT
        ENDIF
      NEXT i%
      EXIT IF bis_s%=n%
      von_s%=bis_s%+1
      LPRINT STRING$(123,"-")
      '
    LOOP
    '
    LPRINT elite$
  ENDIF
  von_s%=1
  von_z%=1
  '
  DO
    '
    spalte%=von_s%+max_spalte%
    zeile%=von_z%+max_zeile%
    IF spalte%>n%
      spalte%=n%
    ENDIF
    IF zeile%>n%
      zeile%=n%
    ENDIF
    DEFFILL 1,0,0
    PBOX 0,0,640,399
    PRINT AT(10,1);ueberschrift$
    PRINT
    DEFTEXT 1,0,0,schrift%
    IF schrift%=4
      PRINT AT(1,9)
    ENDIF
    PRINT TAB(7);
    FOR i%=von_s% TO spalte%
      PRINT USING uefo$,ue(i%);
    NEXT i%
    PRINT
    PRINT
    k3%=0
    FOR i%=von_z% TO zeile%
      PRINT USING "  ##   ",i%;
      FOR j%=von_s% TO spalte%
        PRINT USING fo$,m(i%,j%);
      NEXT j%
      INC k3%
      IF k3%=3
        k3%=0
        PRINT
      ENDIF
      PRINT
    NEXT i%
    DEFTEXT 1,0,0,13
    EXIT IF n%<=max_spalte%+1
    PRINT AT(5,22);"Bei grožen Matrizen kann man mit den Cursortasten bl„ttern!"
    PRINT AT(9,23);"weiter mit <return> oder Mausklick";
    REPEAT
      a$=INKEY$
      as%=CVI(a$)
      IF MOUSEK>0
        a$=CHR$(13)
      ENDIF
    UNTIL a$=CHR$(13) OR as%=80 OR as%=72 OR as%=77 OR as%=75
    EXIT IF a$=CHR$(13)
    IF as%=72                 !rauf
      SUB von_z%,max_zeile%
      IF von_z%<1
        von_z%=1
      ENDIF
    ENDIF
    IF as%=80                 !runter
      ADD von_z%,max_zeile%
      IF von_z%>n%
        von_z%=1
      ENDIF
    ENDIF
    '
    IF as%=77                 !rechts
      ADD von_s%,max_spalte%
      IF von_s%>n%
        von_s%=1
      ENDIF
    ENDIF
    IF as%=75                 !links
      SUB von_s%,max_spalte%
      IF von_s%<1
        von_s%=1
      ENDIF
    ENDIF
    '
  LOOP
  '
RETURN
> PROCEDURE hueckel_mat
  '
  LOCAL i%,j%
  '
  ueberschrift$="H�ckelmatrix"
  FOR i%=1 TO n%
    FOR j%=1 TO n%
      m(i%,j%)=om(i%,j%)
    NEXT j%
    ue(i%)=i%
  NEXT i%
  uefo$="  ##    "
  matrix_list
  '
RETURN
> PROCEDURE hmo_koeff
  '
  LOCAL i%,j%
  '
  ueberschrift$="MO-Energien und MO-Koeffizienten in Vielfachen von "+beta$
  FOR i%=1 TO n%
    FOR j%=1 TO n%
      m(i%,j%)=u(i%,j%)
    NEXT j%
    ue(i%)=ad(i%)
  NEXT i%
  uefo$=fo$
  matrix_list
  '
RETURN
> PROCEDURE bindungso
  '
  LOCAL i%,j%
  '
  ueberschrift$=pi$+"-Ladungsdichten und Bindungsordnungen"
  FOR i%=1 TO n%
    FOR j%=1 TO n%
      m(i%,j%)=b(i%,j%)
    NEXT j%
    ue(i%)=i%
  NEXT i%
  uefo$="  ##    "
  matrix_list
  '
RETURN
> PROCEDURE bdg_laenge
  '
  LOCAL i%,j%
  '
  ueberschrift$="Bindungsl„ngen in "+angstroem$
  FOR i%=1 TO n%
    FOR j%=1 TO n%
      m(i%,j%)=bl(i%,j%)
    NEXT j%
    ue(i%)=i%
  NEXT i%
  uefo$="  ##    "
  matrix_list
  '
RETURN
> PROCEDURE diag_vorbereitung
  '
  LOCAL i%,j%,hi
  '
  FOR j%=1 TO n%
    FOR i%=1 TO j%
      hi=-om(i%,j%)
      a(i%,j%)=hi
      a(j%,i%)=hi
    NEXT i%
  NEXT j%
  '
RETURN
> PROCEDURE bind_ordnung
  '
  LOCAL bo%,bp%,bs,j%
  '
  FOR bo%=1 TO n%
    FOR bp%=1 TO bo%
      IF om(bo%,bp%)<>0 OR bo%=bp%
        bs=0
        FOR j%=1 TO m%
          bs=bs+u(bo%,j%)*u(bp%,j%)
        NEXT j%
        bs=2*bs
        IF radikal!=TRUE
          bs=bs-u(bo%,m%)*u(bp%,m%)
        ENDIF
        b(bo%,bp%)=bs
        b(bp%,bo%)=bs
      ENDIF
    NEXT bp%
  NEXT bo%
  '
RETURN
> PROCEDURE bind_laenge
  '
  LOCAL i%,j%,bdg_len
  '
  FOR i%=1 TO n%-1
    FOR j%=i%+1 TO n%
      IF om(i%,j%)<>0
        bdg_len=1.506-0.1678*b(i%,j%)
        bl(i%,j%)=bdg_len
        bl(j%,i%)=bdg_len
      ENDIF
    NEXT j%
  NEXT i%
  '
RETURN
> PROCEDURE freie_valenzen
  '
  LOCAL i%,j%,nb
  '
  FOR j%=1 TO n%
    FOR i%=1 TO n%
      IF (i%<>j%) AND (ABS(om(i%,j%))>0.1)
        nb=nb+b(i%,j%)
      ENDIF
    NEXT i%
    e(j%)=wurz_3-nb
  NEXT j%
  '
RETURN
> PROCEDURE ges_energie
  '
  LOCAL von%,bis%,i%
  '
  uefo$="  ##    "
  pi_energie
  IF drucken!=TRUE
    LPRINT dpplt_ein$
    LPRINT na$
    LPRINT dpplt_aus$
    LPRINT "Gesamt-";pi$;"-Elektronenenergie:";USING " -##.### "+beta$,ge
    LPRINT
    LPRINT "Elektronenzahl  ";ne%
    LPRINT
    LPRINT "Freie Valenzen"
    LPRINT
    von%=1
    '
    DO
      '
      bis%=von%+8
      IF bis%>n%
        bis%=n%
      ENDIF
      LPRINT SPACE$(3);
      FOR i%=von% TO bis%
        LPRINT USING uefo$,i%;
      NEXT i%
      LPRINT
      LPRINT
      LPRINT SPACE$(3);
      FOR i%=von% TO bis%
        LPRINT USING fo$,e(i%);
      NEXT i%
      LPRINT
      EXIT IF bis%=n%
      von%=bis%+1
      LPRINT SPACE$(5);STRING$(70,"-")
      '
    LOOP
    '
  ENDIF
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  PRINT AT(5,1);"Gesamt-";pi$;"-Elektronenenergie:";USING " -##.#### "+beta$,ge
  PRINT AT(5,3);"Elektronenzahl: ";ne%
  PRINT AT(5,5);"Freie Valenzen"
  PRINT
  von%=1
  DO
    '
    bis%=von%+8
    IF bis%>n%
      bis%=n%
    ENDIF
    PRINT TAB(3);
    FOR i%=von% TO bis%
      PRINT USING uefo$,i%;
    NEXT i%
    PRINT
    PRINT
    PRINT TAB(3);
    FOR i%=von% TO bis%
      PRINT USING fo$,e(i%);
    NEXT i%
    EXIT IF bis%=n%
    von%=bis%+1
    PRINT TAB(5);STRING$(70,"-")
    '
  LOOP
  '
RETURN
> PROCEDURE pi_energie
  '
  LOCAL j%
  '
  ge=0
  FOR j%=1 TO m%
    ge=ge+ad(j%)
  NEXT j%
  ge=ge*2
  IF radikal!=TRUE
    ge=ge-ad(m%)
  ENDIF
  '
RETURN
> PROCEDURE diagonalisierung
  '
  LOCAL zeit%,i%,j%,j1%,ni%,l%,h,g,k%,s,f,b,p,r,c
  '
  bild_aufbau
  zeit%=TIMER
  IF n%=1
    ad(1)=a(1,1)
    u(1,1)=1
    GOTO diag_ende
  ENDIF
  FOR i%=1 TO n%
    FOR j%=1 TO i%
      u(i%,j%)=a(i%,j%)
    NEXT j%
  NEXT i%
  '   HOUSHOLDER
  DEFFILL 1,2,18
  y0%=112    !Grafik
  y1%=y0%+16
  FOR ni%=2 TO n%
    i%=n%+2-ni%
    l%=i%-2
    h=0
    g=u(i%,i%-1)
    IF l%<=0
      GOTO raus_1
    ENDIF
    FOR k%=1 TO l%
      h=h+u(i%,k%)^2
    NEXT k%
    s=h+g*g
    IF s<tl
      h=0
      GOTO raus_1
    ENDIF
    IF h<=0
      GOTO raus_1
    ENDIF
    INC l%
    f=g
    g=SQR(s)
    IF f>0
      MUL g,-1
    ENDIF
    h=s-f*g
    u(i%,i%-1)=f-g
    f=0
    FOR j%=1 TO l%
      u(j%,i%)=u(i%,j%)/h
      s=0
      FOR k%=1 TO j%
        s=s+u(j%,k%)*u(i%,k%)
      NEXT k%
      j1%=j%+1
      IF j1%<=l%
        FOR k%=j1% TO l%
          s=s+u(k%,j%)*u(i%,k%)
        NEXT k%
      ENDIF
      he(j%)=s/h
      f=f+s*u(j%,i%)
    NEXT j%
    f=f/(h+h)
    FOR j%=1 TO l%
      he(j%)=he(j%)-f*u(i%,j%)
    NEXT j%
    FOR j%=1 TO l%
      f=u(i%,j%)
      s=he(j%)
      FOR k%=1 TO j%
        u(j%,k%)=u(j%,k%)-f*he(k%)-u(i%,k%)*s
      NEXT k%
    NEXT j%
  raus_1:
    ad(i%)=h
    he(i%-1)=g
    zaehler%=ni%
    rechteck
  NEXT ni%
  ad(1)=u(1,1)
  u(1,1)=1
  DEFFILL 1,2,12
  y0%=144    !Grafik
  y1%=y0%+16
  FOR i%=2 TO n%
    l%=i%-1
    IF ad(i%)>0
      FOR j%=1 TO l%
        s=0
        FOR k%=1 TO l%
          s=s+u(i%,k%)*u(k%,j%)
        NEXT k%
        FOR k%=1 TO l%
          u(k%,j%)=u(k%,j%)-s*u(k%,i%)
        NEXT k%
      NEXT j%
    ENDIF
    ad(i%)=u(i%,i%)
    u(i%,i%)=1
    FOR j%=1 TO l%
      u(i%,j%)=0
      u(j%,i%)=0
    NEXT j%
    zaehler%=i%
    rechteck
  NEXT i%
  '      DIAG TRIDIAGMAT
  b=0
  f=0
  he(n%)=0
  DEFFILL 1,2,14
  y0%=176    !Grafik
  y1%=y0%+16
  FOR l%=1 TO n%
    h=eps*(ABS(ad(l%))+ABS(he(l%)))
    IF h>b
      b=h
    ENDIF
    FOR j%=l% TO n%
      IF ABS(he(j%))<=b
        i%=j%
        j%=n%
      ENDIF
    NEXT j%
    j%=i%
    IF j%<>l%
      REPEAT
        g=ad(l%)
        p=(ad(l%+1)-g)*0.5/he(l%)
        r=SQR(p*p+1)
        IF p>=0
          p=p+r
        ELSE
          p=p-r
        ENDIF
        ad(l%)=he(l%)/p
        h=g-ad(l%)
        k%=l%+1
        FOR i%=k% TO n%
          SUB ad(i%),h
        NEXT i%
        f=f+h
        '     QR-TRANSF
        p=ad(j%)
        c=1
        s=0
        j1%=j%-1
        FOR ni%=l% TO j1%
          i%=l%+j1%-ni%
          g=c*he(i%)
          h=c*p
          IF ABS(p)<ABS(he(i%))
            c=p/he(i%)
            r=SQR(c*c+1)
            he(i%+1)=s*he(i%)*r
            s=1/r
            DIV c,r
          ELSE
            c=he(i%)/p
            r=SQR(c*c+1)
            he(i%+1)=s*p*r
            s=c/r
            c=1/r
          ENDIF
          p=c*ad(i%)-s*g
          ad(i%+1)=h+s*(c*g+s*ad(i%))
          FOR k%=1 TO n%
            h=u(k%,i%+1)
            u(k%,i%+1)=u(k%,i%)*s+h*c
            u(k%,i%)=u(k%,i%)*c-h*s
          NEXT k%
        NEXT ni%
        he(l%)=s*p
        ad(l%)=c*p
      UNTIL ABS(he(l%))<=b
    ENDIF
    ADD ad(l%),f
    zaehler%=l%
    rechteck
  NEXT l%
  '      ORDNUNG DER EIGENWERTE
  ni%=n%-1
  DEFFILL 1,2,17
  y0%=208    !Grafik
  y1%=y0%+16    !Grafik
  FOR i%=1 TO ni%
    k%=i%
    p=ad(i%)
    j1%=i%+1
    FOR j%=j1% TO n%
      IF ad(j%)<p
        k%=j%
        p=ad(j%)
      ENDIF
    NEXT j%
    IF k%<>i%
      ad(k%)=ad(i%)
      ad(i%)=p
      FOR j%=1 TO n%
        SWAP u(j%,i%),u(j%,k%)
      NEXT j%
    ENDIF
    zaehler%=i%
    rechteck
  NEXT i%
  zaehler%=i%
  rechteck
  orbitale_verb
diag_ende:
  PRINT AT(5,18);"Uff, in  ";(TIMER-zeit%)/200;" s geschafft. Mach's nach!"
  '
RETURN
> PROCEDURE orbitale_verb
  '
  LOCAL i%,j%
  '
  FOR i%=1 TO n%
    IF u(1,i%)<0
      FOR j%=1 TO n%
        MUL u(j%,i%),-1
      NEXT j%
    ENDIF
  NEXT i%
  '      TRANSFORM. ENTART. ORBITALE (LOGIK)
  ia%=1
  ir%=1
  DO
    '
    WHILE ABS(ad(ia%)-ad(ia%+ir%))<0.0001
      INC ir%
      EXIT IF ia%+ir%>n%
    WEND
    IF ir%>1
      orbit_transf
    ENDIF
    EXIT IF ia%+ir%>=n%
    ADD ia%,ir%
    ir%=1
    '
  LOOP
  '
RETURN
> PROCEDURE orbit_transf
  '
  LOCAL l%,j%,k%,i%,iz%,vz
  '
  k%=1
  i%=ia%
  iz%=ir%
  vz=0
  REPEAT
    '
    DO
      '
      vz=0
      FOR l%=i% TO i%+iz%-1
        p=ABS(u(k%,l%))
        IF p>vz
          vz=p
          lp=l%
        ENDIF
      NEXT l%
      EXIT IF vz>=0.0001
      INC k%
      '
    LOOP
    '
    FOR j%=1 TO n%
      SWAP u(j%,i%),u(j%,lp)
    NEXT j%
    FOR l%=i%+1 TO i%+iz%-1
      b=u(k%,l%)
      IF ABS(b)>=0.0001
        a=u(k%,i%)
        rn=1/SQR(a*a+b*b)
        FOR j%=1 TO n%
          aj=u(j%,i%)
          bj=u(j%,l%)
          u(j%,i%)=(a*aj+b*bj)*rn
          u(j%,l%)=(b*aj-a*bj)*rn
        NEXT j%
      ENDIF
    NEXT l%
    INC k%
    INC i%
    DEC iz%
    '
  UNTIL iz%<=1
  '
RETURN
> PROCEDURE rechteck
  '
  LOCAL x_koor%
  '
  x_koor%=x0%+zaehler%*masstab%
  VSYNC
  PBOX x0%,y0%,x_koor%,y1%
  '
RETURN
> PROCEDURE bild_aufbau
  '
  LOCAL i%
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  PRINT AT(5,3);"Die Matrix wird diagonalisiert"
  PRINT AT(5,5);"Insgesamt liegen 4 grože Schleifen vor mir, die jeweils"
  PRINT AT(5,6);n%;" mal durchlaufen werden m�ssen"
  RBOX 5,106,635,230
  PRINT AT(2,8);"Ni%:"
  PRINT AT(2,10);"I% :"
  PRINT AT(2,12);"L% :"
  PRINT AT(2,14);"I% :"
  FOR i%=8 TO 14 STEP 2
    BOX x0%,(i%-1)*16,x0%+n%*masstab%,i%*16
  NEXT i%
  '
RETURN
> PROCEDURE schriftgr
  '
  LOCAL x&,y&,w&,h&,buffer$,change%,exit_obj%,status%
  '
  ~FORM_CENTER(textsize_adr%,x&,y&,w&,h&)
  GET x&,y&,x&+w&,y&+h&,buffer$
  status%=OB_STATE(textsize_adr%,textnorm&)
  SELECT status%
  CASE 1
    OB_STATE(textsize_adr%,textnorm&)=1
    OB_STATE(textsize_adr%,texticon&)=0
  CASE 0
    OB_STATE(textsize_adr%,textnorm&)=0
    OB_STATE(textsize_adr%,texticon&)=1
  ENDSELECT
  ~OBJC_DRAW(textsize_adr%,0,2,x&,y&,w&,h&)
  exit_obj%=FORM_DO(textsize_adr%,0)
  status%=OB_STATE(textsize_adr%,textnorm&)
  SELECT status%
  CASE 1
    schrift%=13
    max_zeile%=11
    max_spalte%=8
  CASE 0
    schrift%=4
    max_zeile%=30
    max_spalte%=11
  ENDSELECT
  PUT x&,y&,buffer$
  '
RETURN
> PROCEDURE mol_zeichnen
  '
  LOCAL i%,x_pos%,y_pos%,k%
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  FOR i%=1 TO n%
    PRINT AT(5,2);"Zentrum Nr.: ";USING "##",i%
    '
    GRAPHMODE 3
    DO
      '
      x_pos%=MOUSEX
      y_pos%=MOUSEY
      EXIT IF MOUSEK
      CIRCLE x_pos%,y_pos%,radius%
      CIRCLE x_pos%,y_pos%,radius%
      '
    LOOP
    '
    GRAPHMODE 1
    EXIT IF MOUSEK=2
    CIRCLE x_pos%,y_pos%,radius%
    x_mol(i%)=x_pos%
    y_mol(i%)=y_pos%
    REPEAT
      k%=MOUSEK
    UNTIL k%=0
  NEXT i%
  IF i%>n%
    DEFFILL 1,0,0
    PBOX 0,0,640,399
    geruest
    DEFFILL 1,0,
    FOR i%=1 TO n%
      PCIRCLE x_mol(i%),y_mol(i%),radius%
    NEXT i%
    MENU m_mos,aktiv%
    MENU m_niv,aktiv%
  ENDIF
  '
RETURN
> PROCEDURE radius
  '
  LOCAL x&,y&,w&,h&,buffer$,change%,exit_obj%
  '
  ~FORM_CENTER(radius_adr%,x&,y&,w&,h&)
  GET x&,y&,x&+w&,y&+h&,buffer$
  CHAR{OB_SPEC(radius_adr%,radval&)}=STR$(radius%)
  ~OBJC_DRAW(radius_adr%,0,2,x&,y&,w&,h&)
  DO
    exit_obj%=FORM_DO(radius_adr%,0)
    EXIT IF exit_obj%=radok&
    SELECT exit_obj%
    CASE radinc&
      INC radius%
      IF radius%>95
        radius%=95
      ENDIF
    CASE raddec&
      DEC radius%
      IF radius%<5
        radius%=5
      ENDIF
    ENDSELECT
    CHAR{OB_SPEC(radius_adr%,radval&)}=STR$(radius%)
    VSYNC
    ~OBJC_DRAW(radius_adr%,radmoth&,1,x&,y&,w&,h&)
  LOOP
  radius%=VAL(CHAR{OB_SPEC(radius_adr%,radval&)})
  change%=OB_STATE(radius_adr%,exit_obj%) AND &HFE
  ~OBJC_CHANGE(radius_adr%,exit_obj%,0,x&,y&,w&,h&,change%,0)
  PUT x&,y&,buffer$
  '
RETURN
> PROCEDURE mos_malen
  '
  LOCAL i%,z%,rad%,k%,z$,x_t%,y_t%,d_x%,key$,key_scan%
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  PRINT AT(5,23);"bl„ttern mit linker und rechter Maustaste     Ende mit return";
  i%=1
  '
  DO
    '
    PRINT AT(5,22);"Molek�lorbital ";USING "##",i%
    PRINT AT(30,22);"MO-Energie ",USING fo$,ad(i%)
    DEFTEXT ,,,4
    CLIP 0,19 TO 639,330
    geruest
    FOR z%=1 TO n%
      rad%=ABS(u(z%,i%))*radius%
      IF SGN(u(z%,i%))>=0
        DEFFILL 1,0,
      ELSE
        DEFFILL 1,1,
      ENDIF
      PCIRCLE x_mol(z%),y_mol(z%),rad%
      IF numbers!=TRUE
        z$=STR$(z%)
        d_x%=LEN(z$)*4
        x_t%=x_mol(z%)
        y_t%=y_mol(z%)
        GRAPHMODE 3
        IF rad%<d_x%+2     !ausserhalb
          ADD x_t%,rad%
          SUB y_t%,rad%
          GRAPHMODE 1
        ELSE               !Innerhalb zentriert
          SUB x_t%,d_x%/2
          ADD y_t%,2
        ENDIF
        TEXT x_t%,y_t%,STR$(z%)
        GRAPHMODE 1
      ENDIF
    NEXT z%
    CLIP 0,19 TO 639,399
    DEFTEXT ,,,schrift%
    REPEAT
      k%=MOUSEK
      key$=INKEY$
    UNTIL key$<>"" OR k%<>0
    EXIT IF key$=CHR$(13) OR k%=3
    SELECT key$
    CASE "n","N"
      numbers!=NOT numbers!
    CASE " "
      k%=1
    DEFAULT
      key_scan%=ASC(RIGHT$(key$))
      SELECT key_scan%
      CASE &H48              !Pfeil hoch
        FOR i&=1 TO n%
          SUB y_mol(i&),10
        NEXT i&
      CASE &H50              !Pfeil runter
        FOR i&=1 TO n%
          ADD y_mol(i&),10
        NEXT i&
      CASE &H4B              !Pfeil links
        FOR i&=1 TO n%
          SUB x_mol(i&),10
        NEXT i&
      CASE &H4D              !Pfeil rechts
        FOR i&=1 TO n%
          ADD x_mol(i&),10
        NEXT i&
      ENDSELECT
    ENDSELECT
    IF k%=1
      INC i%
      IF i%>n%
        i%=1
      ENDIF
    ELSE IF k%=2
      DEC i%
      IF i%<1
        i%=n%
      ENDIF
    ENDIF
    '
  LOOP
  '
RETURN
> PROCEDURE geruest
  '
  LOCAL i%,j%
  '
  DEFFILL 1,0
  BOUNDARY 0
  PBOX 0,0,640,330
  BOUNDARY 1
  FOR i1%=1 TO n%-1
    FOR j1%=i1%+1 TO n%
      IF om(i1%,j1%)<>0
        LINE x_mol(i1%),y_mol(i1%),x_mol(j1%),y_mol(j1%)
      ENDIF
    NEXT j1%
  NEXT i1%
  '
RETURN
> PROCEDURE tabelle
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  PRINT AT(5,1);"H�ckel-Parameter"
  PRINT AT(5,3);"Bezeichnungen  :  ";alpha$;" X = ";alpha$;" + H X * ž   (";alpha$;" = - 9,0 eV)"
  PRINT AT(23,4);"ž X-Y = K X-Y * ž   (ž = - 2,4 eV)"
  PRINT AT(5,6);"N„heres siehe Heilbronner-Bock Bd.1, S. 155"
  PRINT
  PRINT TAB(30);"H X";TAB(40);"K C-X"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"C";TAB(30);" 0.0";TAB(40);"1.0"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"B";TAB(30);"-1.0";TAB(40);"0.7"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"N (Z core=1)";TAB(30);" 0.5";TAB(40);"1.0"
  PRINT TAB(5);"N (Z core=2)";TAB(30);" 1.5";TAB(40);"1.0"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"O (Z core=1)";TAB(30);" 1.0";TAB(40);"1.0"
  PRINT TAB(5);"O (Z core=2)";TAB(30);" 2.0";TAB(40);"1.0"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"F";TAB(30);" 3.0";TAB(40);"0.7"
  PRINT TAB(5);STRING$(40,"-")
  PRINT TAB(5);"Cl";TAB(30);" 2.0";TAB(40);"0.4"
  PRINT TAB(5);STRING$(40,"-");
  '
RETURN
> PROCEDURE niveau
  '
  LOCAL x0%,y0%,i%,niveau%,max_x%,min_x%,max_y%,min_y%,ausd_x%,ausd_y%
  LOCAL step_y%,faktor,k%,i1%,j1%,z%,rad,a$,y1%
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  DEFTEXT 1,8,0,13
  PRINT AT(15,1);na$
  DEFTEXT 1,0,0,13
  niveau%=1
  FOR i%=2 TO n%
    IF ABS(ad(i%)-ad(i%-1))>0.01
      INC niveau%
    ENDIF
  NEXT i%
  max_x%=0
  min_x%=640
  max_y%=0
  min_y%=400
  FOR i%=1 TO n%
    IF max_x%<x_mol(i%)
      max_x%=x_mol(i%)
    ENDIF
    IF max_y%<y_mol(i%)
      max_y%=y_mol(i%)
    ENDIF
    IF min_x%>x_mol(i%)
      min_x%=x_mol(i%)
    ENDIF
    IF min_y%>y_mol(i%)
      min_y%=y_mol(i%)
    ENDIF
  NEXT i%
  ausd_x%=max_x%-min_x%
  ausd_y%=max_y%-min_y%
  step_y%=350/(niveau%)
  faktor=350/(niveau%+0.5)/(ausd_y%+radius%)
  IF faktor>1
    faktor=1
  ENDIF
  x0%=350
  y0%=350-step_y%/2
  FOR i%=1 TO n%
    x1(i%)=(x_mol(i%)-min_x%)*faktor
    y1(i%)=(y_mol(i%)-min_y%)*faktor
  NEXT i%
  DEFLINE 1,2,0,1
  LINE 100,370,100,20
  DEFLINE 1,1,0,0
  FOR k%=1 TO n%
    '
    FOR i1%=1 TO n%-1
      FOR j1%=i1%+1 TO n%
        IF om(i1%,j1%)<>0
          LINE x1(i1%)+x0%,y1(i1%)+y0%,x1(j1%)+x0%,y1(j1%)+y0%
        ENDIF
      NEXT j1%
    NEXT i1%
    FOR z%=1 TO n%
      rad=ABS(u(z%,k%))*radius%*faktor
      IF SGN(u(z%,k%))>=0
        DEFFILL 1,0,
      ELSE
        DEFFILL 1,1,
      ENDIF
      PCIRCLE x1(z%)+x0%,y1(z%)+y0%,rad
    NEXT z%
    IF EVEN(k%)=TRUE
      x0%=225
    ELSE
      x0%=475
    ENDIF
    IF k%=n%-1
      IF ABS(ad(n%)-ad(n%-1))>0.1
        x0%=350
      ENDIF
    ENDIF
    '    IF k%=n%-1 AND EVEN(n%)=TRUE
    '    x0%=350
    '  ELSE IF k%=n%-1 AND ODD(n%)=TRUE
    '    x0%=225
    '  ENDIF
    IF ABS(ad(k%)-ad(k%+1))>0.01
      a$=LEFT$(STR$(INT(ad(k%)*100+0.5)/100),6)
      y1%=y0%+(ausd_y%)/2*faktor
      TEXT 45,y1%+8,a$
      LINE 95,y1%,105,y1%
      SUB y0%,step_y%
    ENDIF
  NEXT k%
  '
RETURN
> PROCEDURE n_eck
  '
  LOCAL i%,j%,k%,offset%,x0%,y0%,winkel,d_winkel,masstab%,n_eck%,a$
  LOCAL n_kontrol%,ascii%,scan%,erg%
  '
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  PRINT AT(1,22);"Befehle: |g|-Gr”že  |d|-drehen  |v|-verschieben  |m|-Mažstab"
  PRINT AT(10,23);"|CR|-n„chstes N-Eck    |ESC|-Ger�st fertig";
  offset%=1
  WHILE a$<>CHR$(27)
    x0%=100
    y0%=200
    radius%=40
    winkel=90
    masstab%=10
    PRINT AT(2,1);
    INPUT "Anzahl der Ecken: ";n_eck%
    male(n_eck%,winkel,radius%,x0%,y0%)
    a$="v"
    REPEAT
      SELECT a$
      CASE "g"
        groesse(n_eck%,x0%,y0%,masstab%,winkel,radius%,ascii%)
      CASE "d"
        drehen(n_eck%,x0%,y0%,masstab%,radius%,winkel,ascii%)
      CASE "v"
        verschieben(n_eck%,masstab%,winkel,radius%,x0%,y0%,ascii%)
      CASE "m"
        masstab(n_eck%,x0%,y0%,winkel,radius%,masstab%,ascii%)
      ENDSELECT
      a$=CHR$(ascii%)
      '    UNTIL a$=CHR$(13) OR a$=CHR$(27)
    UNTIL a$<>"m" AND a$<>"v" AND a$<>"d" AND a$<>"g"
    d_winkel=360/n_eck%
    FOR i%=offset% TO n_eck%+offset%-1
      x_wert(i%)=COS(winkel/180*PI)*radius%+x0%
      y_wert(i%)=SIN(winkel/180*PI)*radius%+y0%
      winkel=winkel+d_winkel
    NEXT i%
    offset%=offset%+n_eck%
  WEND
  offset%=offset%-1
  '
  PRINT AT(1,22);SPACE$(75)
  PRINT AT(1,23);SPACE$(75);
  PRINT AT(1,23);"Datenreduktion: vorher ";offset%;
  i%=0
  WHILE i%<offset%-1
    INC i%
    j%=i%
    WHILE j%<offset%
      INC j%
      IF x_wert(i%)<x_wert(j%)+2 AND x_wert(i%)>x_wert(j%)-2
        IF y_wert(i%)<y_wert(j%)+2 AND y_wert(i%)>y_wert(j%)-2
          FOR k%=j% TO offset%-1
            x_wert(k%)=x_wert(k%+1)
            y_wert(k%)=y_wert(k%+1)
          NEXT k%
          DEC offset%
        ENDIF
      ENDIF
    WEND
  WEND
  PRINT AT(30,23);"verbliebene Daten: ";offset%;
  '
  erg%=0
  IF offset%>n%
    ALERT 2,"Die Anzahl der Atome stimmt|nicht! Es verbleiben mehr,|als im Molek�l angegeben!",1,"Abbruch|weiter",erg%
  ENDIF
  IF offset%<n%
    ALERT 2,"Die Anzahl der Atome stimmt|nicht! Es verbleiben weniger,|als im Molek�l angegeben!",1,"Abbruch|weiter",erg%
  ENDIF
  IF erg%=1
    GOTO pro_ende
  ENDIF
  PRINT AT(2,2);SPACE$(15)
  n_kontrol%=0
  FOR i%=1 TO n%
    PRINT AT(1,1);"Atom Nummer ";i%;" anklicken."
    REPEAT
    UNTIL MOUSEK=1
    x_mol(i%)=MOUSEX
    y_mol(i%)=MOUSEY
    FOR j%=1 TO offset%
      IF x_mol(i%)>x_wert(j%)-radius%/5 AND x_mol(i%)<x_wert(j%)+radius%/5
        IF y_mol(i%)>y_wert(j%)-radius%/5 AND y_mol(i%)<y_wert(j%)+radius%/5
          x_mol(i%)=x_wert(j%)
          y_mol(i%)=y_wert(j%)
          n_kontrol%=n_kontrol%+1
          PCIRCLE x_mol(i%),y_mol(i%),radius%/5
        ENDIF
      ENDIF
    NEXT j%
    REPEAT
    UNTIL MOUSEK=0
  NEXT i%
  DEFFILL 1,0,0
  PBOX 0,0,640,399
  IF n_kontrol%<n%
    ALERT 3,"Ich finde zuwenig Atome",1,"weiter",dummy%
  ENDIF
  IF n_kontrol%>n%
    ALERT 3,"Ich finde zuviel Atome",1,"weiter",dummy%
  ENDIF
  geruest
  FOR i%=1 TO n%
    PCIRCLE x_mol(i%),y_mol(i%),radius%/5
  NEXT i%
  '
  MENU m_mos,aktiv%
  MENU m_niv,aktiv%
  '
pro_ende:
  '
RETURN
> PROCEDURE hard_copy
  '
  LOCAL a$,g$,s%,x%,q%,inhalt|,bedarf%,flag!,bytes&,x_size&
  LOCAL start_x%,schluss_x%,start_y%,schluss_y%,i&
  LOCAL x0&,y0&,x1&,y1&,x2&,y2&,erg%,grafein$,zeilenv$
  '
  IF OUT?(0)=TRUE
    REPEAT
    UNTIL MOUSEK=0
    DEFMOUSE 3
    REPEAT
      x0&=MOUSEX
      y0&=MOUSEY
    UNTIL MOUSEK=1
    x0&=(x0& DIV 8)*8
    GRAPHMODE 3
    x2&=x0&
    y2&=y0&
    REPEAT
      x1&=MOUSEX
      y1&=MOUSEY
      x1&=(x1& DIV 8)*8-1
      IF x1&<>x2& OR y1&<>y2&
        BOX x0&,y0&,x2&,y2&
        BOX x0&,y0&,x1&,y1&
        x2&=x1&
        y2&=y1&
      ENDIF
    UNTIL MOUSEK=0
    DEFMOUSE 0
    ALERT 2,"Bereich mit Rahmen drucken",2,"ja|nein|Abbruch",erg%
    IF erg%=2
      BOX x0&,y0&,x1&,y1&
    ENDIF
    SUB y0&,3
    ADD y0&,19
    ADD y1&,19
    x_size&=(WORK_OUT(0)+1)/8
    start_x%=XBIOS(2)+y0&*x_size&+x0& DIV 8
    schluss_x%=(x1&-x0&) DIV 8
    start_y%=(y1&-y0&)*x_size&
    schluss_y%=y0&
    a$=SPACE$(y1&-y0&)
    ADD y0&,3
    SUB y0&,19
    SUB y1&,19
    interpretiere(gr_ein$,grafein$)
    interpretiere(gr_vor$,zeilenv$)
    IF erg%<>3
      REPEAT
      UNTIL INKEY$=""
      HIDEM
      OPEN "",#98,"LST:"
      PRINT #98
      FOR s%=start_x% TO start_x%+schluss_x%
        EXIT IF INKEY$=CHR$(27)
        x%=VARPTR(a$)
        flag!=FALSE
        bytes&=0
        FOR q%=s%+start_y% TO s%+schluss_y% STEP -x_size&
          inhalt|=PEEK(q%)
          POKE x%,inhalt|
          INC x%
          INC bytes&
          IF inhalt|<>0
            flag!=TRUE
            bedarf%=bytes&
          ENDIF
        NEXT q%
        IF flag!=TRUE
          g$=grafein$+CHR$(bedarf%)+CHR$(bedarf%/256)
          FOR i&=1 TO mehrfach%
            PRINT #98,g$;LEFT$(a$,bedarf%);CHR$(13);zeilenv$;CHR$(1);
          NEXT i&
          PRINT #98,zeilenv$;CHR$(24-mehrfach%);
        ELSE
          PRINT #98,zeilenv$;CHR$(24);
        ENDIF
      NEXT s%
      CLOSE #98
      SHOWM
    ENDIF
    IF erg%<>2
      BOX x0&,y0&,x1&,y1&
    ENDIF
  ELSE
    ALERT 3,"Drucker einschalten!|Sonst geht nichts.",1,"ach ja",erg%
  ENDIF
  GRAPHMODE 1
  '
RETURN
> PROCEDURE interpretiere(rein$,VAR raus$)
  '
  LOCAL pos_1%
  '
  raus$=CHR$(VAL(rein$))
  pos_1%=INSTR(rein$,",",1)+1
  REPEAT
    raus$=raus$+CHR$(VAL(MID$(rein$,pos_1%)))
    pos_1%=INSTR(rein$,",",pos_1%)+1
  UNTIL pos_1%=1
  '
RETURN
> PROCEDURE druck_param
  '
  LOCAL x&,y&,b&,h&,buffer$,change%,exit_obj%
  '
  ~FORM_CENTER(param_adr%,x&,y&,b&,h&)
  GET x&,y&,x&+b&,y&+h&,buffer$
  CHAR{{OB_SPEC(param_adr%,grein&)}}=gr_ein$
  CHAR{{OB_SPEC(param_adr%,grvor&)}}=gr_vor$
  change%=OB_STATE(param_adr%,doppelt&)
  IF mehrfach%=2
    OB_STATE(param_adr%,doppelt&)=change% OR 1
  ELSE
    OB_STATE(param_adr%,doppelt&)=change% AND &HFE
  ENDIF
  ~OBJC_DRAW(param_adr%,0,3,x&,y&,b&,h&)
  exit_obj%=FORM_DO(param_adr%,0)
  PUT x&,y&,buffer$
  change%=OB_STATE(param_adr%,exit_obj%) AND &HFE
  ~OBJC_CHANGE(param_adr%,exit_obj%,0,x&,y&,b&,h&,change%,0)
  IF exit_obj%=paramok&
    gr_ein$=CHAR{{OB_SPEC(param_adr%,grein&)}}
    gr_vor$=CHAR{{OB_SPEC(param_adr%,grvor&)}}
    IF BTST(OB_STATE(param_adr%,doppelt&),0)=TRUE
      mehrfach%=2
    ELSE
      mehrfach%=1
    ENDIF
  ENDIF
  '
RETURN
> PROCEDURE groesse(n_eck%,x0%,y0%,masstab%,winkel,VAR radius%,ascii%)
  '
  LOCAL a$,scan%,k%
  '
  ascii%=0
  REPEAT
    a$=INKEY$
    IF a$<>"" THEN
      scan%=ASC(RIGHT$(a$))
      k%=0
      IF scan%=72
        k%=masstab%
      ENDIF
      IF scan%=80
        k%=masstab%*-1
      ENDIF
      COLOR 0
      male(n_eck%,winkel,radius%,x0%,y0%)
      COLOR 1
      radius%=radius%+k%
      male(n_eck%,winkel,radius%,x0%,y0%)
      ascii%=ASC(a$)
    ENDIF
  UNTIL ascii%<>0
RETURN
> PROCEDURE drehen(n_eck%,x0%,y0%,masstab%,radius%,VAR winkel,ascii%)
  '
  LOCAL a$,scan%,k%
  '
  ascii%=0
  REPEAT
    a$=INKEY$
    IF a$<>"" THEN
      scan%=ASC(RIGHT$(a$))
      k%=0
      IF scan%=77
        k%=masstab%
      ENDIF
      IF scan%=75
        k%=masstab%*-1
      ENDIF
      COLOR 0
      male(n_eck%,winkel,radius%,x0%,y0%)
      COLOR 1
      winkel=winkel+k%
      male(n_eck%,winkel,radius%,x0%,y0%)
      ascii%=ASC(a$)
    ENDIF
  UNTIL ascii%<>0
RETURN
> PROCEDURE verschieben(n_eck%,masstab%,winkel,radius%,VAR x0%,y0%,ascii%)
  '
  LOCAL a$,scan%,k%,x%,y%
  '
  ascii%=0
  REPEAT
    a$=INKEY$
    IF a$<>"" THEN
      scan%=ASC(RIGHT$(a$))
      x%=0
      y%=0
      IF scan%=72
        y%=masstab%*-1
      ENDIF
      IF scan%=80
        y%=masstab%
      ENDIF
      IF scan%=75
        x%=masstab%*-1
      ENDIF
      IF scan%=77
        x%=masstab%
      ENDIF
      COLOR 0
      male(n_eck%,winkel,radius%,x0%,y0%)
      COLOR 1
      x0%=x0%+x%
      y0%=y0%+y%
      male(n_eck%,winkel,radius%,x0%,y0%)
      ascii%=ASC(a$)
    ENDIF
  UNTIL ascii%<>0
  '
RETURN
> PROCEDURE masstab(n_eck%,x0%,y0%,winkel,radius%,VAR masstab%,ascii%)
  '
  PRINT AT(2,2);SPACE$(15)
  PRINT AT(2,2);
  INPUT "Mažstab : ";masstab%
  male(n_eck%,winkel,radius%,x0%,y0%)
  ascii%=103
  '
RETURN
> PROCEDURE male(n_eck%,winkel,radius%,x0%,y0%)
  '
  LOCAL i%,d_winkel,x1%,y1%
  '
  d_winkel=360/n_eck%
  x1%=COS(winkel/180*PI)*radius%+x0%
  y1%=SIN(winkel/180*PI)*radius%+y0%
  PLOT x1%,y1%
  FOR i%=2 TO n_eck%
    winkel=winkel+d_winkel
    DRAW  TO COS(winkel/180*PI)*radius%+x0%,SIN(winkel/180*PI)*radius%+y0%
  NEXT i%
  DRAW  TO x1%,y1%
  '
RETURN
> PROCEDURE delta_slider(mother&,VAR sm%,sc%)
  '
  sm%=OB_H(eingabe_adr%,mother&)
  sc%=sm%*7/ke_max%
  IF sc%>sm%
    sc%=sm%
  ENDIF
  '
RETURN
> PROCEDURE y_slider(slider&,sm%,sc%,VAR von&,bis&)
  '
  LOCAL y_sc%
  '
  bis&=von&+6
  IF bis&>ke_max%
    bis&=ke_max%
    von&=bis&-6
  ENDIF
  y_sc%=(sm%-sc%)*(von&-1)/(ke_max%-7)
  OB_Y(eingabe_adr%,slider&)=y_sc%
  '
RETURN
> PROCEDURE kette(von&,bis&,read!)
  '
  LOCAL i&
  '
  IF read!=TRUE
    FOR i&=von& TO bis&
      kette$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einkett1&+i&-von&)}}
    NEXT i&
  ELSE
    FOR i&=von& TO bis&
      CHAR{{OB_SPEC(eingabe_adr%,einkett1&+i&-von&)}}=kette$(i&)
    NEXT i&
  ENDIF
  '
RETURN
> PROCEDURE beta(von&,bis&,read!)
  '
  LOCAL i&
  '
  IF read!=TRUE
    FOR i&=von& TO bis&
      beta$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einbeta1&+i&-von&)}}
    NEXT i&
  ELSE
    FOR i&=von& TO bis&
      CHAR{{OB_SPEC(eingabe_adr%,einbeta1&+i&-von&)}}=beta$(i&)
    NEXT i&
  ENDIF
  '
RETURN
> PROCEDURE alpha(von&,bis&,read!)
  '
  LOCAL i&
  '
  IF read!=TRUE
    FOR i&=von& TO bis&
      alpha$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einalph1&+i&-von&)}}
    NEXT i&
  ELSE
    FOR i&=von& TO bis&
      CHAR{{OB_SPEC(eingabe_adr%,einalph1&+i&-von&)}}=alpha$(i&)
    NEXT i&
  ENDIF
  '
RETURN
> PROCEDURE shift_slider(slider&,VAR von&)
  '
  LOCAL x_abs%,y_abs%,y_abs_maus%
  '
  ~OBJC_OFFSET(eingabe_adr%,slider&,x_abs%,y_abs%)
  y_abs_maus%=MOUSEY
  IF y_abs_maus%>y_abs%
    ADD von&,7
  ELSE
    SUB von&,7
  ENDIF
  '
RETURN
> PROCEDURE manager(slider&,sm%,sc%,VAR von&,bis&)
  '
  IF von&<1
    von&=1
  ENDIF
  y_slider(slider&,sm%,sc%,von&,bis&)
  '
RETURN
DEFFN s_back(x%)=(ke_max%-7)*(x%/1000)+1