home *** CD-ROM | disk | FTP | other *** search
/ Explore the World of Soft…ids, Adults, Educational / RocelcoInc-ExploreTheWorldOfSoftware-KidsAdultsEducational-Vol2-Shareware.iso / educate / disk133 / nmr3.bas < prev    next >
Encoding:
BASIC Source File  |  1985-04-19  |  3.5 KB  |  99 lines
  1. 1  'NMR3--Part 3 of NMRCALC package.
  2. 2  'Calculates line frequencies and intensities.
  3. 10 DEFINT I-N: DEFDBL A-H,O-Z
  4. 15 'COMMON IPFLAG,IREAD,FF$
  5. 16 OPEN "scratch.nmr" FOR INPUT AS #1
  6. 17 INPUT #1, IPFLAG: INPUT #1, IREAD: LINE INPUT #1, FF$
  7. 18 CLOSE 1
  8. 20 DIM A(35,35),B(35,35),E(35),F(35)
  9. 30 DIM SF(128,7),BC(7),FZ(8),PM(7,7),SH(7)
  10. 40 DIM NCV(35,35)
  11. 45 ON ERROR GOTO 60000
  12. 50  TI = 0
  13. 60 COLOR 14,4,1: KEY OFF: CLS
  14. 70 N2 = 1
  15. 80 NTOTAL = 0
  16. 130 DF$ = FF$ + ".0": PRINT:PRINT "Loading file:  ";DF$: PRINT:                      OPEN DF$ FOR INPUT AS 1
  17. 140 INPUT #1, NS: INPUT #1, FR: NF = 2^NS: FZ = NS/2 + 1
  18. 145 FACTOR = 1/2^(NS - 3)
  19. 150 FOR I = 1 TO NS + 1: FZ = FZ - 1: FZ(I) = FZ: NEXT
  20. 160 FOR I = 1 TO NS: INPUT #1, SH(I): INPUT #1, PM(I,I): NEXT
  21. 170 FOR I = 1 TO NS - 1: FOR J = I+1 TO NS: INPUT #1, PM(I,J): NEXT: NEXT
  22. 180 FOR I = 1 TO NF: FOR J = 1 TO NS: INPUT #1, SF(I,J): NEXT: NEXT
  23. 190 FOR I = 0 TO NS: INPUT #1, BC(I): NEXT
  24. 200 CLOSE 1
  25. 210 PRINT "File now loaded.": PRINT
  26. 220 D1$ = FF$ + ".lin": UL = 1: UU = 1: DF$ = D1$: PRINT: PRINT "Setting up file ";DF$: PRINT: OPEN DF$ FOR OUTPUT AS 2: CLOSE 2
  27. 230 NZ = 1: GOSUB 61000
  28. 240 FOR NZ = 2 TO NS + 1
  29. 250 GOSUB 62000
  30. 260 GOSUB 61000
  31. 262 NTRANS = BC(NZ-2)*BC(NZ-1): NTOTAL = NTOTAL + NTRANS
  32. 265 PRINT"Calc:  Fz =";FZ(NZ);"to Fz =";FZ(NZ-1);"(";NTRANS;"TRANSITIONS)."
  33. 270 N1 = N2: N2 = N: LL = UL: LU = UU: UL = UU + 1: UU = LU + BC(NZ - 1):            DF$ = D1$: OPEN DF$ FOR APPEND AS 2
  34. 275 GOSUB 61500
  35. 280 FOR MM = 1 TO N1
  36. 290 MI = LL + MM - 1: TN = MI/1000
  37. 300 FOR NN = 1 TO N2
  38. 310 NI = UL + NN - 1: TM = 0
  39. 320 TR = NI + TN: PRINT #2,TR
  40. 330 ER = E(MM) - F(NN): PRINT #2,ER
  41. 340 FOR K = 1 TO N1
  42. 350 A = A(K,MM)
  43. 360 FOR L = 1 TO N2
  44. 370 IF NCV(K,L) = 0 THEN 390
  45. 380 TM = TM + A*B(L,NN)
  46. 390 NEXT
  47. 400 NEXT
  48. 410 TM = (TM/2)^2: TM = TM*FACTOR: PRINT #2,TM
  49. 415 TI = TI + TM
  50. 420 NEXT
  51. 430 NEXT
  52. 440 CLOSE 2
  53. 450 NEXT
  54. 460 PRINT: PRINT "Total of intensities: ";TI
  55. 470 PRINT NTOTAL;"transitions calculated and listed."
  56. 500 PRINT: PRINT "Calculation of frequencies and intensities finished.": PRINT
  57. 510 GOSUB 63999
  58. 560 CLS
  59. 570 PRINT: PRINT"The following files are saved:": PRINT
  60. 580 PRINT TAB(5);FF$;".0"
  61. 590 PRINT TAB(5);FF$;".inf"
  62. 600 PRINT TAB(5);FF$;".lin"
  63. 605 FOR I = 1 TO NS + 1: PRINT TAB(5);FF$ + "." + RIGHT$(STR$(I),LEN(STR$(I))-1)     : NEXT
  64. 610 PRINT:PRINT"Ready to exit to final display routines.": GOSUB 63999
  65. 1000 CLOSE
  66. 1005 OPEN "scratch.nmr" FOR OUTPUT AS #1
  67. 1010 PRINT #1, IPFLAG: PRINT #1, IREAD: PRINT #1, FF$
  68. 1020 CLOSE 1
  69. 1030 CHAIN "nmr4"
  70. 60000 PRINT: BEEP: PRINT"Error encountered!  Can't continue.  Will return to main I/O routine.": GOSUB 63999
  71. 60010 CLOSE 1,2
  72. 60020 CHAIN "nmr1"
  73. 61000 DF$ = FF$ + "." + RIGHT$(STR$(NZ),LEN(STR$(NZ))-1)
  74. 61010 OPEN DF$ FOR INPUT AS 1
  75. 61020 INPUT #1, N
  76. 61030 FOR I = 1 TO N: INPUT #1, F(I): NEXT
  77. 61040 IF N > 1 THEN 61060
  78. 61050 B(1,1) = 1: GOTO 61065
  79. 61060 FOR J = 1 TO N: FOR I = 1 TO N: INPUT #1, B(I,J): NEXT: NEXT
  80. 61065 CLOSE 1
  81. 61070 RETURN
  82. 61500 FOR MM = 1 TO N1
  83. 61510 MI = LL + MM - 1
  84. 61520 FOR NN = 1 TO N2
  85. 61530 NI = UL + NN - 1
  86. 61540 V = 0: I = 1
  87. 61550 IF SF(MI,I) <> SF(NI,I) THEN V = V + 1
  88. 61560 IF V > 1 THEN 61590
  89. 61570 I = I + 1: IF I <= NS THEN 61550
  90. 61580 NCV(MM,NN) = 1: GOTO 61600
  91. 61590 NCV(MM,NN) = 0
  92. 61600 NEXT
  93. 61610 NEXT
  94. 61620 RETURN
  95. 62000 N = BC(NZ - 2)
  96. 62010 FOR I = 1 TO N: E(I) = F(I): FOR J = 1 TO N: A(I,J) = B(I,J): NEXT:NEXT
  97. 62020 RETURN
  98. 63999 IF IPFLAG = 1 THEN RETURN ELSE PRINT: INPUT"Hit <Return> to continue.",A$        :RETURN
  99.