home *** CD-ROM | disk | FTP | other *** search
/ The Very Best of Atari Inside / The Very Best of Atari Inside 1.iso / sharew / chemie / hmo / hmo.gfa (.txt) next >
Encoding:
GFA-BASIC Atari  |  1993-02-21  |  34.9 KB  |  1,904 lines
  1. REM *************************************************************************
  2. REM *   HMO Programm                    24.11.1987                          *
  3. REM *************************************************************************
  4. '
  5. $%I+
  6. $%3
  7. $*&
  8. $S&
  9. $S>
  10. $F<
  11. '
  12. IF FRE(0)<100000
  13.   ALERT 3,"Keine Chance!|Viel zu wenig Speicher frei.|Schaff erst einmal Platz.",1," Pech ",dummy%
  14.   STOP
  15. ENDIF
  16. RESERVE 150000
  17. ke_max%=14
  18. '
  19. DIM ue#(30),m#(30,30),a#(30,30),b#(30,30),om#(30,30),ad#(30),e#(30),u#(30,30),he#(160)
  20. DIM bl#(30,30),x_mol#(30),y_mol#(30),x1#(30),y1#(30),x_wert#(128),y_wert#(128)
  21. DIM kette$(ke_max%),alpha$(ke_max%),beta$(ke_max%)
  22. '
  23. REM ------------ wichtige Variablen ----------------------------------------
  24. '   Ue() - Überschrift über die Spalten der Matrix bei der Ausgabe
  25. '   M()  - Matrix in die die jeweilige darzustellende Matrix übertragen wird
  26. '   Om() - Hückelmatrix
  27. '   U()  - MO-Koeffizienten
  28. '   B()  - Pi-Ladungsdichten und Bindungsordnungen
  29. '   Bl() - Bindungslängen zw. gebundenen Atomen
  30. '   E()  - Freie Valenzen
  31. '   A()  - Diagonalmatrix
  32. '   Ad() - MO-Energien
  33. '   X_mol() - X-Koordinaten des Moleküls
  34. '   Y_mol() - Y-Koordinaten des Moleküls
  35. REM ------------------------------------------------------------------------
  36. '
  37. DIM leiste$(50)
  38. '
  39. FOR i%=0 TO 50
  40.   READ leiste$(i%)
  41.   EXIT IF leiste$(i%)="--"
  42. NEXT i%
  43. leiste$(i%)=""
  44. leiste$(i%+1)=""
  45. '
  46. DATA Desk,  Prg Info,--------------------,1,2,3,4,5,6,""
  47. DATA Eingabe,  Molekül,  neue Rechnung ,  Ende,""
  48. DATA Ausgabe,  Hückelmatrix,  HMO Koeffizienten,  Bindungsordnung,  Ges.Energie/freie Valenzen ,  Bindungslängen,  Drucker,""
  49. DATA Parameter,  Schriftgröße ,  Radius,  Tabelle,  Druckercodes ,""
  50. DATA Grafik,  Molekül zeichnen ,  MO's zeichnen,  Niveaus,  N_Eck,  Hardcopy ,""
  51. DATA --
  52. '
  53. REM ---------- Konstanten festlegen ----------------
  54. info$="Hückelrechnung|"+CHR$(189)+" Kollmannsberger WS 85/86 |  geändert J.D. 24.11.1987|     Errare humanum est"
  55. fo$=" -#.####"
  56. alpha$="α"
  57. beta$="|β|"
  58. pi$="π"
  59. bell$=CHR$(7)
  60. angstroem$="Å"
  61. eps#=3E-10
  62. tl#=2E-38
  63. max_spalte%=8
  64. max_zeile%=11
  65. sg%=1
  66. schrift%=13
  67. wurz_3#=SQR(3)
  68. x0%=50
  69. radius%=50
  70. aktiv%=3     !Menüpunkt wählbar
  71. inaktiv%=2   !          nicht wählbar
  72. c_set%=1     !Checkmark setzen
  73. c_reset%=0   !          zurücksetzen
  74. mehrfach%=1
  75. laufw$=CHR$(GEMDOS(25)+65)
  76. numbers!=FALSE   !Nummern nicht einzeichnen
  77. REM ------------------------------------------------
  78. '
  79. REM ----------------- Druckerbefehle -----------------------
  80. rand$=CHR$(27)+"l"+CHR$(7)         !Linker Rand bei Spalte 7
  81. elite$=CHR$(27)+"M"                !Elite Schriftart
  82. schmal$=CHR$(27)+CHR$(15)          !Schmalschrift
  83. dpplt_ein$=CHR$(27)+"G"            !Doppelter Anschlag ein
  84. dpplt_aus$=CHR$(27)+"H"            !                   aus
  85. init$=CHR$(27)+"@"                 !Druckerinitialisierung
  86. gr_ein$="27,42,5"                  !Grafik ein für eine Zeile
  87. gr_vor$="27,74"                    !Einmaliger Zeilenvorschub um n/216 Zoll
  88. REM --------------------------------------------------------
  89. '
  90. REM ----------------- Menüpunkte -------------------
  91. m_ein#=11      !Eingabe des Moleküls
  92. m_neu#=12      !Neue Rechnung
  93. m_hue#=16      !Ausgabe Hückelmatrix
  94. m_hmo#=17      !        HMO-Koeffizienten
  95. m_bio#=18      !        Pi Bindungsordnunge und Ladungsdichte
  96. m_ene#=19      !        Ges. Energie und freie Valenzen
  97. m_bil#=20      !        Bindungslängen
  98. m_dru#=21      !Drucker ein/aus
  99. m_mol#=30      !Molekül zeichnen
  100. m_mos#=31      !MO's zeichnen
  101. m_niv#=32      !Niveaus zeichnen
  102. m_nec#=33      !N-Ecke zeichnen
  103. REM ------------------------------------------------
  104. CLS
  105. rcs_verwaltung
  106. CLS
  107. '
  108. MENU leiste$()
  109. OPENW 0
  110. ON MENU GOSUB menue
  111. neustart
  112. programmende!=FALSE
  113. '
  114. DO
  115.   ON MENU
  116. LOOP UNTIL programmende!=TRUE
  117. '
  118. programmende:
  119. ~RSRC_FREE()
  120. RESERVE
  121. '
  122. > PROCEDURE menue
  123.   '
  124.   LOCAL a%
  125.   '
  126.   a%=MENU(0)
  127.   ON a%-10 GOSUB eingabe,neustart,ende
  128.   ON a%-15 GOSUB hueckel_mat,hmo_koeff,bindungso,ges_energie,bdg_laenge,drucker
  129.   ON a%-23 GOSUB schriftgr,radius,tabelle,druck_param
  130.   ON a%-29 GOSUB mol_zeichnen,mos_malen,niveau,n_eck,hard_copy
  131.   ON a% GOSUB prginfo
  132.   '
  133.   MENU OFF
  134.   '
  135. RETURN
  136. > PROCEDURE ende
  137.   '
  138.   LOCAL erg%
  139.   '
  140.   ALERT 3,"Programm beenden",1,"ja|nein",erg%
  141.   IF erg%=1
  142.     programmende!=TRUE
  143.   ENDIF
  144.   '
  145. RETURN
  146. > PROCEDURE prginfo
  147.   '
  148.   LOCAL erg%
  149.   '
  150.   ALERT 0,info$,1,"weiter",erg%
  151.   '
  152. RETURN
  153. > PROCEDURE drucker
  154.   '
  155.   LOCAL erg%
  156.   '
  157.   IF drucken!=FALSE
  158.     IF OUT?(0)=TRUE
  159.       drucken!=TRUE
  160.       LPRINT init$
  161.       LPRINT rand$
  162.       LPRINT elite$
  163.       MENU m_dru#,c_set%
  164.     ELSE
  165.       ALERT 2,"Drucker einschalten,|sonst geht nichts !",1,"weiter|Abbruch",erg%
  166.       IF erg%=1
  167.         drucker
  168.       ENDIF
  169.     ENDIF
  170.   ELSE
  171.     drucken!=FALSE
  172.     MENU m_dru#,c_reset%
  173.   ENDIF
  174.   '
  175. RETURN
  176. > PROCEDURE neustart
  177.   '
  178.   LOCAL i&
  179.   '
  180.   init_felder
  181.   FOR i&=1 TO ke_max%
  182.     kette$(i&)=""
  183.     alpha$(i&)=""
  184.     beta$(i&)=""
  185.   NEXT i&
  186.   na$=""
  187.   n%=0
  188.   ne%=0
  189.   CHAR{{OB_SPEC(eingabe_adr%,einmolek&)}}=""
  190.   CHAR{{OB_SPEC(eingabe_adr%,einzentr&)}}=""
  191.   CHAR{{OB_SPEC(eingabe_adr%,einelekt&)}}=""
  192.   '
  193.   drucken!=FALSE
  194.   '
  195.   REM -------------------Menüpunkte desaktivieren
  196.   '
  197.   MENU m_ein#,aktiv%
  198.   MENU m_neu#,inaktiv%
  199.   MENU m_hue#,inaktiv%
  200.   MENU m_hmo#,inaktiv%
  201.   MENU m_bio#,inaktiv%
  202.   MENU m_ene#,inaktiv%
  203.   MENU m_bil#,inaktiv%
  204.   MENU m_dru#,c_reset%
  205.   MENU m_mol#,inaktiv%
  206.   MENU m_mos#,inaktiv%
  207.   MENU m_niv#,inaktiv%
  208.   MENU m_nec#,inaktiv%
  209.   '
  210. RETURN
  211. > PROCEDURE init_felder
  212.   '
  213.   ARRAYFILL ue#(),0
  214.   ARRAYFILL m#(),0
  215.   ARRAYFILL a#(),0
  216.   ARRAYFILL b#(),0
  217.   ARRAYFILL bl#(),0
  218.   ARRAYFILL om#(),0
  219.   ARRAYFILL ad#(),0
  220.   ARRAYFILL e#(),0
  221.   ARRAYFILL u#(),0
  222.   ARRAYFILL he#(),0
  223.   '
  224. RETURN
  225. > PROCEDURE rcs_verwaltung
  226.   '
  227.   LOCAL fehler%,dummy%,schalter%,path$,leer$,font$,i&
  228.   '
  229.   LET menue&=0 !RSC_TREE
  230.   LET eingabe&=1 !RSC_TREE
  231.   LET radius&=2 !RSC_TREE
  232.   LET textsize&=3 !RSC_TREE
  233.   LET einmolek&=1 !Obj in #1
  234.   LET einzentr&=2 !Obj in #1
  235.   LET einelekt&=3 !Obj in #1
  236.   LET einkett1&=7 !Obj in #1
  237.   LET einkett7&=13 !Obj in #1
  238.   LET einkettm&=6 !Obj in #1
  239.   LET einhoch1&=16 !Obj in #1
  240.   LET eindown1&=17 !Obj in #1
  241.   LET einslid1&=15 !Obj in #1
  242.   LET einmoth1&=14 !Obj in #1
  243.   LET einalph1&=21 !Obj in #1
  244.   LET einalph7&=27 !Obj in #1
  245.   LET einhoch3&=28 !Obj in #1
  246.   LET eindown3&=31 !Obj in #1
  247.   LET einslid3&=30 !Obj in #1
  248.   LET einmoth3&=29 !Obj in #1
  249.   LET einalphm&=20 !Obj in #1
  250.   LET einab&=50 !Obj in #1
  251.   LET einok&=46 !Obj in #1
  252.   LET einbeta1&=35 !Obj in #1
  253.   LET einbeta7&=41 !Obj in #1
  254.   LET einbetam&=34 !Obj in #1
  255.   LET einhoch2&=42 !Obj in #1
  256.   LET eindown2&=45 !Obj in #1
  257.   LET einslid2&=44 !Obj in #1
  258.   LET einmoth2&=43 !Obj in #1
  259.   LET raddec&=5 !Obj in #2
  260.   LET radinc&=6 !Obj in #2
  261.   LET radval&=4 !Obj in #2
  262.   LET textnorm&=2 !Obj in #3
  263.   LET texticon&=3 !Obj in #3
  264.   LET radmoth&=3 !Obj in #2
  265.   LET radok&=7 !Obj in #2
  266.   LET param&=4 !RSC_TREE
  267.   LET grein&=4 !Obj in #4
  268.   LET grvor&=5 !Obj in #4
  269.   LET doppelt&=6 !Obj in #4
  270.   LET paramok&=8 !Obj in #4
  271.   '
  272.   path$="HMO.RSC"
  273.   REPEAT
  274.     DEFMOUSE 2
  275.     PRINT AT(5,2);path$+" WIRD GELADEN"
  276.     fehler%=RSRC_LOAD(path$)
  277.     DEFMOUSE 0
  278.     IF fehler%=0
  279.       ALERT 3,"Resource nicht gefunden !|Bitte Pfad angeben.",1," sowas ",dummy%
  280.       path$=laufw$+":\*.RSC"
  281.       VOID FSEL_INPUT(path$,leer$,schalter%)
  282.       CLS
  283.       IF schalter%=0
  284.         programmende!=TRUE
  285.       ENDIF
  286.       leer$="HMO.RSC"
  287.       i&=RINSTR(path$,"\")
  288.       path$=LEFT$(path$,i&)+leer$
  289.     ENDIF
  290.   UNTIL fehler%<>0 OR schalter%=0
  291.   IF programmende!=FALSE
  292.     ~RSRC_GADDR(0,eingabe&,eingabe_adr%)
  293.     ~RSRC_GADDR(0,radius&,radius_adr%)
  294.     ~RSRC_GADDR(0,textsize&,textsize_adr%)
  295.     ~RSRC_GADDR(0,param&,param_adr%)
  296.     '    DIM message_buffer%(3)
  297.     '    mes_adr%=V:message_buffer%(0)
  298.     '    ABSOLUTE mes_type&,mes_adr%
  299.     '    ABSOLUTE m_titel&,mes_adr%+6
  300.     '    ABSOLUTE m_eintrag&,mes_adr%+8
  301.   ENDIF
  302. RETURN
  303. > PROCEDURE eingabe
  304.   '
  305.   LOCAL x&,y&,w&,h&,buffer$,exit_obj%,change%
  306.   LOCAL i&,dummy%
  307.   LOCAL delta_sc1%,delta_sm1%,von1&,bis1&
  308.   LOCAL delta_sc2%,delta_sm2%,von2&,bis2&
  309.   LOCAL delta_sc3%,delta_sm3%,von3&,bis3&
  310.   '
  311.   ~FORM_CENTER(eingabe_adr%,x&,y&,w&,h&)
  312.   GET x&,y&,x&+w&,y&+h&,buffer$
  313.   von1&=1
  314.   von2&=1
  315.   von3&=1
  316.   delta_slider(einmoth1&,delta_sm1%,delta_sc1%)
  317.   delta_slider(einmoth2&,delta_sm2%,delta_sc2%)
  318.   delta_slider(einmoth3&,delta_sm3%,delta_sc3%)
  319.   OB_H(eingabe_adr%,einslid1&)=delta_sc1%
  320.   OB_H(eingabe_adr%,einslid2&)=delta_sc2%
  321.   OB_H(eingabe_adr%,einslid3&)=delta_sc3%
  322.   ~OBJC_DRAW(eingabe_adr%,0,2,x&,y&,w&,h&)
  323.   y_slider(einslid1&,delta_sm1%,delta_sc1%,von1&,bis1&)
  324.   y_slider(einslid2&,delta_sm2%,delta_sc2%,von2&,bis2&)
  325.   y_slider(einslid3&,delta_sm3%,delta_sc3%,von3&,bis3&)
  326.   kette(von1&,bis1&,FALSE)      !FALSE heißt schreiben
  327.   beta(von2&,bis2&,FALSE)
  328.   alpha(von3&,bis3&,FALSE)
  329.   ~OBJC_DRAW(eingabe_adr%,einkettm&,3,x&,y&,w&,h&)
  330.   ~OBJC_DRAW(eingabe_adr%,einbetam&,3,x&,y&,w&,h&)
  331.   ~OBJC_DRAW(eingabe_adr%,einalphm&,3,x&,y&,w&,h&)
  332.   init_felder
  333.   DO
  334.     exit_obj%=FORM_DO(eingabe_adr%,0)
  335.     ~OBJC_CHANGE(eingabe_adr%,exit_obj%,0,x&,y&,w&,h&,0,1)
  336.     SELECT exit_obj%
  337.     CASE einhoch1&
  338.       kette(von1&,bis1&,TRUE)        !TRUE heißt lesen
  339.       DEC von1&
  340.     CASE eindown1&
  341.       kette(von1&,bis1&,TRUE)
  342.       INC von1&
  343.     CASE einmoth1&
  344.       kette(von1&,bis1&,TRUE)
  345.       shift_slider(einslid1&,von1&)
  346.     CASE einslid1&
  347.       kette(von1&,bis1&,TRUE)
  348.       slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth1&,einslid1&,1)
  349.       von1&=FN s_back(slide_back%)
  350.     CASE einhoch2&
  351.       beta(von2&,bis2&,TRUE)
  352.       DEC von2&
  353.     CASE eindown2&
  354.       beta(von2&,bis2&,TRUE)
  355.       INC von2&
  356.     CASE einmoth2&
  357.       beta(von2&,bis2&,TRUE)
  358.       shift_slider(einslid2&,von2&)
  359.     CASE einslid2&
  360.       beta(von2&,bis2&,TRUE)
  361.       slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth2&,einslid2&,1)
  362.       von2&=FN s_back(slide_back%)
  363.     CASE einhoch3&
  364.       alpha(von3&,bis3&,TRUE)
  365.       DEC von3&
  366.     CASE eindown3&
  367.       alpha(von3&,bis3&,TRUE)
  368.       INC von3&
  369.     CASE einmoth3&
  370.       alpha(von3&,bis3&,TRUE)
  371.       shift_slider(einslid3&,von3&)
  372.     CASE einslid3&
  373.       alpha(von3&,bis3&,TRUE)
  374.       slide_back%=GRAF_SLIDEBOX(eingabe_adr%,einmoth3&,einslid3&,1)
  375.       von3&=FN s_back(slide_back%)
  376.     ENDSELECT
  377.     SELECT exit_obj%
  378.     CASE einhoch1&,eindown1&,einmoth1&,einslid1&
  379.       manager(einslid1&,delta_sm1%,delta_sc1%,von1&,bis1&)
  380.       kette(von1&,bis1&,FALSE)
  381.       ~OBJC_DRAW(eingabe_adr%,einkettm&,3,x&,y&,w&,h&)
  382.     CASE einhoch2&,eindown2&,einmoth2&,einslid2&
  383.       manager(einslid2&,delta_sm2%,delta_sc2%,von2&,bis2&)
  384.       beta(von2&,bis2&,FALSE)
  385.       ~OBJC_DRAW(eingabe_adr%,einbetam&,3,x&,y&,w&,h&)
  386.     CASE einhoch3&,eindown3&,einmoth3&,einslid3&
  387.       manager(einslid3&,delta_sm3%,delta_sc3%,von3&,bis3&)
  388.       alpha(von3&,bis3&,FALSE)
  389.       ~OBJC_DRAW(eingabe_adr%,einalphm&,3,x&,y&,w&,h&)
  390.     ENDSELECT
  391.   LOOP UNTIL exit_obj%=einok& OR exit_obj%=einab&
  392.   PUT x&,y&,buffer$
  393.   IF exit_obj%=einok&
  394.     kette(von1&,bis1&,TRUE)
  395.     beta(von2&,bis2&,TRUE)
  396.     alpha(von3&,bis3&,TRUE)
  397.     na$=CHAR{{OB_SPEC(eingabe_adr%,einmolek&)}}
  398.     n%=VAL(CHAR{{OB_SPEC(eingabe_adr%,einzentr&)}})
  399.     ne%=VAL(CHAR{{OB_SPEC(eingabe_adr%,einelekt&)}})
  400.     ~OBJC_CHANGE(eingabe_adr%,exit_obj%,0,x&,y&,w&,h&,0,0)
  401.     IF n%=0
  402.       ALERT 3," Ohne Zentren| |keine Rechnung!",1,"klar?",dummy%
  403.     ELSE IF ne%=0
  404.       ALERT 3,"Ohne Elektronen| |keine Rechnung!",1,"klar?",dummy%
  405.     ELSE
  406.       molekuel
  407.     ENDIF
  408.   ENDIF
  409.   '
  410. RETURN
  411. > PROCEDURE molekuel
  412.   '
  413.   LOCAL ke%,k%,i1%,i2%,zeile%,k$,kk%,we#
  414.   '
  415.   masstab%=540/n%
  416.   m%=INT(ne%/2+0.6)
  417.   radikal!=ODD(ne%)       ! Radikal!=True wenn Ne ungerade
  418.   FOR ke%=1 TO 14
  419.     k$=alpha$(ke%)
  420.     EXIT IF k$=""
  421.     i1%=VAL(LEFT$(k$,2))
  422.     om#(i1%,i1%)=VAL(RIGHT$(k$,5))
  423.   NEXT ke%
  424.   FOR ke%=1 TO 14
  425.     k$=kette$(ke%)
  426.     EXIT IF k$=""
  427.     kk%=1
  428.     i1%=VAL(MID$(k$,1))
  429.     DO
  430.       kk%=INSTR(k$,"-",kk%)+1
  431.       EXIT IF kk%=1
  432.       i2%=VAL(MID$(k$,kk%))
  433.       om#(i1%,i2%)=1
  434.       om#(i2%,i1%)=1
  435.       i1%=i2%
  436.     LOOP
  437.   NEXT ke%
  438.   FOR ke%=1 TO 14
  439.     k$=beta$(ke%)
  440.     EXIT IF k$=""
  441.     i1%=VAL(LEFT$(k$,2))
  442.     i2%=VAL(MID$(k$,3,2))
  443.     om#(i1%,i2%)=VAL(RIGHT$(k$,5))
  444.     om#(i2%,i1%)=VAL(RIGHT$(k$,5))
  445.   NEXT ke%
  446.   diag_vorbereitung
  447.   diagonalisierung
  448.   PRINT AT(5,22);"Einen Moment Geduld, die restlichen Berechnungen laufen noch"
  449.   bind_ordnung
  450.   bind_laenge
  451.   freie_valenzen
  452.   PRINT AT(5,22);"                                                            "
  453.   PRINT bell$;
  454.   MENU m_neu#,aktiv%
  455.   MENU m_hue#,aktiv%
  456.   MENU m_hmo#,aktiv%
  457.   MENU m_bio#,aktiv%
  458.   MENU m_ene#,aktiv%
  459.   MENU m_bil#,aktiv%
  460.   MENU m_mol#,aktiv%
  461.   MENU m_nec#,aktiv%
  462.   '
  463. RETURN
  464. > PROCEDURE matrix_list
  465.   '
  466.   LOCAL spalte%,zeile%,von_s%,bis_s%,von_z%,k3%,i%,j%,a$,as%
  467.   '
  468.   IF drucken!=TRUE
  469.     LPRINT dpplt_ein$
  470.     LPRINT na$
  471.     LPRINT dpplt_aus$
  472.     LPRINT ueberschrift$
  473.     IF n%>9
  474.       LPRINT schmal$
  475.       spalte%=14
  476.     ELSE
  477.       LPRINT
  478.       spalte%=8
  479.     ENDIF
  480.     von_s%=1
  481.     k3%=1
  482.     '
  483.     DO
  484.       '
  485.       bis_s%=von_s%+spalte%
  486.       IF bis_s%>n%
  487.         bis_s%=n%
  488.       ENDIF
  489.       LPRINT SPACE$(3);
  490.       FOR i%=von_s% TO bis_s%
  491.         LPRINT USING uefo$,ue#(i%);
  492.       NEXT i%
  493.       LPRINT
  494.       LPRINT
  495.       FOR i%=1 TO n%
  496.         LPRINT USING " ##",i%;
  497.         FOR j%=von_s% TO bis_s%
  498.           LPRINT USING fo$,m#(i%,j%);
  499.         NEXT j%
  500.         LPRINT
  501.         INC k3%
  502.         IF k3%>3
  503.           k3%=1
  504.           LPRINT
  505.         ENDIF
  506.       NEXT i%
  507.       EXIT IF bis_s%=n%
  508.       von_s%=bis_s%+1
  509.       LPRINT STRING$(123,"-")
  510.       '
  511.     LOOP
  512.     '
  513.     LPRINT elite$
  514.   ENDIF
  515.   von_s%=1
  516.   von_z%=1
  517.   '
  518.   DO
  519.     '
  520.     spalte%=von_s%+max_spalte%
  521.     zeile%=von_z%+max_zeile%
  522.     IF spalte%>n%
  523.       spalte%=n%
  524.     ENDIF
  525.     IF zeile%>n%
  526.       zeile%=n%
  527.     ENDIF
  528.     DEFFILL 1,0,0
  529.     PBOX 0,0,640,399
  530.     PRINT AT(10,1);ueberschrift$
  531.     PRINT
  532.     DEFTEXT 1,0,0,schrift%
  533.     IF schrift%=4
  534.       PRINT AT(1,9)
  535.     ENDIF
  536.     PRINT TAB(7);
  537.     FOR i%=von_s% TO spalte%
  538.       PRINT USING uefo$,ue#(i%);
  539.     NEXT i%
  540.     PRINT
  541.     PRINT
  542.     k3%=0
  543.     FOR i%=von_z% TO zeile%
  544.       PRINT USING "  ##   ",i%;
  545.       FOR j%=von_s% TO spalte%
  546.         PRINT USING fo$,m#(i%,j%);
  547.       NEXT j%
  548.       INC k3%
  549.       IF k3%=3
  550.         k3%=0
  551.         PRINT
  552.       ENDIF
  553.       PRINT
  554.     NEXT i%
  555.     DEFTEXT 1,0,0,13
  556.     EXIT IF n%<=max_spalte%+1
  557.     PRINT AT(5,22);"Bei großen Matrizen kann man mit den Cursortasten blättern!"
  558.     PRINT AT(9,23);"weiter mit <return> oder Mausklick";
  559.     REPEAT
  560.       a$=INKEY$
  561.       as%=CVI(a$)
  562.       IF MOUSEK>0
  563.         a$=CHR$(13)
  564.       ENDIF
  565.     UNTIL a$=CHR$(13) OR as%=80 OR as%=72 OR as%=77 OR as%=75
  566.     EXIT IF a$=CHR$(13)
  567.     IF as%=72                 !rauf
  568.       SUB von_z%,max_zeile%
  569.       IF von_z%<1
  570.         von_z%=1
  571.       ENDIF
  572.     ENDIF
  573.     IF as%=80                 !runter
  574.       ADD von_z%,max_zeile%
  575.       IF von_z%>n%
  576.         von_z%=1
  577.       ENDIF
  578.     ENDIF
  579.     '
  580.     IF as%=77                 !rechts
  581.       ADD von_s%,max_spalte%
  582.       IF von_s%>n%
  583.         von_s%=1
  584.       ENDIF
  585.     ENDIF
  586.     IF as%=75                 !links
  587.       SUB von_s%,max_spalte%
  588.       IF von_s%<1
  589.         von_s%=1
  590.       ENDIF
  591.     ENDIF
  592.     '
  593.   LOOP
  594.   '
  595. RETURN
  596. > PROCEDURE hueckel_mat
  597.   '
  598.   LOCAL i%,j%
  599.   '
  600.   ueberschrift$="Hückelmatrix"
  601.   FOR i%=1 TO n%
  602.     FOR j%=1 TO n%
  603.       m#(i%,j%)=om#(i%,j%)
  604.     NEXT j%
  605.     ue#(i%)=i%
  606.   NEXT i%
  607.   uefo$="  ##    "
  608.   matrix_list
  609.   '
  610. RETURN
  611. > PROCEDURE hmo_koeff
  612.   '
  613.   LOCAL i%,j%
  614.   '
  615.   ueberschrift$="MO-Energien und MO-Koeffizienten in Vielfachen von "+beta$
  616.   FOR i%=1 TO n%
  617.     FOR j%=1 TO n%
  618.       m#(i%,j%)=u#(i%,j%)
  619.     NEXT j%
  620.     ue#(i%)=ad#(i%)
  621.   NEXT i%
  622.   uefo$=fo$
  623.   matrix_list
  624.   '
  625. RETURN
  626. > PROCEDURE bindungso
  627.   '
  628.   LOCAL i%,j%
  629.   '
  630.   ueberschrift$=pi$+"-Ladungsdichten und Bindungsordnungen"
  631.   FOR i%=1 TO n%
  632.     FOR j%=1 TO n%
  633.       m#(i%,j%)=b#(i%,j%)
  634.     NEXT j%
  635.     ue#(i%)=i%
  636.   NEXT i%
  637.   uefo$="  ##    "
  638.   matrix_list
  639.   '
  640. RETURN
  641. > PROCEDURE bdg_laenge
  642.   '
  643.   LOCAL i%,j%
  644.   '
  645.   ueberschrift$="Bindungslängen in "+angstroem$
  646.   FOR i%=1 TO n%
  647.     FOR j%=1 TO n%
  648.       m#(i%,j%)=bl#(i%,j%)
  649.     NEXT j%
  650.     ue#(i%)=i%
  651.   NEXT i%
  652.   uefo$="  ##    "
  653.   matrix_list
  654.   '
  655. RETURN
  656. > PROCEDURE diag_vorbereitung
  657.   '
  658.   LOCAL i%,j%,hi#
  659.   '
  660.   FOR j%=1 TO n%
  661.     FOR i%=1 TO j%
  662.       hi#=-om#(i%,j%)
  663.       a#(i%,j%)=hi#
  664.       a#(j%,i%)=hi#
  665.     NEXT i%
  666.   NEXT j%
  667.   '
  668. RETURN
  669. > PROCEDURE bind_ordnung
  670.   '
  671.   LOCAL bo%,bp%,bs#,j%
  672.   '
  673.   FOR bo%=1 TO n%
  674.     FOR bp%=1 TO bo%
  675.       IF om#(bo%,bp%)<>0 OR bo%=bp%
  676.         bs#=0
  677.         FOR j%=1 TO m%
  678.           bs#=bs#+u#(bo%,j%)*u#(bp%,j%)
  679.         NEXT j%
  680.         bs#=2*bs#
  681.         IF radikal!=TRUE
  682.           bs#=bs#-u#(bo%,m%)*u#(bp%,m%)
  683.         ENDIF
  684.         b#(bo%,bp%)=bs#
  685.         b#(bp%,bo%)=bs#
  686.       ENDIF
  687.     NEXT bp%
  688.   NEXT bo%
  689.   '
  690. RETURN
  691. > PROCEDURE bind_laenge
  692.   '
  693.   LOCAL i%,j%,bdg_len#
  694.   '
  695.   FOR i%=1 TO n%-1
  696.     FOR j%=i%+1 TO n%
  697.       IF om#(i%,j%)<>0
  698.         bdg_len#=1.506-0.1678*b#(i%,j%)
  699.         bl#(i%,j%)=bdg_len#
  700.         bl#(j%,i%)=bdg_len#
  701.       ENDIF
  702.     NEXT j%
  703.   NEXT i%
  704.   '
  705. RETURN
  706. > PROCEDURE freie_valenzen
  707.   '
  708.   LOCAL i%,j%,nb#
  709.   '
  710.   FOR j%=1 TO n%
  711.     FOR i%=1 TO n%
  712.       IF (i%<>j%) AND (ABS(om#(i%,j%))>0.1)
  713.         nb#=nb#+b#(i%,j%)
  714.       ENDIF
  715.     NEXT i%
  716.     e#(j%)=wurz_3#-nb#
  717.   NEXT j%
  718.   '
  719. RETURN
  720. > PROCEDURE ges_energie
  721.   '
  722.   LOCAL von%,bis%,i%
  723.   '
  724.   uefo$="  ##    "
  725.   pi_energie
  726.   IF drucken!=TRUE
  727.     LPRINT dpplt_ein$
  728.     LPRINT na$
  729.     LPRINT dpplt_aus$
  730.     LPRINT "Gesamt-";pi$;"-Elektronenenergie:";USING " -##.### "+beta$,ge#
  731.     LPRINT
  732.     LPRINT "Elektronenzahl  ";ne%
  733.     LPRINT
  734.     LPRINT "Freie Valenzen"
  735.     LPRINT
  736.     von%=1
  737.     '
  738.     DO
  739.       '
  740.       bis%=von%+8
  741.       IF bis%>n%
  742.         bis%=n%
  743.       ENDIF
  744.       LPRINT SPACE$(3);
  745.       FOR i%=von% TO bis%
  746.         LPRINT USING uefo$,i%;
  747.       NEXT i%
  748.       LPRINT
  749.       LPRINT
  750.       LPRINT SPACE$(3);
  751.       FOR i%=von% TO bis%
  752.         LPRINT USING fo$,e#(i%);
  753.       NEXT i%
  754.       LPRINT
  755.       EXIT IF bis%=n%
  756.       von%=bis%+1
  757.       LPRINT SPACE$(5);STRING$(70,"-")
  758.       '
  759.     LOOP
  760.     '
  761.   ENDIF
  762.   DEFFILL 1,0,0
  763.   PBOX 0,0,640,399
  764.   PRINT AT(5,1);"Gesamt-";pi$;"-Elektronenenergie:";USING " -##.#### "+beta$,ge#
  765.   PRINT AT(5,3);"Elektronenzahl: ";ne%
  766.   PRINT AT(5,5);"Freie Valenzen"
  767.   PRINT
  768.   von%=1
  769.   DO
  770.     '
  771.     bis%=von%+8
  772.     IF bis%>n%
  773.       bis%=n%
  774.     ENDIF
  775.     PRINT TAB(3);
  776.     FOR i%=von% TO bis%
  777.       PRINT USING uefo$,i%;
  778.     NEXT i%
  779.     PRINT
  780.     PRINT
  781.     PRINT TAB(3);
  782.     FOR i%=von% TO bis%
  783.       PRINT USING fo$,e#(i%);
  784.     NEXT i%
  785.     EXIT IF bis%=n%
  786.     von%=bis%+1
  787.     PRINT TAB(5);STRING$(70,"-")
  788.     '
  789.   LOOP
  790.   '
  791. RETURN
  792. > PROCEDURE pi_energie
  793.   '
  794.   LOCAL j%
  795.   '
  796.   ge#=0
  797.   FOR j%=1 TO m%
  798.     ge#=ge#+ad#(j%)
  799.   NEXT j%
  800.   ge#=ge#*2
  801.   IF radikal!=TRUE
  802.     ge#=ge#-ad#(m%)
  803.   ENDIF
  804.   '
  805. RETURN
  806. > PROCEDURE diagonalisierung
  807.   '
  808.   LOCAL zeit%,i%,j%,j1%,ni%,l%,h#,g#,k%,s#,f#,b#,p#,r#,c#
  809.   '
  810.   bild_aufbau
  811.   zeit%=TIMER
  812.   IF n%=1
  813.     ad#(1)=a#(1,1)
  814.     u#(1,1)=1
  815.     GOTO diag_ende
  816.   ENDIF
  817.   FOR i%=1 TO n%
  818.     FOR j%=1 TO i%
  819.       u#(i%,j%)=a#(i%,j%)
  820.     NEXT j%
  821.   NEXT i%
  822.   '   HOUSHOLDER
  823.   DEFFILL 1,2,18
  824.   y0%=112    !Grafik
  825.   y1%=y0%+16
  826.   FOR ni%=2 TO n%
  827.     i%=n%+2-ni%
  828.     l%=i%-2
  829.     h#=0
  830.     g#=u#(i%,i%-1)
  831.     IF l%<=0
  832.       GOTO raus_1
  833.     ENDIF
  834.     FOR k%=1 TO l%
  835.       h#=h#+u#(i%,k%)^2
  836.     NEXT k%
  837.     s#=h#+g#*g#
  838.     IF s#<tl#
  839.       h#=0
  840.       GOTO raus_1
  841.     ENDIF
  842.     IF h#<=0
  843.       GOTO raus_1
  844.     ENDIF
  845.     INC l%
  846.     f#=g#
  847.     g#=SQR(s#)
  848.     IF f#>0
  849.       MUL g#,-1
  850.     ENDIF
  851.     h#=s#-f#*g#
  852.     u#(i%,i%-1)=f#-g#
  853.     f#=0
  854.     FOR j%=1 TO l%
  855.       u#(j%,i%)=u#(i%,j%)/h#
  856.       s#=0
  857.       FOR k%=1 TO j%
  858.         s#=s#+u#(j%,k%)*u#(i%,k%)
  859.       NEXT k%
  860.       j1%=j%+1
  861.       IF j1%<=l%
  862.         FOR k%=j1% TO l%
  863.           s#=s#+u#(k%,j%)*u#(i%,k%)
  864.         NEXT k%
  865.       ENDIF
  866.       he#(j%)=s#/h#
  867.       f#=f#+s#*u#(j%,i%)
  868.     NEXT j%
  869.     f#=f#/(h#+h#)
  870.     FOR j%=1 TO l%
  871.       he#(j%)=he#(j%)-f#*u#(i%,j%)
  872.     NEXT j%
  873.     FOR j%=1 TO l%
  874.       f#=u#(i%,j%)
  875.       s#=he#(j%)
  876.       FOR k%=1 TO j%
  877.         u#(j%,k%)=u#(j%,k%)-f#*he#(k%)-u#(i%,k%)*s#
  878.       NEXT k%
  879.     NEXT j%
  880.   raus_1:
  881.     ad#(i%)=h#
  882.     he#(i%-1)=g#
  883.     zaehler%=ni%
  884.     rechteck
  885.   NEXT ni%
  886.   ad#(1)=u#(1,1)
  887.   u#(1,1)=1
  888.   DEFFILL 1,2,12
  889.   y0%=144    !Grafik
  890.   y1%=y0%+16
  891.   FOR i%=2 TO n%
  892.     l%=i%-1
  893.     IF ad#(i%)>0
  894.       FOR j%=1 TO l%
  895.         s#=0
  896.         FOR k%=1 TO l%
  897.           s#=s#+u#(i%,k%)*u#(k%,j%)
  898.         NEXT k%
  899.         FOR k%=1 TO l%
  900.           u#(k%,j%)=u#(k%,j%)-s#*u#(k%,i%)
  901.         NEXT k%
  902.       NEXT j%
  903.     ENDIF
  904.     ad#(i%)=u#(i%,i%)
  905.     u#(i%,i%)=1
  906.     FOR j%=1 TO l%
  907.       u#(i%,j%)=0
  908.       u#(j%,i%)=0
  909.     NEXT j%
  910.     zaehler%=i%
  911.     rechteck
  912.   NEXT i%
  913.   '      DIAG TRIDIAGMAT
  914.   b#=0
  915.   f#=0
  916.   he#(n%)=0
  917.   DEFFILL 1,2,14
  918.   y0%=176    !Grafik
  919.   y1%=y0%+16
  920.   FOR l%=1 TO n%
  921.     h#=eps#*(ABS(ad#(l%))+ABS(he#(l%)))
  922.     IF h#>b#
  923.       b#=h#
  924.     ENDIF
  925.     FOR j%=l% TO n%
  926.       IF ABS(he#(j%))<=b#
  927.         i%=j%
  928.         j%=n%
  929.       ENDIF
  930.     NEXT j%
  931.     j%=i%
  932.     IF j%<>l%
  933.       REPEAT
  934.         g#=ad#(l%)
  935.         p#=(ad#(l%+1)-g#)*0.5/he#(l%)
  936.         r#=SQR(p#*p#+1)
  937.         IF p#>=0
  938.           p#=p#+r#
  939.         ELSE
  940.           p#=p#-r#
  941.         ENDIF
  942.         ad#(l%)=he#(l%)/p#
  943.         h#=g#-ad#(l%)
  944.         k%=l%+1
  945.         FOR i%=k% TO n%
  946.           SUB ad#(i%),h#
  947.         NEXT i%
  948.         f#=f#+h#
  949.         '     QR-TRANSF
  950.         p#=ad#(j%)
  951.         c#=1
  952.         s#=0
  953.         j1%=j%-1
  954.         FOR ni%=l% TO j1%
  955.           i%=l%+j1%-ni%
  956.           g#=c#*he#(i%)
  957.           h#=c#*p#
  958.           IF ABS(p#)<ABS(he#(i%))
  959.             c#=p#/he#(i%)
  960.             r#=SQR(c#*c#+1)
  961.             he#(i%+1)=s#*he#(i%)*r#
  962.             s#=1/r#
  963.             DIV c#,r#
  964.           ELSE
  965.             c#=he#(i%)/p#
  966.             r#=SQR(c#*c#+1)
  967.             he#(i%+1)=s#*p#*r#
  968.             s#=c#/r#
  969.             c#=1/r#
  970.           ENDIF
  971.           p#=c#*ad#(i%)-s#*g#
  972.           ad#(i%+1)=h#+s#*(c#*g#+s#*ad#(i%))
  973.           FOR k%=1 TO n%
  974.             h#=u#(k%,i%+1)
  975.             u#(k%,i%+1)=u#(k%,i%)*s#+h#*c#
  976.             u#(k%,i%)=u#(k%,i%)*c#-h#*s#
  977.           NEXT k%
  978.         NEXT ni%
  979.         he#(l%)=s#*p#
  980.         ad#(l%)=c#*p#
  981.       UNTIL ABS(he#(l%))<=b#
  982.     ENDIF
  983.     ADD ad#(l%),f#
  984.     zaehler%=l%
  985.     rechteck
  986.   NEXT l%
  987.   '      ORDNUNG DER EIGENWERTE
  988.   ni%=n%-1
  989.   DEFFILL 1,2,17
  990.   y0%=208    !Grafik
  991.   y1%=y0%+16    !Grafik
  992.   FOR i%=1 TO ni%
  993.     k%=i%
  994.     p#=ad#(i%)
  995.     j1%=i%+1
  996.     FOR j%=j1% TO n%
  997.       IF ad#(j%)<p#
  998.         k%=j%
  999.         p#=ad#(j%)
  1000.       ENDIF
  1001.     NEXT j%
  1002.     IF k%<>i%
  1003.       ad#(k%)=ad#(i%)
  1004.       ad#(i%)=p#
  1005.       FOR j%=1 TO n%
  1006.         SWAP u#(j%,i%),u#(j%,k%)
  1007.       NEXT j%
  1008.     ENDIF
  1009.     zaehler%=i%
  1010.     rechteck
  1011.   NEXT i%
  1012.   zaehler%=i%
  1013.   rechteck
  1014.   orbitale_verb
  1015. diag_ende:
  1016.   PRINT AT(5,18);"Uff, in  ";(TIMER-zeit%)/200;" s geschafft. Mach's nach!"
  1017.   '
  1018. RETURN
  1019. > PROCEDURE orbitale_verb
  1020.   '
  1021.   LOCAL i%,j%
  1022.   '
  1023.   FOR i%=1 TO n%
  1024.     IF u#(1,i%)<0
  1025.       FOR j%=1 TO n%
  1026.         MUL u#(j%,i%),-1
  1027.       NEXT j%
  1028.     ENDIF
  1029.   NEXT i%
  1030.   '      TRANSFORM. ENTART. ORBITALE (LOGIK)
  1031.   ia%=1
  1032.   ir%=1
  1033.   DO
  1034.     '
  1035.     WHILE ABS(ad#(ia%)-ad#(ia%+ir%))<0.0001
  1036.       INC ir%
  1037.       EXIT IF ia%+ir%>n%
  1038.     WEND
  1039.     IF ir%>1
  1040.       orbit_transf
  1041.     ENDIF
  1042.     EXIT IF ia%+ir%>=n%
  1043.     ADD ia%,ir%
  1044.     ir%=1
  1045.     '
  1046.   LOOP
  1047.   '
  1048. RETURN
  1049. > PROCEDURE orbit_transf
  1050.   '
  1051.   LOCAL l%,j%,k%,i%,iz%,vz#
  1052.   '
  1053.   k%=1
  1054.   i%=ia%
  1055.   iz%=ir%
  1056.   vz#=0
  1057.   REPEAT
  1058.     '
  1059.     DO
  1060.       '
  1061.       vz#=0
  1062.       FOR l%=i% TO i%+iz%-1
  1063.         p#=ABS(u#(k%,l%))
  1064.         IF p#>vz#
  1065.           vz#=p#
  1066.           lp#=l%
  1067.         ENDIF
  1068.       NEXT l%
  1069.       EXIT IF vz#>=0.0001
  1070.       INC k%
  1071.       '
  1072.     LOOP
  1073.     '
  1074.     FOR j%=1 TO n%
  1075.       SWAP u#(j%,i%),u#(j%,lp#)
  1076.     NEXT j%
  1077.     FOR l%=i%+1 TO i%+iz%-1
  1078.       b#=u#(k%,l%)
  1079.       IF ABS(b#)>=0.0001
  1080.         a#=u#(k%,i%)
  1081.         rn#=1/SQR(a#*a#+b#*b#)
  1082.         FOR j%=1 TO n%
  1083.           aj#=u#(j%,i%)
  1084.           bj#=u#(j%,l%)
  1085.           u#(j%,i%)=(a#*aj#+b#*bj#)*rn#
  1086.           u#(j%,l%)=(b#*aj#-a#*bj#)*rn#
  1087.         NEXT j%
  1088.       ENDIF
  1089.     NEXT l%
  1090.     INC k%
  1091.     INC i%
  1092.     DEC iz%
  1093.     '
  1094.   UNTIL iz%<=1
  1095.   '
  1096. RETURN
  1097. > PROCEDURE rechteck
  1098.   '
  1099.   LOCAL x_koor%
  1100.   '
  1101.   x_koor%=x0%+zaehler%*masstab%
  1102.   VSYNC
  1103.   PBOX x0%,y0%,x_koor%,y1%
  1104.   '
  1105. RETURN
  1106. > PROCEDURE bild_aufbau
  1107.   '
  1108.   LOCAL i%
  1109.   '
  1110.   DEFFILL 1,0,0
  1111.   PBOX 0,0,640,399
  1112.   PRINT AT(5,3);"Die Matrix wird diagonalisiert"
  1113.   PRINT AT(5,5);"Insgesamt liegen 4 große Schleifen vor mir, die jeweils"
  1114.   PRINT AT(5,6);n%;" mal durchlaufen werden müssen"
  1115.   RBOX 5,106,635,230
  1116.   PRINT AT(2,8);"Ni%:"
  1117.   PRINT AT(2,10);"I% :"
  1118.   PRINT AT(2,12);"L% :"
  1119.   PRINT AT(2,14);"I% :"
  1120.   FOR i%=8 TO 14 STEP 2
  1121.     BOX x0%,(i%-1)*16,x0%+n%*masstab%,i%*16
  1122.   NEXT i%
  1123.   '
  1124. RETURN
  1125. > PROCEDURE schriftgr
  1126.   '
  1127.   LOCAL x&,y&,w&,h&,buffer$,change%,exit_obj%,status%
  1128.   '
  1129.   ~FORM_CENTER(textsize_adr%,x&,y&,w&,h&)
  1130.   GET x&,y&,x&+w&,y&+h&,buffer$
  1131.   status%=OB_STATE(textsize_adr%,textnorm&)
  1132.   SELECT status%
  1133.   CASE 1
  1134.     OB_STATE(textsize_adr%,textnorm&)=1
  1135.     OB_STATE(textsize_adr%,texticon&)=0
  1136.   CASE 0
  1137.     OB_STATE(textsize_adr%,textnorm&)=0
  1138.     OB_STATE(textsize_adr%,texticon&)=1
  1139.   ENDSELECT
  1140.   ~OBJC_DRAW(textsize_adr%,0,2,x&,y&,w&,h&)
  1141.   exit_obj%=FORM_DO(textsize_adr%,0)
  1142.   status%=OB_STATE(textsize_adr%,textnorm&)
  1143.   SELECT status%
  1144.   CASE 1
  1145.     schrift%=13
  1146.     max_zeile%=11
  1147.     max_spalte%=8
  1148.   CASE 0
  1149.     schrift%=4
  1150.     max_zeile%=30
  1151.     max_spalte%=11
  1152.   ENDSELECT
  1153.   PUT x&,y&,buffer$
  1154.   '
  1155. RETURN
  1156. > PROCEDURE mol_zeichnen
  1157.   '
  1158.   LOCAL i%,x_pos%,y_pos%,k%
  1159.   '
  1160.   DEFFILL 1,0,0
  1161.   PBOX 0,0,640,399
  1162.   FOR i%=1 TO n%
  1163.     PRINT AT(5,2);"Zentrum Nr.: ";USING "##",i%
  1164.     '
  1165.     GRAPHMODE 3
  1166.     DO
  1167.       '
  1168.       x_pos%=MOUSEX
  1169.       y_pos%=MOUSEY
  1170.       EXIT IF MOUSEK
  1171.       CIRCLE x_pos%,y_pos%,radius%
  1172.       CIRCLE x_pos%,y_pos%,radius%
  1173.       '
  1174.     LOOP
  1175.     '
  1176.     GRAPHMODE 1
  1177.     EXIT IF MOUSEK=2
  1178.     CIRCLE x_pos%,y_pos%,radius%
  1179.     x_mol#(i%)=x_pos%
  1180.     y_mol#(i%)=y_pos%
  1181.     REPEAT
  1182.       k%=MOUSEK
  1183.     UNTIL k%=0
  1184.   NEXT i%
  1185.   IF i%>n%
  1186.     DEFFILL 1,0,0
  1187.     PBOX 0,0,640,399
  1188.     geruest
  1189.     DEFFILL 1,0,
  1190.     FOR i%=1 TO n%
  1191.       PCIRCLE x_mol#(i%),y_mol#(i%),radius%
  1192.     NEXT i%
  1193.     MENU m_mos#,aktiv%
  1194.     MENU m_niv#,aktiv%
  1195.   ENDIF
  1196.   '
  1197. RETURN
  1198. > PROCEDURE radius
  1199.   '
  1200.   LOCAL x&,y&,w&,h&,buffer$,change%,exit_obj%
  1201.   '
  1202.   ~FORM_CENTER(radius_adr%,x&,y&,w&,h&)
  1203.   GET x&,y&,x&+w&,y&+h&,buffer$
  1204.   CHAR{OB_SPEC(radius_adr%,radval&)}=STR$(radius%)
  1205.   ~OBJC_DRAW(radius_adr%,0,2,x&,y&,w&,h&)
  1206.   DO
  1207.     exit_obj%=FORM_DO(radius_adr%,0)
  1208.     EXIT IF exit_obj%=radok&
  1209.     SELECT exit_obj%
  1210.     CASE radinc&
  1211.       INC radius%
  1212.       IF radius%>95
  1213.         radius%=95
  1214.       ENDIF
  1215.     CASE raddec&
  1216.       DEC radius%
  1217.       IF radius%<5
  1218.         radius%=5
  1219.       ENDIF
  1220.     ENDSELECT
  1221.     CHAR{OB_SPEC(radius_adr%,radval&)}=STR$(radius%)
  1222.     VSYNC
  1223.     ~OBJC_DRAW(radius_adr%,radmoth&,1,x&,y&,w&,h&)
  1224.   LOOP
  1225.   radius%=VAL(CHAR{OB_SPEC(radius_adr%,radval&)})
  1226.   change%=OB_STATE(radius_adr%,exit_obj%) AND &HFE
  1227.   ~OBJC_CHANGE(radius_adr%,exit_obj%,0,x&,y&,w&,h&,change%,0)
  1228.   PUT x&,y&,buffer$
  1229.   '
  1230. RETURN
  1231. > PROCEDURE mos_malen
  1232.   '
  1233.   LOCAL i%,z%,rad%,k%,z$,x_t%,y_t%,d_x%,key$,key_scan%
  1234.   '
  1235.   DEFFILL 1,0,0
  1236.   PBOX 0,0,640,399
  1237.   PRINT AT(5,23);"blättern mit linker und rechter Maustaste     Ende mit return";
  1238.   i%=1
  1239.   '
  1240.   DO
  1241.     '
  1242.     PRINT AT(5,22);"Molekülorbital ";USING "##",i%
  1243.     PRINT AT(30,22);"MO-Energie ",USING fo$,ad#(i%)
  1244.     DEFTEXT ,,,4
  1245.     CLIP 0,19 TO 639,330
  1246.     geruest
  1247.     FOR z%=1 TO n%
  1248.       rad%=ABS(u#(z%,i%))*radius%
  1249.       IF SGN(u#(z%,i%))>=0
  1250.         DEFFILL 1,0,
  1251.       ELSE
  1252.         DEFFILL 1,1,
  1253.       ENDIF
  1254.       PCIRCLE x_mol#(z%),y_mol#(z%),rad%
  1255.       IF numbers!=TRUE
  1256.         z$=STR$(z%)
  1257.         d_x%=LEN(z$)*4
  1258.         x_t%=x_mol#(z%)
  1259.         y_t%=y_mol#(z%)
  1260.         GRAPHMODE 3
  1261.         IF rad%<d_x%+2     !ausserhalb
  1262.           ADD x_t%,rad%
  1263.           SUB y_t%,rad%
  1264.           GRAPHMODE 1
  1265.         ELSE               !Innerhalb zentriert
  1266.           SUB x_t%,d_x%/2
  1267.           ADD y_t%,2
  1268.         ENDIF
  1269.         TEXT x_t%,y_t%,STR$(z%)
  1270.         GRAPHMODE 1
  1271.       ENDIF
  1272.     NEXT z%
  1273.     CLIP 0,19 TO 639,399
  1274.     DEFTEXT ,,,schrift%
  1275.     REPEAT
  1276.       k%=MOUSEK
  1277.       key$=INKEY$
  1278.     UNTIL key$<>"" OR k%<>0
  1279.     EXIT IF key$=CHR$(13) OR k%=3
  1280.     SELECT key$
  1281.     CASE "n","N"
  1282.       numbers!=NOT numbers!
  1283.     CASE " "
  1284.       k%=1
  1285.     DEFAULT
  1286.       key_scan%=ASC(RIGHT$(key$))
  1287.       SELECT key_scan%
  1288.       CASE &H48              !Pfeil hoch
  1289.         FOR i&=1 TO n%
  1290.           SUB y_mol#(i&),10
  1291.         NEXT i&
  1292.       CASE &H50              !Pfeil runter
  1293.         FOR i&=1 TO n%
  1294.           ADD y_mol#(i&),10
  1295.         NEXT i&
  1296.       CASE &H4B              !Pfeil links
  1297.         FOR i&=1 TO n%
  1298.           SUB x_mol#(i&),10
  1299.         NEXT i&
  1300.       CASE &H4D              !Pfeil rechts
  1301.         FOR i&=1 TO n%
  1302.           ADD x_mol#(i&),10
  1303.         NEXT i&
  1304.       ENDSELECT
  1305.     ENDSELECT
  1306.     IF k%=1
  1307.       INC i%
  1308.       IF i%>n%
  1309.         i%=1
  1310.       ENDIF
  1311.     ELSE IF k%=2
  1312.       DEC i%
  1313.       IF i%<1
  1314.         i%=n%
  1315.       ENDIF
  1316.     ENDIF
  1317.     '
  1318.   LOOP
  1319.   '
  1320. RETURN
  1321. > PROCEDURE geruest
  1322.   '
  1323.   LOCAL i%,j%
  1324.   '
  1325.   DEFFILL 1,0
  1326.   BOUNDARY 0
  1327.   PBOX 0,0,640,330
  1328.   BOUNDARY 1
  1329.   FOR i1%=1 TO n%-1
  1330.     FOR j1%=i1%+1 TO n%
  1331.       IF om#(i1%,j1%)<>0
  1332.         LINE x_mol#(i1%),y_mol#(i1%),x_mol#(j1%),y_mol#(j1%)
  1333.       ENDIF
  1334.     NEXT j1%
  1335.   NEXT i1%
  1336.   '
  1337. RETURN
  1338. > PROCEDURE tabelle
  1339.   '
  1340.   DEFFILL 1,0,0
  1341.   PBOX 0,0,640,399
  1342.   PRINT AT(5,1);"Hückel-Parameter"
  1343.   PRINT AT(5,3);"Bezeichnungen  :  ";alpha$;" X = ";alpha$;" + H X * ß   (";alpha$;" = - 9,0 eV)"
  1344.   PRINT AT(23,4);"ß X-Y = K X-Y * ß   (ß = - 2,4 eV)"
  1345.   PRINT AT(5,6);"Näheres siehe Heilbronner-Bock Bd.1, S. 155"
  1346.   PRINT
  1347.   PRINT TAB(30);"H X";TAB(40);"K C-X"
  1348.   PRINT TAB(5);STRING$(40,"-")
  1349.   PRINT TAB(5);"C";TAB(30);" 0.0";TAB(40);"1.0"
  1350.   PRINT TAB(5);STRING$(40,"-")
  1351.   PRINT TAB(5);"B";TAB(30);"-1.0";TAB(40);"0.7"
  1352.   PRINT TAB(5);STRING$(40,"-")
  1353.   PRINT TAB(5);"N (Z core=1)";TAB(30);" 0.5";TAB(40);"1.0"
  1354.   PRINT TAB(5);"N (Z core=2)";TAB(30);" 1.5";TAB(40);"1.0"
  1355.   PRINT TAB(5);STRING$(40,"-")
  1356.   PRINT TAB(5);"O (Z core=1)";TAB(30);" 1.0";TAB(40);"1.0"
  1357.   PRINT TAB(5);"O (Z core=2)";TAB(30);" 2.0";TAB(40);"1.0"
  1358.   PRINT TAB(5);STRING$(40,"-")
  1359.   PRINT TAB(5);"F";TAB(30);" 3.0";TAB(40);"0.7"
  1360.   PRINT TAB(5);STRING$(40,"-")
  1361.   PRINT TAB(5);"Cl";TAB(30);" 2.0";TAB(40);"0.4"
  1362.   PRINT TAB(5);STRING$(40,"-");
  1363.   '
  1364. RETURN
  1365. > PROCEDURE niveau
  1366.   '
  1367.   LOCAL x0%,y0%,i%,niveau%,max_x%,min_x%,max_y%,min_y%,ausd_x%,ausd_y%
  1368.   LOCAL step_y%,faktor#,k%,i1%,j1%,z%,rad#,a$,y1%
  1369.   '
  1370.   DEFFILL 1,0,0
  1371.   PBOX 0,0,640,399
  1372.   DEFTEXT 1,8,0,13
  1373.   PRINT AT(15,1);na$
  1374.   DEFTEXT 1,0,0,13
  1375.   niveau%=1
  1376.   FOR i%=2 TO n%
  1377.     IF ABS(ad#(i%)-ad#(i%-1))>0.01
  1378.       INC niveau%
  1379.     ENDIF
  1380.   NEXT i%
  1381.   max_x%=0
  1382.   min_x%=640
  1383.   max_y%=0
  1384.   min_y%=400
  1385.   FOR i%=1 TO n%
  1386.     IF max_x%<x_mol#(i%)
  1387.       max_x%=x_mol#(i%)
  1388.     ENDIF
  1389.     IF max_y%<y_mol#(i%)
  1390.       max_y%=y_mol#(i%)
  1391.     ENDIF
  1392.     IF min_x%>x_mol#(i%)
  1393.       min_x%=x_mol#(i%)
  1394.     ENDIF
  1395.     IF min_y%>y_mol#(i%)
  1396.       min_y%=y_mol#(i%)
  1397.     ENDIF
  1398.   NEXT i%
  1399.   ausd_x%=max_x%-min_x%
  1400.   ausd_y%=max_y%-min_y%
  1401.   step_y%=350/(niveau%)
  1402.   faktor#=350/(niveau%+0.5)/(ausd_y%+radius%)
  1403.   IF faktor#>1
  1404.     faktor#=1
  1405.   ENDIF
  1406.   x0%=350
  1407.   y0%=350-step_y%/2
  1408.   FOR i%=1 TO n%
  1409.     x1#(i%)=(x_mol#(i%)-min_x%)*faktor#
  1410.     y1#(i%)=(y_mol#(i%)-min_y%)*faktor#
  1411.   NEXT i%
  1412.   DEFLINE 1,2,0,1
  1413.   LINE 100,370,100,20
  1414.   DEFLINE 1,1,0,0
  1415.   FOR k%=1 TO n%
  1416.     '
  1417.     FOR i1%=1 TO n%-1
  1418.       FOR j1%=i1%+1 TO n%
  1419.         IF om#(i1%,j1%)<>0
  1420.           LINE x1#(i1%)+x0%,y1#(i1%)+y0%,x1#(j1%)+x0%,y1#(j1%)+y0%
  1421.         ENDIF
  1422.       NEXT j1%
  1423.     NEXT i1%
  1424.     FOR z%=1 TO n%
  1425.       rad#=ABS(u#(z%,k%))*radius%*faktor#
  1426.       IF SGN(u#(z%,k%))>=0
  1427.         DEFFILL 1,0,
  1428.       ELSE
  1429.         DEFFILL 1,1,
  1430.       ENDIF
  1431.       PCIRCLE x1#(z%)+x0%,y1#(z%)+y0%,rad#
  1432.     NEXT z%
  1433.     IF EVEN(k%)=TRUE
  1434.       x0%=225
  1435.     ELSE
  1436.       x0%=475
  1437.     ENDIF
  1438.     IF k%=n%-1
  1439.       IF ABS(ad#(n%)-ad#(n%-1))>0.1
  1440.         x0%=350
  1441.       ENDIF
  1442.     ENDIF
  1443.     '    IF k%=n%-1 AND EVEN(n%)=TRUE
  1444.     '    x0%=350
  1445.     '  ELSE IF k%=n%-1 AND ODD(n%)=TRUE
  1446.     '    x0%=225
  1447.     '  ENDIF
  1448.     IF ABS(ad#(k%)-ad#(k%+1))>0.01
  1449.       a$=LEFT$(STR$(INT(ad#(k%)*100+0.5)/100),6)
  1450.       y1%=y0%+(ausd_y%)/2*faktor#
  1451.       TEXT 45,y1%+8,a$
  1452.       LINE 95,y1%,105,y1%
  1453.       SUB y0%,step_y%
  1454.     ENDIF
  1455.   NEXT k%
  1456.   '
  1457. RETURN
  1458. > PROCEDURE n_eck
  1459.   '
  1460.   LOCAL i%,j%,k%,offset%,x0%,y0%,winkel#,d_winkel#,masstab%,n_eck%,a$
  1461.   LOCAL n_kontrol%,ascii%,scan%,erg%
  1462.   '
  1463.   DEFFILL 1,0,0
  1464.   PBOX 0,0,640,399
  1465.   PRINT AT(1,22);"Befehle: |g|-Größe  |d|-drehen  |v|-verschieben  |m|-Maßstab"
  1466.   PRINT AT(10,23);"|CR|-nächstes N-Eck    |ESC|-Gerüst fertig";
  1467.   offset%=1
  1468.   WHILE a$<>CHR$(27)
  1469.     x0%=100
  1470.     y0%=200
  1471.     radius%=40
  1472.     winkel#=90
  1473.     masstab%=10
  1474.     PRINT AT(2,1);
  1475.     INPUT "Anzahl der Ecken: ";n_eck%
  1476.     male(n_eck%,winkel#,radius%,x0%,y0%)
  1477.     a$="v"
  1478.     REPEAT
  1479.       SELECT a$
  1480.       CASE "g"
  1481.         groesse(n_eck%,x0%,y0%,masstab%,winkel#,radius%,ascii%)
  1482.       CASE "d"
  1483.         drehen(n_eck%,x0%,y0%,masstab%,radius%,winkel#,ascii%)
  1484.       CASE "v"
  1485.         verschieben(n_eck%,masstab%,winkel#,radius%,x0%,y0%,ascii%)
  1486.       CASE "m"
  1487.         masstab(n_eck%,x0%,y0%,winkel#,radius%,masstab%,ascii%)
  1488.       ENDSELECT
  1489.       a$=CHR$(ascii%)
  1490.       '    UNTIL a$=CHR$(13) OR a$=CHR$(27)
  1491.     UNTIL a$<>"m" AND a$<>"v" AND a$<>"d" AND a$<>"g"
  1492.     d_winkel#=360/n_eck%
  1493.     FOR i%=offset% TO n_eck%+offset%-1
  1494.       x_wert#(i%)=COS(winkel#/180*PI)*radius%+x0%
  1495.       y_wert#(i%)=SIN(winkel#/180*PI)*radius%+y0%
  1496.       winkel#=winkel#+d_winkel#
  1497.     NEXT i%
  1498.     offset%=offset%+n_eck%
  1499.   WEND
  1500.   offset%=offset%-1
  1501.   '
  1502.   PRINT AT(1,22);SPACE$(75)
  1503.   PRINT AT(1,23);SPACE$(75);
  1504.   PRINT AT(1,23);"Datenreduktion: vorher ";offset%;
  1505.   i%=0
  1506.   WHILE i%<offset%-1
  1507.     INC i%
  1508.     j%=i%
  1509.     WHILE j%<offset%
  1510.       INC j%
  1511.       IF x_wert#(i%)<x_wert#(j%)+2 AND x_wert#(i%)>x_wert#(j%)-2
  1512.         IF y_wert#(i%)<y_wert#(j%)+2 AND y_wert#(i%)>y_wert#(j%)-2
  1513.           FOR k%=j% TO offset%-1
  1514.             x_wert#(k%)=x_wert#(k%+1)
  1515.             y_wert#(k%)=y_wert#(k%+1)
  1516.           NEXT k%
  1517.           DEC offset%
  1518.         ENDIF
  1519.       ENDIF
  1520.     WEND
  1521.   WEND
  1522.   PRINT AT(30,23);"verbliebene Daten: ";offset%;
  1523.   '
  1524.   erg%=0
  1525.   IF offset%>n%
  1526.     ALERT 2,"Die Anzahl der Atome stimmt|nicht! Es verbleiben mehr,|als im Molekül angegeben!",1,"Abbruch|weiter",erg%
  1527.   ENDIF
  1528.   IF offset%<n%
  1529.     ALERT 2,"Die Anzahl der Atome stimmt|nicht! Es verbleiben weniger,|als im Molekül angegeben!",1,"Abbruch|weiter",erg%
  1530.   ENDIF
  1531.   IF erg%=1
  1532.     GOTO pro_ende
  1533.   ENDIF
  1534.   PRINT AT(2,2);SPACE$(15)
  1535.   n_kontrol%=0
  1536.   FOR i%=1 TO n%
  1537.     PRINT AT(1,1);"Atom Nummer ";i%;" anklicken."
  1538.     REPEAT
  1539.     UNTIL MOUSEK=1
  1540.     x_mol#(i%)=MOUSEX
  1541.     y_mol#(i%)=MOUSEY
  1542.     FOR j%=1 TO offset%
  1543.       IF x_mol#(i%)>x_wert#(j%)-radius%/5 AND x_mol#(i%)<x_wert#(j%)+radius%/5
  1544.         IF y_mol#(i%)>y_wert#(j%)-radius%/5 AND y_mol#(i%)<y_wert#(j%)+radius%/5
  1545.           x_mol#(i%)=x_wert#(j%)
  1546.           y_mol#(i%)=y_wert#(j%)
  1547.           n_kontrol%=n_kontrol%+1
  1548.           PCIRCLE x_mol#(i%),y_mol#(i%),radius%/5
  1549.         ENDIF
  1550.       ENDIF
  1551.     NEXT j%
  1552.     REPEAT
  1553.     UNTIL MOUSEK=0
  1554.   NEXT i%
  1555.   DEFFILL 1,0,0
  1556.   PBOX 0,0,640,399
  1557.   IF n_kontrol%<n%
  1558.     ALERT 3,"Ich finde zuwenig Atome",1,"weiter",dummy%
  1559.   ENDIF
  1560.   IF n_kontrol%>n%
  1561.     ALERT 3,"Ich finde zuviel Atome",1,"weiter",dummy%
  1562.   ENDIF
  1563.   geruest
  1564.   FOR i%=1 TO n%
  1565.     PCIRCLE x_mol#(i%),y_mol#(i%),radius%/5
  1566.   NEXT i%
  1567.   '
  1568.   MENU m_mos#,aktiv%
  1569.   MENU m_niv#,aktiv%
  1570.   '
  1571. pro_ende:
  1572.   '
  1573. RETURN
  1574. > PROCEDURE hard_copy
  1575.   '
  1576.   LOCAL a$,g$,s%,x%,q%,inhalt|,bedarf%,flag!,bytes&,x_size&
  1577.   LOCAL start_x%,schluss_x%,start_y%,schluss_y%,i&
  1578.   LOCAL x0&,y0&,x1&,y1&,x2&,y2&,erg%,grafein$,zeilenv$
  1579.   '
  1580.   IF OUT?(0)=TRUE
  1581.     REPEAT
  1582.     UNTIL MOUSEK=0
  1583.     DEFMOUSE 3
  1584.     REPEAT
  1585.       x0&=MOUSEX
  1586.       y0&=MOUSEY
  1587.     UNTIL MOUSEK=1
  1588.     x0&=(x0& DIV 8)*8
  1589.     GRAPHMODE 3
  1590.     x2&=x0&
  1591.     y2&=y0&
  1592.     REPEAT
  1593.       x1&=MOUSEX
  1594.       y1&=MOUSEY
  1595.       x1&=(x1& DIV 8)*8-1
  1596.       IF x1&<>x2& OR y1&<>y2&
  1597.         BOX x0&,y0&,x2&,y2&
  1598.         BOX x0&,y0&,x1&,y1&
  1599.         x2&=x1&
  1600.         y2&=y1&
  1601.       ENDIF
  1602.     UNTIL MOUSEK=0
  1603.     DEFMOUSE 0
  1604.     ALERT 2,"Bereich mit Rahmen drucken",2,"ja|nein|Abbruch",erg%
  1605.     IF erg%=2
  1606.       BOX x0&,y0&,x1&,y1&
  1607.     ENDIF
  1608.     SUB y0&,3
  1609.     ADD y0&,19
  1610.     ADD y1&,19
  1611.     x_size&=(WORK_OUT(0)+1)/8
  1612.     start_x%=XBIOS(2)+y0&*x_size&+x0& DIV 8
  1613.     schluss_x%=(x1&-x0&) DIV 8
  1614.     start_y%=(y1&-y0&)*x_size&
  1615.     schluss_y%=y0&
  1616.     a$=SPACE$(y1&-y0&)
  1617.     ADD y0&,3
  1618.     SUB y0&,19
  1619.     SUB y1&,19
  1620.     interpretiere(gr_ein$,grafein$)
  1621.     interpretiere(gr_vor$,zeilenv$)
  1622.     IF erg%<>3
  1623.       REPEAT
  1624.       UNTIL INKEY$=""
  1625.       HIDEM
  1626.       OPEN "",#98,"LST:"
  1627.       PRINT #98
  1628.       FOR s%=start_x% TO start_x%+schluss_x%
  1629.         EXIT IF INKEY$=CHR$(27)
  1630.         x%=VARPTR(a$)
  1631.         flag!=FALSE
  1632.         bytes&=0
  1633.         FOR q%=s%+start_y% TO s%+schluss_y% STEP -x_size&
  1634.           inhalt|=PEEK(q%)
  1635.           POKE x%,inhalt|
  1636.           INC x%
  1637.           INC bytes&
  1638.           IF inhalt|<>0
  1639.             flag!=TRUE
  1640.             bedarf%=bytes&
  1641.           ENDIF
  1642.         NEXT q%
  1643.         IF flag!=TRUE
  1644.           g$=grafein$+CHR$(bedarf%)+CHR$(bedarf%/256)
  1645.           FOR i&=1 TO mehrfach%
  1646.             PRINT #98,g$;LEFT$(a$,bedarf%);CHR$(13);zeilenv$;CHR$(1);
  1647.           NEXT i&
  1648.           PRINT #98,zeilenv$;CHR$(24-mehrfach%);
  1649.         ELSE
  1650.           PRINT #98,zeilenv$;CHR$(24);
  1651.         ENDIF
  1652.       NEXT s%
  1653.       CLOSE #98
  1654.       SHOWM
  1655.     ENDIF
  1656.     IF erg%<>2
  1657.       BOX x0&,y0&,x1&,y1&
  1658.     ENDIF
  1659.   ELSE
  1660.     ALERT 3,"Drucker einschalten!|Sonst geht nichts.",1,"ach ja",erg%
  1661.   ENDIF
  1662.   GRAPHMODE 1
  1663.   '
  1664. RETURN
  1665. > PROCEDURE interpretiere(rein$,VAR raus$)
  1666.   '
  1667.   LOCAL pos_1%
  1668.   '
  1669.   raus$=CHR$(VAL(rein$))
  1670.   pos_1%=INSTR(rein$,",",1)+1
  1671.   REPEAT
  1672.     raus$=raus$+CHR$(VAL(MID$(rein$,pos_1%)))
  1673.     pos_1%=INSTR(rein$,",",pos_1%)+1
  1674.   UNTIL pos_1%=1
  1675.   '
  1676. RETURN
  1677. > PROCEDURE druck_param
  1678.   '
  1679.   LOCAL x&,y&,b&,h&,buffer$,change%,exit_obj%
  1680.   '
  1681.   ~FORM_CENTER(param_adr%,x&,y&,b&,h&)
  1682.   GET x&,y&,x&+b&,y&+h&,buffer$
  1683.   CHAR{{OB_SPEC(param_adr%,grein&)}}=gr_ein$
  1684.   CHAR{{OB_SPEC(param_adr%,grvor&)}}=gr_vor$
  1685.   change%=OB_STATE(param_adr%,doppelt&)
  1686.   IF mehrfach%=2
  1687.     OB_STATE(param_adr%,doppelt&)=change% OR 1
  1688.   ELSE
  1689.     OB_STATE(param_adr%,doppelt&)=change% AND &HFE
  1690.   ENDIF
  1691.   ~OBJC_DRAW(param_adr%,0,3,x&,y&,b&,h&)
  1692.   exit_obj%=FORM_DO(param_adr%,0)
  1693.   PUT x&,y&,buffer$
  1694.   change%=OB_STATE(param_adr%,exit_obj%) AND &HFE
  1695.   ~OBJC_CHANGE(param_adr%,exit_obj%,0,x&,y&,b&,h&,change%,0)
  1696.   IF exit_obj%=paramok&
  1697.     gr_ein$=CHAR{{OB_SPEC(param_adr%,grein&)}}
  1698.     gr_vor$=CHAR{{OB_SPEC(param_adr%,grvor&)}}
  1699.     IF BTST(OB_STATE(param_adr%,doppelt&),0)=TRUE
  1700.       mehrfach%=2
  1701.     ELSE
  1702.       mehrfach%=1
  1703.     ENDIF
  1704.   ENDIF
  1705.   '
  1706. RETURN
  1707. > PROCEDURE groesse(n_eck%,x0%,y0%,masstab%,winkel#,VAR radius%,ascii%)
  1708.   '
  1709.   LOCAL a$,scan%,k%
  1710.   '
  1711.   ascii%=0
  1712.   REPEAT
  1713.     a$=INKEY$
  1714.     IF a$<>"" THEN
  1715.       scan%=ASC(RIGHT$(a$))
  1716.       k%=0
  1717.       IF scan%=72
  1718.         k%=masstab%
  1719.       ENDIF
  1720.       IF scan%=80
  1721.         k%=masstab%*-1
  1722.       ENDIF
  1723.       COLOR 0
  1724.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1725.       COLOR 1
  1726.       radius%=radius%+k%
  1727.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1728.       ascii%=ASC(a$)
  1729.     ENDIF
  1730.   UNTIL ascii%<>0
  1731. RETURN
  1732. > PROCEDURE drehen(n_eck%,x0%,y0%,masstab%,radius%,VAR winkel#,ascii%)
  1733.   '
  1734.   LOCAL a$,scan%,k%
  1735.   '
  1736.   ascii%=0
  1737.   REPEAT
  1738.     a$=INKEY$
  1739.     IF a$<>"" THEN
  1740.       scan%=ASC(RIGHT$(a$))
  1741.       k%=0
  1742.       IF scan%=77
  1743.         k%=masstab%
  1744.       ENDIF
  1745.       IF scan%=75
  1746.         k%=masstab%*-1
  1747.       ENDIF
  1748.       COLOR 0
  1749.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1750.       COLOR 1
  1751.       winkel#=winkel#+k%
  1752.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1753.       ascii%=ASC(a$)
  1754.     ENDIF
  1755.   UNTIL ascii%<>0
  1756. RETURN
  1757. > PROCEDURE verschieben(n_eck%,masstab%,winkel#,radius%,VAR x0%,y0%,ascii%)
  1758.   '
  1759.   LOCAL a$,scan%,k%,x%,y%
  1760.   '
  1761.   ascii%=0
  1762.   REPEAT
  1763.     a$=INKEY$
  1764.     IF a$<>"" THEN
  1765.       scan%=ASC(RIGHT$(a$))
  1766.       x%=0
  1767.       y%=0
  1768.       IF scan%=72
  1769.         y%=masstab%*-1
  1770.       ENDIF
  1771.       IF scan%=80
  1772.         y%=masstab%
  1773.       ENDIF
  1774.       IF scan%=75
  1775.         x%=masstab%*-1
  1776.       ENDIF
  1777.       IF scan%=77
  1778.         x%=masstab%
  1779.       ENDIF
  1780.       COLOR 0
  1781.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1782.       COLOR 1
  1783.       x0%=x0%+x%
  1784.       y0%=y0%+y%
  1785.       male(n_eck%,winkel#,radius%,x0%,y0%)
  1786.       ascii%=ASC(a$)
  1787.     ENDIF
  1788.   UNTIL ascii%<>0
  1789.   '
  1790. RETURN
  1791. > PROCEDURE masstab(n_eck%,x0%,y0%,winkel#,radius%,VAR masstab%,ascii%)
  1792.   '
  1793.   PRINT AT(2,2);SPACE$(15)
  1794.   PRINT AT(2,2);
  1795.   INPUT "Maßstab : ";masstab%
  1796.   male(n_eck%,winkel#,radius%,x0%,y0%)
  1797.   ascii%=103
  1798.   '
  1799. RETURN
  1800. > PROCEDURE male(n_eck%,winkel#,radius%,x0%,y0%)
  1801.   '
  1802.   LOCAL i%,d_winkel#,x1%,y1%
  1803.   '
  1804.   d_winkel#=360/n_eck%
  1805.   x1%=COS(winkel#/180*PI)*radius%+x0%
  1806.   y1%=SIN(winkel#/180*PI)*radius%+y0%
  1807.   PLOT x1%,y1%
  1808.   FOR i%=2 TO n_eck%
  1809.     winkel#=winkel#+d_winkel#
  1810.     DRAW  TO COS(winkel#/180*PI)*radius%+x0%,SIN(winkel#/180*PI)*radius%+y0%
  1811.   NEXT i%
  1812.   DRAW  TO x1%,y1%
  1813.   '
  1814. RETURN
  1815. > PROCEDURE delta_slider(mother&,VAR sm%,sc%)
  1816.   '
  1817.   sm%=OB_H(eingabe_adr%,mother&)
  1818.   sc%=sm%*7/ke_max%
  1819.   IF sc%>sm%
  1820.     sc%=sm%
  1821.   ENDIF
  1822.   '
  1823. RETURN
  1824. > PROCEDURE y_slider(slider&,sm%,sc%,VAR von&,bis&)
  1825.   '
  1826.   LOCAL y_sc%
  1827.   '
  1828.   bis&=von&+6
  1829.   IF bis&>ke_max%
  1830.     bis&=ke_max%
  1831.     von&=bis&-6
  1832.   ENDIF
  1833.   y_sc%=(sm%-sc%)*(von&-1)/(ke_max%-7)
  1834.   OB_Y(eingabe_adr%,slider&)=y_sc%
  1835.   '
  1836. RETURN
  1837. > PROCEDURE kette(von&,bis&,read!)
  1838.   '
  1839.   LOCAL i&
  1840.   '
  1841.   IF read!=TRUE
  1842.     FOR i&=von& TO bis&
  1843.       kette$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einkett1&+i&-von&)}}
  1844.     NEXT i&
  1845.   ELSE
  1846.     FOR i&=von& TO bis&
  1847.       CHAR{{OB_SPEC(eingabe_adr%,einkett1&+i&-von&)}}=kette$(i&)
  1848.     NEXT i&
  1849.   ENDIF
  1850.   '
  1851. RETURN
  1852. > PROCEDURE beta(von&,bis&,read!)
  1853.   '
  1854.   LOCAL i&
  1855.   '
  1856.   IF read!=TRUE
  1857.     FOR i&=von& TO bis&
  1858.       beta$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einbeta1&+i&-von&)}}
  1859.     NEXT i&
  1860.   ELSE
  1861.     FOR i&=von& TO bis&
  1862.       CHAR{{OB_SPEC(eingabe_adr%,einbeta1&+i&-von&)}}=beta$(i&)
  1863.     NEXT i&
  1864.   ENDIF
  1865.   '
  1866. RETURN
  1867. > PROCEDURE alpha(von&,bis&,read!)
  1868.   '
  1869.   LOCAL i&
  1870.   '
  1871.   IF read!=TRUE
  1872.     FOR i&=von& TO bis&
  1873.       alpha$(i&)=CHAR{{OB_SPEC(eingabe_adr%,einalph1&+i&-von&)}}
  1874.     NEXT i&
  1875.   ELSE
  1876.     FOR i&=von& TO bis&
  1877.       CHAR{{OB_SPEC(eingabe_adr%,einalph1&+i&-von&)}}=alpha$(i&)
  1878.     NEXT i&
  1879.   ENDIF
  1880.   '
  1881. RETURN
  1882. > PROCEDURE shift_slider(slider&,VAR von&)
  1883.   '
  1884.   LOCAL x_abs%,y_abs%,y_abs_maus%
  1885.   '
  1886.   ~OBJC_OFFSET(eingabe_adr%,slider&,x_abs%,y_abs%)
  1887.   y_abs_maus%=MOUSEY
  1888.   IF y_abs_maus%>y_abs%
  1889.     ADD von&,7
  1890.   ELSE
  1891.     SUB von&,7
  1892.   ENDIF
  1893.   '
  1894. RETURN
  1895. > PROCEDURE manager(slider&,sm%,sc%,VAR von&,bis&)
  1896.   '
  1897.   IF von&<1
  1898.     von&=1
  1899.   ENDIF
  1900.   y_slider(slider&,sm%,sc%,von&,bis&)
  1901.   '
  1902. RETURN
  1903. DEFFN s_back(x%)=(ke_max%-7)*(x%/1000)+1
  1904.