C  PROGRAM DIFGEN ADAPTED FROM DIFIN4 BY  R. SNYDER 2/1/73
C UNIT 10 IS A SCRATCH FILE
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
	 COMMON /IO/ IREAD, ITYP, IPNCH
C
013	FORMAT ( 1X, 3I3)
C
	IREAD = 5
	ITYP = 6
	IPNCH = 7
100	WRITE(ITYP,1)
1	FORMAT('0 PROGRAM DIFGEN TO GENERATE DIFFRACTOMETER COORDINATES
	1')
	CALL INPUT
	IF (NCARD(7)) 116, 116, 200
116	K1 = 1
117	READ           (IREAD, 013) (IH(J), J=1,3)
	WRITE (10)  IH
	K1=K1+1
	IF (IH(1)**2+IH(2)**2+IH(3)**2) 118, 118, 117
118	K1=K1-1
	IF (NCARD(15 )) 120, 120, 119
119	CALL REF
	NCOUN = NCARD(15)
120	READ (10)  IH
	IF (IH(1)**2+IH(2)**2+IH(3)**2) 100, 100, 125
C
125	CALL CALC1
C
	CALL OTPUT
C
	IF (NCARD(15)) 120, 120, 130
130	NCOUN = NCOUN + 1
	IF (NCARD(16)-NCOUN ) 119, 119, 120
C
C
200	I1 = NCARD(1)
	I2 = NCARD(2)
	I3 = NCARD(3)
C
	RHMIN = B(I1,1)
	RHMAX = B(I1,2)
	RHDEL = B(I1,3)
	RKMIN = B(I2,1)
	RKMAX = B(I2,2)
	RKDEL = B(I2,3)
	RLMIN = B(I3,1)
	RLMAX = B(I3,2)
	RLDEL = B(I3,3)
	RH = RHMIN
	RK = RKMIN
	RL = RLMIN
C
	IH(1) = 0
	IH(2) = 0
	IH(3) = 0
C
	J1 = NCARD(4)
	J2 = NCARD(5)
	J3 = NCARD(6)
C
	RAD = 3.1415926 / 180.0
	PHIMN  = C(J1,1) * RAD
	PHIMX  = C(J1,2) * RAD
	PHIDL  = C(J1,3) * RAD
	CHIMN  = C(J2,1) * RAD
	CHIMX  = C(J2,2) * RAD
	CHIDL  = C(J2,3) * RAD
	DSMIN = C(J3,1)
	DSDEL = C(J3,3)
	PHILO = PHIMN
	PHIHI = PHIMN +PHIDL
	CHILO = CHIMN
	CHIHI = CHIMN +CHIDL
	DSLO = DSMIN
	DSHI = DSMIN+DSDEL
C
	CALL RANGE
C
205	NCOUN  = NCARD(15)
	IF(NCARD(15))210, 210, 207
207	CALL REF
C
210	IH(I1) = RH
	IH(I2) = RK
	IH(I3) = RL
	CALL GEN (JDONE)
C
	IF (JDONE) 211,211,220
C
211	IF (NCARD(11)) 311, 311, 2111
2111	CALL XTINC(NG)
	IF (NG) 210,311,210
311	IF(IH(I1))800,801,800
801	IF(IH(I2))800,802,800
802	IF(IH(I3))800,210,800
800	CALL CALC1
	IF (NCARD(8)) 218,218,212
212	IF (PHIHI-PHI) 210,213,213
213	IF (PHI-PHILO) 210,214,214
214	IF (CHIHI-CHI) 210,215,215
215	IF (CHI-CHILO) 210,216,216
216	IF (DSHI-DSTAR) 210,217,217
217	IF (DSTAR-DSLO) 210,218,218
C
218	CALL OTPUT
C
	IF(NCARD(15)) 210,210,219
219	NCOUN  = NCOUN +1
	IF (NCARD(16)-NCOUN ) 205,205,210
C
C
220	IF(NCARD(8)) 225, 225, 221
221	CALL POLAR (KDONE)
	CALL RANGE
C
	IF (KDONE) 222,222,225
C
222	RHMIN = B(I1,1)
	RHMAX = B(I1,2)
	RHDEL = B(I1,3)
	RKMIN = B(I2,1)
	RKMAX = B(I2,2)
	RKDEL = B(I2,3)
	RLMIN = B(I3,1)
	RLMAX = B(I3,2)
	RLDEL = B(I3,3)
	RH = RHMIN
	RK = RKMIN
	RL = RLMIN
	IH (1) = 0
	IH (2) = 0
	IH (3) = 0
C
	GO TO 210
C
225	IF(NCARD(15)) 229, 229, 227
227	CALL REF
229	IF (NCARD(24)) 100,999,100
C
999	CALL EXIT
	END

	SUBROUTINE INPUT
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
	 COMMON /IO/ IREAD, ITYP, IPNCH

010	FORMAT (72
	1                       )
011	FORMAT (9F8.7)
012	FORMAT (2(1X,3I1), 18I4)
013	FORMAT ( 1X,3I3)
014	FORMAT (' REFL. COORDS. IN R. L. U. = ' )
015	FORMAT ( '   X = ', F9.6, ' * H + ', F9.6, ' * K + ' F9.6, ' * L')
115	FORMAT ( '   Y = ', F9.6, ' * H + ', F9.6, ' * K + ' F9.6, ' * L')
116	FORMAT ( '   Z = ', F9.6, ' * H + ', F9.6, ' * K + ' F9.6, ' * L')
016	FORMAT ( ' H,K,L SCAN LIMITS =')
017	FORMAT ( '  H,K,L LOW     ', 3F5.0 )
018	FORMAT ( '  H,K,L HIGH    ', 3F5.0 )
019	FORMAT ( '  H,K,L DELTAS  ', 3F5.0 )
020	FORMAT ( ' PHI, CHI, DSTAR SCAN LIMITS =' )
021	FORMAT ('  PH, CH, DS LOW    ', 3F8.2 )
022	FORMAT ('  PH, CH, DS HIGH   ', 3F8.2 )
023	FORMAT ('  PH, CH, DS DELTAS ', 3F8.2 )
024	FORMAT ( ' SCAN SEQ. HKL (H=1,K=2,L=3) IS ', 3I2 )
025	FORMAT ( ' SCAN SEQ. PH, CH, DS (P=1,C=2,D=3) IS', 3I2 )
026	FORMAT ( ' READ HKL FROM CARDS ' )
028	FORMAT ( ' IGNORE PH, CH, DS LIMITS ' )
3010	 FORMAT(' EXTINC SUBR BYPASSED')
3011	FORMAT(' P 21 EXTINCT SUBR CALLED')
3012	 FORMAT(' P 21/C EXTINCT SUBR CALLED')
3013	FORMAT ( ' P 21 21 21 EXTINCT SUBR CALLED ' )
3014	FORMAT (' FD3 EXTINC SUBR CALLED ' )
3040	 FORMAT(' DUMMY EXTINC SUBR CALLED--EQUIV BYPASS')
032	FORMAT (' READ LOG ',I2,',  WRITE LOG ',I2,',  PRINT LOG ',I2 )
033	FORMAT ( ' REF. HKL S = ', I2, '  (LT. 20)')
034	FORMAT ( ' REF. HKL EVERY ', I2, ' HKL S ' )
0351	FORMAT ( ' OMEGA SCAN ' )
0352	FORMAT ( ' TWO THETA SCAN ' )
0353	FORMAT ( ' TWO THETA 9 PT. ' )
0354	FORMAT ( ' OMEGA 3 PT. ' )
0355	FORMAT ( ' TWO THETA 12 PT. ' )
039	FORMAT ( '   2*THETA   DELTA -   DELTA +     WIDTH ' )
040	FORMAT ( 4(F10.2))
042	FORMAT ( ' SCAN LOW = 2*TH-A/100-B/100*TAN(TH) ' / ' SCAN HI  = 2
	1TH+A/100+C/100*TAN(TH) ' /' WHERE A = ',I4,', B = ',I4,', AND C =
	2', I4 )
043	FORMAT(1H0)
044	FORMAT ( ' NO REF. HKL S ' )
C
	  WRITE(108,33)
	READ(IREAD, 010)
	READ(IREAD, 012) NCARD
	WRITE(ITYP, 043)
	WRITE(ITYP, 010)
	IF (NCARD(23)) 106, 106, 105
105	READ(IREAD, 011) WAVE
106	IF (NCARD(23)) 101, 101, 102
101	READ(IREAD, 011) A, B, C
	GO TO 110
102	CALL DIFOR (A, WAVE)
	READ(IREAD, 011) B, C
C
110	 ICOUN=NCARD(22) - 1
	JZ = NCARD(15)
	IF(JZ) 113,113,111
111	DO 112 J=1,JZ
	READ           (IREAD, 013) (IHREG(K,J),K=1,3)
112	CONTINUE
113	CONTINUE
117	WRITE(ITYP, 014)
	WRITE         (ITYP, 015) A(1,1), A(1,2), A(1,3)
	WRITE         (ITYP, 115) A(2,1), A(2,2), A(2,3)
	WRITE         (ITYP, 116) A(3,1), A(3,2), A(3,3)
	IF(NCARD(7)) 202, 202, 201
202	WRITE         (ITYP, 026)
	GO TO 212
201	WRITE         (ITYP, 016)
	WRITE         (ITYP, 017) B(1,1), B(2,1), B(3,1)
	WRITE         (ITYP, 018) B(1,2), B(2,2), B(3,2)
	WRITE         (ITYP, 019) B(1,3), B(2,3), B(3,3)
	IF(NCARD(8)) 208, 208, 209
208	WRITE         (ITYP, 028)
	GO TO 212
209	WRITE         (ITYP, 020)
	WRITE         (ITYP, 021) C(1,1), C(2,1), C(3,1)
	WRITE         (ITYP, 022) C(1,2), C(2,2), C(3,2)
	WRITE         (ITYP, 023) C(1,3), C(2,3), C(3,3)
	WRITE         (ITYP, 024) NCARD(1), NCARD(2), NCARD(3)
	WRITE         (ITYP, 025) NCARD(4), NCARD(5), NCARD(6)
212	JJ11=NCARD(11) + 1
	GO TO (2120, 2121, 2122, 2123, 2124, 2140, 2140, 2140, 2140, 2140
	1 2140, 2140, 2140, 2140, 2140, 2140, 2140, 2140, 2140, 2140, 2140
	2 2140, 2140, 2140, 2140, 2140, 2140 ), JJ11
2120	 WRITE(ITYP,3010)
	 GO TO 217
2121	 WRITE(ITYP,3011)
	 GO TO 217
2122	 WRITE(ITYP,3012)
	 GO TO 217
2123	 WRITE(ITYP,3013)
	GO TO 217
2124	WRITE ( ITYP, 3014 )
	GO TO 217
2140	WRITE (ITYP,3040)
217	WRITE         (ITYP, 032) NCARD(12), NCARD(13), NCARD(14)
	IF (JZ) 218, 218, 219
218	WRITE         (ITYP,044 )
	GO TO 220
219	WRITE         (ITYP, 033) NCARD(15)
	WRITE         (ITYP, 034) NCARD(16)
220	JQ = NCARD(17)
	GO TO (221, 222, 223, 224, 225), JQ
221	WRITE (ITYP, 0351)
	GO TO 300
222	WRITE (ITYP, 0352)
	GO TO 300
223	WRITE (ITYP, 0353)
	GO TO 300
224	WRITE (ITYP, 0354)
	GO TO 300
225	WRITE (ITYP, 0355)
300	WRITE          (ITYP,043 )
	WRITE (ITYP, 042) NCARD(18), NCARD(19), NCARD(20)
	WRITE (ITYP, 039)
	DO 310 J=1,7
	XJ = J - 1
	THETA = (1.570796 * XJ) / 9.0
	CALL CALC3 (WDTH1,WDTH2)
	THTA2 = (180.0 *THETA)/1.570796
	WDTH1 = WDTH1/100.0
	WDTH2 = WDTH2 /100.0
	SUMDT = WDTH1 + WDTH2
	WRITE         (ITYP, 040) THTA2, WDTH1,WDTH2,SUMDT
310	CONTINUE
320	READ(IREAD, 010 )
	WRITE         (ITYP,043 )
	RETURN
	END

	SUBROUTINE DIFOR ( XYZV, WAVE)
	DIMENSION A(3,3),ABCO(3,3),XYZV(3,3)
	DIMENSION AINV(3,3),ABCV(3,3)
	 COMMON /IO/ IREAD, ITYP, IPNCH
C     A PROGRAM TO OBTAIN THE RECIPROCAL LATTICE COORDINATE
C  THIS PROGRAM CALCULATES LATTICE PARAMETERS FROM THREE OR MORE
C  REFLECTIONS OBTAINED FROM A SINGLE CRYSTAL ON A DIFFRACTOMETER.
C                            MAY 1966                   R.SHIONO
C                FOR IBM 1130 SYSTEM                   MAY 1968
C                FOR USE WITH DIFN4  (E.L.MC GANDY)    DEC 1968
C
C  INPUT REQUIRED--
C        1. 7F10.5      WAVE,CRPHI,CRCHI,CRTHE
C                            WAVE LENGTH USED, CORRECTIONS FOR PHI,
C                            CHI AND TWO THETA
C      WAVE ONLY NEEDED. FIXED VALUES USED AS FOLLOWS
	CRPHI = 180.0
	CRCHI = 180.0
	CRTHE = 0.0
C
C       2.  3F5.0, 3F10.2
C              H,K,L,PHI,CHI, AND TWO-THETA SINGLE-CRYSTAL DIFFRACTOMETER
C
036	FORMAT ('MAX H,K,L =' 5I5 )
45	FORMAT ( 3F5.0, F10.2,F10.2,F10.2   )
047	FORMAT('A, B, C ='3F7.3,/'COS A, B, G ='3F9.5,/'LAMBDA ='F7.5/)
110	FORMAT (  3F20.7, I5  )
125	FORMAT ( 3F7.3, 4F7.4  )
048	FORMAT (/'REFLECTION INPUT TO -A- MATRIX CALCULATION'/'     H   K
	1  L     PHI     CHI    2*TH'//)
049	FORMAT (2X, 3I4, 3F8.2)
	DO 50 I=1,3
	DO 50 J=1,3
	ABCO(I,J)=0.0
	A(I,J)=0.0
50	AINV(I,J)=0.0
	N=0
	CON=1.7453294E-2
	WRITE (ITYP, 048)
108	READ ( IREAD,45 ) FH,FK,FL,PHI,CHI,THET2
	IF  ( FH-999.0 )  120,  121,  121
120	IH = FH
	IK = FK
	IL = FL
	WRITE (ITYP, 049) IH, IK, IL, PHI, CHI, THET2
	PHI=PHI-CRPHI
	PHI = - PHI
	CHI=CHI-CRCHI
	THET2=THET2-CRTHE
	IF  ( PHI )  122,  123,  123
122	PHI=PHI+360.
123	IF  ( CHI )  124,  126,  126
124	CHI=CHI+360.0
126	IF  ( THET2 )  127,  128,  128
127	THET2=-THET2
128	THET2=THET2*CON
	CHI=CHI*CON
	PHI=PHI*CON
	N=N+1
	TEM=2.0*SIN(0.5*THET2)
	X=TEM*COS(CHI)*COS(PHI)
	Y=TEM*COS(CHI)*SIN(PHI)
	Z=TEM*SIN(CHI)
	A(1,1)=A(1,1)+FH*FH
	A(2,2)=A(2,2)+FK*FK
	A(3,3)=A(3,3)+FL*FL
	A(1,2)=A(1,2)+FH*FK
	A(1,3)=A(1,3)+FH*FL
	A(2,3)=A(2,3)+FK*FL
	ABCO(1,1)=ABCO(1,1)+FH*X
	ABCO(1,2)=ABCO(1,2)+FK*X
	ABCO(1,3)=ABCO(1,3)+FL*X
	ABCO(2,1)=ABCO(2,1)+FH*Y
	ABCO(2,2)=ABCO(2,2)+FK*Y
	ABCO(2,3)=ABCO(2,3)+FL*Y
	ABCO(3,1)=ABCO(3,1)+FH*Z
	ABCO(3,2)=ABCO(3,2)+FK*Z
	ABCO(3,3)=ABCO(3,3)+FL*Z
	GO TO  108
121	A(3,1)=A(1,3)
	A(2,1)=A(1,2)
	A(3,2)=A(2,3)
	DETA=A(1,1)*A(2,2)*A(3,3)+2.*A(1,2)*A(2,3)*A(1,3)
	DETA=DETA-A(1,3)*A(1,3)*A(2,2)-A(2,3)*A(2,3)*A(1,1)
	DETA=DETA-A(1,2)*A(1,2)*A(3,3)
	AINV(1,1) =(A(2,2)*A(3,3)-A(3,2)*A(2,3))/DETA
	AINV(2,2) =(A(1,1)*A(3,3)-A(3,1)*A(1,3))/DETA
	AINV(3,3) =(A(1,1)*A(2,2)-A(2,1)*A(1,2))/DETA
	AINV(1,2) =(A(3,2)*A(1,3)-A(1,2)*A(3,3))/DETA
	AINV(1,3) =(A(1,2)*A(2,3)-A(2,2)*A(1,3))/DETA
	AINV(2,3) =(A(2,1)*A(1,3)-A(1,1)*A(2,3))/DETA
	AINV(3,1) = AINV(1,3)
	AINV(2,1) = AINV(1,2)
	AINV(3,2) = AINV(2,3)
	DO 200 M = 1,3
	DO 200 I=1,3
	XYZV(M,I)=0.0
	DO 200 J=1,3
200	XYZV(M,I)= AINV(I,J)*ABCO(M,J) +XYZV(M,I)
	DO 201 I =1,3
	DO 201 J =1,3
201	A(I,J) = XYZV(I,J)
	DO 202 I = 1,3
	DO 202 J = 1,3
	XYZV(I,J)=A(J,I)
	IF  ( ABS(XYZV(I,J))-0.00005 )  203,  203,  202
203	XYZV(I,J)=0.0
202	CONTINUE
	WRITE (ITYP, 010 )
010	FORMAT ( 1H0 )
	DO 112 I=1,3
	DO 112 J=1,3
112	ABCV(I,J)=XYZV(I,J)
	AVS=ABCV(1,1)*ABCV(1,1)+ABCV(1,2)*ABCV(1,2)+ABCV(1,3)*ABCV(1,3)
	BVS=ABCV(2,1)*ABCV(2,1)+ABCV(2,2)*ABCV(2,2)+ABCV(2,3)*ABCV(2,3)
	CVS=ABCV(3,1)*ABCV(3,1)+ABCV(3,2)*ABCV(3,2)+ABCV(3,3)*ABCV(3,3)
	ASTAR=SQRT(AVS)
	BSTAR=SQRT(BVS)
	CSTAR=SQRT(CVS)
	BCV=ABCV(2,1)*ABCV(3,1)+ABCV(2,2)*ABCV(3,2)+ABCV(2,3)*ABCV(3,3)
	ACV=ABCV(1,1)*ABCV(3,1)+ABCV(1,2)*ABCV(3,2)+ABCV(1,3)*ABCV(3,3)
	ABV=ABCV(1,1)*ABCV(2,1)+ABCV(1,2)*ABCV(2,2)+ABCV(1,3)*ABCV(2,3)
	COAST = BCV/(BSTAR*CSTAR)
	COBST = ACV/(ASTAR*CSTAR)
	COGST = ABV/(ASTAR*BSTAR)
	SIAST=SQRT(1.0-COAST*COAST)
	SIBST=SQRT(1.0-COBST*COBST)
	SIGST=SQRT(1.0-COGST*COGST)
	VSTAR=XYZV(1,1)*XYZV(2,2)*XYZV(3,3)+XYZV(2,1)*XYZV(3,2)*XYZV(1,3)
	VSTAR=VSTAR+XYZV(3,1)*XYZV(1,2)*XYZV(2,3)
	VSTAR=VSTAR-XYZV(1,3)*XYZV(2,2)*XYZV(3,1)
	VSTAR=VSTAR-XYZV(2,3)*XYZV(3,2)*XYZV(1,1)
	VSTAR=VSTAR-XYZV(3,3)*XYZV(1,2)*XYZV(2,1)
	FATA=(WAVE*BSTAR*CSTAR*SIAST)/VSTAR
	FATB=(WAVE*ASTAR*CSTAR*SIBST)/VSTAR
	FATC=(WAVE*ASTAR*BSTAR*SIGST)/VSTAR
	MAXH=2.0/WAVE*FATA
	MAXK=2.0/WAVE*FATB
	MAXL=2.0/WAVE*FATC
	WRITE  ( ITYP,36 ) MAXH,MAXK,MAXL
	COSA=(COBST*COGST -COAST)/(SIBST*SIGST)
	SINA=SQRT(1.0-COSA*COSA)
	COSB=(COAST*COGST-COBST)/(SIAST*SIGST)
	SINB=SQRT(1.0-COSB*COSB)
	COSG=(COAST*COBST-COGST)/(SIAST*SIBST)
	SING=SQRT(1.0-COSG*COSG)
	WRITE  (ITYP,47 ) FATA,FATB,FATC,COSA,COSB,COSG, WAVE
	DO 300 I = 1, 3
	DO 300 J = 1, 3
300	XYZV(I,J) = ABCV(J,I)
	RETURN
	END

	SUBROUTINE OTPUT
C
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
	 COMMON /IO/ IREAD, ITYP, IPNCH
C
C
	IPUNCH = NCARD(12) + 1
C
010	FORMAT ( 1X, 3I4, 2X, 2(I4, I2), 4I6, 2X, I4 )
011	FORMAT ( 1X, 3I4, '  NEG. ANG. - REFL. SKIPPED ' )
012	FORMAT(1H1,3I3,2(I3,I2),4I5,36X ,I4)
013	FORMAT(77X,I3)
014	FORMAT ()
C
	IF(ICOUN-9996)118,117,117
117	ICOUN=NCARD(22) - 1
118	CALL CALC3(WDTH1,WDTH2)
	PI = 3.1415926
	CHIX=CHI*180./PI+0.001
	 ICH=CHIX
	JCH=100.*(CHIX-FLOAT(ICH))
	PHIXX = NCARD(10)
	PHIX = PHI * 180. / PI + 0.001 + 0.01 * PHIXX
	IF (PHIX) 100, 101, 101
100	PHIX = PHIX + 360.
101	IPH=PHIX
	JPH=100.*(PHIX-FLOAT(IPH))
	IOM = (OMEGA * 18000.) / PI + 18000.01
	IOM1 = (OMEGA * 18000.) / PI - WDTH1  + 18000.01
	IOM2 = (OMEGA * 18000.) / PI + WDTH2  + 18000.01
	ITH = ((THETA * 36000.) / PI) + 18000.01
	ITH2 = ((THETA * 36000.) / PI) + WDTH2  + 18000.01
	ITH1 = ((THETA * 36000.) / PI) - WDTH1  + 18000.01
	IB = 0
C
	IF (ICH) 110, 102, 102
102	IF (IPH) 110, 103, 103
103	IF (IOM) 110, 104, 104
104	IF (IOM1) 110, 105, 105
105	IF (IOM2) 110, 106, 106
106	IF (ITH) 110, 107, 107
107	IF (ITH1) 110, 108, 108
108	IF (ITH2) 110, 109, 109
109	GO TO 112
110	WRITE  (ITYP, 011) IH
	GO TO 150
112	ICOUN  = ICOUN  + 1
	J17=NCARD(17)
	GO TO (115,135,125,145),J17
C
115	WRITE(ITYP,010)IH,ICH,JCH,IPH,JPH,IOM1,ITH,IOM2,IB,ICOUN
704	IF (IPUNCH - 1) 150, 150, 116
116	WRITE(IPNCH,012)IH,ICH,JCH,IPH,JPH,IOM1,ITH,IOM2,IB,ICOUN
	GO TO 150
C
125	TH1 = -0.40 * WDTH1
	TH2 = -0.20 * WDTH1
	TH3 = -0.1333 * WDTH1
	TH4 = -0.0667 * WDTH1
	TH5 = 0.0667 * WDTH2
	TH7 = 0.1333*WDTH2
	TH8 = 0.40 * WDTH2
	TH9 = WDTH2
	IT1 = ITH+ IFIX(TH1)
	IT2 = ITH+ IFIX(TH2)
	IT3 = ITH+IFIX (TH3)
	IT4 = ITH+ IFIX(TH4)
	IT5 = ITH+ IFIX(TH5)
	IT6 = ITH
	IT7 = ITH+ IFIX(TH7)
	IT8 = ITH+ IFIX(TH8)
	IT9 = ITH+ IFIX(TH9)
	WRITE (ITYP,010)IH,ICH,JCH,IPH,JPH,IOM,IT3,IT2,IT1,ICOUN
	ICOUN  = ICOUN  + 1
	WRITE(ITYP,010)IH,ICH,JCH,IPH,JPH,IOM,IT6,IT5,IT4,ICOUN
	ICOUN  = ICOUN  + 1
	WRITE(ITYP,010)IH,ICH,JCH,IPH, JPH,IOM,IT7,IT8,IT9,ICOUN
706	IF (IPUNCH - 1) 150, 150, 126
126	ICOUN = ICOUN - 2
	WRITE (IPNCH,012)IH,ICH,JCH,IPH,JPH,IOM,IT3,IT2,IT1,ICOUN
	WRITE (IPNCH, 014)
	ICOUN  = ICOUN  + 1
	WRITE(IPNCH,012)IH,ICH,JCH,IPH,JPH,IOM,IT6,IT5,IT4,ICOUN
	WRITE (IPNCH, 014)
	ICOUN  = ICOUN  + 1
	WRITE(IPNCH,012)IH,ICH,JCH,IPH, JPH,IOM,IT7,IT8,IT9,ICOUN
	WRITE (IPNCH, 014)
	GO TO 150
C
135	WRITE (ITYP, 010) IH, ICH, JCH, IPH, JPH, IOM, ITH1, ITH2, IB, IC
	1UN
	IF (IPUNCH - 1) 150, 150, 710
710	WRITE (IPNCH, 012) IH, ICH, JCH, IPH, JPH, IOM, ITH1, ITH2, IB, IC
	1OUN
	GO TO 150
C
C
145	WRITE(ITYP,010)IH,ICH,JCH,IPH,JPH,IOM,ITH,IOM1,IOM2,ICOUN
	IF (IPUNCH - 1) 150, 150, 148
148	WRITE(IPNCH,012)IH,ICH,JCH,IPH,JPH,IOM,ITH,IOM1,IOM2,ICOUN
	WRITE (IPNCH, 014)
	GO TO 150
150	RETURN
	END

	SUBROUTINE CALC1
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
	PI = 3.1415926
	PI2 = 1.5707963
	P2PI = 6.2831852
	P3PI = 9.4247778
C
	PK = IH(2)
	PL = IH(3)
	PH = IH(1)
C
100	X = PH*A(1,1) + PK*A(1,2) + PL*A(1,3)
	Y = PH*A(2,1) + PK*A(2,2) + PL*A(2,3)
	Z = PH*A(3,1) + PK*A(3,2) + PL*A(3,3)
	R1 = SQRT  ( X**2 + Y**2 )
	DSTAR = SQRT  ( R1**2 + Z**2 )
	IF (R1) 105, 101, 105
101	PHI = NCARD(21)
	PHI = PHI * PI / 180.
	IF(Z) 103, 103, 102
102	CHI = 1.5 * PI
	GO TO 120
103	CHI = 0.5 * PI
	GO TO 120
C
105	SIN1 = - Y / R1
	ANG = ASIN(SIN1)
	IF (X) 106, 110, 110
106	IF (ANG) 107, 108, 108
107	ANG = - ANG + 0.00001
	GO TO 115
108	ANG = P2PI - ANG + 0.00001
	GO TO 115
110	ANG = PI + ANG
115	IF (ANG - P2PI) 1161, 116, 116
116	ANG = ANG - P2PI
1161	PHI = ANG
	SIN1 = -Z / DSTAR
	ANG = ASIN(SIN1)
	ANG = P3PI - ANG
	IF (ANG - P2PI) 118, 117, 117
117	ANG = ANG - P2PI
118	CHI = ANG + 0.00001
C
120	OMEGA = 0.0
	SIN1 = 0.5 * DSTAR
	ANG = ASIN(SIN1)
	THETA = ANG
C
	RETURN
	END

	SUBROUTINE REF
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
C
	ISAV1 = IH(1)
	ISAV2 = IH(2)
	ISAV3 = IH(3)
C
	JA = NCARD(15)
100	DO 120  J=1, JA
	IH(1)=IHREG(1,J)
	IH(2)=IHREG(2,J)
	IH(3)=IHREG(3,J)
C
C
	CALL CALC1
	CALL OTPUT
C
120	CONTINUE
	IH(1) = ISAV1
	IH(2) = ISAV2
	IH(3) = ISAV3
C
	RETURN
	END

	SUBROUTINE GEN(JDONE)
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
C
C
100	RH = RH+RHDEL
	IF (RH-RHMAX) 110, 190, 120
110	IF (RH-RHMIN) 120, 190, 190
120	RHDEL = -RHDEL
	RH = RH+RHDEL
	RK = RK+RKDEL
	IF (RK-RKMAX) 130, 190, 140
130	IF (RK-RKMIN) 140, 190, 190
140	RKDEL = -RKDEL
	RK = RK+RKDEL
	RL = RL+RLDEL
	IF (RL-RLMAX) 150, 190, 160
150	IF (RL-RLMIN) 160, 190, 190
C
160	JDONE = 1
	GO TO 195
C
190	JDONE = 0
195	RETURN
	END

	SUBROUTINE POLAR(KDONE)
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
C
100	PHIHI = PHIHI+PHIDL
	IF(PHIHI-PHIMX - 0.000001) 110, 120, 120
110	TEST = PHIHI-ABS (PHIDL )-PHIMN + 0.000001
	IF (TEST) 120,115,115
115	PHILO = PHILO+PHIDL
	GO TO 190
120	PHIDL  = -PHIDL
	PHIHI = PHIHI+PHIDL
	CHIHI = CHIHI+CHIDL
	IF (CHIHI-CHIMX  - 0.000001) 130, 140, 140
130	TEST = CHIHI-ABS (CHIDL )-CHIMN + 0.000001
	IF (TEST) 140,135,135
135	CHILO = CHILO+CHIDL
	GO TO 190
140	CHIDL  = -CHIDL
	CHIHI = CHIHI+CHIDL
	DSHI = DSHI+DSDEL
	IF (DSHI-DSMAX - 0.000001) 150, 160, 160
150	TEST = DSHI-ABS (DSDEL)-DSMIN + 0.000001
	IF (TEST) 160,155,155
155	DSLO = DSLO+DSDEL
	GO TO 190
160	KDONE = 1
	GO TO 195
C
190	KDONE = 0
195	RETURN
	END

	SUBROUTINE  RANGE
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
	 COMMON /IO/ IREAD, ITYP, IPNCH
C
010	FORMAT(/////)
011	FORMAT ( ' GROUP SCAN LIMITS ' / '     CHI     PHI   DSTAR  2*TH')
012	FORMAT ( 4F 8.2 )
045	FORMAT ( '    H   K   L     CHI   PHI  ANG1  ANG2  ANG3  ANG4 COUN
	1T ' //)
C
	WRITE            (ITYP,010)
	WRITE            (ITYP,011)
	RAD = 180.0/3.1415926
	PH1 = PHIHI*RAD
	PH2 = PHILO*RAD
	CH1 = CHIHI*RAD
	CH2 = CHILO*RAD
	SIN1 = 0.50 * DSLO
	ANG = ASIN(SIN1)
	THLO = 2.0 * ANG * RAD
	SIN1 = 0.50 * DSHI
	ANG = ASIN(SIN1)
	THHI = 2.0 * ANG * RAD
	WRITE            (ITYP,012)CH2,PH2,DSLO,THLO
	WRITE            (ITYP,012)CH1,PH1,DSHI,THHI
	WRITE            (ITYP,010)
	WRITE (ITYP, 045)
	RETURN
	END

	SUBROUTINE CALC3 (WDTH1,WDTH2)
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
	A1 = NCARD(18)
	B1 = NCARD(19)
	C1 = NCARD(20)
C     DSTAR = 2.0 * SIN (THETA)
C     WIDTH = A1 + B1 * TAN (THETA) ,   SO THEREFORE
	WDTH1 = A1 + B1 * TAN(THETA)
	WDTH2 = A1 + C1 * TAN(THETA)
	RETURN
	END

	FUNCTION IMOD(J,M)
	AJ=J
	 AM=M
	A=AJ/AM
	K=A
	IF(A-K)2,1,2
1	IMOD=0
	GO TO 3
2	IMOD=1
3	RETURN
	END

	FUNCTION AMOD(X1,X2)

	A=X1/X2
	K=A
	IF(A-K)2,1,2
1	AMOD=0
	GO TO 3
2	AMOD=1
3	RETURN
	END

	SUBROUTINE  XTINC(NG)
C
	DIMENSION A(3,3), B(3,3), C(3,3), NCARD(24), IHREG(3,20), IH(3)
	COMMON IHREG, A, B, C, NCARD, RH, RK, RL, ICOUN, NCOUN , IH
	COMMON PHI,CHI,OMEGA,THETA,DSTAR,PHIHI,PHILO,CHIHI,CHILO,DSHI,DSLO
	COMMON RHMIN,RHMAX,RHDEL,RKMIN,RKMAX,RKDEL,RLMIN,RLMAX,RLDEL
	COMMON CHIMN,CHIMX,CHIDL,DSMIN,DSMAX,DSDEL,PHIMN,PHIMX,PHIDL
C
C
	J11 = NCARD (11)
	GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000,
	1       1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000)
	2             ,J11
C
C
C
C      P 21
C
100	IF (IH(1)) 160, 101, 160
101	IF (IH(3)) 160, 110, 160
110	IF (IMOD (IH(2),2)) 150, 160, 150
150	NG = 1
	GO TO 170
160	NG = 0
170	RETURN
C
C
C
C      P 21/C
C
200	IF (IH(2)) 210, 201, 210
201	IF (IMOD(IH(3),2)) 250, 240, 250
210	IF (IH(1)) 240, 220, 240
220	IF (IH(3)) 240, 230, 240
230	IF (IMOD (IH(2),2)) 250, 240, 250
240	NG = 0
	GO TO 260
250	NG = 1
260	RETURN
C
C
C
C      P 21 21 21
C
300	IF (IH(1)) 301, 310, 301
301	IF (IH(2)) 380, 320, 380
310	IF (IH(2)) 350, 340, 350
320	IF (IH(3)) 380, 330, 380
330	IF ( IMOD (IH(1),2)) 390, 380, 390
340	IF (IH(3)) 360, 380, 360
350	IF (IH(3)) 380, 370, 380
360	IF (IMOD (IH(3),2)) 390, 380, 390
370	IF ( IMOD(IH(2),2)) 390, 380, 390
380	NG = 0
	GO TO 399
390	NG = 1
399	 RETURN
C
C
C
C  SUBROUTINE FOR CUBIC SPACE GROUP FD3(IE OF B.B.A.)
C
400	IF(IH(1))420,410,420
410	IF(IMOD(IH(2)+IH(3),4))490,460,490
420	IF(IH(2))440,430,440
430	IF(IMOD(IH(1)+IH(3),4))490,460,490
440	IF(IH(3))460,450,460
450	IF(IMOD(IH(1)+IH(2),4))490,460,490
460	IF(IMOD(IH(2)+IH(3),2))490,470,490
470	IF(IMOD(IH(1)+IH(3),2))490,480,490
480	IF(IMOD(IH(1)+IH(2),2))490,495,490
490	NG=1
	GO TO 499
495	NG = 0
499	RETURN
C
C
500	RETURN
C
600	RETURN
C
700	RETUR
C
800	RETURN
C
900	RETURN
C
1000	RETURN
C
1100	RETURN
C
1200	RETURN
C
1300	RETURN
C
1400	RETURN
C
1500	RETURN
C
1600	RETURN
C
1700	RETURN
C
1800	RETURN
C
1900	RETURN
C
2000	RETURN
C
