C     PROGRAM TO COMPUTE POWDER PATTERNS FOR A PARTICULAR CRYSTAL
C     STRUCTURE.  THE PROGRAM GENERATES THE MILLER INDICES ACCORDING TO
C     THE LAUE GROUP, COMPUTES THE STRUCTURE FACTORS, SQUARES AND
C     APPLIES THE LP, MULTIPLICITY, TEMPERATURE, AND ABSORPTION FACTORS
C
C     THIS IS ACTUALLY AN UNCOMMENTED VERSION 10 RECEIVED FROM DEANE 9/2
C     VERSION 7
C     MODIFIED FOR D.K.SMITH BY M.A.HOLOMANY  1/28/78
C     MODIFIED TO WRITE OUTPUT PATTERN IN D5000 FORMAT OCT-91 S.I.Z.
C     ***** NOTICE *****
C        THIS PROGRAM HAS PASSED THROUGH SEVERAL VERSIONS AND HAS BEEN
C     OPERATED SUCCESSFULLY ON A LARGE NUMBER OF PROBLEMS. IT IS
C     POSSIBLE, HOWEVER, THAT UNDER SOME CIRCUMSTANCES WITH A
C     PARTICULAR COMPUTER SYSTEM, ERRONEOUS RESULTS WILL BE OBTAINED.
C     THE AUTHOR, THE PENNSYLVANIA STATE UNIVERSITY, THEREFORE TAKE
C     NO RESPONSIBILITIES FOR THE CORRECTNESS OF THE PROGRAM IN ALL
C     RESPECTS. IT WOULD BE APPRECIATED IF ANY DISCREPENCIES IN THE
C     PROGRAM ARE BROUGHT TO THE ATTENTION OF THE AUTHOR FOR
C     IMPROVEMENTS IN LATER VERSIONS.
C
C     ******            *******          ********          *****
C     *    *            *     *  <---->  *SCATFC*  <---->  *EOF*
C     *    *            *     *          ********          *****
C     *    *            *     *
C     *    *            *     *          ********          *****
C     *    *            *     *          *      *  <---->  *EOF*
C     *    *            *     *          *      *          *****
C     *    *            *     *  <---->  *SYMPOS*
C     *    *            *     *          *      *          ******
C     *    *  <------>  *READX*          *      *  <---->  *CNVT*
C     *    *            *     *          ********          ******
C     *    *            *     *
C     *    *            *     *          ********
C     *    *            *     *  <---->  *CELCON*
C     *    *            *     *          ********
C     *    *            *     *
C     *    *            *     *          ********
C     *    *            *     *  <---->  *NETOUT*
C     *    *            *     *          ********
C     *    *            *     *
C     *    *            *     *          **Q****
C     *    *            *     *  <---->  *CARDS*
C     *    *            *******          *******
C     *    *
C     *    *            ********          ******
C     *MAIN*  <------>  *INDEX *  <---->  *EXTN*
C     *    *            ********          ******
C     *    *
C     *    *            ********
C     *    *  <------>  *ORDER *
C     *    *            ********
C     *    *
C     *    *            ********          ******          ******
C     *    *            *      *  <---->  *CALC*  <---->  *MULT*
C     *    *            *      *          ******          ******
C     *    *  <------>  *SCALEX*
C     *    *            *      *          ******
C     *    *            *      *  <---->  *ABSX*
C     *    *            ********          ******
C     *    *
C     *    *            ********          ******
C     *    *  <------>  * OUTX *  <---->  *ABSX*
C     *    *            ********          ******
C     *    *
C     *    *            ********          *******
C     *    *  <------>  *CCHART*  <---->  *XPLOT*
C     ******            ********          *******
C
C     SUGGESTED OVERLAY TREE
C
C     CONTROL AND DATA       MAIN,COMMON BLOCKS,SYSTEM ROUTINES
C     OVERLAY 1              READX,CELCON,SCATFC,EOF,SYMPOS,CNVT,NETOUT,
C                            CARDS
C     OVERLAY 2              INDEX,EXTN,ORDER
C     OVERLAY 3              SCALEX,CALC,MULT,ABSX,OUTX
C     OVERLAY 4              CCHART,PLOT
C
C     SUBROUTINES USED BY THIS PROGRAM
C
C         THOSE SUBROUTINES NECESSARY FOR THIS PROGRAM TO RUN ARE
C        SUPPLIED AS DECKS. EITHER REMOVE THOSE SYSTEM ROUTINES OR
C        REPLACE WITH LOCAL SYSTEM ROUTINES
C
C     MAIN    CALLING AND TIMING                           DECK
C     READX   READ INPUT CARDS, PREPARE FOR COMPUTATION    DECK
C     SYMPOS  READ SYMMETRY DATA FROM TAPE OR CARDS        DECK
C     CNVT    CONVERT SYMMETRY TO INTERNAL FORMAT          DECK
C     SCATFC  READ SCATTERING FACTORS FROM TAPE OR CARDS   DECK
C     EOF     READ TO END OF TAPE FILE                     DECK
C     CELCON  COMPUTE RECIPROCAL CELL CONSTANTS AND CROSS-
C                 PRODUCTS                                 DECK
C     NETOUT  PRINT LATTICE AND EXTINCTION TYPE            DECK
C     CARDS    INPUT ERROR - SKIP TO NEXT DATA SET         DECK
C     INDEX   COMPUTE H,K,L AND D - ALL NONREDUNDANT       DECK
C     EXTN    REJECT REFLECTIONS SYSTEMATICALLY EXTINCT    DECK
C     ORDER   ORDER REFLECTIONS BY DESCENDING D            DECK
C     SCALEX  FIND SCALE REFLECTION AND CALCULATE SCALE
C                 FACTORS AND ABSORPTION TABLE             DECK
C     CALC    CALCULATE F FOR ONE REFLECTION               DECK
C     OUTX    PRINT RESULTS                                DECK
C     ABSX    CALCULATE ABSORPTION CORRECTION              DECK
C     CCHART  CALCULATE DIFFRACTOMETER TRACE               DECK
C     XPLOT   PLOT THE CALCULATED TRACE
C             *****VERY SYSTEM DEPENDENT - DUMMY SUPPLIED  DECK
C     TIME    CPU TIME                                     SYSTEM
C     DATE    MONTH, DATE, AND YEAR                        SYSTEM
C     TIMREM  TIME LEFT TIL MAX GIVEN FOR JOB              SYSTEM
C
C     SYSTEM ROUTINES MAY DE DUMMIED OUT WITHOUT HARMING THE LOGIC
C
C     DUMMY SUBROUTINES TO SUBSTITUTE FOR PSU SYSTEM ROUTINES
C
C	SUBROUTINE TIME(N)
C	BYTE N(8)
C	N = TIM(N)
C	RETURN
C	END
C
C	SUBROUTINE DATE(I)
C	BYTE I(9)
C	I = DAT(I)
C	RETURN
C	END
C
C      SUBROUTINE TIMREM(I)
C      I=100
C      RETURN
C      END
C
C     FUNCTIONS USED BY THE PROGRAM
C
C     IABS    ABSOLUTE VALUE OF AN INTEGER                 SYSTEM
C     ABS     ABSOLUTE VALUE OF A REAL NUMBER              SYSTEM
C     SIGN    SIGN OF SECOND REAL ARG APPLIED TO FIRST     SYSTEM
C     FLOAT   REAL VALUE OF AN INTEGER                     SYSTEM
C     SIN     SINE                                         SYSTEM
C     COS     COSINE                                       SYSTEM
C     ACOS    ARCOSINE                                     SYSTEM
C     ATAN    ARCTANGENT                                   SYSTEM
C     EXP     NATURAL LOG                                  SYSTEM
C     SQRT    SQUARE ROOT                                  SYSTEM
C     MOD     REMAINDER OF TWO INTEGER ARGUMENTS           SYSTEM
C     AMOD    REMAINDER OF TWO REAL ARGUMENTS              SYSTEM
C     CHEQ     2 LOGICAL VARIABLES EQUAL - T OR F          SYSTEM
C
C
C     ***NOTE*** YOU MAY GET COMPILATION WARNINGS ON COMMON BLOCKS
C     /CAL/ AND /DATA/ --- THESE ARE PURPOSLY OF DIFFERENT SIZES TO
C     ACT AS A SORT OF EQUIVALENCE TO CUT DOWN ON THE AMOUNT OF MEMORY
C     USED
C
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	DATA NSTOP/4H%*  /
C
C     SET I/O UNIT NUMBERS
C
	NJOB=0
C  FORTRAN INPUT
	NIN=5
	NOUT=6
	NPUNCH=7
	NSCRT1=9
	NFILE=30
c
c
c
c  open the scratch files so they will be deleted at the end of the run
c
       	OPEN(UNIT=10, TYPE='SCRATCH')
       	OPEN(UNIT=11, TYPE='SCRATCH')
C
C     BEGIN DATA SET PROCESSING
C
100	YBEGIN = 0.0
	YBEGIN = SECNDS (YBEGIN)
	NJOB=NJOB+1
C
C     READ INPUT DATA USING SUBROUTINE READ
C
	CALL READX
	IF (IOUT.EQ.1) GO TO 100
	IF (NPLOT.LT.0) GO TO 110
C
C     GENERATE MILLER INDICES
C
	CALL INDEX
C
C     ENTER SUBROUTINE TO ORDER REFLECTIONS BY DECENDING D-VALUES
C
	CALL ORDER
C
C     DETERMINE SCALE FACTORS
C
	CALL SCALEX
C
C     PREPARE AND PUT OUT DATA
C
	CALL OUTX
C
C     PLOT THE DIFFRACTOMETER TRACE
C
	IF (NPLOT.EQ.0) GO TO 120
	IF (NPLOT.GE.2) GO TO 120
110	CALL CCHART
C
C     TERMINATE PROGRAM
C
120	YBEGIN = SECNDS (YBEGIN)
	WRITE (NOUT,130) NJOB,YBEGIN
130	FORMAT (17H0TIME USED BY JOB,I3,3H IS,F10.2,8H SECONDS)
C     IF LESS THAN 20 SECONDS REMAINING - TERMINATE JOB
C
C
	READ (NIN,140,END=150) ISTOP
140	FORMAT (A2)
	IF (ISTOP.EQ.NSTOP) GO TO 100
150	WRITE (NOUT,160)
160	FORMAT (1H0,'NORMAL TERMINATION OF POWD10')
	STOP
	END
	
	SUBROUTINE ABSX (SST,TTH,ABS)
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	DIMENSION AX(19)
C
C     SET UP (SIN THETA)**2 TABLE
C
	DATA AX/0.0,0.0076,0.0302,0.0670,0.1170,0.1786,0.250,0.3290,0.4132
	1,0.5000,0.5868,0.6710,0.7500,0.8214,0.8830,0.9330,0.9698,0.9924,1.
	20/
	GO TO (140,100,150), IA
C
C     INTERPOLATE ABSORPTION FACTOR
C
100	DO 130  I=1,19
	IF (AX(I)-SST) 130,110,120
110	ABS=1.0/A(I)
	GO TO 160
120	FRACPT=(AX(I)-SST)/(AX(I)-AX(I-1))
	FRACA=(A(I)-A(I-1))*FRACPT
	ABS=1.0/(A(I)-FRACA)
	GO TO 160
130	CONTINUE
140	XMU=XMUR/0.015
C
C     CALCULATE FLAT SPECIMEN ABSORPTION FACTOR
C          ASSUME SPECIMEN THICKNESS IS 0.1
C
C     XPONNT LIMIT LOWERED FROM 100 TO 85  2/83  M.Z.
150	XPONNT = 0.20*XMU/SIN(TTH/114.5916)
	IF (XPONNT .GT. 85.) XPONNT=85.
	ABS = 1.0/(1.0-EXP(-XPONNT))
160	RETURN
	END
	
	SUBROUTINE CALC (N,F,Y,SST,TTH)
	INTEGER*2 IH,IK,IL,IS,ISFA
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,E(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /CELLS/RCP(14),PRCP(6)
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
	DIMENSION DADFI(99),DBDFI(99),HJ(3),HHJ(6),H(3)
C
C     CALCULATE FORM FACTORS AND STRUCTURE FACTORS
C
	H(1)=IH(N)
	H(2)=IK(N)
	H(3)=IL(N)
C
C     COMPUTE REQUIRED SUMS OVER NS SYMMETRY TRANSFORMATIONS FOR EACH OF
C     NA ATOMS
C
	DO 100  I=1,NA
	DADFI(I)=0.0
100	DBDFI(I)=0.0
C
C        START LOOP THROUGH THE NS SYMMETRY TRANSFORMATIONS
	DO 160  J=1,NS
C
C     STORE TRANSFORMED INDICES
C
	TJ=0.0
	DO 120  I=1,3
	TJ=TJ+H(I)*TS(I,J)
	HJ(I)=0.0
	DO 110  K=1,3
	FS=IS(I,K,J)
110	HJ(I)=HJ(I)+H(K)*FS
120	CONTINUE
C
C     COMPUTE PRODUCTS OF TRANSFORMED INDICES
C
	HHJ(1)=HJ(1)**2
	HHJ(2)=HJ(2)**2
	HHJ(3)=HJ(3)**2
	HHJ(4)=2.0*HJ(1)*HJ(2)
	HHJ(5)=2.0*HJ(1)*HJ(3)
	HHJ(6)=2.0*HJ(2)*HJ(3)
C
C     START LOOP THROUGH THE NA ATOMS
C
	DO 150  I=1,NA
C
C     COMPUTE TRIGONOMETRIC TERMS
C
	HX=TJ+HJ(1)*XYZ(1,I)+HJ(2)*XYZ(2,I)+HJ(3)*XYZ(3,I)
	COSIJ=COS(6.283185*HX)
	SINIJ=SIN(6.283185*HX)
C
C     COMPUTE ANISOTROPIC TEMPERATURE FACTOR
C
	IF (ITF.EQ.0) GO TO 140
	HHB=0.0
	DO 130  K=1,6
130	HHB=HHB+HHJ(K)*BETA(K,I)
	EXPIJ=EXP(-HHB)
	COSIJ=COSIJ*EXPIJ
	SINIJ=SINIJ*EXPIJ
C
C     ACCUMULATE REQUIRED SUMS
C
140	DADFI(I)=DADFI(I)+COSIJ
C
C     BYPASS REMAINING SUMS IF CENTROSYMMETRIC
C
	IF (ICENT.NE.0) GO TO 150
	DBDFI(I)=DBDFI(I)+SINIJ
150	CONTINUE
C
C     END LOOP THROUGH THE NA ATOMS
C
160	CONTINUE
C
C     END LOOP THROUGH THE NS SYMMETRY TRANSFORMATIONS
C
C     COMPUTE A AND B
C
	A=0.0
	B=0.0
	IF (N.NE.NMAX) GO TO 170
	RHO=H(1)**2*PRCP(1)+H(2)**2*PRCP(2)+H(3)**2*PRCP(3)+2.0*H(1)*H(2)*
	1PRCP(4)+2.0*H(1)*H(3)*PRCP(5)+2.0*H(2)*H(3)*PRCP(6)
	SINTHL=SQRT(RHO)
	GO TO 180
170	SINTHL=1.0/(2.0*D(N))
	RHO=SINTHL*SINTHL
180	IF (NORFL.EQ.0) GO TO 190
	PT=SINTHL/0.05+1.0
	IPT=PT
	FRACPT=PT-DFLOAT(IPT)
C
C     START LOOP THROUGH NA ATOMS
C
190	DO 300  I=1,NA
C
C     OBTAIN SCATTERING FACTOR
C
	IF (NF) 210,200,210
200	FI=SF(I)
	RFI=0.0
	FI1=0.0
	GO TO 260
210	L=SF(I)
	IF (L.GT.NORFL) GO TO 220
	FI=FX(IPT,L)+(FX(IPT+1,L)-FX(IPT,L))*FRACPT+0.50*FRACPT*(FRACPT-1.
	10)*(FX(IPT+2,L)-2.0*FX(IPT+1,L)+FX(IPT,L))
	GO TO 230
220	FI=FX(1,L)*EXP((-RHO)*FX(2,L))+FX(3,L)*EXP((-RHO)*FX(4,L))+FX(5,L)
	1*EXP((-RHO)*FX(6,L))+FX(7,L)*EXP((-RHO)*FX(8,L))+FX(9,L)
230	IF (ISFA(I)) 240,240,250
240	RFI=0.0
	FI1=0.0
	GO TO 260
250	L=ISFA(I)
	FI1=FX(NAS,L)
	RFI=FX(NAS+1,L)
C
C     COMPUTE ISOTROPIC TEMPERATURE FACTOR
C
260	IF (ITF.EQ.0) GO TO 270
	TFI=1.0
	GO TO 280
270	TFI=EXP(-BETA(1,I)*RHO)
C
C     COMPUTE A
C
280	FI=FI+FI1
	FTA=FI*TFI*AI(I)
	RFTA=RFI*TFI*AI(I)
	FTACOS=FTA*DADFI(I)-RFTA*DBDFI(I)
	A=A+FTACOS
C
C     COMPUTE B
C
	IF (ICENT.EQ.0) GO TO 290
	IF (NAS.EQ.0) GO TO 300
290	FTASIN=FTA*DBDFI(I)+RFTA*DADFI(I)
	B=B+FTASIN
300	CONTINUE
C
C     END LOOP THROUGH THE NA ATOMS
C
C     COMPUTE OVERALL TEMPERATURE FACTOR
C
	SQTO=EXP(-TO*RHO)
C
C     CALCULATE F
C
	IF (ICENT.EQ.0) GO TO 310
	IF (NAS.NE.0) GO TO 310
	CA=SIGN(2.0*SQTO,A)
	F=CA*A
	GO TO 320
310	SQRTAB=SQRT(A**2+B**2)
	F=SQTO*SQRTAB
C     CORRECT F'S FOR CENTRIC AND ANOMALOUS CASE (SYM OP -X-Y-Z OMITTED)
	IF (ICENT .NE. 0) F=2.0*F
C
C     CALCULATE LP CORRECTION
C
320	ST=XLAMDA*SINTHL
	SST=ST**2
	CT=SQRT(1.0-SST)
	TTH=114.5916*ATAN(ST/CT)
	XLP=4.0*SST*CT
	IF (NLAMDA.GE.0)
	1 XLP = XLP*(1.0+COS(TTHIBM))*0.5/(4.0*(1.0+(1.0-2.0*SST)**2
	2       *COS(TTHIBM)*COS(TTHDBM)))
C
C     CALL THE SUBROUTINE TO DETERMINE THE MULTIPLICITY
C
	CALL MULT (N,FAC)
C
C     APPLY MULTIPLICITY AND LP CORRECTIONS
C     APPLY LATTICE CENTERING MULTIPLIER
C
	F=F*CENTR
	Y=(F**2*FAC)/XLP
C
C     THE EXPERIMENTAL CONDITION FUNCTION - G MAY BE ADDED TO THE
C        CALCULATION BY INSERTING THE FOLLOWING
C     *****     ADD TO CALC HERE
C     Y=GEXPT(Y)
C
C     *****     ADD THE FUNCTION GEXPT(Y)
C     FUNCTION GEXPT(Y)
C
C     EXPERIMENTAL CONDITION FUNCTION
C
C     RETURN
C     DEFAULT G=1
C
C     GEXPT=Y*1.0
C     END
C
	RETURN
	END
	
	SUBROUTINE CARDS
C
C     INPUT ERROR - SKIP TO NEXT DATA SET
C
	INTEGER*2 ISTOP,NSTOP
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	DATA ISTOP/2H%*/
100	READ (NIN,110,END=120) NSTOP
110	FORMAT (A2)
	IF (NSTOP.NE.ISTOP) GO TO 100
	REWIND NFILE
	IOUT=1
	RETURN
120	WRITE (NOUT,130)
130	FORMAT (42H0**********     END OF DATA     **********)
	STOP
	END
	
	SUBROUTINE CELCON
C
C      CALCULATE RECIPROCAL CELL CONSTANTS
C
	COMMON /CELLS/A,B,C,COSAL,COSBE,COSGA,RCV,RCP(6),VOL,PRCP(6)
	SINAL=SQRT(1.0-COSAL**2)
	SINBE=SQRT(1.0-COSBE**2)
	SINGA=SQRT(1.0-COSGA**2)
	RCV=A*B*C*SQRT(1.0-COSAL**2-COSBE**2-COSGA**2+2.0*COSAL*COSBE*COSG
	1A)
	RCP(1)=B*C*SINAL/RCV
	RCP(2)=A*C*SINBE/RCV
	RCP(3)=A*B*SINGA/RCV
	RCP(4)=(COSBE*COSGA-COSAL)/(SINBE*SINGA)
	RCP(5)=(COSAL*COSGA-COSBE)/(SINAL*SINGA)
	RCP(6)=(COSAL*COSBE-COSGA)/(SINAL*SINBE)
	VOL=RCP(1)*RCP(2)*RCP(3)*SQRT(1.0-RCP(4)**2-RCP(5)**2-RCP(6)**2+2.
	10*RCP(4)*RCP(5)*RCP(6))
C
C     CALCULATE CROSS PRODUCTS OF RECIPROCAL CELL PARAMETERS
C
	PRCP(1)=RCP(1)**2*0.25
	PRCP(2)=RCP(2)**2*0.25
	PRCP(3)=RCP(3)**2*0.25
	PRCP(4)=RCP(1)*RCP(2)*RCP(6)*0.25
	PRCP(5)=RCP(1)*RCP(3)*RCP(5)*0.25
	PRCP(6)=RCP(2)*RCP(3)*RCP(4)*0.25
	RETURN
	END
	
	SUBROUTINE CNVT
	REAL*8 ATOM
	INTEGER*2 IS,ISFA,ICHAR,IALPHA,IALPOS,IALNEG,IALCOM,IALFAX,IALFAY,
	1IALFAZ,IALSP,IALSLH
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
	LOGICAL*1 FILLR2
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
      COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
      COMMON /DATA/ATOM(99),ATWT(99),XMURHO(99),BXYZ(6),URHO(7,20),
     1 WEIGHT(20),RDUMMY(439),NNF(20),NTRAN(3),JEXT(13),JNUM(3),JDEN(3),
     2 JCX(3),JCY(3),JCZ(3),ITRAN(30),M,IDUMMY(885),ICHAR(72),
     3 FILLR2(1850)
	DIMENSION IALPHA(9)
	DATA IALPHA/2H1 ,2H2 ,2H3 ,2H4 ,2H5 ,2H6 ,2H7 ,2H8 ,2H9 /,IALPOS/2
	1H+ /,IALNEG/2H- /,IALCOM/2H, /,IALFAX/2HX /,IALFAY/2HY /,IALFAZ/2H
	2Z /,IALSP/2H  /,IALSLH/2H/ /
C
	IF (NS.LE.0) GO TO 210
C
C     TRANSLATE X,Y,Z FORMAT TO INTERNAL FORMAT
C
C     BEGIN LOOP THRU ITH COORDINATE
C
	NJ=1
	DO 200  I=1,3
C     INITIALIZE LALS VARIABLES
	JNUM(I)=0
	JDEN(I)=0
	JCX(I)=0
	JCY(I)=0
	JCZ(I)=0
	NN=1
C
C     BEGIN LOOP BETWEEN COMMAS ON INPUT CARD
C
	DO 180  J=NJ,72
	ICH=ICHAR(J)
C
C     CHECK FOR NUMBER
C
	DO 120  K=1,9
	IF (ICH.NE.IALPHA(K)) GO TO 120
C     CHECK FOR NONZERO NUMERATOR
	IF (JNUM(I).NE.0) GO TO 110
C
100	NNUM=K
	NN=NNUM*NN
	GO TO 180
C     CHECK FOR NONZERO DENOMINATOR
110	IF (JDEN(I).NE.0) GO TO 100
	JDEN(I)=K
	GO TO 170
120	CONTINUE
C
C     CHECK FOR X,Y, OR Z AND SET JC*(I) TO VALUE OF NN IF FOUND
C
	IF (ICH.NE.IALFAX) GO TO 130
	JCX(I)=NN
	GO TO 170
130	IF (ICH.NE.IALFAY) GO TO 140
	JCY(I)=NN
	GO TO 170
140	IF (ICH.NE.IALFAZ) GO TO 150
	JCZ(I)=NN
	GO TO 170
C     PLUS(+) - IGNORE
150	IF (ICH.EQ.IALPOS) GO TO 180
C     COMMA (,) - END OF LOOP THRU ITH COORDINATE
	IF (ICH.EQ.IALCOM) GO TO 190
C     SLASH (/) - END OF NUMERATOR, DENOMINATOR FOLLOWS
	IF (ICH.EQ.IALSLH) GO TO 160
C     MINUS (-) - MAKE NN NEGATIVE
	IF (ICH.EQ.IALNEG) NN=-NN
C     INVALID CHARACTER - IGNORE
	GO TO 180
160	JNUM(I)=NN
C     RESET COUNTER
170	NN=1
180	CONTINUE
190	NJ=J+1
200	CONTINUE
C
C     CONVERT SYMMETRY DATA TO ORFLS FORMAT USED IN CALCULATION
C
210	M=M+1
	DO 220  K=1,3
C
C     CONVERT TRANSLATION TO REAL FRACTION IN ARRAY TS(3,192)
	ANUM=JNUM(K)
	ADEN=JDEN(K)
	IF (JDEN(K).EQ.0) ADEN=1.0
	TS(K,M)=ANUM/ADEN
C
C     PLACE XYZ DATA IN ARRAY IS(3,3,192)
	IS(1,K,M)=JCX(K)
	IS(2,K,M)=JCY(K)
220	IS(3,K,M)=JCZ(K)
C
C     CONVERT SYMMETRY POSITIONS TO XYZ FORMAT FOR PRINTED OUTPUT
C
	IF (IXYZ.NE.0) GO TO 480
	K=0
	DO 430  I=1,3
	KNUM=JNUM(I)
	KDEN=JDEN(I)
	KCX=JCX(I)
	KCY=JCY(I)
	KCZ=JCZ(I)
C     CONVERT TRANSLATIONAL FRACTION TO CHARACTER FRACTION
	K=K+1
	IF (KNUM) 230,250,240
230	ICHAR(K)=IALNEG
	K=K+1
240	ICHAR(K)=IALPHA(KNUM)
	K=K+1
	ICHAR(K)=IALSLH
	K=K+1
	ICHAR(K)=IALPHA(KDEN)
	K=K+1
C     CONVERT X
250	IF (KCX) 260,310,270
260	ICHAR(K)=IALNEG
	KCX=-KCX
	GO TO 280
270	ICHAR(K)=IALPOS
280	K=K+1
	IF (KCX-1) 490,300,290
290	ICHAR(K)=IALPHA(KCX)
	K=K+1
300	ICHAR(K)=IALFAX
	K=K+1
C      CONVERT Y
310	IF (KCY) 320,370,330
320	ICHAR(K)=IALNEG
	KCY=-KCY
	GO TO 340
330	ICHAR(K)=IALPOS
340	K=K+1
	IF (KCY-1) 490,360,350
350	ICHAR(K)=IALPHA(KCY)
	K=K+1
360	ICHAR(K)=IALFAY
	K=K+1
C      CONVERT Z
370	IF (KCZ) 380,430,390
380	ICHAR(K)=IALNEG
	KCZ=-KCZ
	GO TO 400
390	ICHAR(K)=IALPOS
400	K=K+1
	IF (KCZ-1) 490,420,410
410	ICHAR(K)=IALPHA(KCZ)
	K=K+1
420	ICHAR(K)=IALFAZ
	K=K+1
430	ICHAR(K)=IALCOM
C      FILL REMAINDER OF 72 CHARACTER RECORD WITH BLANKS
440	ICHAR(K)=IALSP
	IF (K-72) 450,460,490
450	K=K+1
	GO TO 440
460	WRITE (NOUT,470) ICHAR
470	FORMAT (1H ,72A1)
480	RETURN
490	WRITE (NOUT,500)
500	FORMAT (43H ERROR IN SYMMETRY CONVERSION TO XYZ FORMAT)
	CALL CARDS
	GO TO 480
	END

	SUBROUTINE EOF (N)
C
C     SUBROUTINE TO FIND ENDFILE - FOR A DATA TAPE
C
C     FOR A DISK BASED SYSTEM THIS COULD BE
C        EITHER REPLACED BY AN UPDATE OF THE FILE NUMBER IN THIS ROUTINE
C             (AND RESET FOR EACH DATA SET IN READX OR MAIN)
C        OR EACH FILE GIVEN A SEPARATE NUMBER (IN SCATFC,SYMPOS,SCALEX)
C
C******************** THIS VERSION IS FOR THE VAX VMS SYSTEM WHERE
C******************** THE DATA FILES ARE ON DISK
C
	CHARACTER*40  NAME
	CHARACTER*1 NUM(10)
	DATA NUM/'1','2','3','4','5','6','7','8','9','0'/
	DATA NAME/'POWD:[PUBLIC.EXE.POWD10]POWD10FL*.BIN'/
	N = N + 1
	IF(N .GE. 37) N = 31
C
C  SET UP AND OPEN THE FILE 
C
	M = N - 30
	NAME(33:33) = NUM(M)
	OPEN(UNIT=N, FILE=NAME, STATUS='OLD', FORM='UNFORMATTED',
     1 READONLY)
C100	READ (N,END=110)
C	GO TO 100
C110	RETURN
	RETURN
	END

	SUBROUTINE EXTN
C
C     REJECT SYSTEMATICALLY EXTINCT REFLECTIONS
C
	INTEGER*2 IH,IK,IL
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /EXTNS/RECD,LAUE,I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13
	1,NEX,NH,NK,NL,JNUM
	NEX=0
	JJ=JJ+1
	IF (JJ.LE.JNUM) GO TO 100
C
C     TOO MANY REFLECTIONS, INCREASE DMIN AND TRY AGAIN
C
	NEX=-1
	DMIN=DMIN*1.1
	JJ=JJ-1
	GO TO 730
C
C     I1 - LATTICE TYPE (ALL HKL)
C
100	GO TO (220,110,140,150,160,170,200,180,190,220), I1
C     A (K+L=2N)
110	IX=NK+NL
120	IXI=MOD(IX,2)
	IF (IXI.EQ.0) GO TO 220
130	NEX=1
	JJ=JJ-1
	GO TO 730
C     B (H+L=2N)
140	IX=NH+NL
	GO TO 120
C     C (H+K=2N)
150	IX=NH+NK
	GO TO 120
C     F (H+K=2N,H+L=2N,K+L=2N)
160	IX=NK*NH*NL
	IF (MOD(IX,2).NE.0) GO TO 220
	IF (MOD(NH,2).NE.0) GO TO 130
	IF (MOD(NK,2).NE.0) GO TO 130
	IX=NL
	GO TO 120
C     I (H+K+L=2N)
170	IX=NH+NK+NL
	GO TO 120
C     R(R) (H-K+L=3N)
180	IX=NH-NK+NL
	GO TO 210
C     H (H-K=3N)
190	IX=NH-NK
	GO TO 210
C     R(O) (-H+K+L=3N)
200	IX=NK-NH+NL
210	IF (MOD(IX,3).NE.0) GO TO 130
C     I2 (HK0 ZONE)
C
220	IF (NL.NE.0) GO TO 280
	GO TO (280,260,230,240,250,280), I2
C     B-GLIDE (K=2N)
230	IX=NK
	GO TO 270
C     N-GLIDE (H+K=2N)
240	IX=NH+NK
	GO TO 270
C     D-GLIDE (H+K=4N,H=2N,K=2N)
250	IX=NH+NK
	IF (MOD(IX,4).EQ.0) GO TO 230
	GO TO 130
C     A-GLIDE (H=2N)
260	IX=NH
270	IF (MOD(IX,2).NE.0) GO TO 130
C
C     I3 (H0L ZONE)
C
280	IF (NK.NE.0) GO TO 340
	GO TO (340,320,300,310,290,340), I3
290	IX=NH+NL
C     D-GLIDE (H+L=4N,H=2N,L=2N)
	IF (MOD(IX,4).NE.0) GO TO 130
C     C-GLIDE (L=2N)
300	IX=NL
	GO TO 330
C     N-GLIDE (H+L=2N)
310	IX=NH+NL
	GO TO 330
C     A-GLIDE (H=2N)
320	IX=NH
330	IF (MOD(IX,2).NE.0) GO TO 130
C
C     I4 (0KL ZONE)
C
340	IF (NH.NE.0) GO TO 400
	GO TO (400,380,360,370,350,400), I4
C     D-GLIDE (K+L=4N,K=2N,L=2N)
350	IX=NK+NL
	IF (MOD(IX,4).NE.0) GO TO 130
C     C-GLIDE (L=2N)
360	IX=NL
	GO TO 390
C     N-GLIDE (K+L=2N)
370	IX=NK+NL
	GO TO 390
C     B-GLIDE (K=2N)
380	IX=NK
390	IF (MOD(IX,2).NE.0) GO TO 130
C
C     I5 (HHL ZONE)
C
400	IF (NH-NK.NE.0) GO TO 410
	IN=I5
	GO TO 420
C
C     I6 (-HHL ZONE)
C
410	IF (NH+NK.NE.0) GO TO 460
	IN=I6
420	GO TO (460,430,440,460), IN
C     C(N)-GLIDE (L=2N)
430	IXI=MOD(NL,2)
	GO TO 450
C     D-GLIDE (2H+L=4N)
440	IX=2*NH+NL
	IXI=MOD(IX,4)
450	IF (IXI.NE.0) GO TO 130
C
C     I9 (HKK ZONE)
C
460	IF (NK-NL.NE.0) GO TO 470
	IN=I9
	GO TO 480
C
C     I10 (H-KK ZONE)
C
470	IF (NK+NL.NE.0) GO TO 520
	IN=I10
480	GO TO (520,490,500,520), IN
C     A(N)-GLIDE (H=2N)
490	IXI=MOD(NH,2)
	GO TO 510
C     D-GLIDE (2K+H=4N)
500	IX=NH+2*NL
	IXI=MOD(IX,4)
510	IF (IXI.NE.0) GO TO 130
C
C     I7 (HKH ZONE)
C
520	IF (NH-NL.NE.0) GO TO 530
	IN=I7
	GO TO 540
C
C     I8 (-HKH ZONE)
C
530	IF (NH+NL.NE.0) GO TO 580
	IN=I8
540	GO TO (580,550,560,580), IN
C     B(N)-GLIDE (K=2N)
550	IXI=MOD(NK,2)
	GO TO 570
C     D-GLIDE (2H+K=4N)
560	IX=2*NH+NK
	IXI=MOD(IX,4)
570	IF (IXI.NE.0) GO TO 130
C
C     I11 (H00 ROW)
C
580	IF (NK.NE.0.OR.NL.NE.0) GO TO 620
	GO TO (620,590,600,620), I11
C     2(1) OR 4(2) SCREW H=2N)
590	IXI=MOD(NH,2)
	GO TO 610
C     4(1) OR 4(3) SCREW (H=4N)
600	IXI=MOD(NH,4)
610	IF (IXI.NE.0) GO TO 130
C
C     I12 (0K0 ROW)
C
620	IF (NH.NE.0.OR.NL.NE.0) GO TO 660
	GO TO (660,630,640,660), I12
C     2(1) OR 4(2) SCREW (K=2N)
630	IXI=MOD(NK,2)
	GO TO 650
C     4(1) OR 4(3) SCREW (K=4N)
640	IXI=MOD(NK,4)
650	IF (IXI.NE.0) GO TO 130
C
C     I13 (00L ROW)
C
660	IF (NH.NE.0.OR.NK.NE.0) GO TO 720
C     ELIMINATE 000 REFLECTION
	IF (NL.EQ.0) GO TO 130
	GO TO (720,670,680,690,700,720), I13
C     2(1),4(2) OR 6(3) SCREW (L=2N)
670	IXI=MOD(NL,2)
	GO TO 710
C     3(1),3(2),6(2) OR 6(4) SCREW (L=3N)
680	IXI=MOD(NL,3)
	GO TO 710
C     4(1) OR 4(3) SCREW (L=4N)
690	IXI=MOD(NL,4)
	GO TO 710
C     6(1) OR 6(5) SCREW (L=6N)
700	IXI=MOD(NL,6)
710	IF (IXI.NE.0) GO TO 130
720	IH(JJ)=NH
	IK(JJ)=NK
	IL(JJ)=NL
730	RETURN
	END
	
	SUBROUTINE INDEX
C
C     SUBROUTINE TO GENERATE MILLER INDICES ACCORDING TO THE SPECIFIC
C     LAUE GROUP WITHOUT REDUNDANCIES
C
C     THE CODE WORD, LAUE, FOUND ON THE POWDER DATA CONTROL CARD HAS THE
C     FOLLOWING INTERPRETATION
C         LAUE = 1   LAUE GROUP -1
C         LAUE = 2   LAUE GROUP 2/M (Y AXIS UNIQUE)
C         LAUE = 3   LAUE GROUP 2/M (Z AXIS UNIQUE)
C         LAUE = 4   LAUE GROUP MMM
C         LAUE = 5   LAUE GROUP 4/M
C         LAUE = 6   LAUE GROUP 4/MMM
C         LAUE = 7   LAUE GROUP M3
C         LAUE = 8   LAUE GROUP M3M
C         LAUE = 9   LAUE GROUP -3     RHOMBOHEDRAL AXES
C         LAUE =10   LAUE GROUP -3M    RHOMBOHEDRAL AXES
C         LAUE =11   LAUE GROUP -3     HEXAGONAL AXES
C         LAUE =12   LAUE GROUP -3M    HEXAGONAL AXES
C         LAUE =13   LAUE GROUP 6/M
C         LAUE =14   LAUE GROUP 6/MMM
C         LAUE =15   LAUE GROUP -3M    ROTATED
C
	INTEGER*2 IH,IK,IL
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,E(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
C
C  NMAX = THE MAXIMUM NUMBER OF REFLECTIONS ALLOWED
C
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /EXTNS/RECD,LAUE,IEXT(13),NEX,NH,NK,NL,JNUM
	COMMON /CELLS/A,B,C,AL,BE,GA,RCV,RCP(6),VOL,PRCP(6)
	DIMENSION HH(100),HK(100),HL(100)
	NMAX = 1001
	DO 100  I=1,100
	HH(I)=0.0
	HK(I)=0.0
100	HL(I)=0.0
	DO 110  I=1,NMAX
	D(I)=0.0
	IH(I)=0
	IK(I)=0
110	IL(I)=0
	DO 120  I=1,13
120	IEXT(I)=IEXT(I)+1
	JNUM=NMAX
	IF (NAS.GT.0) JNUM=NMAX/2
C
C     DETERMINE MAXIMUM INDICES
C
C     SET UP RANGE OF MILLER INDICES
C
	HLMAX=C/DMIN
	LMAX=HLMAX+1.0
	DO 130  K=1,LMAX
130	HL(K+1)=HL(K)+1.0
C
	HKMAX=B/DMIN
	KMAX=HKMAX+1.0
	IF (LAUE.EQ.1) GO TO 150
	DO 140  J=1,KMAX
140	HK(J+1)=HK(J)+1.0
	GO TO 170
150	KMAX=2*KMAX-1
	N=HKMAX
	HK(1)=N
	DO 160  J=1,KMAX
160	HK(J+1)=HK(J)-1.0
C
170	HHMAX=A/DMIN
	IMAX=HHMAX+1.0
	IF (LAUE.LE.3) GO TO 190
	DO 180  I=1,IMAX
180	HH(I+1)=HH(I)+1.0
	GO TO 210
190	IMAX=2*IMAX-1
	M=HHMAX
	HH(1)=M
	DO 200  I=1,IMAX
200	HH(I+1)=HH(I)-1.0
C
210	JJ=0
	GO TO (220,260,310,350,350,820,460,460,460,460,820,820,820,820,820
	1), LAUE
C
C     TRICLINIC SYSTEM - LAUE GROUP -1
C
C     GENERATE MILLER INDICES (H00)
C
220	NK=0
	NL=0
	DO 250  I=1,M
	NH=HH(I)
	CALL EXTN
	IF (NEX) 210,230,250
230	RECD=HH(I)*RCP(1)
	IF (RECD.EQ.0) GO TO 240
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 250
240	JJ=JJ-1
250	CONTINUE
C
C     GENERATE MILLER INDICES (HK0) (K NOT ZERO)
C
	JQ=N
	IQ=IMAX
	ASSIGN 400 TO NINDX
	GO TO 270
C
C     MONOCLINIC SYSTEM (Y UNIQUE)
C
260	JQ=KMAX
	IQ=M+1
	ASSIGN 410 TO NINDX
	NL=0
C
C     GENERATE MILLER INDICES (HK0)
C
270	DO 300  J=1,JQ
	DO 300  I=1,IQ
	NH=HH(I)
	NK=HK(J)
	CALL EXTN
	IF (NEX) 210,280,300
280	RECD=0.0
	IF (LAUE.EQ.1) RECD=HH(I)*HK(J)*PRCP(4)*2.0
	RECD=2.0*SQRT(HH(I)**2*PRCP(1)+HK(J)**2*PRCP(2)+RECD)
	IF (RECD.EQ.0) GO TO 290
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 300
290	JJ=JJ-1
300	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (L NOT ZERO)
C
	JQ=1
	KQ=2
	GO TO 370
C
C     MONOCLINIC SYSTEM (Z UNIQUE)
C
310	MN=M+1
	NK=0
C
C     GENERATE MILLER INDICES (H0L)
C
	DO 340  K=1,LMAX
	DO 340  I=1,MN
	NH=HH(I)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,320,340
320	RECD=2.0*SQRT(HH(I)**2*PRCP(1)+HL(K)**2*PRCP(3))
	IF (RECD.EQ.0) GO TO 330
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 340
330	JJ=JJ-1
340	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (K NOT ZERO)
C
	JQ=2
	ASSIGN 420 TO NINDX
	GO TO 360
C
C     ORTHORHOMBIC SYSTEM
C
C     TETRAGONAL SYSTEM - 4/M
C
C
C     GENERATE MILLER INDICES (HKL)
C
350	ASSIGN 430 TO NINDX
	JQ=1
360	KQ=1
370	DO 450  K=KQ,LMAX
	DO 450  J=JQ,KMAX
	DO 450  I=1,IMAX
	IF (LAUE.NE.5) GO TO 380
	IF (HH(I).EQ.0.AND.HK(J).NE.0.0) GO TO 450
380	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,390,450
390	RECD=HH(I)**2*PRCP(1)+HK(J)**2*PRCP(2)+HL(K)**2*PRCP(3)
	GO TO NINDX, (400,410,420,430)
400	RECD=RECD+2.0*(HH(I)*HK(J)*PRCP(4)+HH(I)*HL(K)*PRCP(5)+HK(J)*HL(K)
	1*PRCP(6))
	GO TO 430
410	RECD=RECD+2.0*HH(I)*HL(K)*PRCP(5)
	GO TO 430
420	RECD=RECD+2.0*HH(I)*HK(J)*PRCP(4)
430	RECD=2.0*SQRT(RECD)
	IF (RECD.EQ.0) GO TO 440
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 450
440	JJ=JJ-1
450	CONTINUE
	GO TO 1100
C
C     RHOMBOHEDRAL SYSTEM
C     RHOMBOHEDRAL LAUE GROUPS WITH RHOMBOHEDRAL LATTICE
C
C     CUBIC SYSTEM
C
C
C     LAUE GROUPS -3 AND -3M            3M AND M3M
C
C
C      GENERATE MILLER INDICES (HKL) (H GREATER OR EQUAL K GREATER OR
C     EQUAL +L)
C
460	DO 490  K=1,IMAX
	DO 490  J=K,IMAX
	DO 490  I=J,IMAX
	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,470,490
470	RECD=0.0
	IF (LAUE.GE.9) RECD=2.0*RCP(4)*(HH(I)*HK(J)+HH(I)*HL(K)+HK(J)*HL(K
	1))
	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+RECD)*PRCP(1))
	IF (RECD.EQ.0) GO TO 480
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 490
480	JJ=JJ-1
490	CONTINUE
	IF (LAUE-8) 630,1100,500
C
C     GENERATE MILLER INDICES (HKL) (-H GREATER OR EQUAL K GREATER OR
C     EQUAL L, K NOT ZERO)
C
500	DO 540  K=1,IMAX
	DO 540  J=K,IMAX
	IF (HK(J).EQ.0) GO TO 540
	DO 530  I=J,IMAX
	NH=-HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,510,530
510	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(-HH(I)*HK(J)
	1-HH(I)*HL(K)+HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0) GO TO 520
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 530
520	JJ=JJ-1
	GO TO 540
530	CONTINUE
540	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (H GREATER OR EQUAL K GREATER OR
C     EQUAL -L, L NOT ZERO)
C
	DO 570  K=2,IMAX
	DO 570  J=K,IMAX
	DO 570  I=J,IMAX
	IF (HH(I).EQ.HL(K)) GO TO 570
	NH=HH(I)
	NK=HK(J)
	NL=-HL(K)
	CALL EXTN
	IF (NEX) 210,550,570
550	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(HH(I)*HK(J)-
	1HH(I)*HL(K)-HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0) GO TO 560
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 570
560	JJ=JJ-1
570	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (H GREATER THAN -K GREATER THAN L)
C
	DO 620  K=2,IMAX
	KK=K+1
	IF (KK.GT.IMAX) GO TO 620
	DO 610  J=KK,IMAX
	JJJ=J+1
	IF (JJJ.GT.IMAX) GO TO 610
	DO 600  I=JJJ,IMAX
	NH=HH(I)
	NK=-HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,580,600
580	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(-HH(I)*HK(J)
	1+HH(I)*HL(K)-HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0) GO TO 590
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 600
590	JJ=JJ-1
600	CONTINUE
610	CONTINUE
620	CONTINUE
	IF (LAUE.NE.9) GO TO 1100
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN K LESS THAN L)
C
630	DO 680  I=1,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 680
	DO 670  J=II,IMAX
	JJJ=J+1
	IF (JJJ.GT.IMAX) GO TO 670
	DO 660  K=JJJ,IMAX
	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,640,660
640	RECD=0.0
	IF (LAUE.NE.7) RECD=2.0*RCP(4)*(HH(I)*HH(J)+HH(I)*HL(K)+HK(J)*HL(K
	1))
	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+RECD)*PRCP(1))
	IF (RECD.EQ.0) GO TO 650
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 660
650	JJ=JJ-1
660	CONTINUE
670	CONTINUE
680	CONTINUE
	IF (LAUE.EQ.7) GO TO 1100
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN -K LESS THAN L)
C
	DO 730  I=1,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 730
	DO 720  J=II,IMAX
	JJJ=J+1
	IF (JJJ.GT.IMAX) GO TO 720
	DO 710  K=JJJ,IMAX
	NH=HH(I)
	NK=-HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,690,710
690	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(-HH(I)*HK(J)
	1+HH(I)*HL(K)-HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0.0) GO TO 700
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 710
700	JJ=JJ-1
710	CONTINUE
720	CONTINUE
730	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (-H LESS OR EQUAL K LESS THAN L,
C     H NOT ZERO)
C
	DO 770  I=2,IMAX
	DO 770  J=I,IMAX
	JJJ=J+1
	IF (JJJ.GT.IMAX) GO TO 770
	DO 760  K=JJJ,IMAX
	NH=-HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,740,760
740	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(-HH(I)*HK(J)
	1-HH(I)*HL(K)+HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0.0) GO TO 750
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 760
750	JJ=JJ-1
760	CONTINUE
770	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN K LESS OR EQUAL -L,
C     H NOT ZERO
C
	DO 810  I=2,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 810
	DO 800  J=II,IMAX
	DO 800  K=J,IMAX
	NH=HH(I)
	NK=HK(J)
	NL=-HL(K)
	CALL EXTN
	IF (NEX) 210,780,800
780	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HL(K)**2+2.0*RCP(4)*(HH(I)*HK(J)-
	1HH(I)*HL(K)-HK(J)*HL(K)))*PRCP(1))
	IF (RECD.EQ.0.0) GO TO 790
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 800
790	JJ=JJ-1
800	CONTINUE
810	CONTINUE
	GO TO 1100
C
C     HEXAGONAL SYSTEM
C
C     TETRAGONAL SYSTEM
C
C     LAUE GROUPS -3, -3M, 6/M, AND 6/MMM        4/MMM
C
C     GENERATE MILLER INDICES FOR (HKL) (H GREATER OR EQUAL K ALL +L)
C
820	DO 850  J=1,IMAX
	DO 850  I=J,IMAX
	DO 850  K=1,LMAX
	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,830,850
830	RECD=0.0
	IF (LAUE.NE.6) RECD=HH(I)*HK(J)
	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+RECD)*PRCP(1)+HL(K)**2*PRCP(3))
	IF (RECD.EQ.0.0) GO TO 840
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 850
840	JJ=JJ-1
850	CONTINUE
	IF (LAUE.EQ.6) GO TO 1100
	IF (LAUE-13) 910,860,970
C
C     LAUE GROUP 6/M
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN K ALL +L, H NOT ZERO)
C
860	DO 900  I=2,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 900
	DO 890  J=II,IMAX
	DO 890  K=1,LMAX
	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,870,890
870	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HH(I)*HK(J))*PRCP(1)+HL(K)**2*PRC
	1P(3))
	IF (RECD.EQ.0.0) GO TO 880
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 890
880	JJ=JJ-1
890	CONTINUE
900	CONTINUE
C
C     LAUE GROUP -3M
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN K, L NOT ZERO)
C
910	IF (LAUE-12) 1010,920,1100
920	DO 960  I=1,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 960
	DO 950  J=II,IMAX
	DO 950  K=2,LMAX
	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,930,950
930	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HH(I)*HK(J))*PRCP(1)+HL(K)**2*PRC
	1P(3))
	IF (RECD.EQ.0.0) GO TO 940
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 950
940	JJ=JJ-1
950	CONTINUE
960	CONTINUE
	GO TO 1100
C
C     LAUE GROUP -3M ROTATED
C
C     GENERATE MILLER INDICES (HKL)  (H GREATER OR EQUAL K, K NOT EQUAL
C     ZERO, ALL +L)
C
970	IF (LAUE.NE.15) GO TO 1100
	DO 1000  J=2,IMAX
	DO 1000  I=J,IMAX
	DO 1000  K=2,LMAX
	NH=-HH(I)
	NK=-HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,980,1000
980	RECD=2.0*SQRT((HH(I)**2+HK(J)**2-HH(I)*(-HK(J)))*PRCP(1)+HL(K)**2*
	1PRCP(3))
	IF (RECD.EQ.0.0) GO TO 990
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 1000
990	JJ=JJ-1
1000	CONTINUE
	GO TO 1100
C
C     LAUE GROUP -3
C
C     GENERATE MILLER INDICES (HKL) (H LESS THAN K, ALL +L)
C
1010	DO 1060  I=1,IMAX
	II=I+1
	IF (II.GT.IMAX) GO TO 1060
	DO 1050  J=II,IMAX
	DO 1050  K=1,LMAX
	IF (HL(K).NE.0) GO TO 1020
	IF (HH(I).EQ.0) GO TO 1050
1020	NH=HH(I)
	NK=HK(J)
	NL=HL(K)
	CALL EXTN
	IF (NEX) 210,1030,1050
1030	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HH(I)*HK(J))*PRCP(1)+HL(K)**2*PRC
	1P(3))
	IF (RECD.EQ.0.0) GO TO 1040
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 1050
1040	JJ=JJ-1
1050	CONTINUE
1060	CONTINUE
C
C     GENERATE MILLER INDICES (HKL) (H AND K NOT ZERO, ALL -L)
C
	DO 1090  I=2,IMAX
	DO 1090  J=2,IMAX
	DO 1090  K=2,LMAX
	NH=HH(I)
	NK=HK(J)
	NL=-HL(K)
	CALL EXTN
	IF (NEX) 210,1070,1090
1070	RECD=2.0*SQRT((HH(I)**2+HK(J)**2+HH(I)*HK(J))*PRCP(1)+HL(K)**2*PRC
	1P(3))
	IF (RECD.EQ.0.0) GO TO 1080
	D(JJ)=1.0/RECD
	IF (D(JJ).GE.DMIN) GO TO 1090
1080	JJ=JJ-1
1090	CONTINUE
1100	RETURN
	END
	
	SUBROUTINE MULT (I,FAC)
C
C     DETERMINE THE MULTIPLICITY FOR A REFLECTION
C
	INTEGER*2 IH,IK,IL,KH,KK,KL
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /EXTNS/RECD,LAUE,IEXT(13),NEX,NH,NK,NL,JNUM
	KH=IH(I)
	KK=IK(I)
	KL=IL(I)
	GO TO (100,110,130,140,180,200,240,290,350,360,400,410,430,450,480
	1), LAUE
C
C     LAUE GROUP -1
C
100	FAC=2.0
	GO TO 510
C
C     LAUE GROUP 2/M (Y UNIQUE)
C
110	IF (KK.EQ.0) GO TO 100
	IF (KL.NE.0) GO TO 120
	IF (KH.EQ.0) GO TO 100
120	FAC=4.0
	GO TO 510
C
C     LAUE GROUP 2/M (Z UNIQUE)
C
130	IF (KL.EQ.0) GO TO 100
	IF (KK.NE.0) GO TO 120
	IF (KH) 120,100,120
C
C     LAUE GROUP MMM
C
140	IF (KH.NE.0) GO TO 160
	IF (KK.EQ.0) GO TO 100
150	IF (KL) 120,100,120
160	IF (KK.EQ.0) GO TO 150
	IF (KL.EQ.0) GO TO 120
170	FAC=8.0
	GO TO 510
C
C     LAUE GROUP 4/M
C
180	IF (KH.NE.0) GO TO 190
	IF (KK.EQ.0) GO TO 100
190	IF (KL) 170,120,170
C
C     LAUE GROUP 4/MMM
C
200	IF (KH.NE.0) GO TO 220
	IF (KK.EQ.0) GO TO 100
210	IF (KL) 170,120,170
220	IF (KK.EQ.0) GO TO 210
	IF (KL.NE.0) GO TO 230
	IF (KK-KH) 170,120,170
230	IF (KK-KH.EQ.0) GO TO 170
	FAC=16.0
	GO TO 510
C
C     LAUE GROUP M3
C
240	IF (KH.NE.0) GO TO 270
	IF (KK.EQ.0) GO TO 260
250	IF (KL.NE.0) GO TO 300
260	FAC=6.0
	GO TO 510
270	IF (KK.EQ.0) GO TO 250
	IF (KL.EQ.0) GO TO 300
	IF (KH-KK.NE.0) GO TO 280
	IF (KK-KL.EQ.0) GO TO 170
280	FAC=24.0
	GO TO 510
C
C     LAUE GROUP M3M
C
290	IF (KH.NE.0) GO TO 310
	IF (KK.EQ.0) GO TO 260
	IF (KL.EQ.0) GO TO 260
	IF (KK-KL.NE.0) GO TO 280
300	FAC=12.0
	GO TO 510
310	IF (KK.NE.0) GO TO 320
	IF (KL.EQ.0) GO TO 260
	IF (KH-KL) 280,300,280
320	IF (KL.NE.0) GO TO 330
	IF (KH-KK) 280,300,280
330	IF (KH-KK.NE.0) GO TO 340
	IF (KH-KL) 280,170,280
340	IF (KH-KL.EQ.0) GO TO 280
	IF (KK-KL.EQ.0) GO TO 280
	FAC=48.0
	GO TO 510
C
C     LAUE GROUP -3 (RHOMBOHEDRAL)
C
350	IF (KH-KK.NE.0) GO TO 260
	IF (KH-KL) 260,100,260
C
C     LAUE GROUP -3M (RHOMBOHEDRAL)
C
360	IF (KH-KK.NE.0) GO TO 370
	IF (KH-KL) 260,100,260
370	IF (KH-KL.EQ.0) GO TO 260
	IF (KK-KL.EQ.0) GO TO 260
	IF (KH-KK.NE.0) GO TO 390
380	IF (KL) 300,260,300
390	IF (KH+KK) 300,380,300
C
C     LAUE GROUP -3 (HEXAGONAL)
C
400	IF (KH.NE.0) GO TO 260
	IF (KK) 260,100,260
C
C     LAUE GROUP -3M (HEXAGONAL)
C
410	IF (KH.NE.0) GO TO 420
	IF (KK) 260,100,260
420	IF (KK.EQ.0) GO TO 260
	IF (KH-KK.NE.0) GO TO 300
	IF (KL) 300,260,300
C
C     LAUE GROUP 6/M
C
430	IF (KH.NE.0) GO TO 440
	IF (KK.EQ.0) GO TO 100
440	IF (KL) 300,260,300
C
C     LAUE GROUP 6/MMM
C
450	IF (KH.NE.0) GO TO 470
	IF (KK.EQ.0) GO TO 100
460	IF (KL) 300,260,300
470	IF (KK.EQ.0) GO TO 460
	IF (KH-KK.EQ.0) GO TO 460
	IF (KL) 280,300,280
C
C     LAUE GROUP -3M (ROTATED)
C
480	IF (KH.NE.0) GO TO 500
	IF (KK.EQ.0) GO TO 100
490	IF (KL) 300,260,300
500	IF (KK.EQ.0) GO TO 490
	IF (KH-KK) 300,260,300
C
C
510	RETURN
	END
	
	SUBROUTINE NETOUT
C
C     PRODUCE NEATLY WRITTEN OUTPUT DEFINING LAUE GROUP AND EXTINCTIONS
C
	INTEGER*2 IS,ISFA
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /EXTNS/RECD,LAUE,I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13
	1,NEX,NH,NK,NL,JNUM
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
	DIMENSION IHH(2),IKK(2),ILL(4),ITYPE(13),ILAUE(10),ICELL(3,9)
	DIMENSION IHK(2),IHL(2),IKL(2),IHHK(2),IHHL(2),IKKH(2),IHK4(5),IHL
	14(5),IKL4(5)
	DIMENSION CENTRD(9)
	EQUIVALENCE (IH,IHH(1)),(IK,IKK(1)),(IL,ILL(1))
	DATA CENTRD/2.0,2.0,2.0,4.0,2.0,3.0,3.0,3.0,1.0/
	DATA ITYPE/4H    ,4HHKO),4HHOL),4HOKL),4HHHL),4HH-HL,4HHKH),4HHK-H
	1,4HHKK),4HHK-K,4HHOO),4HOKO),4HOOL)/
	DATA ILAUE/4H0 TH,4HIS P,4HATTE,4HRN I,4HS BA,4HSED ,4HON L,4HAUE 
	1,4HGROU,4HP   /
	DATA ICELL/4H A-C,4HENTE,4HRED ,4H B-C,4HENTE,4HRED ,4H C-C,4HENTE
	1,4HRED ,4H F-C,4HENTE,4HRED ,4H I-C,4HENTE,4HRED ,4H R-O,4HBVER,4H
	2SE  ,4H R-R,4HEVER,4HSE  ,4H HEX,4HAGON,4HAL  ,4H PRI,4HMITI,4HVE  
	3 /
	DATA IHH/4HH=2N,4HH=4N/
	DATA IKK/4HK=2N,4HK=4N/
	DATA ILL/4HL=2N,4HL=3N,4HL=4N,4HL=6N/
	DATA IHK/4HH+K=,4H2N  /
	DATA IHL/4HH+L=,4H2N  /
	DATA IKL/4HK+L=,4H2N  /
	DATA IHHK/4H2H+K,4H=4N /
	DATA IHHL/4H2H+L,4H=4N /
	DATA IKKH/4H2K+H,4H=4N /
	DATA IHK4/4HH+K=,4H4N (,4HH=2N,4H,K=2,4HN)  /
	DATA IHL4/4HH+L=,4H4N (,4HH=2N,4H,L=2,4HN)  /
	DATA IKL4/4HK+L=,4H4N (,4HK=2N,4H,L=2,4HN)  /
	GO TO (100,120,140,160,180,200,220,240,260,280,300,320,340,360,380
	1), LAUE
100	WRITE (NOUT,110) ILAUE
110	FORMAT (10A4,2H-1)
	GO TO 400
120	WRITE (NOUT,130) ILAUE
130	FORMAT (10A4,14H2/M (Y UNIQUE))
	GO TO 400
140	WRITE (NOUT,150) ILAUE
150	FORMAT (10A4,14H2/M (Z UNIQUE))
	GO TO 400
160	WRITE (NOUT,170) ILAUE
170	FORMAT (10A4,3HMMM)
	GO TO 400
180	WRITE (NOUT,190) ILAUE
190	FORMAT (10A4,3H4/M)
	GO TO 400
200	WRITE (NOUT,210) ILAUE
210	FORMAT (10A4,5H4/MMM)
	GO TO 400
220	WRITE (NOUT,230) ILAUE
230	FORMAT (10A4,2HM3)
	GO TO 400
240	WRITE (NOUT,250) ILAUE
250	FORMAT (10A4,3HM3M)
	GO TO 400
260	WRITE (NOUT,270) ILAUE
270	FORMAT (10A4,17H-3 (RHOMBOHEDRAL))
	GO TO 400
280	WRITE (NOUT,290) ILAUE
290	FORMAT (10A4,17H-3M(RHOMBOHEDRAL))
	GO TO 400
300	WRITE (NOUT,310) ILAUE
310	FORMAT (10A4,14H-3 (HEXAGONAL))
	GO TO 400
320	WRITE (NOUT,330) ILAUE
330	FORMAT (10A4,14H-3M(HEXAGONAL))
	GO TO 400
340	WRITE (NOUT,350) ILAUE
350	FORMAT (10A4,3H6/M)
	GO TO 400
360	WRITE (NOUT,370) ILAUE
370	FORMAT (10A4,5H6/MMM)
	GO TO 400
380	WRITE (NOUT,390) ILAUE
390	FORMAT (10A4,23H-3M (HEXAGONAL-ROTATED))
C
400	IF (I1.LE.0.OR.I1.GT.9) I1=9
	WRITE (NOUT,410) (ICELL(J,I1),J=1,3)
410   FORMAT (21H  THE LATTICE TYPE IS,3A4,41HWITH THE FOLLOWING SPACE G
     1ROUP CONDITIONS)
	CENTR=CENTRD(I1)
C
	IF (I2.LE.0) GO TO 460
	GO TO (420,430,440,450), I2
420	WRITE (NOUT,760) ITYPE(2),IH
	GO TO 460
430	WRITE (NOUT,760) ITYPE(2),IK
	GO TO 460
440	WRITE (NOUT,760) ITYPE(2),IHK
	GO TO 460
450	WRITE (NOUT,760) ITYPE(2),IHK4
C
460	IF (I3.LE.0) GO TO 510
	GO TO (470,480,490,500), I3
470	WRITE (NOUT,760) ITYPE(3),IH
	GO TO 510
480	WRITE (NOUT,760) ITYPE(3),IL
	GO TO 510
490	WRITE (NOUT,760) ITYPE(3),IHL
	GO TO 510
500	WRITE (NOUT,760) ITYPE(3),IHL4
C
510	IF (I4.LE.0) GO TO 560
	GO TO (520,530,540,550), I4
520	WRITE (NOUT,760) ITYPE(4),IK
	GO TO 560
530	WRITE (NOUT,760) ITYPE(4),IL
	GO TO 560
540	WRITE (NOUT,760) ITYPE(4),IKL
	GO TO 560
550	WRITE (NOUT,760) ITYPE(4),IKL4
C
560	IF (I5-1) 590,570,580
570	WRITE (NOUT,760) ITYPE(5),IL
	GO TO 590
580	WRITE (NOUT,760) ITYPE(5),IHHL
C
590	IF (I6-1) 620,600,610
600	WRITE (NOUT,730) ITYPE(6),IL
	GO TO 620
610	WRITE (NOUT,730) ITYPE(6),IHHL
C
620	IF (I7-1) 650,630,640
630	WRITE (NOUT,760) ITYPE(7),IK
	GO TO 650
640	WRITE (NOUT,760) ITYPE(7),IHHK
C
650	IF (I8-1) 680,660,670
660	WRITE (NOUT,730) ITYPE(8),IK
	GO TO 680
670	WRITE (NOUT,730) ITYPE(8),IHHK
C
680	IF (I9-1) 710,690,700
690	WRITE (NOUT,760) ITYPE(9),IH
	GO TO 710
700	WRITE (NOUT,760) ITYPE(9),IKKH
C
710	IF (I10-1) 750,720,740
720	WRITE (NOUT,730) ITYPE(10),IH
730	FORMAT (8H       (,A4,4H)   ,2A4)
	GO TO 750
740	WRITE (NOUT,730) ITYPE(10),IKKH
C
750	IF (I11.GT.0) WRITE (NOUT,760) ITYPE(11),IHH(I11)
C
	IF (I12.GT.0) WRITE (NOUT,760) ITYPE(12),IKK(I12)
C
	IF (I13.GT.0) WRITE (NOUT,760) ITYPE(13),ILL(I13)
760	FORMAT (8H       (,A4,4X,5A4)
	RETURN
	END
	
	SUBROUTINE ORDER
C
C     SUBROUTINE TO ORDER REFLECTIONS ON DECREASING D-VALUES
C
	INTEGER*2 IH,IK,IL,NH,NK,NL
	INTEGER*2 IS,ISFA
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
	DO 110  N=1,JJ
	NN=N+1
C
C     DETERMINE LARGEST D VALUE
C
	I=N
	DO 100  K=NN,JJ
	IF (D(K).GT.D(I)) I=K
100	CONTINUE
C
C     STORE LARGEST D VALUE
C
	TEMP=D(I)
	D(I)=D(N)
	D(N)=TEMP
	NH=IH(I)
	NK=IK(I)
	NL=IL(I)
	IH(I)=IH(N)
	IK(I)=IK(N)
	IL(I)=IL(N)
	IH(N)=NH
	IK(N)=NK
110	IL(N)=NL
	IF (NAS.EQ.0) GO TO 130
C     CORRECTION FOR ACCENTRIC - SKIP IF CENTRIC (ICENT=1)
	IF (ICENT.EQ.1) GO TO 130
	J = NAMX / 2
	IF (JJ .LT. NMAX/2) J=JJ
	JJ=2*J
	DO 120  I=1,J
	K=JJ-I*2+1
	L=K+1
	N=J-I+1
	D(K)=D(N)
	D(L)=D(N)
	IH(K)=IH(N)
	IH(L)=-IH(N)
	IK(K)=IK(N)
	IK(L)=-IK(N)
	IL(K)=IL(N)
120	IL(L)=-IL(N)
130	WRITE (NOUT,140) JJ
140	FORMAT (35H0THE TOTAL NUMBER OF REFLECTIONS ISI6)
	RETURN
	END
	
	SUBROUTINE OUTX
C
	INTEGER*2 IH,IK,IL,NH,NK,NL
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /CAL/XINT1(1000),XINT3(1000),TTH1(1000)
	COMMON /XXCENT/ ICENT
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
C
	IND=55
	ISUB=0
	XTTH=0.0
	IF (NPLOT.LE.1) GO TO 120
	WRITE (NPUNCH,100) (ITITLE(I),I=1,LENX)
100	FORMAT ((1X,80A1))
	WRITE (NPUNCH,110) JJ,NPLOT,XLAMDA,WL2
110	FORMAT (2X,I4,3X,I3,48X,2F10.5)
C
C     SET UP BRANCHES FOR ABSORPTION CORRECTION
C
120	IF (XMU.LE.0.0) GO TO 130
C     BRANCH FOR ABSORPTION CORRECTION
	ASSIGN 190 TO KBRNCH
	ASSIGN 240 TO NBRNCH
	GO TO 140
C     BRANCH FOR NO ABSORPTION CORRECTION
130	ASSIGN 210 TO KBRNCH
	ASSIGN 260 TO NBRNCH
C
C     BEGIN LOOP THRU JJ REFLECTIONS
C
140	DO 300  I=1,JJ
C
C     RETREIVE INTERMEDIATE DATA FOR ONE REFLECTION FROM SCRATCH TAPE
C
	READ (NSCRT1) N,TTH1(N),SST,XINT1(N),F
C
C     APPLY SCALE FACTOR
C
	XINT1(N)=XINT1(N)*SC(1)
C
C     SUM OVERLAPPED PEAKS
C
	IF (N.EQ.1) GO TO 150
	IF (TTH1(N)-XTTH.LE.0.02) GO TO 160
150	YSUM=XINT1(N)
	YS=0.0
	GO TO 170
160	YSUM=YSUM+XINT1(N)
	YS=YSUM
C
C     TRANSFORM MILLER INDICES TO USER SETTING
C
170	IF (ITRANS.EQ.0) GO TO 180
	NH=IH(N)*NTRANS(1,1)+IK(N)*NTRANS(1,2)+IL(N)*NTRANS(1,3)
	NK=IH(N)*NTRANS(2,1)+IK(N)*NTRANS(2,2)+IL(N)*NTRANS(2,3)
	NL=IH(N)*NTRANS(3,1)+IK(N)*NTRANS(3,2)+IL(N)*NTRANS(3,3)
	IH(N)=NH
	IK(N)=NK
	IL(N)=NL
C
C     LIST DATA ON OUTPUT TAPE
C
180	IF (IND.LT.55) GO TO 230
C     WRITE PAGE HEADER
	IND=0
	GO TO KBRNCH, (190,210)
190	WRITE (NOUT,200)
200   FORMAT (1H1,29X,61H2THETA      D      H  K  L   I(0)  SUM I   I(1)    
     1   I(2)     F )
	GO TO 230
210	WRITE (NOUT,220)
220   FORMAT (1H1,29X,47H2THETA      D      H  K  L   I(0)  SUM I     F     
     1)
230	IND=IND+1
	GO TO NBRNCH, (240,260)
C
C     DETERMINE ABSORPTION CORRECTION
C
240	IA=2
	CALL ABSX (SST,TTH1(N),ABS1)
	XINT3(N)=(XINT1(N)/ABS1)*SC(2)
	IA=3
	CALL ABSX (SST,TTH1(N),ABS2)
	XINT5=(XINT1(N)/ABS2)*SC(3)
	WRITE (NOUT,250) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),YS,XINT3(
	1N),XINT5,F
250	FORMAT (30X,F6.2,F10.5,I4,2I3,5F7.1)
	GO TO 270
260	WRITE (NOUT,250) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),YS,F
270	XTTH=TTH1(N)
	ISUB = ISUB + 1
	IF (ICENT.NE.0 .OR. NAS.LE.0) GO TO 6000
	IF (I/2*2 .NE. I) GO TO 6000
	ISUB = ISUB-1
	TTH1(ISUB) = TTH1(N)
	D(ISUB) = D(N)
	IH(ISUB) = IH(N-1)
	IK(ISUB) = IK(N-1)
	IL(ISUB) = IL(N-1)
	XINT1(ISUB) = (XINT1(N) + XINT1(N-1))*0.5
	XINT3(ISUB) = (XINT3(N) + XINT3(N-1))*0.5
6000	CONTINUE
	IF (NPLOT.LT.2) GO TO 300
	IF (NPLOT.EQ.NPUNCH) GO TO 280
	WRITE (NPLOT) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N),XIN
	1T5
	GO TO 300
280	WRITE (NPUNCH,290) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N
	1),XINT5
290	FORMAT (2F10.5,1X,3I3,3F10.5)
300	CONTINUE
	IF (ICENT.EQ.0 .AND. NAS.GT.0) JJ=JJ/2
	RETURN
	END
	
	SUBROUTINE PLOTT(Y,NSC1,NPLT,LENGTH,JSCALE)
C  THIS SUBROUTINE PRODUCES A SIMULATED TRACE ON THE LINE PRINTER
C  WE DUMMY IT OUT AS NOT VERY USEFUL
C	LOGICAL*1 ITITLE, IDAY, ITIME(8)
C      COMMON/GENL/WL1,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),                       
C     1ITIME,NIN,NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXY2,ITRANS,               
C     2NTRANS(3,3),ISCALE,NPLOT,NREFL,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,             
C     3LENX,ITITLE(320),IDAY(9)                                                  
C	COMMON/XPLOT/ W,TTHETA,SCMAX
C	DIMENSION Y(8001), INTEN(101)
C	DATA NX/'X'/,NPLUS/'+'/,NBLANK/' '/
C5     FORMAT (41H THE INTENSITY SCALE IS BASED ON I(MAX) =,I5/44H THE 2T
C     1HETA SCALE IS PLOTTED IN INTERVALS OF,F5.2,8H DEGREES//10X,
C	1 7H 2THETA,
C	225X, 9HINTENSITY)
C10	FORMAT (18X,1H0,8X,2H10,8X,2H20,8X,2H30,8X,2H40,8X,2H50,8X,2H60,8X
C	1,2H70,8X,2H80,8X,2H90,8X3H100,/18X,10(1HI,9X),1HI)
C20	FORMAT (12X,I3,3H - ,101A1)
C30	FORMAT (18X,101A1)
C	DO 100 I=1,101
C100	INTEN(I)=NBLANK
CC     DEFINE PLOT SCALES
C	ISCALE=SCMAX
C	NPLT=NPLT+1
C	IF(JSCALE.GE.4) NSCALE=1
C	IF(JSCALE.EQ.3) NSCALE=2
C	IF(JSCALE.EQ.2) NSCALE=5
C	IF(JSCALE.LE.1) NSCALE=10
C	DELTA=FLOAT(NSCALE)*0.02
C	WRITE (NOUT, 5) ISCALE,DELTA
C	WRITE (NOUT,10)
C     SETUP DIFFRACTION TRACE
C	DO 215 I=1,NPLT,NSCALE
C	NPOINT=Y(I)+1.5
C	IF(NPOINT.GT.101) GO TO 205
C	INTEN (NPOINT)=NX
C	GO TO 210
C205	INTEN(101)=NX
C	KPOINT=Y(I)*100.0/FLOAT(ISCALE)+1.5
C	INTEN(KPOINT)=NPLUS
C210	TTH=5.00+(I-1)*0.02
C	NTH=TTH
C	IF(MOD(I,50)-1 .EQ.0.0) WRITE (NOUT,20 ) NTH,INTEN
C	IF(MOD(I,50)-1 .NE.0.0) WRITE (NOUT,30) INTEN
C	INTEN(NPOINT)=NBLANK
C	INTEN(KPOINT)=NBLANK
C	INTEN(101)=NBLANK
C215	CONTINUE
	RETURN
	END
	
	SUBROUTINE READX
C
C     SUBROUTINE TO READ INPUT DATA FOR ONE STRUCTURE
C
	REAL*8 ATOM
	INTEGER*2 IS,ISFA,IWLWV,IWL,ICHAR
	LOGICAL*1 ITITLE,IDAY,IBNK,IENDMK, ITIME(8)
	LOGICAL CHEQ
	LOGICAL*1 FILLR1
	LOGICAL*1 FILLR2
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /BETA/ CORSC,LBETA
	COMMON /CELLS/RCP(6),RCV,RECELL(6),VOL,PRCP(6)
	COMMON /EXTNS/RECD,LAUE,IEXT(13),NEX,NH,NK,NL,JJJJ
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
      COMMON /DATA/ATOM(99),ATWT(99),XMURHO(99),BXYZ(6),URHO(7,20),
     1 WEIGHT(20),RDUMMY(439),NNF(20),NTRAN(3),JEXT(13),JNUM(3),JDEN(3),
     2 JCX(3),JCY(3),JCZ(3),ITRAN(30),M,IDUMMY(885),ICHAR(72),
     3 FILLR2(1850)
	COMMON /DENSTY/ DENS,DENSC
	COMMON /SCALES/ NTCS
	DIMENSION X1RCP(6),X2RCP(6)
	DIMENSION WLS1(7),WLS2(7),LTRAN(3,5),IWLWV(8)
	DIMENSION XINIT(1875),INIT(272),IINIT(24)
	DIMENSION WLB(7)
	EQUIVALENCE (XINIT(1),FX(1,1)),(INIT(1),NF),(IINIT(1),IA)
	DATA RAD/57.29578/
	DATA IBNK/' '/,IENDMK/'%'/
	DATA WLB/0.632253,1.39217,1.50010,1.62075,1.75653,2.08480,0.49707/
C     PISQ2 = 2*PI**2
	DATA PISQ2/19.73921/
	DATA WLS1/0.70926,1.5405981,1.65783,1.78890,1.93597,2.28962,
	1 0.559363/
	DATA WLS2/0.71354,1.544438,1.66168,1.79279,1.93991,2.29352,
	1 0.563775/
	DATA IWLWV/2HMO,2HCU,2HNI,2HCO,2HFE,2HCR,2HAG,2HED/
	DATA LTRAN/3,1,2,2,3,1,1,-3,2,2,1,-3,-3,2,1/
	REWIND NSCRT1
	N1=0
	N2=0
	N3=0
	DO 100  I=1,1875
100	XINIT(I)=0.0
	DO 110  I=1,272
110	INIT(I)=0
	DO 120  I=1,24
120	IINIT(I)=0
C
C     ALLOW UP TO 4 TITLE CARDS, CONTINUATION SIGNIFIED BY CHARACTER IN
C     COLUMN 80 (THUS ONLY 1-79 ACTUALLY USEABLE)
	READ (NIN,5010) (ITITLE(I),I=1,320)
5010	FORMAT (80A1)
	LENX=320
C      FIND LENGTH OF TITLE FOR USE IN PLOT ROUTINE
C      % IS DELIMITER.  BLANK OUT % WHEN FOUND
	DO 140 I=1,72
	IF (ITITLE(I).EQ.IENDMK) GO TO 150
140	CONTINUE
	LENT=72
	GO TO 160
150	LENT=I-1
	ITITLE(I)=IBNK
160	CALL DATE (IDAY)
	CALL TIME (ITIME)
	WRITE (NOUT,170) (ITITLE(I),I=1,80),ITIME,IDAY
170	FORMAT (1HP,80A1,20X,8A1,2X,9A1)
	IF (LENX .LE. 80) GO TO 172
	WRITE (NOUT,171) (ITITLE(I),I=81,LENX)
171	FORMAT ((1X,80A1))
172	WRITE (NOUT,173)
173	FORMAT (/)
	READ (NIN,180) IWL,NSG,NA,NPLOT,NLAMDA,NABS,NAS,IXYZ,NLAUE,ITRANS,
	1IBETA,LBETA,NTCS,TTHIBM,TTHDBM,XLAMDA,WL2
180	FORMAT (A2,I4,11I3,9X,2F6.3,2F10.5)
C
C     DETERMINE WAVE LENGTH
C
	DO 190  NWL=1,7
	IF (IWL.NE.IWLWV(NWL)) GO TO 190
	IF (LBETA.NE.0) GO TO 189
	XLAMDA=WLS1(NWL)
	WL2=WLS2(NWL)
	GO TO 210
189	XLAMDA=WLB(NWL)
	WL2=0.0
	WRITE (NOUT,174)
174	FORMAT (36H CALCULATION IS FOR K BETA RADIATION)
	GO TO 210
190	CONTINUE
	IF(IWL.EQ.IWLWV(8)) WRITE (NOUT,195)
195	FORMAT (40H CALCULATION IS FOR ELECTRON DIFFRACTION)
	NWL=1
	IF (XLAMDA.GT.0.0) GO TO 210
	WRITE (NOUT,200)
200	FORMAT (37H WAVE LENGTH NOT IN TABLE OR SUPPLIED)
	GO TO 450
210	IF (NLAMDA) 230,250,220
220	XLAMDA=(XLAMDA*2.0+WL2)/3.0
	GO TO 240
230	NWL=0
240	WL2=0.0
C
C     PROCESS NPLOT TRANSFER OPTION
C
250	IF (NPLOT) 790,270,260
260	IF (NPLOT.EQ.2) NPLOT=NPUNCH
C
C     READ INPUT CARDS AND INITIALIZE
C
270	WRITE (NOUT,280) IWL,XLAMDA,WL2,NSG,NA,NPLOT,NAS,ITRANS,TTHIBM,
	1 TTHDBM,IBETA
280   FORMAT (12H RADIATION =A2/12H   ALPHA 1 =F8.5/12H   ALPHA 2 =F8.5/
     114H SPACE GROUP =I5/34H NO. OF ATOMS IN ASYMMETRIC UNIT =I3/8H NPL
     2OT =I3/6H NAS =I3/9H ITRANS =,I3/' 2 THETA(IBM)=',F6.3,/
     3 ' 2 THETA(DBM)=',F6.3/' IBETA =',I3)
	IF (IBETA.LT.10) GO TO 911
	ASSIGN 908 TO KBETA
	IBETA=IBETA-10
	GO TO 910
911	ASSIGN 900 TO KBETA
910	IBETA=IBETA+1
	READ (NIN,290) NNF
290	FORMAT (20I3)
	IF (IWL.EQ.IWLWV(8)) GO TO 341
291	CONTINUE
	WRITE (NOUT,300) NNF
300	FORMAT (1X,20I4)
	READ (NIN,310)(RCP(N),N=1,3),RCP(4),SEC4,RCP(5),SEC5,RCP(6),SEC6,
	1CORSC
310	FORMAT (3F10.5,3(F7.3,F3.0),F6.2)
311	FORMAT (8F10.5)
	RCP(4)=RCP(4)+SEC4/60.0
	RCP(5)=RCP(5)+SEC5/60.0
	RCP(6)=RCP(6)+SEC6/60.0
	WRITE (NOUT,320) RCP
320	FORMAT (1X,8F10.5)
	READ (NIN,330) ISH,ISK,ISL,XMU,XMAX,DENS,TTHMAX,SC(4),IEXT
330	FORMAT (3I2,4F6.2,F6.4,4X,13I2)
	IF (IABS(ISH)+IABS(ISK)+IABS(ISL).NE.0) ISCALE=1
C
	IF (ITRANS.LE.0) GO TO 370
	IF (ITRANS.LE.5) GO TO 350
	WRITE (NOUT,340)
340	FORMAT ('0INVALID TRANSFORMATION INDEX')
	GO TO 450
341	DO 342 N=1,20
	IF (NNF(N).EQ.0) GO TO 342
	NNF(N)=NNF(N)+1000
342	CONTINUE
	GO TO 291
350	DO 360  I=1,3
360	NTRAN(I)=LTRAN(I,ITRANS)
	N1=IABS(NTRAN(1))
	N2=IABS(NTRAN(2))
	N3=IABS(NTRAN(3))
	NTRANS(1,N1)=NTRAN(1)/N1
	NTRANS(2,N2)=NTRAN(2)/N2
	NTRANS(3,N3)=NTRAN(3)/N3
	IF (ISCALE.NE.1) GO TO 370
	NH=ISH*NTRANS(1,1)+ISK*NTRANS(2,1)+ISL*NTRANS(3,1)
	NK=ISH*NTRANS(1,2)+ISK*NTRANS(2,2)+ISL*NTRANS(3,2)
	NL=ISH*NTRANS(1,3)+ISK*NTRANS(2,3)+ISL*NTRANS(3,3)
	ISH=NH
	ISK=NK
	ISL=NL
370	SC(2)=0.0
	SC(3)=0.0
	IF (SC(4).LE.0.0) SC(4)=1.0
	IF (XMAX.LE.0.0) XMAX=100.0
	IF (TTHMAX.LE.0.0) TTHMAX=175.0
	DMIN=XLAMDA/(2.0*SIN(TTHMAX/(RAD*2.0)))
	WRITE (NOUT,380) NLAUE,DMIN,IEXT,XMU,ISH,ISK,ISL,DENS,SC(4),TTHMAX
	1,XMAX
380   FORMAT (1X,8HNLAUE = I4/1X,8HDMIN =  F7.5/1X,12HEXTN CODE = 13I2/1
     1X,5HMU = F7.2,10X,29H(HKL) OF SCALE REFLECTION IS 3I3/
     211H DENSITY = , F9.3/9H SC(4) = ,F9.3/10H TTHMAX = ,
     3 F9.3/8H XMAX = ,F9.3)
C
C     SET UP RECIPROCAL CELL PARAMETERS
C
	DO 1073 I=1,6
1073	X1RCP(I)=RCP(I)
	IF (ITRANS.EQ.0) GO TO 520
	RECELL(N1)=RCP(1)
	RECELL(N2)=RCP(2)
	RECELL(N3)=RCP(3)
	RECELL(N1+3)=RCP(4)
	RECELL(N2+3)=RCP(5)
	RECELL(N3+3)=RCP(6)
	DO 490  I=1,6
490	RCP(I)=RECELL(I)
	IF (NTRAN(1)*NTRAN(2).LT.0) RCP(N3+3)=180.0-RCP(N3+3)
	IF (NTRAN(1)*NTRAN(3).LT.0) RCP(N2+3)=180.0-RCP(N2+3)
	IF (NTRAN(2)*NTRAN(3).LT.0) RCP(N1+3)=180.0-RCP(N1+3)
	DO 1074 I=1,6
1074	X2RCP(I)=RCP(I)
520	DO 530  N=4,6
530	RCP(N)=COS(RCP(N)/RAD)
	CALL CELCON
	DO 430  N=1,NA
	READ (NIN,390) ATOM(N),SF(N),AI(N),(XYZ(K,N),K=1,3),BETA(1,N),ISFA
	1(N)
390	FORMAT (A8,2F6.1,4F10.6,18X,I2)
	WRITE (NOUT,400) ATOM(N),SF(N),AI(N),(XYZ(K,N),K=1,3),BETA(1,N),IS
	1FA(N)
400	FORMAT (1H ,A8,2F7.3,4F10.6,I10)
	IF (IBETA.GE.7.AND.BETA(1,N).NE.0.0) BETA(1,N)=BETA(1,N)*PISQ2
	AI(N)=AI(N)/SC(4)
	IF (ITRANS.EQ.0) GO TO 410
	BXYZ(N1)=XYZ(1,N)*NTRANS(1,N1)
	BXYZ(N2)=XYZ(2,N)*NTRANS(2,N2)
	BXYZ(N3)=XYZ(3,N)*NTRANS(3,N3)
	XYZ(1,N)=BXYZ(1)
	XYZ(2,N)=BXYZ(2)
	XYZ(3,N)=BXYZ(3)
410	IF (BETA(1,N).NE.0) GO TO 430
	READ (NIN,311) (BETA(I,N),I=1,6)
	WRITE (NOUT,320) (BETA(I,N),I=1,6)
	ITF=1
C
C     MODIFY ANISOTROPIC TEMPERATURE FACTORS
C
	GO TO (905,901,902,902,909,909,904,904,904,904),IBETA
901	BETA(4,N)=BETA(4,N)/2.0
	BETA(5,N)=BETA(5,N)/2.0
	BETA(6,N)=BETA(6,N)/2.0
905	GO TO KBETA,(900,908)
902	BETA(4,N)=BETA(4,N)*RECELL(1)*RECELL(2)/4.0
	BETA(5,N)=BETA(5,N)*RECELL(1)*RECELL(3)/4.0
	BETA(6,N)=BETA(6,N)*RECELL(2)*RECELL(3)/4.0
903	DO 4001 I=1,3
C
C     CORRECTION 9/83: LINE 2221 USED TO BE
C4001 BETA(I,N)=BETA(I,N)*RECELL(N)*RECELL(N)/4.0
C
4001	BETA(I,N)=BETA(I,N)*RECELL(I)*RECELL(I)/4.0
	GO TO (905,905,905,901,905,901,905,901,905,901),IBETA
904	DO 4002 I=1,6
4002	BETA(I,N)=BETA(I,N)*PISQ2
	GO TO (906,906,906,906,906,906,902,902,909,909),IBETA
909	DO 912 I=4,6
912	BETA(I,N)=BETA(I,N)*PRCP(I)
	GO TO 903
906	WRITE (NOUT,907)
907	FORMAT ('0***ERROR DETECTED WHILE TRANSFORMING TEMPERATURE FACTORS
	1***')
	CALL CARDS
908	BETA(1,N) = 1.333333*(BETA(1,N)*RCP(1)*RCP(1) + BETA(2,N)*RCP(2)*
	1            RCP(2) + BETA(3,N)*RCP(3)*RCP(3) + BETA(4,N)*RCP(1)*
	2            RCP(2) + BETA(5,N)*RCP(1)*RCP(3) + BETA(6,N)*RCP(2)*
	3            RCP(3))
	DO 4004 I=2,6
4004	BETA(I,N) = 0.0
	ITF = 0
900	CONTINUE
	IF (ITRANS.EQ.0) GO TO 430
	BXYZ(N1)=BETA(1,N)
	BXYZ(N2)=BETA(2,N)
	BXYZ(N3)=BETA(3,N)
	BXYZ(N1+N2+1)=BETA(4,N)
	BXYZ(N1+N3+1)=BETA(5,N)
	BXYZ(N2+N3+1)=BETA(6,N)
	DO 420  I=1,6
420	BETA(I,N)=BXYZ(I)
430	CONTINUE
	WRITE (NOUT,170) (ITITLE(I),I=1,80),ITIME,IDAY
	IF (LENX .LE. 80) GO TO 175
	WRITE (NOUT,171) (ITITLE(I),I=81,LENX)
175	WRITE (NOUT,173)
C
C     READ F TABLES
C
	IF (NLAMDA.LT.0) NNF(1)=0
	CALL SCATFC
	IF (IOUT.EQ.1) GO TO 790
C
C     READ SYMMETRY POSITIONS
C
	ICENT=0
	CALL SYMPOS
	IF (IOUT.EQ.1) GO TO 790
	IF (NLAUE.LT.0) ICENT=1
	IF (LAUE.EQ.0) LAUE=IABS(NLAUE)
	IF (LAUE.GT.0.AND.LAUE.LE.15) GO TO 460
	WRITE (NOUT,440)
440	FORMAT (19H INVALID LAUE GROUP)
450	CALL CARDS
	GO TO 790
C
C     OUTPUT LATTICE AND EXTINCTION TYPE
C
460	CALL NETOUT
	WRITE (NOUT,470)
470	FORMAT (1H1,14HCELL CONSTANTS//)
	WRITE (NOUT,480) X1RCP
480	FORMAT (2X,3HA= F7.4/5H  B= F7.4/5H  C= F7.4/9H  ALPHA= F6.2/9H  B
	1ETA=  F6.2/9H  GAMMA= F6.2)
	IF (ITRANS .EQ.0) GO TO 526
	WRITE (NOUT,500) NTRANS
500	FORMAT (44H0MATRIX TO TRANSFORM USER CELL TO FILE CELL //3(10X,3I4
	1/))
	WRITE (NOUT,510)
510	FORMAT (27H TRANSFORMED CELL CONSTANTS)
	WRITE (NOUT,480) X2RCP
526	CONTINUE
	WRITE (NOUT,540) (RCP(N),N=4,6)
540	FORMAT (12H COS ALPHA= F8.5,12H  COS BETA= F8.5,13H  COS GAMMA= F8
	1.5/)
	DO 550  N=4,6
550	BXYZ(N)=ACOS(RECELL(N))*RAD
	WRITE (NOUT,560) (RECELL(I),I=1,3),(BXYZ(N),N=4,6)
560	FORMAT (26H0RECIPROCAL CELL CONSTANTS//6H  A*= F7.4/6H  B*= F7.4/6
	1H  C*= F7.4/10H  ALPHA*= F6.2/10H  BETA*=  F6.2/10H  GAMMA*= F6.2/
	2)
	TO=0.0
	IF (ITF.LE.0) GO TO 600
	DO 580  I=1,NA
	IF (BETA(2,I).NE.0) GO TO 580
	TFI=BETA(1,I)
	DO 570  K=1,6
570	BETA(K,I)=TFI*PRCP(K)
580	CONTINUE
	WRITE (NOUT,590) (ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3),(BETA(J,I),
	1J=1,6),ISFA(I),I=1,NA)
590   FORMAT (130H  ATOM         SF       MULT       X         Y             
     1 Z       BETA(1,N) BETA(2,N) BETA(3,N) BETA(4,N) BETA(5,N) BETA(6,    
     2N)     SFA//99(1X,A8,11F10.4,I10/))
	GO TO 620
600	WRITE (NOUT,610) (ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3),BETA(1,I),I
	1SFA(I),I=1,NA)
610   FORMAT (79H  ATOM         SF       MULT       X         Y             
     1Z       BETA         SFA//99(1X,A8,6F10.4,I10/))
620	WRITE (NOUT,630) SC(4),DMIN,XLAMDA
630   FORMAT (33H0THE MULTIPLICITY SCALE FACTOR ISF9.4/23H0THE MINIMUM D     
     1-VALUE ISF8.4,8H LAMDA =F8.5)
	WRITE (NOUT,170) (ITITLE(I),I=1,80),ITIME,IDAY
	IF (LENX .LE. 80) GO TO 176
	WRITE (NOUT,171) (ITITLE(I),I=81,LENX)
176	WRITE (NOUT,173)
C
C     CALCULATE LINEAR ABSORPTION COEFFICIENT
C
	IF (NWL.NE.0) GO TO 650
	DO 640  I=1,NA
	XMURHO(I)=0.0
640	ATWT(I)=0.0
	GO TO 670
650	DO 660  I=1,NA
	NFORM=SF(I)
	IF (NWL.GT.0) XMURHO(I)=URHO(NWL,NFORM)
660	ATWT(I)=WEIGHT(NFORM)
670	WRITE (NOUT,680) (ATOM(N),XMURHO(N),ATWT(N),N=1,NA)
680	FORMAT (/39H ABSORPTION COEFFICIENTS USED FOR ATOMS/10X,4HATOM,12X
	1,6HMU/RHO,4X,6HAT.WT./99(10X,A8,4X,2F10.3/))
C     CALCULATE DENSITY
	FORWT=0.0
	DO 690  I=1,NA
690	FORWT=FORWT+AI(I)*ATWT(I)
	AICORR=NS*(1+ICENT)
	DENSC = (1.6602*FORWT*AICORR*CENTR)/RCV
	WRITE (NOUT,700) DENSC
700	FORMAT (/21H CALCULATED DENSITY =F7.3)
	IF (DENSC.LT.0.1) GO TO 710
	IF (ABS(DENS/DENSC-1.0) .LT. 0.1) GO TO 710
	WRITE (NOUT,704)
	WRITE (NOUT,701)
701	FORMAT ('0CALCULATED DENSITY USED IN GAMMA, MU, AND I/I-COR')
710	IF (XMU.GT.0.0) GO TO 760
	XMU=0.0
	FRACWT=0.0
	TOTWT=0.0
	DO 720  I=1,NA
720	TOTWT=AI(I)*ATWT(I)+TOTWT
	IF (TOTWT.LE.0.0) GO TO 740
	DO 730  I=1,NA
730	FRACWT=(AI(I)*ATWT(I)/TOTWT)*XMURHO(I)+FRACWT
704	FORMAT ('0*** CALCULATED AND INPUT DENSITY DON''T AGREE ***')
	XMU=DENSC*FRACWT
740	WRITE (NOUT,750) XMU
750	FORMAT (/44H CALCULATED LINEAR ABSORPTION COEFFICIENT = F8.2)
	GO TO 780
760	WRITE (NOUT,770) XMU
770	FORMAT (/33H LINEAR ABSORPTION COEFFICIENT = F8.2)
780	XMUR=XMU*0.015
790	CONTINUE
	IF (TTHIBM .NE. 0.0) WRITE(NOUT,791) TTHIBM
791	FORMAT ('0INCIDENT BEAM MONOCHROMATOR 2 THETA=',F5.2)
	RETURN
	END
	
	SUBROUTINE SCALEX
	INTEGER*2 IH,IK,IL
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
      COMMON /DATA/ATOM(99),ATWT(99),XMURHO(99),BXYZ(6),URHO(7,20),
     1 WEIGHT(20),RDUMMY(439),NNF(20),NTRAN(3),JEXT(13),JNUM(3),JDEN(3),
     2 JCX(3),JCY(3),JCZ(3),ITRAN(30),M,IDUMMY(885),ICHAR(72),
     3 FILLR2(1850)
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON /CELLS/CELL(6),RCV,RCP(7),PRCP(6)
	COMMON /DENSTY/ DENS,DENSC
	COMMON /IICOR/ XINTR
	COMMON /XXCENT/ ICENT
	COMMON /SCALES/ NTCS
	COMMON /BETA/ CORSC,LBETA
	DIMENSION B(19)
	Y=0.0
C
C     CALCULATE F AND Y FOR ALL REFLECTIONS
C
	DO 100  N=1,JJ
C
C     CALCULATE F AND CORRECTED F**2
C
	CALL CALC (N,F,YX,SST,TTH)
C     CORRECT FOR THETA COMPENSATING SLIT
	IF(NTCS.NE.0) YX=YX*XLAMDA/(2.0*D(N))
C
C     SAVE REFLECTION DATA FOR OUTX ON BINARY SCRATCH TAPE
	WRITE (NSCRT1) N,TTH,SST,YX,F
C
C     FIND AND SAVE LARGEST CORRECTED F**2 AND ITS PLACE IN LIST
C     FIX SCALE FACTOR FOR CENTRIC WITH ANAMOLOUS DISPERSION CASE TO GET
C     A 100 LINE
	IF (ICENT.NE.0 .OR. NAS.LE.0) GO TO 50
	IF (N/2*2.EQ.N) GO TO 60
	YLAST=YX
	GO TO 100
60	YAVE=(YX+YLAST)*0.5
	IF (YAVE.LE.Y) GO TO 100
	Y=YAVE
	NUM=N-1
	GO TO 100
50	IF (YX.LE.Y) GO TO 100
	Y=YX
	NUM=N
100	CONTINUE
C
C     REWIND BINARY SCRATCH TAPE FOR USE IN OUTX
	ENDFILE NSCRT1
	REWIND NSCRT1
C     OUT MAXIMUM REFLECTION AS CALCULATED SCALE REFLECTION
	WRITE (NOUT,110) IH(NUM),IK(NUM),IL(NUM)
110	FORMAT (/36H THE CALCULATED SCALE REFLECTION IS 3I3)
	IF (ISCALE.EQ.0) GO TO 120
	NUM=1001
	IH(1001)=ISH
	IK(1001)=ISK
	IL(1001)=ISL
120	WRITE (NOUT,130) IH(NUM),IK(NUM),IL(NUM)
130	FORMAT (/30H THE SCALE REFLECTION USED IS 3I3)
C
C     CALCULATE STRUCTURE FACTOR
C
	CALL CALC (NUM,FS,YS,SSTS,TTHS)
	IF (NTCS.NE.0) YS=YS*XLAMDA/(2.0*D(NUM))
	IF (ICENT.EQ.0 .AND. NAS.GT.0) YS=Y
C
C     DETERMINE ABSORPTION CORRECTION FOR SCALE REFLECTION
C     SET UP ABSORPTION TABLES
C
	IF (XMU.LE.0.0) GO TO 310
	IF (XMUR.LT.8.0) GO TO 140
C
C     SET UP TABLE USED IF MUR IS GREATER THAN 7
C
	X1=1.0/XMUR
	X2=XMUR**(-2.0)
	X3=XMUR**(-3.0)
	X4=XMUR**(-4.0)
	X5=XMUR**(-5.0)
	X7=XMUR**(-7.0)
	A(1)=0.3183*X3+0.955*X5+7.1*X7
	A(2)=0.001615*X1+0.0314*X2+0.0648*X3+0.835*X4+0.14*X5
	A(3)=0.00642*X1+0.053*X2+0.179*X3+0.057*X4
	A(4)=0.01442*X1+0.086*X2+0.061*X3+0.33*X4
	A(5)=0.0254*X1+0.105*X2+0.080*X3+0.13*X4
	A(6)=0.0394*X1+0.123*X2+0.073*X3-0.16*X4
	A(7)=0.056*X1+0.139*X2
	A(8)=0.0752*X1+0.15*X2-0.022*X3
	A(9)=0.0966*X1+0.159*X2-0.1*X3
	A(10)=0.1199*X1+0.164*X2-0.16*X3
	A(11)=0.1448*X1+0.16*X2-0.2*X3
	A(12)=0.1741*X1+0.13*X2-0.3*X3
	A(13)=0.1984*X1+0.11*X2-0.21*X3
	A(14)=0.226*X1+0.1*X2-0.33*X3
	A(15)=0.25*X1+0.105*X2-0.48*X3
	A(16)=0.274*X1+0.08*X2-0.52*X3
	A(17)=0.295*X1+0.064*X2-0.64*X3
	A(18)=0.3107*X1+0.03*X2-0.5*X3
	A(19)=0.3183*X1-0.53*X3
	GO TO 270
C     READ MUR TABLE FROM CARDS
C
140	IF (NABS.EQ.0) GO TO 160
	READ (NIN,150) A
150	FORMAT (8F10.5)
	GO TO 270
C
C     READ TABLES FROM NFILE TAPE
C
160	READ (NFILE) RMU,A
170	READ (NFILE) RMUX,B
C
C     INTERPOLATE TABLE
C
	IF (XMUR-RMU) 200,290,180
180	IF (XMUR.LT.RMUX) GO TO 240
	RMU=RMUX
	DO 190  I=1,19
190	A(I)=B(I)
	GO TO 170
200	WRITE (NOUT,210)
210	FORMAT (31H ERROR IN ABSORPTION CORRECTION)
	WRITE (NOUT,220) XMUR,RMU,RMUX,A
220	FORMAT (8H XMUR = F5.2,8H  RMU = F5.2,9H  RMUX = F5.2/10F10.4/9F10
	1.4)
	DO 230  I=1,19
230	A(I)=1.0
	SC(2)=1.0
	GO TO 300
240	PART=(XMUR-RMU)/(RMUX-RMU)
	DO 250  I=1,19
250	A(I)=A(I)+PART*(B(I)-A(I))
	DO 260  I=1,19
260	A(I)=1.0/A(I)
270	WRITE (NOUT,280) XMUR,A
280	FORMAT (/26H THE A(I) TABLE FOR MUR = F6.2,3H IS//10F10.4/9F10.4)
290	IA=2
	CALL ABSX (SSTS,TTHS,SC(2))
300	IA=1
	CALL ABSX (SSTS,TTHS,SC(3))
310	SC(1)=XMAX/YS
	IF (XMU*RCV*SC(1).EQ.0) GO TO 311
	SC(5)=1.0/(2.0*XMU*RCV**2*SC(1))
	GO TO 315
311	SC(5)=SC(1)
	GO TO 315
315	WRITE (NOUT,320) SC
320	FORMAT (/14H SCALE FACTORS/13H     SC(1) = E15.4/13H     SC(2) = E
	115.4/13H     SC(3) = E15.4/13H     SC(4) = E15.4/13H     SC(5) = E
	215.4//35H SC(5) IS THE ABSOLUTE SCALE FACTOR)
C
C     CALCULATE  I/I-COR
C     REFERENCE USED IS ALPHA AL203   CORSC=DENS/(MU*GAMMA)
C                                          =62.62 FOR CU K ALPHA
C                                          =49.24 FOR CU K BETA
C                                          =INPUT FOR OTHER RADIATION
	IF (CORSC.NE.0.0) GO TO 330
	IF (LBETA.NE.0) GO TO 325
	CORSC=62.62
	GO TO 330
325	CORSC=49.24
330	IF (DENSC.LT..01) GO TO 340
	XINTR=(XMU*SC(5)/DENSC)*CORSC
340	REWIND NFILE
	RETURN
	END
	
	SUBROUTINE SCATFC
	REAL*8 ATOM
	INTEGER*2 IS,ISFA,ICHAR
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
	LOGICAL*1 FILLR2
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
      COMMON /DATA/ATOM(99),ATWT(99),XMURHO(99),BXYZ(6),URHO(7,20),
     1 WEIGHT(20),RDUMMY(439),NNF(20),NTRAN(3),JEXT(13),JNUM(3),JDEN(3),
     2 JCX(3),JCY(3),JCZ(3),ITRAN(30),M,IDUMMY(885),ICHAR(72),
     3 FILLR2(1850)
	COMMON /BETA/ CORSC,LBETA
C
	DIMENSION NNFCD(4),NNFBEG(4)
	DIMENSION URHOB(7,20)
	ASSIGN 130 TO NINFL
	ASSIGN 200 TO NINCD
C
C  CALL EOF TO OPEN THE FIRST DATA FILE
C
	CALL EOF(NFILE)
	NUM=32
	IFILE=1
	IF (NAS.NE.0) NAS=NWL*2-1
	NF=0
	IF (NNF(1).EQ.0) GO TO 331
	WRITE (NOUT,100)
100	FORMAT (25H0SCATTERING FACTOR TABLES)
	DO 310  I=1,20
	NF=NF+1
110	IF (NNF(I).EQ.0) GO TO 270
C
	DATA NNFBEG/470,888,1000,1250/
	IF (NNF(I).GT.NNFBEG(IFILE)) GO TO 270
C
C     OPTION TO CALL IN F-FACTORS VIA CARDS
	DATA NNFCD/449,867,988,1204/
	IF (NNF(I).GT.NNFCD(IFILE)) GO TO 180
C
C     READ SCATTERING FACTORS FROM TAPE
C
120	GO TO NINFL, (130,140)
130	READ (NFILE) ICODE,NAME,IDENT,(FX(J,NF),J=1,NUM),NAMES,(URHO(JX,NF
	1),JX=1,7),WEIGHT(NF),(URHOB(JX,NF),JX=1,7)
	IF (LBETA.EQ.0) GO TO 150
	DO 136 JX=1,7
136	URHO(JX,NF)=URHOB(JX,NF)
	GO TO 150
C
140	READ (NFILE) ICODE,NAME,(FX(J,NF),J=1,NUM)
C
150	IF (ICODE-NNF(I)) 120,300,160
C
160	WRITE (NOUT,170) NNF(I),I
170	FORMAT (29H0ERROR IN READING F TABLE NO.I4,5H  NO.I4,8H IN LIST)
	CALL CARDS
	GO TO 330
C
C     READ SCATTERING FACTOR TABLE FROM CARDS
C
180	NFF=NF-1+NNF(I)-NNFCD(IFILE)
	DO 260  K=NF,NFF
	READ (NIN,190) NAME,IDENT
190	FORMAT (2A4)
	GO TO NINCD, (200,220)
C
200	READ (NIN,210) (FX(J,K),J=1,NUM),URHO(NWL,K),WEIGHT(K)
210	FORMAT (8F10.5)
	GO TO 230
C
220	READ (NIN,210) FX(NAS,K),FX(NAS+1,K)
C
230	WRITE (NOUT,240) K,NAME,IDENT
240	FORMAT (/24H SCATTERING FACTOR TABLEI4,5X,2(5X,A4)//)
	WRITE (NOUT,250) (FX(J,K),J=1,NUM)
250	FORMAT (1X,8F10.3)
260	CONTINUE
	NF=NFF
	GO TO 310
C
C     UPDATE FILE PARAMETERS
C
270	CALL EOF (NFILE)
	IFILE=IFILE+1
	GO TO (160,280,290,291,330), IFILE
C
280	NUM=9
	NORFL=NF-1
	GO TO 110
C
290	NUM=14
	NP=NF-1-NORFL
	ASSIGN 140 TO NINFL
	ASSIGN 220 TO NINCD
	DATA IBLANK/4H    /
	IDENT=IBLANK
	GO TO 110
291	NUM=32
	ASSIGN 130 TO NINFL
	ASSIGN 200 TO NINCD
	GO TO 110
C
300	WRITE (NOUT,240) NF,NAME,IDENT
	WRITE (NOUT,250) (FX(J,NF),J=1,NUM)
310	CONTINUE
	MFILE=4-IFILE
	DO 320 N=1,MFILE
320	CALL EOF (NFILE)
	GO TO 330
331	DO 332 N=1,4
332	CALL EOF (NFILE)
330	RETURN
	END
	
	SUBROUTINE SYMPOS
	REAL*8 ATOM
	INTEGER*2 IS,ISFA,ICHAR
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	LOGICAL*1 FILLR1
	LOGICAL*1 FILLR2
      COMMON /GENL/XLAMDA,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),ITIME,NIN,
     1 NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,NTRANS(3,3),
     2 ISCALE,NPLOT,JJ,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,LENX,ITITLE(320),
     3 IDAY(9)
	COMMON /CAL/FX(32,20),TS(3,48),BETA(6,99),AI(99),XYZ(3,99),SF(99),
	1TO,CENTR,NF,NA,NS,      ITF,NORFL,NLAMDA,TTHIBM,TTHDBM,
	1 IS(3,3,48),ISFA(99),FILLR1(3406)
	COMMON /XXCENT/ ICENT
      COMMON /DATA/ATOM(99),ATWT(99),XMURHO(99),BXYZ(6),URHO(7,20),
     1 WEIGHT(20),RDUMMY(439),NNF(20),NTRAN(3),JEXT(13),JNUM(3),JDEN(3),
     2 JCX(3),JCY(3),JCZ(3),ITRAN(30),M,IDUMMY(885),ICHAR(72),
     3 FILLR2(1850)
	COMMON /EXTNS/RECD,LAUE,IEXT(13),NEX,NH,NK,NL,JNUMM
C
C     READ SYMMETRY POSITIONS FROM CARDS OR NFILE TAPE
C
C     INITIALIZE VARIABLES AND COUNTERS
	LAUE=0
	M=0
	WRITE (NOUT,100) NSG
100   FORMAT (16H1SPACE GROUP NO.I4//66H SYMMETRY POSITIONS EXCLUDING TH
     1OSE GENERATED BY LATTICE CENTERING/)
C
C     DETERMINE SYMMETRY INPUT UNIT
	IF (NSG.LE.300) GO TO 140
C
C     READ SYMMETRY POSITIONS IN XYZ FORMAT FROM NSG-240 CARDS
C
	IXYZ=-1
	NS=NSG-300
	DO 130  NS1=1,NS
	READ (NIN,110) ICHAR
110	FORMAT (72A1)
	WRITE (NOUT,120) ICHAR
120	FORMAT (1H 72A1)
C
C     CONVERT SYMMETRY POSITIONS TO INTERNAL FORMAT VIA TRANSL
C
	CALL CNVT
	IF (IOUT.EQ.1) GO TO 240
130	CONTINUE
	GO TO 220
C
C     READ SYMMETRY POSITIONS FROM NFILE TAPE
C
140	READ (NFILE) ISG,LAUE,INC,ICENT,ILAT,ITRAN,JEXT
	IF (NSG.EQ.ISG) GO TO 160
C     INCORRECT SPACE GROUP, SKIP TO CHECK NEXT ONE ON TAPE
	DO 150  N=1,INC
150	READ (NFILE) (JNUM(I),JDEN(I),JCX(I),JCY(I),JCZ(I),I=1,3),ITTI
	GO TO 140
C     CORRECT SPACE GROUP
160	DO 170  N=1,INC
	READ (NFILE) (JNUM(I),JDEN(I),JCX(I),JCY(I),JCZ(I),I=1,3),ITTI
C     CONVERT TO INTERNAL FORMAT
	CALL CNVT
	IF (IOUT.EQ.1) GO TO 240
170	CONTINUE
	NS=INC
C
C     READ AND PROCESS FILE EXTINCTION CODE
C
	WRITE (NOUT,180) JEXT
180	FORMAT (/25H  FILE EXTINCTION CODE = 13I2)
	DO 210  I=1,13
C     CHECK FOR NEW EXTINCTION CODE
	IF (IEXT(I)) 190,200,210
190	IEXT(I)=0
	GO TO 210
200	IEXT(I)=JEXT(I)
210	CONTINUE
220	WRITE (NOUT,230) IEXT
230	FORMAT (25H FINAL EXTINCTION CODE = 13I2)
	CALL EOF(NFILE)
240	RETURN
	END

	SUBROUTINE CCHART
C     THIS VERSION OF CCHART PRODUCES AN ADDITIONAL OUTPUT IN A FORMAT
C     FOR DIRECT TYPING OF JCPDS CARDS.  IT IS  ROUTINELY USED AT PSU
C     FOR THE PRODUCTION OF REFERENCE PATTERNS.  AFTER FILLING IN THE
C     APPROPRIATE SPACES THE OUTPUT MAY BE SUBMITTED DIRECTLY TO THE
C     JCPDS FOR INCLUSION IN THE PDF.
C
C     PROGRAM TO SIMULATE A DIFFRACTOMETER CHART
C     *** PSU PRODUCTION VERSION ***
C
	CHARACTER QDATE*9, QTIME*8,slid*60
	INTEGER*2 IH,IK,IL
	BYTE  FMT(55), FMT1(50), FMT2(45)
	DATA   FMT/'(','1','X',',','F','8','.','4',',','1','X',',','I',
     1 '4',',','1','X',',','2','(','3','I','3',',','A','1',')',',',
     1 '2','X',',','F','8','.','4',',','1','X',',','I','4',',','1',
     1 'X',',','2','(','3','I','3',',','A','1',')',')'/
	DATA  FMT1/'(','1','X',',','F','8','.','4',',','1','X',',','I',
     1 '4',',','1','X',',','3','I','3',',','1','3','X',',','F','8',
     1 '.','4',',','1','X',',','I','4',',','1','X',',','2','(','3',
     1 'I','3',',','A','1',')',')'/
	DATA  FMT2/'(','/','1','X',',','F','8','.','4',',','1','H',',',
     1 ',','F','8','.','4',',','1','H',',',',','F','8','.','4',',','1',
     1 '0','X',',','2','(','I','3',',','1','H',',',')',',','I','3',')'/
	BYTE ONE/'1'/,TWO/'2'/,THREE/'3'/,FOUR/'4'/,SEVEN/'7'/,
	1EIGHT/'8'/
	LOGICAL*1 ITITLE, IDAY, ITIME(8)
	COMMON/GENL/WL1,WL2,DMIN,XMUR,XMAX,XMU,A(19),SC(5),
	1ITIME,NIN,NOUT,NPUNCH,NSCRT1,NFILE,IA,NABS,NSG,IXYZ,ITRANS,
	2NTRANS(3,3),ISCALE,NPLOT,NREFL,NAS,NWL,ISH,ISK,ISL,IOUT,LENT,
	3 LENX,ITITLE(320),IDAY(9)
	COMMON /DATD/D(1001),IH(1001),IK(1001),IL(1001),NMAX
	COMMON/CAL/XINT1(1000),XINT3(1000),TTH1(1000)
	COMMON /XPLOT/W,TTHETA,SCMAX
	COMMON/CELLS/REALA,B,C,ALPHA,BETA,GAMMA,DUMMY(14)
	COMMON /DENSTY/ DENS,DENSC
	COMMON /IICOR/ XINTR
	DIMENSION XINT2(1000),TTH2(1000)
	DIMENSION Y(8001)
	DIMENSION TABLE1(15),TABLE2(15),TABLE(15),XANGLE(15)
	DIMENSION TABLE3(15)
	DIMENSION TEM(20),ITEM(20)
	DIMENSION CELL(6)
	DATA BLANK,PLUS,SIGN1,SIGN2,COMMA/' ','+',' ',' ',','/
C
C     INITIALIZE VARIABLES
C
	PI=3.141593
	RAD=114.5916
	ZERO=0.0
	SANGLE=5.00
	UANGLE=165.00
	RESET=249.00
	NTAPE1=10
	NTAPE2=11
	KOUNT=0
	KOUNT2=0
	FACT=2.0/RAD
	ALPHA=(ACOS(ALPHA))/FACT
	BETA=(ACOS(BETA))/FACT
	GAMMA=(ACOS(GAMMA))/FACT
C
	DATA TABLE1/0.060,0.066,0.075,0.089,0.108,0.130,0.160,0.175,0.205,
	10.225,0.250,0.295,0.360,0.410,0.500/
C
	DATA TABLE2/0.070,0.075,0.088,0.105,0.130,0.185,0.260,0.315,0.390,
	10.450,0.535,0.750,1.200,1.500,2.000/
C
C     NBS MEASURED FWHM TABLE
	DATA TABLE3/0.12,0.12,0.12,0.125,0.13,0.135,0.155,0.185,0.23,
	1           0.255,0.285,0.315,0.36,0.41,0.5/
C
	DATA XANGLE/0.0,20.0,40.0,60.0,80.0,100.0,120.0,130.0,140.0,145.0,
	1150.0,155.0,160.0,162.5,165.0/
C
C     READ CCHART CARD
C
	READ (NIN,120) W,TTHETA,SCMAX,NSC1,NTYPE,NCURVE,NSUPP,NLIST,NPR,
	1NCC,SCA,SCB,SCC,SCD,SCE,SCMAX2,NSC2,MCURVE,NFLAG
	WRITE (NOUT,120) W,TTHETA,SCMAX,NSC1,NTYPE,NCURVE,NSUPP,NLIST,
	1NPR,NCC,SCA,SCB,SCC,SCD,SCE,SCMAX2,NSC2,MCURVE,NFLAG
120	FORMAT (3F6.2,7I2,3X,5F5.4,F6.2,3I2)
	IF (CUTOFF.LE.0.0)  CUTOFF=1.5
	IF(NPR.LE.0) NPR=1
	IF (NCURVE.EQ.0) GO TO 140
	AMULT=3.0
	WRITE (NOUT,130)
130	FORMAT (32H0GAUSSIAN CURVE WILL BE COMPUTED)
	GO TO 160
140	AMULT=25.0
	WRITE (NOUT,150)
150	FORMAT (30H0CAUCHY CURVE WILL BE COMPUTED)
160	IF (NTYPE) 170,220,180
170	NTYPE=NPUNCH
	GO TO 200
180	IF (NTYPE-6) 190,190,220
190	NTYPE=NOUT
200	IF (SCA.LE.0.0) SCA=0.1
	IF (NLIST.LE.0) NLIST=1
220	IF (NTYPE.GT.2) WRITE (NOUT,230) NTYPE,SCB,SCA,SCB,SCD,SCC,SCD,SCE
230   FORMAT (//53H PRINTABLE SUMMARY TABLE WILL BE LISTED ON TAPE UNIT      
     1I2/40H REFLECTIONS OMITTED FOR D GREATER THAN F6.4,35H IF INTEGRAT    
     2ED INTENSITY LESS THAN F6.1/35H REFLECTIONS OMITTED FOR D BETWEEN     
     3F6.4,5H AND F6.4,35H IF INTEGRATED INTENSITY LESS THAN F6.1/37H RE    
     4FLECTIONS OMITTED FOR D LESS THAN F6.4,35H IF INTEGRATED INTENSITY    
     5 LESS THAN F6.1)
C     IF W=0.0 USE NBS MEASURED FWHM TABLE
	IF (W .GT. 0.01) GO TO 212
	W = 0.12
	TTHETA = 40.0
	DO 723 I=1,15
723	TABLE(I) = TABLE3(I)
	GO TO 249
212	DO 240  I=1,15
	IF (XANGLE(I).LT.TTHETA) GO TO 240
	ITEMP=I-1
	XPART=TTHETA-XANGLE(ITEMP)
	YPART=XANGLE(I)-XANGLE(ITEMP)
	FRAC=XPART/YPART
	HWU=(FRAC*(TABLE2(I)-TABLE2(ITEMP)))+TABLE2(ITEMP)
	HWL=(FRAC*(TABLE1(I)-TABLE1(ITEMP)))+TABLE1(ITEMP)
	DIF=(W-HWL)/(HWU-HWL)
	GO TO 250
240	CONTINUE
250	DO 260  J=1,15
260	TABLE(J)=TABLE1(J)+DIF*(TABLE2(J)-TABLE1(J))
249	WRITE (NOUT,270) W,TTHETA,WL1,WL2
270   FORMAT(/'   THE HALF-WIDTH IS',F5.2,
     1' AT THE DIFFRACTION ANGLE',F6.2,
     19H (2THETA)/'   THE ALPHA ONE WAVE LENGTH IS',F8.5/
     2' THE ALPHA TWO WAVE LENGTH IS',F8.5)
	WRITE (NOUT,251) (XANGLE(J),J=1,15),(TABLE(K),K=1,15)
251	FORMAT ('0ANGLE=',4X,15F6.1/' FWHM=',5X,15F6.3)
	FRAC=WL2/WL1
C
C     READ CCHART DATA INPUT FOR INTERRUPTED PLOT
C
	IF (NPLOT.GT.0) GO TO 330
	IF (NPLOT.EQ.-2) GO TO 300
	NPLOT=IABS(NPLOT)
	DO 290  N=1,NREFL
	READ (NPLOT) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N),XINT
	15
	WRITE (NOUT,310) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N),
	1XINT5
310	FORMAT (2F10.5,1X,3I3,3F10.5)
290	CONTINUE
	GO TO 330
300	DO 320  N=1,NREFL
	READ (NIN,310) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N),XI
	1NT5
	WRITE (NOUT,310) TTH1(N),D(N),IH(N),IK(N),IL(N),XINT1(N),XINT3(N),
	1XINT5
320	CONTINUE
330	DO 340  I=1,8001
340	Y(I)=0.0
	IF (NFLAG.NE.2) GO TO 323
C     SIMULATE TRACE FOR CUK(ALPHA) IF LAMBDA.NE.CUK(ALPHA)
	IF (WL1.EQ.1.5405981) GO TO 323
	RATIO=1.5405981/WL1
	DO 321 I=1,NREFL
	SINTH=RATIO*SIN(TTH1(I)/RAD)
	IF (ABS(SINTH).GE.1.0) GO TO 322
321	TTH1(I)=RAD*ASIN(SINTH)
	GO TO 323
322	NREFL=I
323	CONTINUE
	K=2
	M=1
	IREFL=NREFL
	IF (TTH1(1).GE.5.0) GO TO 345
	SANGLE=0.00
	UANGLE=160.00
	RESET=-1.00
345	DO 470  II=1,NREFL
	IF (TTH1(II).LE.UANGLE) GO TO 360
	IREFL=II-1
	GO TO 480
360	XINT2(II)=0.5*XINT1(II)
	X=FRAC*SIN(TTH1(II)/RAD)
	TTH2(II)=0.0
	IF (X.LT.1.0) TTH2(II)=RAD*ATAN(X/SQRT(1.0-X**2))
C     CHECK FOR REFLECTION     RANGE FOR HALF WIDTH DETERMINATION
370	IF (XANGLE(K).GE.TTH1(II)) GO TO 380
	K=K+1
	GO TO 370
380	KTEMP=K-1
	XPART=TTH1(II)-XANGLE(KTEMP)
	YPART=XANGLE(K)-XANGLE(KTEMP)
	WREFL=(XPART/YPART)*(TABLE(K)-TABLE(KTEMP))+TABLE(KTEMP)
	WSQ=WREFL*WREFL
	IF (NCURVE.NE.0) GO TO 390
	ZREFL=2.0*XINT1(II)*WREFL/PI
	GO TO 400
390	ZREFL=XINT1(II)/WREFL
C     SET RANGE OF Y CALCULATION DEPENDING ON HALF WIDTH
400	ISTART=(TTH1(II)-WREFL*AMULT)*50.0-RESET
	INT=WREFL*AMULT*100.0
	ISTOP=ISTART+INT
C
C     CHECK LIMITS OF CALCULATION RANGE
C
	IF (ISTART.LE.0) ISTART=1
	IF (ISTOP.GT.8001) ISTOP=8001
C     CALCULATE PROFILE FOR A REFLECTION
	DO 420  J=ISTART,ISTOP
	X=J
	DEL=TTH1(II)-((X+RESET)/50.0)
	DELSQ = DEL*DEL
	IF (NCURVE.NE.0) GO TO 410
C     CAUCHY PROFILE FOR A REFLECTION
	Y(J)=Y(J)+(ZREFL/(WSQ+4.0*DELSQ))
	GO TO 420
C     GAUSSIAN PROFILE FOR A REFLECTION
410	Y(J)=Y(J)+ZREFL*EXP(-PI*DELSQ/WSQ)
420	CONTINUE
C
C     REPEAT PROFILE FOR ALPHA2
	IF (NFLAG.EQ.2) WL2=0.0
	IF (WL2.EQ.0.0) GO TO 470
	ZPART=TTH2(II)-XANGLE(KTEMP)
	XREFL=(ZPART/YPART)*(TABLE(K)-TABLE(KTEMP))+TABLE(KTEMP)
	XSQ=XREFL*XREFL
	IF (NCURVE.NE.0) GO TO 430
	YREFL=2.0*XINT2(II)*XREFL/PI
	GO TO 440
430	YREFL=XINT2(II)/XREFL
440	KSTART=(TTH2(II)-XREFL*AMULT)*50.0-RESET
	KSTOP=KSTART+INT
	IF (KSTART.LE.0) KSTART=1
	IF (KSTOP.GT.8001) KSTOP=8001
	DO 460  J=KSTART,KSTOP
	X=J
	DEL=TTH2(II)-((X+RESET)/50.0)
	DELSQ = DEL*DEL
	IF (TTH2(II).LE.0) GO TO 470
	IF (NCURVE.NE.0) GO TO 450
	Y(J)=Y(J)+(YREFL/(XSQ+4.0*DELSQ))
	GO TO 460
450	Y(J)=Y(J)+YREFL*EXP(-PI*DELSQ/XSQ)
460	CONTINUE
470	CONTINUE
C
C     SCALE THE CALCULATED PATTERN
C
480	X=Y(1)
	DO 490  J=2,8001
	IF (X.LE.Y(J)) X=Y(J)
490	CONTINUE
	IF (SCMAX.EQ.0.0) SCMAX=100.2
500	ZSCALE=AMOD(SCMAX,1.0)
	SCMAX=SCMAX-ZSCALE
	NSCALE=10.0*(ZSCALE+0.02)
	IF (NSCALE.EQ.0) NSCALE=2
	LENGTH=40*2**(NSCALE-1)
	XSCAL=1.0
	IF (TTH1(IREFL).GT.164.0) GO TO 510
	VANGLE=UANGLE-1.0
	IF(TTH1(IREFL).GT.VANGLE) GO TO 510
	XSCAL=(TTH1(IREFL)-SANGLE)/160.0
	LENGTH=FLOAT(LENGTH)*XSCAL+1.0
510	NPLT=8000.0*XSCAL
	XSCAL=LENGTH
	WRITE (NOUT,520) ZSCALE,SCMAX,NSCALE,LENGTH,XSCAL
520   FORMAT (1H1, 10H ZSCALE = F7.1/7H  SC = F7.1/11H  NSCALE = I2/11H     
     1 LENGTH = I6/11H  XSCALE = F7.1)
	SCALE=SCMAX/X
	DO 530  J=1,8001
530	Y(J)=Y(J)*SCALE
	IF (SCMAX.EQ.SCMAX2) GO TO 690
	DO 610  II=M,IREFL
	IF (TTH1(II).LE.UANGLE) GO TO 550
540	TTH2(II)=0.0
	GO TO 610
550	NANG=((TTH1(II)-SANGLE)/0.02)+1.0
	IF (Y(NANG)-Y(NANG-1)) 580,600,560
560	IF (NANG-8001) 570,600,540
570	IF (Y(NANG+1).LE.Y(NANG)) GO TO 600
	NANG=NANG+1
	GO TO 560
580	IF (Y(NANG-1).GE.Y(NANG-2)) GO TO 590
	NANG=NANG-1
	GO TO 580
590	NANG=NANG-1
600	XINT2(II)=Y(NANG)
	TTH2(II)=(FLOAT(NANG)-1.0)*0.02+SANGLE
610	CONTINUE
C
C     OUTPUT COMPLETE  I VS.2 THETA TABLE (2 THETA=0.02)
C
C$$$$$$$$$$SKIP PRINTING OF PATTERN$$$$$$$$$$$$$$$$$$$$$$$
       GO TO 690
C	IF (NSUPP.EQ.0) GO TO 690
C	X1=SANGLE
C	X2=SANGLE+1.00
C	X3=SANGLE+2.0
C	X4=SANGLE+3.00
C	X5=SANGLE+4.0
C	NNN=NPLT+1
C	NN=51
C	N1=1
C	N2=51
C	N3=101
C	N4=151
C	N5=201
C620	WRITE (NOUT,630) (ITITLE(I),I=1,80)
C630	FORMAT('1',19X,80A1///)
C	WRITE (NOUT,640)
C640   FORMAT (119H 2THETA   INTENSITY       2THETA   INTENSITY       2TH
C     1ETA   INTENSITY       2THETA   INTENSITY       2THETA   INTENSITY)
C650	WRITE (NOUT,660) X1,Y(N1),X2,Y(N2),X3,Y(N3),X4,Y(N4),X5,Y(N5)
C660	FORMAT (F7.2,F10.2,5X,2F10.2,5X,2F10.2,5X,2F10.2,5X,2F10.2)
C	X1=X1+0.02
C	X2=X2+0.02
C	X3=X3+0.02
C	X4=X4+0.02
C	X5=X5+0.02
C	N1=N1+1
C	N2=N2+1
C	N3=N3+1
C	N4=N4+1
C	N5=N5+1
C	IF (N1.LT.NN) GO TO 650
C	NN=NN+250
C	IF (NN-NNN) 670,680,690
C670	N1=N1+200
C	N2=N2+200
C	N3=N3+200
C	N4=N4+200
C	N5=N5+200
C	X1=X1+4.00
C	X2=X2+4.00
C	X3=X3+4.00
C	X4=X4+4.00
C	X5=X5+4.00
C	GO TO 620
C680	X1=165.00
C	WRITE (NOUT,660) X1,Y(8001)
C
C     PLOT THE DIFFRACTOMETER TRACE
C
C     PREPARE HEADING FOR SIMULATED PLOT
C$$$$$$$$$$$$ OUTPUT A FILE IN ALFRED BINARY FORMAT$$$$$$$$$$$$$$$$$$$$
c
c   Modified to write output in d5000 format S.I. Zdzieszynski oct-91
c
c690	OPEN(UNIT=8,STATUS='NEW',FORM='UNFORMATTED')
690	QCTIME = 1.0
	FFINC=ZSCALE
	IF(ABS(ZSCALE-.03).LT..001) FFINC=.05
	NREC = 8001 / 10 + 1
	NPNT = 1

        encode(60,1,slid)(ititle(i),i=1,60)
1       format(60a1)

        call wrw5000(sangle,uangle,ffinc,slid,y)  ! S.I.Z.


c	CALL DATE( QDATE )
c	CALL TIME( QTIME )
c	WRITE(8) (ITITLE(I),I=1,80)
c	WRITE(8) QDATE,QTIME
c	WRITE(8) SANGLE,UANGLE,FFINC,QCTIME
	WRITE(NOUT,3456)(ITITLE(I),I=1,80)
3456	FORMAT(1X,'d5000 PATTERN FILE BEING WRITTEN: ',80A1)
c	WRITE(NOUT,3457)QDATE,QTIME,SANGLE,UANGLE,FFINC,QCTIME
c3457	FORMAT(' DATE: ',9A1,'  TIME: ',8A1/' SA: ',F10.3,
c     1'  EA: ',F10.3,'  INC: ',F7.4,'  TIME: ',F10.4)
c	DO 9876 JT=1,NREC
c	WRITE(8) ((Y(JTT)+5.),JTT=NPNT,NPNT+9)
c9876	NPNT = NPNT + 10
c	CLOSE(UNIT=8)


C*AU*
	IF (NCC.EQ.0) WRITE (NOUT,105) (ITITLE(I),I=1,80)
105	FORMAT (1H1,80A1)
	IF (NCC.EQ.0) CALL PLOTT(Y,NSC1,NPLT,LENGTH,NSCALE)
C     PREPATE SEPARATE FILE FOR TRACE
	IF (NFLAG.EQ.0) GO TO 695
	IF (MOUT.GT.24) GO TO 695
C*ORIG*
	WRITE (MOUT) (ITITLE(I),I=1,80),XINTR,SCMAX,(Y(I),I=1,8001)
	REWIND MOUT
	MOUT=MOUT+1
695	CONTINUE
	IF (SCMAX2.LE.0.0) GO TO 700
	X=X*SCALE
	SCMAX=SCMAX2
	NSC1=NSC2
	SCMAX2=0.0
	GO TO 500
700	IF (NLIST.EQ.0) GO TO 740
	K=2
	XLIST=ABS(FLOAT(NLIST))
	DO 730  N=M,IREFL
710	IF (XANGLE(K).GE.TTH1(N)) GO TO 720
	K=K+1
	GO TO 710
720	KTEMP=K-1
	XPART=TTH1(N)-XANGLE(KTEMP)
	YPART=XANGLE(K)-XANGLE(KTEMP)
	WREFL=(XPART/YPART)*(TABLE(K)-TABLE(KTEMP))+TABLE(KTEMP)
	IF  (ABS(TTH2(N)-TTH1(N)).GT.XLIST*WREFL) XINT2(N)=0.0
730	CONTINUE
C
C     OUTPUT THE ABRIDGED SUMMARY
C
740	IF (NTYPE.EQ.0) GO TO 950
	IF (NTYPE.NE.NPUNCH) GO TO 760
	ASSIGN 920 TO NTYP1
	NPR=1
	WRITE(NTYPE,750) (ITITLE(I),I=1,LENX)
750	FORMAT((80A1))
760	DO 940  NPRINT=1,NPR
	TTHZ=0.0
	NINTPX = 0
	IF (NTYPE.EQ.NPUNCH) GO TO 780
	ASSIGN 900 TO NTYP1
	NNN=0
	WRITE (NTYPE,770) (ITITLE(I),I=1,LENX)
770	FORMAT('1',10X,80A1/(10X,80A1))
780	WRITE (NTYPE,790)
790   FORMAT (10X,51H 2THETA  PEAK     D      H  K  L I(INT) I(PK) I(DS)
     1)
800	FORMAT (11X,F6.2,1X,F6.2,1X,F6.3,2X,3I3,3I6)
810	FORMAT (11X,F6.2,1X,F6.2,2X,F6.4,1X,3I3,3I6)
820	FORMAT (11X,F6.2,7X,1X,F6.3,2X,3I3,I6,6X,I6)
830	FORMAT (11X,F6.2,7X,2X,F6.4,1X,3I3,I6,6X,I6)
	DO 930  N=1,IREFL
	NINTP=XINT2(N)+0.5
	NINTD=XINT3(N)+0.5
	IF (D(N).GE.SCB) GO TO 850
	IF (D(N).LT.SCD) GO TO 840
	IF (XINT1(N)-SCC) 930,860,860
840	IF (XINT1(N)-SCE) 930,860,860
850	IF (XINT1(N).LT.SCA) GO TO 930
860	NINTI=XINT1(N)+0.5
	IF (TTH2(N).EQ.TTHZ.AND.NINTP.EQ.NINTPX) GO TO 880
	IF (D(N).LT.2.0) GO TO 870
	WRITE (NTYPE,800) TTH1(N),TTH2(N),D(N),IH(N),IK(N),IL(N),NINTI,NIN
	1TP,NINTD
	GO TO NTYP1, (900,920)
870	WRITE (NTYPE,810) TTH1(N),TTH2(N),D(N),IH(N),IK(N),IL(N),NINTI,NIN
	1TP,NINTD
	GO TO NTYP1, (900,920)
880	IF (D(N).LT.2.0) GO TO 890
	WRITE (NTYPE,820) TTH1(N),D(N),IH(N),IK(N),IL(N),NINTI,NINTD
	GO TO NTYP1, (900,920)
890	WRITE (NTYPE,830) TTH1(N),D(N),IH(N),IK(N),IL(N),NINTI,NINTD
	GO TO NTYP1, (900,920)
900	NNN=NNN+1
	IF (NNN.LT.55) GO TO 920
	WRITE (NTYPE,910) (ITITLE(I),I=1,LENX)
910	FORMAT('1',29X,80A1/(29X,80A1))
	WRITE (NTYPE,790)
	NNN=0
920	IF(NPRINT.GT.1) GO TO 929
	IF (XINT1(N).LT.CUTOFF)  GO TO 5
	IF (KOUNT.EQ.120)  GO TO 5
	KOUNT=KOUNT+1
	WRITE(NTAPE1,3) D(N),XINT1(N),IH(N),IK(N),IL(N)
3	FORMAT(2F10.5,3I5)
5	 IF (XINT2(N).LT.CUTOFF)  GO TO 929
	IF (KOUNT2.EQ.120)  GO TO 929
	IF(TTH2(N).EQ.TTHZ.AND.NINTP.EQ.NINTPX) GO TO 929
	K=N+1
	IF(K.GT.IREFL) GO TO 2
	NEXT=XINT2(K)+0.5
	IF(TTH2(K).EQ.TTH2(N).AND.NEXT.EQ.NINTP) GO TO 48
2	MIN1=N
14	KEY=0
	MH=0
	MK=0
	ML=0
	GO TO 15
48	IND=0
	LI=0
	KEY=1
	J=N-1
49	LI=LI+1
	J=J+1
	ITEM(LI)=XINT1(J)+0.5
	IF(TTH2(K).NE.TTH2(N).OR.NEXT.NE.NINTP) GO TO 50
	K=K+1
	IF(K.GT.IREFL) GO TO 50
	NEXT=XINT2(K)+0.5
	GO TO 49
50	MAX=ITEM(1)-ITEM(2)
	IF(MAX.GE.0) GO TO 51
	MAX1=2
	MAX2=1
	GO TO 52
51	MAX1=1
	MAX2=2
52	IF(LI.EQ.2) GO TO 61
	DO 53 I=3,LI
	IF(ITEM(I).LE.ITEM(MAX2)) GO TO 53
	IF(ITEM(I).LE.ITEM(MAX1)) GO TO 54
	MAX2=MAX1
	MAX1=I
	GO TO 53
54	MAX2=I
53	CONTINUE
61	IF(ITEM(MAX2).NE.0) GO TO 55
	IF(ITEM(MAX1).EQ.0) GO TO 56
	MIN1=MAX1+N-1
	GO TO 14
56	IND=0
	GO TO 6
55	IF(ITEM(MAX1).NE.ITEM(MAX2)) GO TO 57
	IND=1
6	J=N-1
	KOUNT4=0
	DO 7 L=1,LI
	J=J+1
	TEM(L)=ABS(TTH2(N)-TTH1(J))
	IF(ITEM(L).EQ.ITEM(MAX1)) KOUNT4=KOUNT4+1
	IF(ITEM(L).NE.ITEM(MAX1)) TEM(L)=100.0
7	CONTINUE
	XTEMP=TEM(1)-TEM(2)
	IF(XTEMP.LE.0.0) GO TO 10
	MIN1=2
	MIN2=1
	GO TO 11
10	MIN1=1
	MIN2=2
11	IF(LI.EQ.2) GO TO 9
	DO 12 I=3,LI
	IF(TEM(I).GE.TEM(MIN2)) GO TO 12
	IF(TEM(I).GE.TEM(MIN1)) GO TO 13
	MIN2=MIN1
	MIN1=I
	GO TO 12
13	MIN2=I
12	CONTINUE
	IF(IND.NE.0) GO TO 23
	MIN1=MIN1+N-1
	GO TO 14
23	IF(KOUNT4.GT.2) KEY=2
	GO TO 9
57	KOUNT3=0
	DIV2=ITEM(MAX1)
	DO 58 I=1,LI
	DIV1=ITEM(I)
	XTEMP=DIV1/DIV2
	IF(XTEMP.GE.0.1) KOUNT3=KOUNT3+1
58	CONTINUE
	IF(KOUNT3.GT.1) GO TO 59
	MIN1=MAX1+N-1
	GO TO 14
59	IF(KOUNT3.GT.2) GO TO 60
	MIN1=MAX1
	MIN2=MAX2
	GO TO 9
60	MIN1=MAX1
	MIN2=MAX2
	KEY=2
9	MIN1=MIN1+N-1
	MIN2=MIN2+N-1
	MH=IH(MIN2)
	MK=IK(MIN2)
	ML=IL(MIN2)
15	KOUNT2=KOUNT2+1
	WRITE(NTAPE2,4) KEY,D(MIN1),XINT2(N),IH(MIN1),IK(MIN1),IL(MIN1),
	1MH,MK,ML
4	FORMAT(I5,2F10.5,6I5)
929	TTHZ=TTH2(N)
	NINTPX=NINTP
930	CONTINUE
940	CONTINUE
	REWIND NTAPE1
	REWIND NTAPE2
	NUMBER=1
	READ(NTAPE1,3) (D(N),XINT1(N),IH(N),IK(N),IL(N),N=1,KOUNT)
16	TEM(1)=XINT1(1)-XINT1(2)
	TEM(2)=XINT1(2)-XINT1(3)
	TEM(3)=XINT1(1)-XINT1(3)
	IF(TEM(1).LT.0.0) GO TO 34
	IF(TEM(2).GE.0.0) GO TO 35
	IF(TEM(3).GE.0.0) GO TO 36
	MAX=3
	MID=1
	MIN=2
	GO TO 37
34	IF(TEM(2).LT.0.0) GO TO 38
	IF(TEM(3).GE.0.0) GO TO 39
	MAX=2
	MID=3
	MIN=1
	GO TO 37
35	MAX=1
	MID=2
	MID=2
	MIN=3
	GO TO 37
36	MAX=1
	MID=3
	MIN=2
	GO TO 37
38	MAX=3
	MID=2
	MIN=1
	GO TO 37
39	MAX=2
	MID=1
	MIN=3
37	DO 40 N=4,KOUNT
	IF(XINT1(N).LE.XINT1(MIN)) GO TO 40
	IF(XINT1(N).LE.XINT1(MID)) GO TO 41
	IF(XINT1(N).LE.XINT1(MAX)) GO TO 42
	MIN=MID
	MID=MAX
	MAX=N
	GO TO 40
42	MIN=MID
	MID=N
	GO TO 40
41	MIN=N
40	CONTINUE
C$$$$$$
c  put the peak intensity table out on summary file
	nout = 6
	if(number .eq. 2)nout = ntype
	IF (NUMBER.EQ.1) WRITE(NOUT,20) (ITITLE(I),I=1,80)
20	FORMAT(1HP,8X,80A1)
	IF (NUMBER.EQ.2) WRITE(NOUT,210) (ITITLE(I),I=1,80)
210	FORMAT(1H1,8X,80A1)
	IF(NUMBER.EQ.1) WRITE(NOUT,19)
19	FORMAT (/1X,43HCALCULATED PATTERN - INTEGRATED INTENSITIES)
	IF(NUMBER.EQ.2) WRITE(NOUT,21)
21	FORMAT (/1X,36HCALCULATED PATTERN - PEAK ITENSITIES)
	IN1=XINT1(MAX)+0.5
	IN2=XINT1(MID)+0.5
	IN3=XINT1(MIN)+0.5
	FMT2(7)=SEVEN
	FMT2(9)=THREE
	FMT2(16)=SEVEN
	FMT2(18)=THREE
	FMT2(25)=SEVEN
	FMT2(27)=THREE
	IF(D(MAX).GE.2.0) GO TO 71
	FMT2(7)=EIGHT
	FMT2(9)=FOUR
71	IF(D(MID).GE.2.0) GO TO 72
	FMT2(16)=EIGHT
	FMT2(18)=FOUR
72	IF(D(MIN).GE.2.0) GO TO 73
	FMT2(25)=EIGHT
	FMT2(27)=FOUR
73	WRITE(NOUT,FMT2) D(MAX),D(MID),D(MIN),IN1,IN2,IN3
	WRITE(NOUT,24) (ITITLE(N),N=1,160)
24    FORMAT(/10X,40A1,10X,40A1//10X,80A1//
     1 ' Ref: Snyder R. L.                                          ',/,
     2 ' The New York State College of Ceramics                     ',/,
     3 ' Alfred University, Alfred, N.Y 14802                         ')
	IF (ITRANS.NE.0) GO TO 989
906	CONTINUE
	WRITE(NOUT,25)(ITITLE(N),N=161,185),DENSC,(ITITLE(N),N=186,240)
	1,REALA
25    FORMAT(/1X,4HSYS.,1X,12A1,1X,4HS.G.,1X,13A1,1X,2HDX,1X,F6.3,1X,1HZ
     1,1X,5A1,1X,8HLOCALITY,1X,50A1/1X,1HA,3X,F8.3)
	IF ((NSG.LE.74.AND.NSG.GE.-74).OR.NSG.GT.230) WRITE(NOUT,994) B
994	FORMAT (1H+,19X,1HB,3X,F8.3)
	IF (NSG.LE.142.OR.(NSG.GE.168.AND.NSG.LE.194).OR.NSG.GT.230)
	1 WRITE(NOUT,995) C
995	FORMAT (1H+,33X,1HC,3X,F8.3)
	IF ((NSG.GE.143.AND.NSG.LE.167).OR.(NSG.LE.2.AND.NSG.GT.0))
	1 WRITE(NOUT,996) ALPHA
996	FORMAT(1X,7HALPHA =,F8.3)
	IF ((NSG.LE.-3.AND.NSG.GE.-15).OR.(NSG.GE.231.AND.NSG.LE.240))
	1 WRITE(NOUT,993)
993	FORMAT (5X)
	IF ((NSG.LE.2.AND.NSG.GE.-15).OR.(NSG.GE.231.AND.NSG.LE.240))
	1 WRITE(NOUT,997) BETA
997	FORMAT(1H+,17X,6HBETA =,F8.3)
	IF (NSG.GE.3.AND.NSG.LE.15) WRITE (NOUT,993)
	IF (NSG.LE.15.AND.NSG.GT.0) WRITE(NOUT,998) GAMMA
998	FORMAT(1H+,32X,7HGAMMA =,F8.3)
	GO TO 992
989	CELL(1)=REALA
	CELL(2)=B
	CELL(3)=C
	CELL(4)=ALPHA
	CELL(5)=BETA
	CELL(6)=GAMMA
	GO TO (901,902,903,904,905), ITRANS
901	REALA=CELL(2)
	B=CELL(3)
	C=CELL(1)
	ALPHA=CELL(5)
	BETA=CELL(6)
	GAMMA=CELL(4)
	GO TO 906
902	REALA=CELL(3)
	B=CELL(1)
	C=CELL(2)
	ALPHA=CELL(6)
	BETA=CELL(4)
	GAMMA=CELL(5)
	GO TO 906
903	REALA=CELL(1)
	B=CELL(3)
	C=CELL(2)
	ALPHA=CELL(4)
	BETA=CELL(6)
	GAMMA=CELL(5)
	GO TO 906
904	REALA=CELL(2)
	B=CELL(1)
	C=CELL(3)
	ALPHA=CELL(5)
	BETA=CELL(4)
	GAMMA=CELL(6)
	GO TO 906
905	REALA=CELL(3)
	B=CELL(2)
	C=CELL(1)
	ALPHA=CELL(6)
	BETA=CELL(5)
	GAMMA=CELL(4)
	GO TO 906
992	WRITE (NOUT,26) (ITITLE(N),N=241,320),SC(5),WL1
26    FORMAT(/1X,4HREF.,80A1//1X,40HSCALE FACTOR (INTEGRATED INTENSITIES
     1) = ,E12.4,11H  LAMBDA = ,F7.4)
	WRITE(NOUT,30)
30    FORMAT(5X,1HD,5X,3HI/I,3X,1HH,2X,1HK,2X,1HL,17X,1HD,5X,3HI/I,3X,
     11HH,2X,1HK,2X,1HL)
	L=5
	J=5
	K=1
18	DO 27 N=K,L
	M=N+J
	NINTP=XINT1(N)+0.5
	IN1=TTH2(N)
	IN2=XINT2(N)
	IN3=XINT3(N)
	IF(TTH1(N).EQ.1.0) SIGN1=BLANK
	IF(TTH1(N).EQ.2.0) SIGN1=PLUS
	IF(D(N).LT.2.0) GO TO 88
	FMT(6)=SEVEN
	FMT(8)=THREE
	FMT(10)=TWO
	FMT1(6)=SEVEN
	FMT1(8)=THREE
	FMT1(10)=TWO
	GO TO 89
88	FMT(6)=EIGHT
	FMT(8)=FOUR
	FMT(10)=ONE
	FMT1(6)=EIGHT
	FMT1(8)=FOUR
	FMT1(10)=ONE
89	IF(M.GT.KOUNT) GO TO 28
	NEXT=XINT1(M)+0.5
	IN4=TTH2(M)
	IN5=XINT2(M)
	IN6=XINT3(M)
	IF(TTH1(M).EQ.1.0) SIGN2=BLANK
	IF(TTH1(M).EQ.2.0) SIGN2=PLUS
	IF(D(M).LT.2.0) GO TO 86
	FMT(33)=SEVEN
	FMT(35)=THREE
	FMT(37)=TWO
	FMT1(28)=SEVEN
	FMT1(30)=THREE
	FMT1(32)=TWO
	GO TO 87
86	FMT(33)=EIGHT
	FMT(35)=FOUR
	FMT(37)=ONE
	FMT1(28)=EIGHT
	FMT1(30)=FOUR
	FMT1(32)=ONE
87	IF(NUMBER.EQ.1) GO TO 43
	IF(TTH1(N).EQ.0.0.AND.TTH1(M).EQ.0.0) GO TO 43
	IF(TTH1(N).GT.0.0.AND.TTH1(M).GT.0.0) WRITE(NOUT,FMT)D(N),NINTP,
	1IH(N),IK(N),IL(N),COMMA,IN1,IN2,IN3,SIGN1,D(M),NEXT,
	2IH(M),IK(M),IL(M),COMMA,IN4,IN5,IN6,SIGN2
	IF(TTH1(N).GT.0.0.AND.TTH1(M).EQ.0.0) WRITE(NOUT,FMT)D(N),NINTP,
	1IH(N),IK(N),IL(N),COMMA,IN1,IN2,IN3,SIGN1,D(M),NEXT,
	2IH(M),IK(M),IL(M)
	IF(TTH1(N).EQ.0.0.AND.TTH1(M).GT.0.0) WRITE(NOUT,FMT1)D(N),NINTP,
	1IH(N),IK(N),IL(N),D(M),NEXT,IH(M),IK(M),IL(M),COMMA,IN4,IN5,
	2IN6,SIGN2
	GO TO 45
43	WRITE(NOUT,FMT1)D(N),NINTP,IH(N),IK(N),IL(N),D(M),NEXT,IH(M),
	1IK(M),IL(M)
	GO TO 45
28	IF(NUMBER.EQ.1) GO TO 46
	IF(TTH1(N).EQ.0.0) GO TO 46
	WRITE(NOUT,FMT)D(N),NINTP,IH(N),IK(N),IL(N),COMMA,IN1,IN2,IN3,SIGN
	GO TO 45
46	WRITE(NOUT,FMT1)D(N),NINTP,IH(N),IK(N),IL(N)
45	IF(MOD(N,5).EQ.0) WRITE(NOUT,33) BLANK
33	FORMAT(5X,A1)
27	CONTINUE
	IF(J.NE.5)  GO TO 31
	IF(KOUNT.LE.10) GO TO 32
	WRITE(NOUT,988)
988	FORMAT (1X,80('-'))
	WRITE(NOUT,30)
	L=35
	IF(KOUNT.LE.35) L=KOUNT
	K=11
	J=25
	GO TO 18
31	IF (J.NE.25)  GO TO 32
	IF (KOUNT.LE.60)  GO TO 32
	IF (NUMBER.EQ.1)  WRITE(NOUT,20) ( ITITLE(I),I=1,80)
	IF (NUMBER.EQ.2)  WRITE(NOUT,210)( ITITLE(I),I=1,80)
	WRITE (NOUT,988)
	WRITE (NOUT,30)
	L=90
	IF (KOUNT.LE.90) L=KOUNT
	K=61
	J=30
	GO TO 18
32	IF(NUMBER.EQ.2) GO TO 950
	NUMBER=2
	KOUNT=KOUNT2
	READ(NTAPE2,47) (TTH1(N),D(N),XINT1(N),IH(N),IK(N),IL(N),TTH2(N),
	1XINT2(N),XINT3(N),N=1,KOUNT)
47	FORMAT(F5.0,2F10.5,3I5,3F5.0)
	GO TO 16
950	IF (IREFL.EQ.NREFL) GO TO 970
	IREFL=NREFL-IREFL
	WRITE (NOUT,960) IREFL,UANGLE
960   FORMAT ('  THE LAST ',I3,' REFLECTIONS ARE GREATER THAN ',F4.0,' D
     1EGREES 2THETA')
970	REWIND NTAPE1
	REWIND NTAPE2
	WRITE (NOUT,1111) XMU,DENS,DENSC,XINTR,SC(5),NSG
1111	FORMAT (/'0LINEAR ABSORPTION COEFFICIENT = ',F8.2/
	1 '0INPUT DENSITY = ',F7.3/'0CALCULATED DENSITY = ',F7.3/
	2 '0I/I-CORUNDUM = ',F6.3/'0GAMMA = ',E15.7/
	3 '0SPACE GROUP = ',I4)
	nout = 6
	RETURN
	END
	
         SUBROUTINE WRW5000(rstart,rend,rstep,slid,yobs)
C     TO WRITE D5000 RAW DATA FILE
C
C     AUTOR: S.I. ZDZIESZYNSKI 
C	     ALFRED UNIVERSITY
C            OCT-18-1991
C
C
C	THIS ROUTINE WRITES OUT A DIFFRAC-5000 RAW DATA FILE
C
C===================================================================
c     	INCLUDE 'FILECONV.CBS'
        CHARACTER DACOUT*1,styp*1,SLID*60,SLID1*36,SLID2*24,
     &            name*12,scan*1,difver*1,gonint*1,anode*2
     	INTEGER*2 IDUM,MTHC,ityp,mesflg,iover,ftyp,mtyp,nrep,
     &            mpro,nrng,difnum,chrlin
        integer*4 irpr(12,2),irlr(12),nhdb,isbf,leng
	REAL*4 SPCAN(4),DATM,TIMM,RSTART,REND,RSTEP,intmax,res
        real*4 YOBS(8001),bang(14),wave(5)
        character mont*36,day*9,tim*8
        iout=8

     	CLOSE( UNIT=iout)

     	OPEN( UNIT=iout, FILE='powd10.out', STATUS='NEW',ERR=888,
     &   ACCESS='DIRECT', RECL=12)

        npts=8001  ! for powd10 only

        NRNG=1	
        NREP=1  
        FTYP=12 

        bang(10)=1
        bang(1)=rstart
        bang(2)=rend
        bang(3)=rstep    
C
C  WRITE THE FILE HEADER BLOCK...
C
        IDUM=2
        ITYP=1
        NHDB=1
        ISBF=2
        LENG=3
        MESFLG=1

      WRITE(IOUT,REC=1,ERR=888)IDUM,ITYP,NHDB,ISBF,LENG,MESFLG,IOVER 
C
C  WRITE THE SPECIFICATION BLOCK REFERENCES...
C

C      TYPE 36,(I,IRPR(I,1),IRPR(I,2),I=1,12)
C36    FORMAT(' * NO. - ',I2,  ' IRPR(1)=',I5,3X,'IRPR(2)=',I5)

     	IREC = ISBF                         
       IF(IFLI.NE.1) THEN
        DO I=1,12
        IRPR(I,1)=0
        IRPR(I,2)=0
        ENDDO
       ENDIF
        NRNG=1

        IRPR(3,1)=ISBF+LENG
        IRPR(3,2)=3
        IRPR(1,1)=IRPR(3,1)+IRPR(3,2)
        IRPR(1,2)=9
        IRPR(2,1)=IRPR(1,1)+IRPR(1,2)
        IF(IRPR(2,2).EQ.0) IRPR(2,1)=0

        IRPR(4,1)=IRPR(1,1)+IRPR(1,2)+IRPR(2,2)
        IRPR(4,2)=NRNG*2
        IRPR(10,1)=IRPR(4,1)+IRPR(4,2)
        IRPR(10,2)=NRNG*2
        IRPR(5,1)=IRPR(4,1)+IRPR(4,2)+IRPR(10,2)
        IF(IRPR(5,2).EQ.0) IRPR(5,1)=0
        IRPR(6,1)=IRPR(4,1)+IRPR(4,2)+IRPR(10,2)+IRPR(5,2)
        IRPR(6,2)=INT(NPTS/12+0.5)
C      TYPE 35,(I,IRPR(I,1),IRPR(I,2),I=1,12)
C35    FORMAT(' ** NO. - ',I2,  ' IRPR(1)=',I5,3X,'IRPR(2)=',I5)
     
      WRITE(IOUT,REC=IREC,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=1,4)    
      WRITE(IOUT,REC=IREC+1,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=5,8) 
      WRITE(IOUT,REC=IREC+2,ERR=888)(IRPR(I,1),IRPR(I,2),IRLR(I),I=9,12) 


C
C  WRITE THE INSTRUMENTATION BLOCK...
C
     	IREC = IRPR(1,1)+4 
        wave(1)=1.54056
        wave(2)=1.54439
        wave(3)=1.54184
        wave(4)=1.39222
        wave(5)=0.5
        anode='CU'
        chrlin=1        

        write(iout,rec=irec)difnum,difver,gonint,anode,chrlin,
     &                      (wave(i),i=1,5)

c        CALL INSPAR(IOUT,IREC)
C
C  WRITE THE FILE DESCRIPTION BLOCK...
C
     	IREC = IRPR(3,1)

c        TYPE 500, SLID,(bang(i),i=1,3),bang(10)
c
c500     FORMAT(' SAMPLE ID:',A60,
c     &         /,' START=',F8.3,3X,'END=',F8.3,3X,'STEP=',F6.3,/,
c     &           ' TIME=',f4.1)
      
        BANG(4)=YOBS(1)/BANG(10)
        DO I=1,NPTS
        IF(YOBS(I)/BANG(10).GT.BANG(4)) BANG(4)=YOBS(I)/BANG(10)
        ENDDO

        IF(INTMAX.EQ.0) INTMAX=BANG(4)  

C*** decode DATE and TIME to d5000 format
c
        call date(day)
        mont='JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'
        IDAY=INDEX(MONT,DAY(4:6))
        ENCODE(2,1,DAY(3:4))IDAY
1       FORMAT(I2)        
        DAY(5:6)=DAY(8:9)
        DECODE(6,5,DAY)DATM
5       FORMAT(F8.0)

        call time(tim)
        TIM(3:4)=TIM(4:5)
        TIM(5:6)=TIM(7:8)
        DECODE(6,3,TIM)TIMM
3       FORMAT(F8.0)

     	WRITE(IOUT,REC= IREC) NAME,DATM,TIMM
     &  ,FTYP,MTYP,INTMAX,RES,NREP,MPRO,NRNG,SCAN

        DECODE(60,50,SLID)SLID1,SLID2
50      FORMAT(A36,A24)

        WRITE(IOUT,REC=IREC+1)(SPCAN(I),I=3,4),STYP,MTHC
     &           ,DACOUT,SLID1
     	WRITE(IOUT,REC= IREC+2) SLID2

C
C  WRITE THE LINE MEASUREMENT BLOCK...
C
     	IREC = IRPR(4,1)

              WRITE(IOUT,REC= IREC,ERR=888) (BANG(I),I=1,12)
     	      WRITE(IOUT,REC= IREC+1,ERR=888) (BANG(I),I=13,14)

c     	NPTS = INT( (BANG(2)-BANG(1))/BANG(3)) + 1
      
     	IRNG = NRNG  

        L=0
        NREC=0
        DO K=1,NPTS 
        L=L+1
        IF(L.EQ.12. OR .K.EQ.NPTS) THEN
          NREC=NREC+1
          L=0
        ENDIF   
        ENDDO

     	IREC = IRPR(6,1)

        K=1
        FIRST=1
        LAST=12
        DO J=0,NREC-1
        WRITE(IOUT,REC=IREC+J,ERR=888)(YOBS(K)+5.0,K=FIRST,LAST)
        FIRST=FIRST+12
        LAST=LAST+12
        IF(NPTS-LAST.LT.0) LAST=NPTS
100     ENDDO
     	GOTO 999
888	IERR = 2
999	RETURN
    	END
