home *** CD-ROM | disk | FTP | other *** search
/ Explore the World of Soft…ids, Adults, Educational / RocelcoInc-ExploreTheWorldOfSoftware-KidsAdultsEducational-Vol2-Shareware.iso / educate / disk133 / nmr1.bas < prev    next >
Encoding:
BASIC Source File  |  1985-04-19  |  21.7 KB  |  545 lines
  1. 1 'Program NMR1 (of NMRCALC package).
  2. 2 'This comprises the main I/O routines.
  3. 5 DEFINT I-N: DEFDBL A-H,O-Z
  4. 10 'COMMON IPFLAG,IREAD,FF$
  5. 20 GOSUB 900
  6. 30 DIM SF(128,7),BC(7),FZ(8),SH(7),PM(7,7),BN(128)
  7. 40 DIM HA(35,35)
  8. 50 SCREEN 0,0,0:COLOR 14,4,1:CLS:KEY OFF:PRINT:PRINT
  9. 60 ON ERROR GOTO 60000
  10. 70 IPFLAG = 0: IREAD = 0
  11. 100 CLS:PRINT:PRINT"Command ('ME' for menu): ";:GOSUB 500
  12. 105 IF P$ = "IP" THEN GOSUB 700
  13. 110 IF P$ = "AR" THEN GOSUB 20000
  14. 115 IF P$ = "FF" THEN LPRINT CHR$(12);
  15. 120 IF P$ = "NS" THEN GOSUB 1000
  16. 130 IF P$ = "BA" THEN GOSUB 7000
  17. 140 IF P$ = "FR" THEN GOSUB 2000
  18. 150 IF P$ = "SH" THEN GOSUB 3000
  19. 160 IF P$ = "JJ" THEN GOSUB 4000
  20. 170 IF P$ = "HA" THEN GOSUB 10000
  21. 180 IF P$ = "AE" THEN GOSUB 9000
  22. 190 IF P$ = "ME" THEN GOSUB 8000
  23. 200 IF P$ = "CS" THEN GOSUB 5000
  24. 210 IF P$ = "CJ" THEN GOSUB 6000
  25. 220 IF P$ <> "QT" THEN 250
  26. 230 CLS: PRINT: PRINT"End of run.  Returning control to system."
  27. 240 END
  28. 250 IF P$ = "XC" THEN GOSUB 11000
  29. 260 IF P$ = "XD" THEN GOSUB 12000
  30. 270 IF P$ = "XR" THEN GOSUB 13000
  31. 280 IF P$ = "XS" THEN GOSUB 14000
  32. 290 IF P$ = "XB" THEN GOSUB 7030
  33. 300 IF P$ = "CB" THEN GOSUB 15000
  34. 310 IF P$ = "OL" THEN GOSUB 16000
  35. 320 IF P$ = "PL" THEN GOSUB 17000
  36. 330 IF P$ = "HD" THEN GOSUB 18000
  37. 335 IF P$ = "FL" THEN GOSUB 19000
  38. 336 IF P$ = "EN" THEN GOSUB 950: CHAIN "NMR6"
  39. 340 GOTO 100
  40. 500 P1$ = INKEY$: IF P1$ = "" THEN 500
  41. 505 IF ASC(P1$) > 90 THEN P1$ = CHR$(ASC(P1$) - 32)
  42. 506 PRINT P1$;
  43. 510 P2$ = INKEY$: IF P2$ = "" THEN 510
  44. 515 IF ASC(P2$) > 90 THEN P2$ = CHR$(ASC(P2$) - 32)
  45. 516 PRINT P2$
  46. 520 P$ = P1$ + P2$
  47. 530 RETURN
  48. 600 P$ = INKEY$: IF P$ = "" THEN 600
  49. 605 IF ASC(P$) > 90 THEN P$ = CHR$(ASC(P$) - 32)
  50. 610 PRINT P$
  51. 615 RETURN
  52. 700 CLS:PRINT:PRINT"Position paper in FX-80 so perforations are at tear bar."
  53. 710 PRINT:INPUT"Hit <Return> to continue.  ",A$
  54. 720 LPRINT CHR$(27);"@";  'initialize printer
  55. 730 LPRINT CHR$(27);"l";CHR$(8);  'set left margin
  56. 740 LPRINT CHR$(27);"M";  'set elite mode
  57. 750 LPRINT CHR$(27);"N";CHR$(10);  'set skip-over perforation setting
  58. 760 PRINT:PRINT"Epson FX-80 now initialized.": GOTO 63999
  59. 800 PRINT:PRINT"Do you desire printed output?  ";:GOSUB 600: PRINT
  60. 810 IF P$ = "Y" THEN IPRINT = 1 ELSE IF P$ = "N" THEN IPRINT = 0                      ELSE BEEP: GOTO 800
  61. 820 RETURN
  62. 900 OPEN "scratch.nmr" FOR INPUT AS 1
  63. 902 INPUT #1, IPFLAG: INPUT #1, IREAD: LINE INPUT #1, FF$
  64. 904 CLOSE #1: RETURN
  65. 950 OPEN "scratch.nmr" FOR OUTPUT AS 1
  66. 952 PRINT #1, IPFLAG: PRINT #1, IREAD: PRINT #1, FF$
  67. 954 CLOSE #1: RETURN
  68. 1000 CLS:PRINT:PRINT:INPUT"Enter number of spins (nuclei): ",NS
  69. 1010 NF = 2^NS
  70. 1020 IF NS > 0 AND NS < 8 THEN 63999
  71. 1030 PRINT "Illegal entry.  Try again.": GOTO 1000
  72. 2000 CLS:PRINT:PRINT"Entry of spectrometer frequency must be in MHz.":PRINT
  73. 2010 PRINT:INPUT"Enter instrument frequency: ",FR
  74. 2020 GOTO 63999
  75. 3000 IF NS = 0 THEN GOSUB 1000
  76. 3010 CLS:PRINT:PRINT"Enter";NS;"chemical shifts (ALWAYS in ppm).":PRINT
  77. 3020 FOR I = 1 TO NS: PRINT"Enter DEL(";:PRINT USING "#";I;
  78. 3030 INPUT ") = ", SH(I)
  79. 3040 NEXT
  80. 3050 PRINT:PRINT"Entry complete.": GOTO 63999
  81. 4000 IF NS = 0 THEN GOSUB 1000
  82. 4010 CLS:PRINT:PRINT"Entry of";NS*(NS-1)/2;"coupling constants for";NS;"spins."
  83. 4020 PRINT:PRINT"Enter below as indicated:":PRINT
  84. 4030 FOR I = 1 TO NS - 1:PRINT
  85. 4040 FOR J = I + 1 TO NS
  86. 4050 PRINT "Enter J(";:PRINT USING "#";I;:PRINT",";:PRINT USING "#";J;
  87. 4060 INPUT ") = ", PM(I,J): PM(J,I) = PM(I,J)
  88. 4070 NEXT
  89. 4080 NEXT
  90. 4090 PRINT:PRINT"Entry of coupling constants completed.": GOTO 63999
  91. 5000 CLS:PRINT:PRINT"Shift corrections (in ppm).":PRINT
  92. 5010 PRINT"Enter shift index and then the new shift value.  Exit with a <Return>.":PRINT
  93. 5020 PRINT:INPUT"Enter number of nucleus: ",I
  94. 5030 IF I = 0 THEN PRINT: PRINT"Shift corrections completed.": GOTO 63999
  95. 5040 IF I < 0 OR I > NS THEN PRINT "Illegal entry--try again!": GOTO 5020
  96. 5050 PRINT "Current shift value: ";SH(I)
  97. 5060  INPUT "Enter correction (hit <Return> to keep old value): ",SH$
  98. 5070 IF SH$ = "" THEN 5020 ELSE SH(I) = VAL(SH$)
  99. 5080 GOTO 5020
  100. 6000 CLS:PRINT:PRINT"Coupling constant corrections.":PRINT
  101. 6010 PRINT"Correct by entering the two indices and then the new value, as requested.  Exit":PRINT" by hitting <Return> or entering zero for either index.":PRINT
  102. 6020 PRINT:INPUT"Enter index #1: ",I
  103. 6030 IF I = 0 THEN 6300
  104. 6040 IF I < 0 OR I > NS THEN PRINT"Illegal entry--try again":GOTO 6020
  105. 6050 INPUT"Enter index #2: ",J
  106. 6060 IF J = 0 THEN 6300
  107. 6070 IF J < 0 OR J > NS OR J = I THEN PRINT "Illegal entry--try again":              GOTO 6050
  108. 6080 PRINT"Current value: "; PM(I,J)
  109. 6090 INPUT"Enter correction (Hit <Return> to keep old value): ", SH$
  110. 6100 IF SH$ = "" THEN 6020
  111. 6110 PM(I,J) = VAL(SH$): PM(J,I) = PM(I,J): GOTO 6020
  112. 6300 PRINT:PRINT"Entry of corrections completed.": GOTO 63999
  113. 7000 IF NS = 0 THEN GOSUB 1000
  114. 7001 CLS:PRINT:PRINT"Ready to set up basis functions.": PRINT:                       PRINT "Auto-generate? ";:GOSUB 600
  115. 7002 IF P$ <> "Y" THEN 7200
  116. 7005 CLS:PRINT:PRINT"Now setting up basis functions.  Be patient!": GOSUB 50000
  117. 7010 GOSUB 63999
  118. 7020 CLS:PRINT:PRINT"Display basis functions? ";:GOSUB 600:                           IF P$ <> "Y" THEN RETURN
  119. 7025 GOSUB 800
  120. 7026 IF IPRINT=1 THEN LPRINT:LPRINT:LPRINT"The spin basis functions:"
  121. 7030 NM = 0
  122. 7040 FOR M = 1 TO NS + 1
  123. 7050 CLS:PRINT:PRINT"Z-expectation value = ";FZ(M): PRINT
  124. 7055 IF IPRINT=1 THEN LPRINT:LPRINT"Z-expectation value = ";FZ(M):LPRINT
  125. 7060 NC = NM + 1: NM = NC + BC(M - 1) - 1
  126. 7070 PRINT " #"; TAB(10);"Function": PRINT "--"; TAB(10);"--------"
  127. 7072 IF IPRINT =1 THEN LPRINT "      #"; TAB(15);"Function":LPRINT "     --";         TAB(15);"--------"
  128. 7075 LOOPER = 0
  129. 7080 FOR I = NC TO NM
  130. 7082 LOOPER = LOOPER + 1: IF LOOPER > 15 THEN GOSUB 63998
  131. 7085 PRINT USING "###";I;:PRINT TAB(10);
  132. 7086 IF IPRINT=1 THEN LPRINT USING "    ###";I;:LPRINT TAB(15);
  133. 7090 FOR J = 1 TO NS
  134. 7100 IF SF(I,J) > 0 THEN PRINT "+";
  135. 7105 IF SF(I,J) > 0 AND IPRINT=1 THEN LPRINT "+";
  136. 7110 IF SF(I,J) < 0 THEN PRINT "-";
  137. 7115 IF SF(I,J) < 0 AND IPRINT=1 THEN LPRINT "-";
  138. 7120 NEXT
  139. 7130 PRINT
  140. 7135 IF IPRINT=1 THEN LPRINT
  141. 7140 NEXT
  142. 7150 GOSUB 63999
  143. 7160 NEXT
  144. 7170 PRINT:PRINT"Basis functions displayed.": GOTO 63999
  145. 7200 CLS:PRINT:PRINT"Manual generation of basis functions.": PRINT
  146. 7210 GOSUB 55000
  147. 7220 PRINT:PRINT"Ready.": PRINT: PRINT"It is recommended that you have these at hand on a pre-prepared list so that":PRINT"you won't make any monumental errors!":PRINT
  148. 7230 PRINT "Functions will be called for one at a time.  You will be given an opportunity":PRINT" to correct errors after each function.  If, for some reason, you find errors":PRINT"later, correct with the 'CB' command.":PRINT
  149. 7250 PRINT:PRINT"Also note that you will be generating these starting with highest Fz and":PRINT"going to the lowest in descending order.":PRINT: GOSUB 63999
  150. 7270 NM = 0
  151. 7280 PRINT:PRINT"Note that the following two functions are never entered, since they are the":PRINT"same for all possible spin systems.":PRINT:PRINT
  152. 7290 PRINT "#1:";TAB(8);"Fz = ";FZ(1); TAB(20);"Function:  ";
  153. 7300 FOR I = 1 TO NS: PRINT "+";: SF(1,I) = .5: NEXT
  154. 7310 PRINT: NF = 2^NS
  155. 7320 FOR I = 1 TO NS: PRINT "-";: SF(NF,I) = -.5: NEXT
  156. 7325 GOSUB 63999
  157. 7330 PRINT:PRINT"Now ready for manual entry:":PRINT
  158. 7340 NM = 1
  159. 7350 FOR M = 1 TO NS - 1
  160. 7360 NC = NM + 1: NM = NC + BC(M) - 1
  161. 7370 FOR I = NC TO NM
  162. 7380 CLS: PRINT: PRINT"Function number";I
  163. 7390 PRINT: PRINT "Fz = ";FZ(M + 1): PRINT
  164. 7400 FOR J = 1 TO NS
  165. 7410 PRINT "Spin #";:PRINT USING "#";J;:PRINT":  ";
  166. 7411 P$ = INKEY$: IF P$ = "" THEN 7411
  167. 7412 IF P$ = "_" THEN P$ = "-"
  168. 7413 IF P$ = "=" THEN P$ = "+"
  169. 7414 IF P$ <> "+" AND P$ <> "-" THEN BEEP: GOTO 7410
  170. 7415 PRINT P$
  171. 7420 IF P$ = "+" THEN SF(I,J) = .5 ELSE SF(I,J) = -.5
  172. 7430 NEXT
  173. 7440 FC = 0
  174. 7450 FOR J = 1 TO NS: FC = FC + SF(I,J): NEXT
  175. 7463 IF FC = FZ(M + 1) THEN 7470
  176. 7464 BEEP: PRINT"Illegal function--re-enter."
  177. 7465 PRINT:PRINT: GOTO 7400
  178. 7470 PRINT:PRINT"Change (re-enter) this function? ";:GOSUB 600
  179. 7475 IF P$ = "Y" THEN 7400 ELSE GOSUB 63999
  180. 7480 NEXT
  181. 7490 PRINT: PRINT "End of entries for Fz = ";FZ(M + 1)
  182. 7500 NEXT
  183. 7510 PRINT:PRINT "End of entries for all functions.": GOTO 63999
  184. 7999 CLS: PRINT: PRINT"Enter '+' for alpha spins and '-' for beta spins.":PRINT:     GOTO 63999
  185. 8000 CLS: PRINT: PRINT "Available commands:":PRINT
  186. 8010 PRINT "AE--Auto-entry of parameters.  Keeps track of things for you."
  187. 8015 PRINT "AR--Auto-reading of data and calculation files (otherwise done manually)."
  188. 8020 PRINT "BA--Set up and store spin basis functions."
  189. 8030 PRINT "CB--Correct or alter a spin basis function."
  190. 8040 PRINT "CJ--Correct or alter a coupling constant."
  191. 8050 PRINT "CS--Correct a chemical shift entry."
  192. 8052 PRINT "EN--Exit to energy level plotting routine."
  193. 8055 PRINT "FL--Alter pause flag (useful for printing under Ctrl/PrtSc option."
  194. 8056 PRINT "FF--Send form-feed to printer."
  195. 8060 PRINT "FR--Enter main spectrometer frequency (in MHz)."
  196. 8070 PRINT "HA--Generate and store Hamiltonian."
  197. 8080 PRINT "HD--Display Hamiltonian."
  198. 8085 PRINT "IP--Initialize printer (program configured for Epson FX80)."
  199. 8090 PRINT "JJ--Enter and store coupling constants (Hz)."
  200. 8095 GOSUB 8300: CLS: PRINT
  201. 8100 PRINT "ME--Display this menu."
  202. 8110 PRINT "NS--Enter number of spins (nuclei)."
  203. 8120 PRINT "OL--Use old calculations directly from disk."
  204. 8130 PRINT "PL--Exit to plotting routines."
  205. 8140 PRINT "QT--Exit and quit program."
  206. 8150 PRINT "SH--Enter and store shifts (ppm)."
  207. 8160 PRINT "XB--Display basis functions."
  208. 8170 PRINT "XC--Exit to calculation routines."
  209. 8180 PRINT "XD--Display current parameters."
  210. 8190 PRINT "XR--Read old set of parameters from disk."
  211. 8200 PRINT "XS--Save current parameters on disk"
  212. 8300 PRINT:INPUT"Hit <Return> to continue.",A$: RETURN
  213. 9000 CLS:PRINT:PRINT"Auto-entry of parameters; called in a relatively easy to handle order.":PRINT: GOSUB 63999
  214. 9005 GOSUB 20000
  215. 9010 GOSUB 1000
  216. 9020 GOSUB 2000
  217. 9030 GOSUB 3000
  218. 9040 GOSUB 4000
  219. 9050 GOSUB 7000
  220. 9060 GOSUB 14000
  221. 9070 GOSUB 10000
  222. 9080 GOTO 11000
  223. 9085 PRINT"     To calculate the spectrum:  'XC'"
  224. 10000 CLS:PRINT:PRINT"Now ready to calculate and store the NMR spin Hamiltonian.":PRINT:PRINT"This will be stored in several sectors to insure compatibility with the":PRINT" following routines and to save space."
  225. 10010 PRINT:PRINT"Have the parameters and basis functions been stored or recalled? ";:GOSUB 600
  226. 10020 IF P$ <> "Y" THEN GOSUB 14000
  227. 10025 NM = 0
  228. 10026 CLS: PRINT:PRINT"Now generating Hamiltonian and writing elements of each subblock on to disk.":PRINT
  229. 10030 FOR N = 1 TO NS + 1
  230. 10035 PRINT "Sub-block for Fz = ";FZ(N)
  231. 10040 DF$ = FF$ + "." + RIGHT$(STR$(N),LEN(STR$(N)) - 1)
  232. 10090 OPEN DF$ FOR OUTPUT AS 1
  233. 10100 BC = BC(N-1): NC = NM + 1: NM = NM + BC
  234. 10110 PRINT #1, BC
  235. 10120 FOR I = NC TO NM
  236. 10130 H = 0
  237. 10140 FOR J = 1 TO NS
  238. 10150 H = H + PM(J,J)*SF(I,J)
  239. 10160 NEXT
  240. 10170 FOR J = 1 TO NS - 1
  241. 10180 FOR K = J + 1 TO NS
  242. 10190 H = H + PM(J,K)*SF(I,J)*SF(I,K)
  243. 10200 NEXT
  244. 10210 NEXT
  245. 10220 PRINT #1, H
  246. 10230 NEXT
  247. 10240 IF NC = NM THEN 10500
  248. 10250 FOR I = NC TO NM - 1
  249. 10260 FOR J = I + 1 TO NM
  250. 10270 IL = 0: IR = 0: K = 1
  251. 10280 IF SF(I,K) <> SF(J,K) THEN 10300
  252. 10290 K = K + 1: IF K < NS THEN 10280
  253. 10300 IL = K: K = K + 1: IF K <= NS THEN 10320
  254. 10310 H = 0: GOTO 10400
  255. 10320 IF SF(I,K) <> SF(J,K) THEN 10340
  256. 10330 K = K + 1: IF K <= NS THEN 10320
  257. 10335 H = 0: GOTO 10400
  258. 10340 IR = K: IF K = NS THEN 10380
  259. 10350 K = K + 1
  260. 10360 IF SF(I,K) <> SF(J,K) THEN 10335
  261. 10370 K = K + 1: IF K <= NS THEN 10360
  262. 10380 H = PM(IL,IR)/2
  263. 10400 PRINT #1, H
  264. 10410 NEXT
  265. 10420 NEXT
  266. 10500 CLOSE #1
  267. 10600 NEXT
  268. 10605 PRINT:PRINT"Hamiltonian stored.  Now storing other useful information.":         PRINT
  269. 10610 DF$ = FF$ + ".inf"
  270. 10620 OPEN DF$ FOR OUTPUT AS 1
  271. 10630 PRINT #1, NS
  272. 10640 PRINT #1, NF
  273. 10650 FOR I = 0 TO NS: PRINT #1, BC(I): NEXT
  274. 10660 FOR I = 1 TO NS + 1: PRINT #1, FZ(I): NEXT
  275. 10670 CLOSE #1
  276. 10700 PRINT "This routine completed.": GOTO 63999
  277. 11000 CLS: PRINT: PRINT"Ready for calculation of frequencies and intensities? ";: GOSUB 600: IF P$ <> "Y" THEN RETURN
  278. 11010 PRINT:PRINT"Are you absolutely sure? ";:GOSUB 600:                               IF P$ <> "Y" THEN RETURN
  279. 11020 GOSUB 950: CHAIN "NMR2"
  280. 12000 IF FR = 0 THEN GOSUB 2000
  281. 12010 IF NS = 0 THEN GOSUB 1000
  282. 12020 CLS:PRINT:PRINT"Display of current parameter values:":PRINT
  283. 12025 GOSUB 800
  284. 12030 PRINT "Instrument frequency (MHz) = ";FR
  285. 12035 IF IPRINT=1 THEN LPRINT "Instrument frequency (MHz) = ";FR
  286. 12040 PRINT:PRINT NS;"nuclear spins"
  287. 12045 IF IPRINT=1 THEN LPRINT:LPRINT NS;"nuclear spins"
  288. 12050 PRINT:PRINT"Chemical shifts:":PRINT:PRINT" #";TAB(6);"  ppm  "; TAB(20);"  Hz  ":PRINT"--"; TAB(6);"-------";TAB(20);"------"
  289. 12055 IF IPRINT=1 THEN LPRINT:LPRINT:LPRINT"The chemical shifts:":LPRINT:LPRINT" #";TAB(6);"  ppm  "; TAB(20);"  Hz  ":LPRINT"--"; TAB(6);"-------";TAB(20);"------"
  290. 12060 FOR I = 1 TO NS
  291. 12070 PRINT I; TAB(6);SH(I);: PM(I,I) = SH(I)*FR: PRINT TAB(20); PM(I,I)
  292. 12075 IF IPRINT=1 THEN LPRINT I; TAB(6); SH(I); TAB(20); PM(I,I)
  293. 12080 NEXT
  294. 12090 GOSUB 63999
  295. 12100 CLS:PRINT:PRINT"The coupling constants:": PRINT
  296. 12105 IF IPRINT=1 THEN LPRINT:LPRINT:LPRINT"The coupling constants:":LPRINT
  297. 12106 PRINT " # ";TAB(6);
  298. 12107 IF IPRINT=1 THEN LPRINT " # ";TAB(6);
  299. 12110 FOR I = 1 TO NS: PRINT USING "     #    ";I;
  300. 12111 IF IPRINT=1 THEN LPRINT USING "     #    ";I;
  301. 12112 NEXT
  302. 12113 PRINT: PRINT TAB(6);
  303. 12114 IF IPRINT = 1 THEN LPRINT: LPRINT TAB(6);
  304. 12115 FOR I = 1 TO NS: PRINT" ---------";
  305. 12116 IF IPRINT=1 THEN LPRINT" ---------";
  306. 12117 NEXT
  307. 12118 PRINT
  308. 12119 IF IPRINT=1 THEN LPRINT
  309. 12120 FOR I = 1 TO NS
  310. 12125 PRINT USING " #";I;:PRINT TAB(6);
  311. 12126 IF IPRINT=1 THEN LPRINT USING " #";I;:LPRINT TAB(6);
  312. 12130 FOR J = 1 TO NS
  313. 12135 IF I = J THEN PRINT "    ------"; ELSE PRINT USING "#######.##";PM(I,J);
  314. 12136 IF I = J AND IPRINT=1 THEN LPRINT "    ------";
  315. 12137 IF I <> J AND IPRINT=1 THEN LPRINT USING "#######.##"; PM(I,J);
  316. 12140 NEXT
  317. 12145 PRINT
  318. 12146 IF IPRINT=1 THEN LPRINT
  319. 12150 NEXT
  320. 12160 GOSUB 63999
  321. 12180 PRINT: PRINT"Display of parameters now complete.": PRINT
  322. 12190 GOTO 7020
  323. 13000 CLS:PRINT:PRINT "Ready to ready in previously stored parameters and basis functions.": PRINT
  324. 13010 INPUT"Enter data set name: ", FF$
  325. 13020 DF$ = FF$ + ".0"
  326. 13030 OPEN DF$ FOR INPUT AS 1
  327. 13060 INPUT #1, NS
  328. 13070 NF = 2^NS
  329. 13080 INPUT #1, FR
  330. 13090 FOR I = 1 TO NS
  331. 13100 INPUT #1, SH(I)
  332. 13110 INPUT #1, PM(I,I)
  333. 13120 NEXT
  334. 13130 FOR I = 1 TO NS - 1
  335. 13140 FOR J = I+1 TO NS
  336. 13150 INPUT #1, PM(I,J)
  337. 13160 PM(J,I) = PM(I,J): NEXT
  338. 13170 NEXT
  339. 13180 FOR I = 1 TO NF
  340. 13190 FOR J = 1 TO NS
  341. 13200 INPUT #1, SF(I,J)
  342. 13210 NEXT
  343. 13220 NEXT
  344. 13221 FOR I = 0 TO NS
  345. 13222 INPUT #1, BC(I)
  346. 13223 NEXT
  347. 13230 CLOSE #1
  348. 13250 PRINT:PRINT"Old data set now retrieved.":PRINT:PRINT"Data set name:  ";          FF$:PRINT"Data file name:  ";DF$
  349. 13260 FZ(1) = NS/2
  350. 13270 FOR I = 1 TO NS: FZ(I+1) = FZ(I) - 1: NEXT
  351. 13280 GOTO 63999
  352. 14000 IF NS = 0 THEN GOSUB 1000
  353. 14010 IF FR = 0 THEN GOSUB 2000
  354. 14020 CLS:PRINT:PRINT"Ready to save parameters and basis functions on disk.":
  355. 14030 PRINT:INPUT"Enter data set name:  ",FF$
  356. 14040 DF$ = FF$ + ".0"
  357. 14045 PRINT"Data saved in file:  ";DF$
  358. 14050 OPEN DF$ FOR OUTPUT AS 1
  359. 14110 PRINT #1, NS
  360. 14120 PRINT #1, FR
  361. 14130 FOR I = 1 TO NS
  362. 14140 PRINT #1, SH(I)
  363. 14150 PM(I,I) = FR*SH(I)
  364. 14160 PRINT #1, PM(I,I)
  365. 14170 NEXT
  366. 14180 FOR I = 1 TO NS - 1
  367. 14190 FOR J = I + 1 TO NS
  368. 14200 PRINT #1, PM(I,J)
  369. 14210 NEXT
  370. 14220 NEXT
  371. 14221 FOR I = 1 TO NF
  372. 14222 FOR J = 1 TO NS
  373. 14223 PRINT #1, SF(I,J)
  374. 14224 NEXT
  375. 14225 NEXT
  376. 14226 FOR I = 0 TO NS
  377. 14227 PRINT #1, BC(I)
  378. 14228 NEXT
  379. 14230 CLOSE #1
  380. 14240 PRINT: PRINT"Spectral parameters and basis functions saved.": PRINT
  381. 14250 PRINT"Data set name:  ";FF$
  382. 14260 PRINT"Data file name: ";DF$
  383. 14270 GOTO 63999
  384. 15000 CLS:PRINT:PRINT"Basis set correction or alteration:":PRINT
  385. 15010 PRINT "(To exit, hit <Return> for the function number.)":PRINT
  386. 15020 PRINT: INPUT"Enter function number: ",I
  387. 15030 IF I > 0 THEN 15050
  388. 15040 PRINT:PRINT"Function alterations completed.":GOTO 63999
  389. 15050 IF I <= NF THEN 15070
  390. 15060 PRINT "Illegal index.  Try again!":PRINT: GOTO 15020
  391. 15070 PRINT"Current function: ";
  392. 15080 FOR J = 1 TO NS
  393. 15090 SF = SF(I,J)
  394. 15100 IF SF < 0 THEN PRINT "-";
  395. 15110 IF SF > 0 THEN PRINT "+";
  396. 15120 NEXT
  397. 15130 PRINT:PRINT"Altered function:  ";
  398. 15140 FOR J = 1 TO NS
  399. 15150 P$ = INKEY$: IF P$ = "" THEN 15150
  400. 15160 IF P$ = "=" THEN P$ = "+"
  401. 15165 IF P$ = "_" THEN P$ = "-"
  402. 15170 IF P$ <> "+" AND P$ <> "-" THEN BEEP: GOTO 15150
  403. 15180 PRINT P$
  404. 15190 IF P$ = "+" THEN SF(I,J) = .5 ELSE SF(I,J) = -.5
  405. 15200 NEXT
  406. 15210 PRINT:PRINT: GOTO 15020
  407. 16000 CLS:PRINT:PRINT"Ready to access old results.  Note that this bypasses all calculations!": PRINT
  408. 16010 PRINT:INPUT"Enter data set name:  ",FF$: PRINT: GOSUB 63999
  409. 16020 CLS:PRINT:PRINT"Now exiting to display routine."
  410. 16030 CHAIN "NMR4"
  411. 17000 CLS:PRINT:PRINT"Ready to exit to plotting routines.":PRINT
  412. 17010 PRINT"Have the necessary calculations been done? ";:GOSUB 600
  413. 17020 IF P$ <> "Y" THEN RETURN
  414. 17030 GOSUB 950: CHAIN "NMR5"
  415. 18000 CLS:PRINT:PRINT"Routine to display Hamiltonian.  Note that this is destroyed after 'XC' has":PRINT" been executed.":PRINT
  416. 18010 PRINT"Has the Hamiltonian been generated? ";:GOSUB 600: IF P$ <> "Y"             THEN RETURN
  417. 18015 GOSUB 800
  418. 18016 IF IPRINT=1 THEN LPRINT:LPRINT"The Hamiltonian sub-matrices:":LPRINT
  419. 18020 CLS:PRINT:PRINT"This will be read out by sub-blocks with the diagonal elements followed by the":PRINT"off-diagonal elements."
  420. 18030 BQ = NS + 1: PRINT: PRINT"You have";BQ;"sub-blocks numbered from 1 to";BQ:       PRINT
  421. 18040 GOSUB 63999
  422. 18050 CLS:PRINT:INPUT"Enter sub-block # (exit with <Return>): ",M
  423. 18060 IF M < 0 OR M > BQ THEN BEEP: GOTO 18050
  424. 18070 IF M > 0 THEN 18090
  425. 18080 PRINT: PRINT "Routine completed.": PRINT: GOTO 63999
  426. 18090 DF$ = FF$ + "." + RIGHT$(STR$(M),LEN(STR$(M)) - 1):                              OPEN DF$ FOR INPUT AS 1
  427. 18100 INPUT #1, N
  428. 18110 FOR I = 1 TO N: INPUT #1, HA(I,I): NEXT
  429. 18115 IF N = 1 THEN 18130
  430. 18120 FOR I = 1 TO N - 1: FOR J = I + 1 TO N: INPUT #1, HA(I,J):                       HA(J,I) = HA(I,J): NEXT: NEXT
  431. 18130 CLOSE #1
  432. 18132 LL = 1: IF M = 1 THEN 18140
  433. 18134 FOR I = 1 TO M - 1: LL = LL + BC(I - 1): NEXT
  434. 18140 FOR KK = 1 TO N STEP 7
  435. 18142 CLS:PRINT:PRINT"Sub-block number";M: PRINT:PRINT"Func";TAB(10);
  436. 18144 IF IPRINT=1 THEN LPRINT:LPRINT:LPRINT"Sub-block number";M;
  437. 18146 IF IPRINT=1 AND KK>1 THEN LPRINT"(continued)" ELSE IF IPRINT=1 THEN LPRINT
  438. 18148 IF IPRINT=1 THEN LPRINT:LPRINT"Func";TAB(10);
  439. 18150 IX = KK + 6: IF IX > N THEN IX=N
  440. 18152 FOR I = KK TO IX: NN = LL + I - 1
  441. 18154 PRINT USING "  ###     ";NN;
  442. 18156 IF IPRINT=1 THEN LPRINT USING "  ###     ";NN;
  443. 18158 NEXT
  444. 18160 PRINT:PRINT"----";TAB(10);
  445. 18162 IF IPRINT=1 THEN LPRINT:LPRINT"----";TAB(10);
  446. 18164 FOR I = KK TO IX: PRINT "--------  ";
  447. 18166 IF IPRINT=1 THEN LPRINT "--------  ";
  448. 18168 NEXT
  449. 18170 PRINT: IF IPRINT=1 THEN LPRINT
  450. 18172 FOR I = 1 TO N: II = LL + I - 1
  451. 18174 PRINT USING " ###";II;: IF IPRINT=1 THEN LPRINT USING  " ###";II;
  452. 18176 PRINT TAB(8);: IF IPRINT=1 THEN LPRINT TAB(8);
  453. 18180 FOR J = KK TO IX
  454. 18182 A = HA(I,J)
  455. 18184 PRINT USING "######.###";A;:IF IPRINT=1 THEN LPRINT USING "######.###";A;
  456. 18186 NEXT
  457. 18188 PRINT: IF IPRINT=1 THEN LPRINT
  458. 18190 NEXT
  459. 18192 GOSUB 63999
  460. 18194 NEXT
  461. 18196 GOTO 18050
  462. 19000 CLS: PRINT:PRINT"Routine to alter 'PAUSE FLAG.'  When flag ON, pause is suppressed.  When flag":PRINT" is OFF, the pause is active.  This latter state is the default.": PRINT
  463. 19010 PRINT"Flag is currently ";: IF IPFLAG = 0 THEN PRINT "OFF."                      ELSE PRINT "ON."
  464. 19020 PRINT"Do you wish to change the state of the flag? ";: GOSUB 600
  465. 19030 IF P$ = "N" THEN 63999 ELSE IF P$ <> "Y" THEN 19020
  466. 19040 IF IPFLAG = 0 THEN IPFLAG = 1 ELSE IPFLAG = 0
  467. 19050 GOTO 63999
  468. 20000 CLS: PRINT: PRINT"Do you wish to have data and calculation files loaded automatically? ";: GOSUB 600: PRINT
  469. 20010 IF P$ = "Y" THEN IREAD = 1: PRINT"Automatic file reading performed.":            GOTO 63999
  470. 20020 IF P$ = "N" THEN IREAD = 0: PRINT"Manual file reading will be needed.":          GOTO 63999
  471. 20030 BEEP: GOTO 20000
  472. 50000 FOR I = 1 TO NF
  473. 50010 BN(I) = NF - I
  474. 50020 FOR J = 1 TO NS
  475. 50030 SF(I,J) = 0
  476. 50040 NEXT
  477. 50050 NEXT
  478. 50060 FOR I = 2 TO NF
  479. 50070 SF = I - 1
  480. 50080 FOR J = NS TO 1 STEP -1
  481. 50090 NC = INT (SF/2)
  482. 50100 SF = SF/2
  483. 50110 SF(I,J) = 2*(SF - NC)
  484. 50120 SF = NC
  485. 50130 NEXT
  486. 50140 NEXT
  487. 50150 FOR I = 1 TO NF
  488. 50160 FOR J = 1 TO NS
  489. 50170 IF SF(I,J) > 0 THEN SF(I,J) = -.5
  490. 50180 IF SF(I,J) = 0 THEN SF(I,J) = .5
  491. 50190 NEXT
  492. 50200 NEXT
  493. 50210 GOSUB 55000
  494. 50290 NM = 1: FZ = NS/2
  495. 50300 FOR M = 1 TO NS - 1
  496. 50310 NC = NM + 1: NM = NC + BC(M) - 1: FZ = FZ - 1
  497. 50320 FOR L = NC TO NM
  498. 50330 I = L
  499. 50340 FC = 0
  500. 50350 FOR J = 1 TO NS: FC = FC + SF(I,J): NEXT
  501. 50360 IF FC = FZ THEN 50390
  502. 50370 I = I + 1: IF I > NF THEN 50420
  503. 50380 GOTO 50340
  504. 50390 FOR J = 1 TO NS
  505. 50400 SWAP SF(L,J),SF(I,J)
  506. 50410 NEXT
  507. 50415 SWAP BN(L),BN(I)
  508. 50420 NEXT
  509. 50430 NEXT
  510. 50440 IF NS < 3 THEN RETURN
  511. 50450 NM = BC(1) + 1
  512. 50460 FOR M = 3 TO NS
  513. 50470 NC = NM + 1: NM = NM + BC(M - 1)
  514. 50480 FOR I = NC TO NM - 1
  515. 50490 BG = BN(I)
  516. 50500 FOR J = I + 1 TO NM
  517. 50510 IF BG > BN(J) THEN 50600
  518. 50520 BG = BN(J): BN(J) = BN(I): BN(I) = BG
  519. 50530 FOR K = 1 TO NS
  520. 50540 SWAP SF(I,K),SF(J,K)
  521. 50550 NEXT
  522. 50600 NEXT
  523. 50610 NEXT
  524. 50620 NEXT
  525. 50630 RETURN
  526. 55000 FOR I = 1 TO NS
  527. 55010 FF = 1: FM = 1: FD = 1
  528. 55020 FOR J = 1 TO NS: FF = J*FF: NEXT
  529. 55030 FOR J = 1 TO I: FM = J*FM: NEXT
  530. 55040 NM = NS - I: IF NM = 0 THEN 55060
  531. 55050 FOR J = 1 TO NM: FD = J*FD: NEXT
  532. 55060 BC(I) = FF/(FM*FD)
  533. 55070 NEXT
  534. 55080 BC(0) = 1
  535. 55090 FZ(1) = NS/2
  536. 55100 FOR I = 1 TO NS
  537. 55110 FZ(I + 1) = FZ(I) - 1
  538. 55120 NEXT
  539. 55140 RETURN
  540. 60000 PRINT: BEEP: PRINT"Error encountered!"
  541. 60010 GOSUB 63999
  542. 60020 RESUME 100
  543. 63998 LOOPER = 0
  544. 63999 IF IPFLAG = 1 THEN RETURN ELSE PRINT:INPUT"Hit <Return> to continue.",A$:       RETURN
  545.