1!		Lawrence University
		Department of Chemistry
		Appleton, Wisconsin 54911
		(414) 739-3681, Ext. 456

2!  Program name, version, date, authorship:
	NMRCAL, Version 1C, 13-Dec-74 (Slave program for NMRSIM)
	NMRSIM was written by Dr. James S. Evans, Department of
	Chemistry, Lawrence University.

3!  Purpose of program:
	NMRSIM simulates nmr spectra from values of coupling
	constants, chemical shifts, rf power, and relaxation times.
4!	Included are subroutines for several plotting devices:
	Tektronix 4010 graphics terminal; TSP-212 plotter system;
	Hewlett-Packard 7200A/7202A graphic plotter.

5!  Language and operating system:
	NMRSIM, written in BASIC-PLUS, uses virtual core files and
	several non-privileged SYS functions, and runs in 8K under
	RSTS Versions 4A-12 (PDP-11/35), 05-21 (PDP-11/45), and 05B-24.

6!  Availability:
	NMRSIM is a non-proprietary program product of Lawrence
	University.  It is distributed at cost for educational use,
	on the condition that it not be sold, rented, or leased
	for profit.

7!  Limitations:
	Variables in NMRSIM are dimensioned to handle up to 6 spin-1/2
	nuclei, or fewer with larger spins.  Larger systems might be
	feasible on an 11/45 configured for 16K of user core.

8!  Further documentation:
	User's guide:  6 pages of run instructions and operational
	  features for students who will use NMRSIM in physical or
	  organic chemistry courses.
9!	Programmer's guide:  discussion of algorithms and instructions
	  for system implementation.

10! Disclaimer:
	Neither the author of this program nor Lawrence University
	assumes any liability, expressed or implied, with respect to
	the correctness or performance of this program.

100 ! NMRCAL - EXTENSION OF SECTION 16 IN NMRSIM
110 DIM A(20%,20%),S(20%,20%),
	Z%(64%,6%),P%(64%),V%(7%),W%(7%),T(20%,20%)
120 DIM #2, N%(30%),N$(20%)=2%,N0$(10%)=8%,
	B$(6%)=4%,L%(6%),G(6%),J(6%,6%),
	I6%(64%,6%),I7%(64%),I8%(7%),I9%(7%),I(1000%,1%)
130 PRINT "CAN'T RUN NMRCAL" : GOTO 32000
200 N1$=CHR$(35%)
210 I4,F0=0 : F1=1 : F2=2 : I2=SQR(.001) : R8=1.E-5 :
	N7%,K0%=0% : K1%=1% : K2%=2% : K3%=3% : K4%=4% :
	K5%=5% : K6%=6% : K7%=7% : K8%=8% : K9%=9% :
	ON ERROR GOTO 31000 : GOSUB 21400
	! INITIALIZE CONSTANTS; ENABLE ^C TRAP 
220 I8%=K9% : GOSUB 20000 :
	OPEN "NMRTMP.J"+RIGHT(NUM$(100%+ASCII(K0$)/K2%),K3%) 
	FOR INPUT AS FILE K2%, CLUSTERSIZE K8%
230 Z%(I%,J%)=I6%(I%,J%) FOR J%=K0% TO K6% FOR I%=K0% TO 64% :
	P%(I%)=I7%(I%) FOR I%=K0% TO 64% :
	V%(I%)=I8%(I%) FOR I%=K0% TO K7% :
	W%(I%)=I9%(I%) FOR I%=K0% TO K7%
	! COPY SPIN ARRAYS INTO REAL CORE
240 L9%=Z%(K0%,K0%) : N8%=Z%(K0%,K2%) :
	A$=B$(Z%(K0%,K4%)) ! RETRIEVE CONSTANTS
1650 FOR H%=L9% TO -L9% STEP -K2% : N%=W%((L9%-H%)/K2%+K1%) :
	I0%=V%((L9%-H%)/K2%+K1%)-N% : GOTO 1690 IF H%=L9% :
 	FOR I%=K1% TO N6% : T(I%,J%)=F0 FOR J%=K1% TO N% :
	T(I%,K0%)=A(I%,I%) : NEXT I%
	! H LOOPS THROUGH EACH VALUE OF TOTAL SPIN
1660 FOR I%=K1% TO N% : I1%=P%(I0%+I%) :
	FOR J%=K1% TO N6% : J1%=P%(I6%+J%) : L%=K0% :
	FOR K%=K1% TO N8% : I8%=(Z%(I1%,K%)-Z%(J1%,K%))/K2% :
	GOTO 1670 IF I8%=K0%  : GOTO 1680 IF I8%<>-K1% OR B$(K%)<>A$ :
	M1%=K% : L%=L%+K1% ! SELECTION RULES FOR "X APPROX."
1670 NEXT K% : GOTO 1680 IF L%<>K1% :
	C=SQR((L%(M1%)+Z%(J1%,M1%))*(L%(M1%)-Z%(J1%,M1%)+K2%))/F2 :
	T(L%,I%)=T(L%,I%)+C*S(J%,L%) FOR L%=K1% TO N6%
1680 NEXT J% : NEXT I% ! T=ALLOWED TRANSITION MATRIX
	NOW MAKE NEXT HAMILTONIAN SUBMATRIX
1690 FOR I%=K1% TO N% : I1%=P%(I0%+I%) : C=F0 :
	FOR J%=K1% TO N8% : C=C+J(J%,J%)*Z%(I1%,J%)/F2 :
	C=C+J(J%,K%)*Z%(I1%,J%)*Z%(I1%,K%)/4. FOR K%=J%+K1% TO N8% :
	NEXT J% : A(I%,I%)=C
1700 FOR J%=I%+K1% TO N% : L%=K0% : A(I%,J%),A(J%,I%)=F0 :
	FOR K%=K1% TO N8% : I8%=(Z%(I1%,K%)-Z%(P%(I0%+J%),K%))/K2%
	! I8%=SPIN CHANGE FOR NUCLEUS K
1710 GOTO 1730 IF ABS(I8%)>K1% : GOTO 1720 UNLESS I8% :
	J1%=K% IF I8%<K0% : M1%=K% IF I8%>K0% :
	L%=L%+K1% : GOTO 1730 IF L%>K2%
	! SPIN-SPIN COUPLING INCREMENTS SPIN OF NUCLEUS J1,
	DECREMENTS M1; NO OTHERS MAY CHANGE
1720 NEXT K% : GOTO 1730 IF B$(J1%)<>B$(M1%) :
	L%=L%(J1%) : C=(L%-Z%(I1%,J1%))*(L%+Z%(I1%,M1%))
	*(L%+Z%(I1%,J1%)+K2%)*(L%-Z%(I1%,M1%)+K2%) :
	A(J%,I%),A(I%,J%)=J(J1%,M1%)*SQR(C)/8.
1730 NEXT J% : NEXT I% : GOSUB 3600 : GOTO 1760 IF H%=L9% :
	FOR I%=K1% TO N6% : FOR J%=K1% TO N% : I7=F0 :
	I7=I7+T(I%,K%)*S(K%,J%) FOR K%=K1% TO N% :
	IF ABS(I7)<I2 THEN 1750 
1740 N7%=N7%+K1% : I7=I7*I7 : I4=I4+I7 :
	I(N7%,K0%)=T(I%,K0%)-A(J%,J%) : I(N7%,K1%)=I7
1750 NEXT J% : NEXT I% ! RECORD LINES ABOVE INTENSITY THRESHOLD
1760 N6%=N% : I6%=I0% : NEXT H% :
	PRINT : PRINT "TOTAL INTENSITY ="I4 :
	N%(K7%)=K7% : N%(K5%)=N7%
1770 CLOSE K2% : CHAIN N1$+"NMRSIM" 200
3600 ! MATRIX DIAGONALIZATION BY METHOD OF JACOBI (1846) USING
	THRESHOLD SEARCH SUGGESTED BY GREENSTADT (1960)
	ASSUMES: F0=0, F1=1, F2=2; K0%=0%, K1%=1%, K2%=2%
3610 !		A=MATRIX, S=EIGENVECTORS, N%=SIZE, R8=REDUCTION FACTOR
	ALTERS: C1,C2,I%,J%,P%,Q%,T1,T2,T8,T9,V0-V4
3620 S(K1%,K1%)=F1 : RETURN IF N%<K2% :
	V0=F0 : FOR I%=K2% TO N% : FOR J%=K1% TO I%-K1% :
	V0=V0+A(J%,I%)*A(J%,I%) : S(I%,J%),S(J%,I%)=F0 :
	NEXT J% : S(I%,I%)=F1 : NEXT I% :
	V0=F2*V0 : RETURN IF V0<=R8 :
	T8=SQR(V0) : T9=R8*T8/N%
3630 T8=T8/N% !  FINAL (T9) AND INITIAL (T8) THRESHOLDS
3640 J%=K1% : FOR Q%=K2% TO N% : FOR P%=K1% TO Q%-K1% :
	V2=A(P%,Q%) : IF ABS(V2)<=T8 THEN 3690 
	! FIND A PIVOT BIGGER THAN THRESHOLD
3650 J%=K0% : V1=A(P%,P%) : V3=A(Q%,Q%) : V4=V1-V3 :
	IF V4=F0 THEN T1=-F1 ELSE
	T1=SGN(V4)*(-F2*V2)/(ABS(V4)+SQR(V4*V4+4*V2*V2))
3660 T2=T1*T1 : C2=F1/(F1+T2) : C1=SQR(C2) ! CALCULATE TRIG FUNCTIONS
3670 FOR I%= K1% TO N% : A1=A(I%,P%) : A2=A(I%,Q%) :
	A(I%,P%),A(P%,I%)=C1*(A1-A2*T1) :
	A(I%,Q%),A(Q%,I%)=C1*(A2+A1*T1) :
	A1=S(I%,P%) : A2=S(I%,Q%) : S(I%,P%)=C1*(A1-A2*T1) :
	S(I%,Q%)=C1*(A2+A1*T1) : NEXT I%
	 !  MATRIX MULTIPLICATION FOR ROTATION
3680 V2=F2*T1*V2 : A(P%,P%)=C2*(V1-V2+T2*V3) :
	A(Q%,Q%)=C2*(V3+V2+T2*V1) : A(P%,Q%),A(Q%,P%)=F0
3690 NEXT P% : NEXT Q% : GOTO 3640 IF J%=K0% : 
	GOTO 3630 IF T8>T9 : RETURN
	! TEST FOR CONVERGENCE
20000 I8%,I9%=K0% UNLESS I7%=K6% :
	K0$=SYS(CHR$(I7%)+CHR$(I8%)+CHR$(I9%)) :
	RETURN					! SYS FUNCTION CALL
21200 I7%=K6% : I8%=K9% : GOSUB 20000 :
	PRINT MID(K0$,K3%,INSTR(K3%,K0$,CHR$(K0%))-K3%) :
	RETURN					! RSTS ERROR MESSAGE
21400 I7%=K6% : I8%=-K7% : I9%=K0% : GOSUB 20000 : RETURN
						! ENABLE ^C TRAP
31000 GOTO 31990 UNLESS ERR=28% : GOSUB 21400 : I7%=K0% :
	GOSUB 20000 : N%(K7%)=K8% : RESUME 1770		! ^C TRAP
31990 I9%=117% : GOSUB 21200 : I9%=114% : GOSUB 21200 :
	PRINT "IF POSSIBLE, CONTACT MR. EVANS BEFORE LOGGING OFF" :
	ON ERROR GOTO 0
32000 END