1  'NMR3--Part 3 of NMRCALC package.
2  'Calculates line frequencies and intensities.
10 DEFINT I-N: DEFDBL A-H,O-Z
15 'COMMON IPFLAG,IREAD,FF$
16 OPEN "scratch.nmr" FOR INPUT AS #1
17 INPUT #1, IPFLAG: INPUT #1, IREAD: LINE INPUT #1, FF$
18 CLOSE 1
20 DIM A(35,35),B(35,35),E(35),F(35)
30 DIM SF(128,7),BC(7),FZ(8),PM(7,7),SH(7)
40 DIM NCV(35,35)
45 ON ERROR GOTO 60000
50  TI = 0
60 COLOR 14,4,1: KEY OFF: CLS
70 N2 = 1
80 NTOTAL = 0
130 DF$ = FF$ + ".0": PRINT:PRINT "Loading file:  ";DF$: PRINT:                      OPEN DF$ FOR INPUT AS 1
140 INPUT #1, NS: INPUT #1, FR: NF = 2^NS: FZ = NS/2 + 1
145 FACTOR = 1/2^(NS - 3)
150 FOR I = 1 TO NS + 1: FZ = FZ - 1: FZ(I) = FZ: NEXT
160 FOR I = 1 TO NS: INPUT #1, SH(I): INPUT #1, PM(I,I): NEXT
170 FOR I = 1 TO NS - 1: FOR J = I+1 TO NS: INPUT #1, PM(I,J): NEXT: NEXT
180 FOR I = 1 TO NF: FOR J = 1 TO NS: INPUT #1, SF(I,J): NEXT: NEXT
190 FOR I = 0 TO NS: INPUT #1, BC(I): NEXT
200 CLOSE 1
210 PRINT "File now loaded.": PRINT
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
230 NZ = 1: GOSUB 61000
240 FOR NZ = 2 TO NS + 1
250 GOSUB 62000
260 GOSUB 61000
262 NTRANS = BC(NZ-2)*BC(NZ-1): NTOTAL = NTOTAL + NTRANS
265 PRINT"Calc:  Fz =";FZ(NZ);"to Fz =";FZ(NZ-1);"(";NTRANS;"TRANSITIONS)."
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
275 GOSUB 61500
280 FOR MM = 1 TO N1
290 MI = LL + MM - 1: TN = MI/1000
300 FOR NN = 1 TO N2
310 NI = UL + NN - 1: TM = 0
320 TR = NI + TN: PRINT #2,TR
330 ER = E(MM) - F(NN): PRINT #2,ER
340 FOR K = 1 TO N1
350 A = A(K,MM)
360 FOR L = 1 TO N2
370 IF NCV(K,L) = 0 THEN 390
380 TM = TM + A*B(L,NN)
390 NEXT
400 NEXT
410 TM = (TM/2)^2: TM = TM*FACTOR: PRINT #2,TM
415 TI = TI + TM
420 NEXT
430 NEXT
440 CLOSE 2
450 NEXT
460 PRINT: PRINT "Total of intensities: ";TI
470 PRINT NTOTAL;"transitions calculated and listed."
500 PRINT: PRINT "Calculation of frequencies and intensities finished.": PRINT
510 GOSUB 63999
560 CLS
570 PRINT: PRINT"The following files are saved:": PRINT
580 PRINT TAB(5);FF$;".0"
590 PRINT TAB(5);FF$;".inf"
600 PRINT TAB(5);FF$;".lin"
605 FOR I = 1 TO NS + 1: PRINT TAB(5);FF$ + "." + RIGHT$(STR$(I),LEN(STR$(I))-1)     : NEXT
610 PRINT:PRINT"Ready to exit to final display routines.": GOSUB 63999
1000 CLOSE
1005 OPEN "scratch.nmr" FOR OUTPUT AS #1
1010 PRINT #1, IPFLAG: PRINT #1, IREAD: PRINT #1, FF$
1020 CLOSE 1
1030 CHAIN "nmr4"
60000 PRINT: BEEP: PRINT"Error encountered!  Can't continue.  Will return to main I/O routine.": GOSUB 63999
60010 CLOSE 1,2
60020 CHAIN "nmr1"
61000 DF$ = FF$ + "." + RIGHT$(STR$(NZ),LEN(STR$(NZ))-1)
61010 OPEN DF$ FOR INPUT AS 1
61020 INPUT #1, N
61030 FOR I = 1 TO N: INPUT #1, F(I): NEXT
61040 IF N > 1 THEN 61060
61050 B(1,1) = 1: GOTO 61065
61060 FOR J = 1 TO N: FOR I = 1 TO N: INPUT #1, B(I,J): NEXT: NEXT
61065 CLOSE 1
61070 RETURN
61500 FOR MM = 1 TO N1
61510 MI = LL + MM - 1
61520 FOR NN = 1 TO N2
61530 NI = UL + NN - 1
61540 V = 0: I = 1
61550 IF SF(MI,I) <> SF(NI,I) THEN V = V + 1
61560 IF V > 1 THEN 61590
61570 I = I + 1: IF I <= NS THEN 61550
61580 NCV(MM,NN) = 1: GOTO 61600
61590 NCV(MM,NN) = 0
61600 NEXT
61610 NEXT
61620 RETURN
62000 N = BC(NZ - 2)
62010 FOR I = 1 TO N: E(I) = F(I): FOR J = 1 TO N: A(I,J) = B(I,J): NEXT:NEXT
62020 RETURN
63999 IF IPFLAG = 1 THEN RETURN ELSE PRINT: INPUT"Hit <Return> to continue.",A$        :RETURN