C  PROGRAM SORT7 WRITTEN FOR THE VAX730 12/83 ADAPTED FROM
C  PROGRAM SORT5 WRITTEN BY R. SNYDER FOR THE XDS SIGMA 5 6/28/72
C  PROGRAM ADAPTED FROM
C  PROGRAM SORT3 WRITTEN BY R. SNYDER FOR THE IBM 360/75   11/1/69
C  ADAPTED FROM THE 1130 PROGRAM SORT1
C  SORT 3 IS A GENERAL PROGRAM TO SORT SINGLE CRYSTAL REFLECTION
C  DATA ON ANY COMBINATION OF INDICES( IE HKL KLH ...) AND/OR AVERAGE
C  EQUIVALENT REFLECTIONS AND/OR INTERSCALE UP TO 10 BATCHES OF DATA
C  THE AVERAGES ARE UNWEIGHTED AND THE SCALE FACTORS ARE LINEAR
C  IF AVERAGING IS DESIRED FOR SPACE GROUPS OTHER THAN ORTHOROMBIC OR
C  MONOCLINIC SUBROUTINE SPACE WHICH CONVERTS ALL INDICES TO THE PARITY
C  DESIRED MUST BE SUPPLIED
C  THE FINAL DATA SET SORTED AND/OR SCALED AND/OR AVERAGED IS WRITTEN
C  ON SEQUENTIAL FILE 20  IN LEAST SQUARES FORMAT.  FILE 20 MAY BE
C  EITHER A DISK OR TAPE FILE AS SPECIFIED BY THE CONTROL CARDS
C***********************************************************************
C  INPUT SETUP
C***********************************************************************
C  CARD 1   CONTROL CARD   (8I1)
C  COL 1,2 AND 3 SPECIFY THE ORDER OF SORTING H=1, K=2 AND L=3
C  E.G.  COL1,2,3=231 MEANS SORT DATA ON KLH   123 MEANS SORT ON HKL
C        COL1     SORT CONTROL INTEGER
C        COL2     SORT CONTROL INTEGER
C        COL3     SORT CONTROL INTEGER
C        COL4= 0  READ ONE BATCH OF DATA AND DO NOT SCALE
C            = 1  READ UP TO 10 BATCHES OF DATA AND SCALE TO FIRST BATCH
C        COL5= 0  DO NOT AVERAGE EQUIVELENT REFLECTIONS
C            = 1  AVERAGE EQUIVELENT REFLECTIONS FOR LAUE GROUP 2/M
C            = 2  AVERAGE EQUIVELENT REFLECTIONS FOR LAUE GROUP MMM
C            = 3  AVERAGE EQUIVELENT REFLECTIONS FOR ANY OTHER LAUE
C                 GROUP (USER SUPPLIED SUBROUTINE SPACE REQUIRED)
C        COL6= 1 PUNCH THE FINAL DATA SET
C            = 0 DO NOT PUNCH BUT DATA IS STILL WRITTEN ON FILE 20
C        COL7= 0 DATA FROM CARDS
C            = 1 DATA FROM BINARY SEQUENTIAL FILE LOGICAL NUMBER 10
C                  FILE 10 CONTAINS RECORDS OF J,K,L,F,SIG,IUN,INT(FLOAT
C                            SIG(I)   LAST RECORD HAS J=999
C        COL8= 0 SLOWEST MOVING INDEX(SMI) CAN BE NEGATIVE
C            = 1 SMI IS + ONLY
C        COL9= 0 NORMAL OPERATION
C            = 1 DETERMINE R VALUES BETWEEN THE INTENSITEES AND CALL EXI
C  CARD 2 AND ON  FIRST DATA SET (3I9,2F9.2,13XI1)
C        COL7-9 =998  MEANS END OF DATA SET READ A NEW SET
C               =999  MEANS END OF DATA BEGIN PROCESSING
C***********************************************************************
	EXTERNAL NJKL
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  SUM(2,10) ARE THE NUMBER OF OVERLAPPING REFLECTIONS BETWEEN BATCHES
C  IBTCH(10) ARE THE NUMBER OF REFLECTIONS IN EACH BATCH
C  NUM(21) ARE THE NUMBER OF DATA ON EACH OF THE 21 DISK FILES
C  SF(10) ARE THE SCALE FACTORS FOR EACH BATCH OF DATA
C  FILE 1 AND 2  ARE SCRATCH DIRECT ACCES FILES
	IDISC1 = 1
	IDISC2 = 2
C  DEFINE I/O LOGICAL NUMBERS
	IN = 105
	ITYP = 108
	IPUCH = 106
C  ITAP IS THE INPUT TAPE OR SEQUENTIAL DISK FILE
C WRITTEN AS TAPE 2 BY DATAP
	ITAP = 10
C  IOUT IS THE OUTPUT TAPE OR SEQUENTIAL DISK FILE
	IOUT = 20
	IUNOB=0
	LSOUT=0
	INTOT=0
	DO100 I=1,10
	SF(I)=1.0
	IBTCH(I)=0
	DO101 J=1,2
101	SUM(J,I)=0.0
100	CONTINUE
	DO105 I=1,21
105	NUM(I)=0
	READ(IN,1)IC
1	FORMAT(20I1)
	WRITE(ITYP,107) IC
107	FORMAT(' CONTROL INTEGERS ',20I1)
	K1 = IC(1)
	K2 = IC(2)
	K3 = IC(3)
	I=IC(5)
C  BEGIN READING LOOP
140	ISCAL=0
200	ISCAL=ISCAL+1
	WRITE( ITYP, 2001 ) ISCAL
2001	FORMAT( 1H1,' INPUT DATA FOR BATCH NUMBER ',I3)
	WRITE( ITYP, 2002)
2002	FORMAT(   '     H    K    L   IUN BATCH  FO       SIGMA   INTENSIT
	1Y   SIGMA'/)
	IHEAD = 0
201	IF(IC(7))205,205,206
C 205 READ(IN,5)(JKL(J,1),J=1,3),FO(1),SIG(1),JKL(4,1),AINT(1),SINT(1)
C   5 FORMAT(3I9,2F9.2,13XI1,F9.0,F9.4)
205	READ(IN,5)(JKL(J,1),J=1,3),FO(1),SIG(1),AINT(1),SINT(1)
5	FORMAT(1X,3I3,4F10.2)
	GO TO 207
206	READ(ITAP,21)(JKL(J,1),J=1,3), FO(1), SIG(1), AINT(1), SINT(1)
21	FORMAT(1X3I3,F10.2,F8.2,F8.0,F8.2)
207	SIG(1) = ABS(SIG(1))
	JKL(4,1) = 0
	IF(FO(1))1007,1007,1008
1007	JKL(4,1) = 1
	FO(1) = ABS(FO(1))
1008	FO(1) = SQRT(FO(1))
	SIG(1) = SQRT(SIG(1))
	IF(IC( 9))208,208,209
209	FO(1)=AINT(1)
	SIG(1)=SINT(1)
208	IREJ=0
	IF(JKL(1,1)-998)210,200,250
210	IF(IC(5))220,220,215
215	GO TO(216,217,218),I
216	CALL MONO(JKL(1,1),JKL(2,1),JKL(3,1),IREJ)
	GO TO 219
217	CALL ORTHO(JKL(1,1),JKL(2,1),JKL(3,1),IREJ)
	GO TO 219
218	CALL SPACE(JKL(1,1),JKL(2,1),JKL(3,1),IREJ)
219	IF(IREJ)201,220,201
220	IF(IC( 8))221,221,226
226	IF(JKL(K1,1)-20)228,227,227
227	IFILE=21
	GO TO 245
228	IFILE=JKL(K1,1)+1
	GO TO 245
221	IF(JKL(K1,1)-10)230,225,225
225	IFILE=21
	GO TO 245
230	IF(JKL(K1,1)+10)235,235,240
235	IFILE=1
	GO TO 245
240	IFILE=JKL(K1,1)+11
245	N=NUM(IFILE)
	IF( N - 1500) 246,247,247
246	N = IFILE*1500*9 - 1500*9 + N*9 +1
	WRITE DISC IDISC1,N,(JKL(J,1),J=1,4),ISCAL,FO(1),SIG(1),
	1 AINT(1), SINT(1)
	IBTCH(ISCAL)=IBTCH(ISCAL)+1
	NUM(IFILE)=NUM(IFILE)+1
	IHEAD = IHEAD + 1
	IF( IHEAD - 47 )2462,2462,2461
2461	WRITE(ITYP,2003)
2003	FORMAT(1H1)
	WRITE( ITYP,2002)
	IHEAD = 0
2462	WRITE( ITYP,2463 )(JKL(J,1),J=1,4),ISCAL,FO(1),SIG(1),AINT(1),SINT
	1(1)
2463	FORMAT( 1X,5I5,2(F10.2,F10.5))
	GO TO 201
247	WRITE(ITYP,10)IFILE
10	FORMAT(/' PROGRAM CANNOT HANDEL DATA SORTED AS SPECIFIED CHOOSE A
	1DIFFERENT  SORTING MODE   AND RE-RUN'/' THE DISK OVERFLOW OCCURED
	2AT SMI = ',I3/)
	GO TO 999
250	DO 255 I=1,21
255	INTOT=INTOT+NUM(I)
C  END READING LOOP
C  SORT THE DATA ON EACH OF THE 21 FILE SEGMENTS
	DO300 I=1,21
	IF(NUM(I))300,300,305
305	LIM=NUM(I)
	N = 1500 * 9 * I - 1500 * 9  - 8
	DO310 J=1,LIM
	N = N + 9
310	READ DISC IDISC1,N,(JKL(K,J),K=1,5),FO(J),SIG(J),AINT(J),SINT(J)
	N = 1500 * 9 * I - 1500 * 9  - 8
	CALL SORT(LIM,NJKL)
	DO315 J=1,LIM
	N = N + 9
315	WRITE DISC IDISC1,N,(JKL(K,J),K=1,5),FO(J),SIG(J),AINT(J),SINT(J)
300	CONTINUE
C  END SORTING
	IF(IC(4))500,500,350
C  BEGIN SCALING DATA SETS
350	CALL INSCL(ITYP,IPUCH,ISCAL)
C  END SCALING OF DATA SETS
500	IF(IC(5))700,700,501
C  BEGIN AVERAGING EQUIVLENT REFLECTIONS
501	CALL AVEQ(IPUCH,ITYP,INTOT,IUNOB,LSOUT,IOUT)
	GO TO 800
C  END AVERAGING EQUIVLENT REFLECTIONS
C  THIS SECTION WRITES DATA FRON SCALING AND/OR SORTING ON FILE 20 (IOUT
700	DO705 I=1,21
	IF(NUM(I))705,705,710
710	LIM=NUM(I)
	N = 1500 * 9 * I - 1500 * 9  - 8
	DO715 J=1,LIM
	N = N + 9
	READ DISC IDISC1,N,(JKL(K,J),K=1,5),FO(J),SIG(J),AINT(J),SINT(J)
	IF(JKL(4,J))725,725,720
720	IUNOB=IUNOB+1
725	LSOUT=LSOUT+1
	WRITE( IOUT   )(JKL(K,J),K=1,3),FO(J),SIG(J),JKL(4,J),JKL(5,J),AIN
	1T(J),SINT(J)
715	CONTINUE
705	CONTINUE
800	REWIND IOUT
C LIST FINAL SET OF DATA ON FILE 20 (IOUT)
	WRITE(ITYP,41)
41	FORMAT(1H1,8X, 'H        K        L   FOBS      SIGMA SCALE NO. ',
	1   ' IUN   INT. I    SIGMA I',//)
	N = 0
	DO810 I=1,LSOUT
	READ(IOUT)(JKL(K,1),K=1,3),FO(1),SIG(1),JKL(4,1),JKL(5,1),AINT(1),
	1SINT(1)
	N = N + 1
	STEMP=1.0
	IF( IC(6))804,804,803
803	WRITE( IPUCH , 4)(JKL(K,1),K=1,3),FO(1),SIG(1),STEMP,JKL(4,1),
	1 AINT(1),SINT(1)
804	IF(N - 47)806,806,805
805	N = 0
	WRITE(ITYP, 41)
806	WRITE( ITYP  , 4)(JKL(K,1),K=1,3),FO(1),SIG(1),STEMP,JKL(4,1),
	1 AINT(1),SINT(1)
810	CONTINUE
4	FORMAT(3I9,F9.2,F9.4,F9.0,I5,F9.0,F9.4)
	WRITE(ITYP,40)     INTOT,IUNOB,LSOUT
40	FORMAT(//  ' TOTAL NUMBER OF REFLECTIONS INPUT=',I5/  ' NUMBER OF
	1UNOBSERVED REFLECTIONS OUTPUT=',I5/  ' TOTAL NUMBER OF REFLECTIONS
	2 FOR LEAST SQUARES=',I5)
999	STOP
	END
	SUBROUTINE INSCL(ITYP,IPUCH,ISCAL)
	DIMENSION LAPOV(10)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C
C  SUBROUTINE INSCL DETERMINES THE SCALE FACTORS AND R VALUES BETWEEN
C  UP TO 10 SETS OF DATA( CONTAINING OVERLAPPING FELLECTIONS)
C
	IDISC1 = 1
	IDISC2 = 2
	WRITE( ITYP,5000 )
5000	FORMAT(1H1,' AVERAGING OF EQUIVALENT REFLECTIONS')
	IF(IC( 9))103,103,102
102	WRITE(ITYP,104)
104	FORMAT(//' ALL F SYMBOLS ON OUTPUT REFER TO INTENSITY VALUES'//)
103	DO 101 JJ=1,10
101	LAPOV(JJ)=0
C
C  BEGIN THE 100 LOOP TO DETERMINE SUMS
C
	DO 100 ILOOP=1,21
	IF(NUM(ILOOP))100,100,105
105	LIM=NUM(ILOOP)
	N = 1500 * 9 * ILOOP - 1500 * 9  - 8
	DO 110 JJ=1,LIM
	N = N + 9
110	READ DISC IDISC1,N,(JKL(I,JJ),I=1,5),FO(JJ),SIG(JJ),
	1 AINT(JJ) , SINT(JJ)
	I=0
120	FPRME=0.0
	IONE=0
125	SUB=0.0
	FTEMP=0.0
130	I=I+1
135	IF(I-LIM)140,225,100
140	IPACK = (JKL(1,I)+50)*10000 + (JKL(2,I)+50)*100 + JKL(3,I)+50
	II=I+1
	JPACK = (JKL(1,II)+50)*10000 + (JKL(2,II)+50)*100 + (JKL(3,II)+50)
	IF(IPACK - JPACK)225,145,225
145	IF(IONE)150,150,190
150	IONE=1
	JJ=I
C
C---- CHECK IF ANY OF THE OVERLAPPING REFLECTIONS OF THIS INDEX ARE UNOB
C
155	IF(JKL(4,JJ))160,160,170
160	JJ=JJ+1
	IF(JJ-LIM)165,165,190
165	JPACK = (JKL(1,JJ)+50)*10000 + (JKL(2,JJ)+50)*100 + (JKL(3,JJ)+50)
	IF( IPACK - JPACK)190,155,190
C
C  IF A REFLECTION IS UNOBSERVED OR HAS NO CORRESPONDING REF. IN SET 1 S
C
170	JJ=JJ+1
	IF(JJ-LIM)175,175,100
175	JPACK = (JKL(1,JJ)+50)*10000 + (JKL(2,JJ)+50)*100 + (JKL(3,JJ)+50)
	IF( IPACK - JPACK)180,170,180
180	I=JJ
	IONE=0
|	GO TO 135
C
C  DETERMINE THE SUMS FOR OBSERVED REF. OVERLAPPING SET 1
C
190	IF(JKL(5,I)-JKL(5,II))200,195,200
195	SUB=SUB+1.0
	FTEMP=FTEMP+FO(I)
	GO TO 130
200	SUB=SUB+1.0
	FTEMP=FTEMP+FO(I)
	FTEMP=FTEMP/SUB
	IT=JKL(5,I)
	IF(IT-1)210,205,210
205	FPRME=FTEMP
	GO TO 125
210	IF(FPRME)215,215,220
215	JJ=II
	SUB=0.0
	FTEMP=0.0
	GO TO 170
220	LAPOV(IT)=LAPOV(IT)+1
	JJ=1500*(IT-1) * 6+LAPOV(IT) * 6 + 1
	SUM(1,IT)=SUM(1,IT)+FPRME
	SUM(2,IT)=SUM(2,IT)+FTEMP
	WRITE DISC IDISC2,JJ,IT,(JKL(K,I),K=1,3),FTEMP,FPRME
	GO TO 125
225	IF(I-1)130,130,230
230	JJ=I-1
	JPACK = (JKL(1,JJ)+50)*10000 + (JKL(2,JJ)+50)*100 + (JKL(3,JJ)+50)
	IF( IPACK - JPACK)130,235,130
235	SUB=SUB+1.0
	FTEMP=FTEMP+FO(I)
	FTEMP=FTEMP/SUB
	IT=JKL(5,I)
	IF(IT-1)120,120,240
240	IF(FPRME)125,125,245
245	LAPOV(IT)=LAPOV(IT)+1
	JJ=1500*(IT-1) * 6+LAPOV(IT) * 6 + 1
	SUM(1,IT)=SUM(1,IT)+FPRME
	SUM(2,IT)=SUM(2,IT)+FTEMP
	WRITE DISC IDISC2,JJ,IT,(JKL(K,I),K=1,3),FTEMP,FPRME
	GO TO 120
C
C  END 100 LOOP
C
100	CONTINUE
C
C  ----- DETERMINE SCALE FACTORS-----------
C
	WRITE(ITYP,1)
1	FORMAT  (  ///  ' SCALE FACTORS BETWEEN SET 1 AND SET N'  // 3X,
	1'  N  FACTOR  NO OF REF. TOT.NO. IN SET SUM SET 1 SUM SET 2'  /3X,
	2'  1    1.0000')
260	IONE=0
	DO 265 I=2,ISCAL
	IF(LAPOV(I))266,266,267
266	IONE=1
	WRITE(ITYP,2)I
2	FORMAT(  ///  ' THERE ARE NO OVERLAPPING REFLECTIONS BETWEEN SET 1
	1 AND SET',  I3 /  ' PROCESSING DISCONTINUED')
	GO TO 265
267	SF(I)=SUM(1,I)/SUM(2,I)
	WRITE(ITYP,3)I,SF(I),LAPOV(I), IBTCH(I),SUM(1,I),SUM(2,I)
3	FORMAT(3X,I3,F10.4,I10,5XI10,2F10.2)
265	CONTINUE
	IF(IONE)275,275,270
270	CALL EXIT
C
C--- BEGIN R FACTOR AND LISTING LOOP---------------------
C
275	DO 280 ILOOP=2,ISCAL
	WRITE(ITYP,4)ILOOP,ILOOP,ILOOP
4	FORMAT(  /// ' LIST OF REFLECTIONS OVERLAPPING SET 1 AND SET',I3//
	1'   H  K  L  F(SET1)  F(SET',I2,')  F(',I2,')*SF      DELTA'/)
	LIM=LAPOV(ILOOP)
	SUM(2,ILOOP)=0.0
	SUB=0.0
	DO 300 I=1,LIM
	IT=(ILOOP-1)*1500 * 6 + I * 6  + 1
	READ DISC IDISC2,IT,II,(JKL(JJ,1),JJ=1,3),FTEMP,FPRME
	SUB=SUB+ABS(FPRME-FTEMP)
	A=FTEMP*SF(ILOOP)
	B=ABS(FPRME-A)
	SUM(2,ILOOP)=SUM(2,ILOOP)+B
	WRITE(ITYP,5)(JKL(JJ,1),JJ=1,3),FPRME,FTEMP,A,B
5	FORMAT(  1X3I3,3F10.2,F10.5)
300	CONTINUE
	A=SUM(2,ILOOP)/SUM(1,ILOOP)
	B=SUB/SUM(1,ILOOP)
	WRITE(ITYP,6)SUB,SUM(1,ILOOP),B,SUM(2,ILOOP),SUM(1,ILOOP),A
6	FORMAT(//2X, '    NUM       DENOM  INTER-SET R',  /  1X2F10.2,F10.
	16,' UNSCALED R'/ 1X2F10.2,F10.6, ' SCALED R'//)
280	CONTINUE
	IF(IC( 9))321,321,270
321	RETURN
	END
	SUBROUTINE AVEQ(IPUCH,ITYP,INTOT,IUNOB,LSOUT,IOUT)
	DIMENSION DELTA(10)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
	IDISC1 = 1
	WRITE( ITYP,1000 )
1000	FORMAT(1H1,' INTER-SCALING INFORMATION')
	IUNIQ=0
	NSDR=0
	SDRAV=0.0
	DO505 I=1,21
	IF(NUM(I))505,505,510
510	LIM=NUM(I)
	LL=0
	N9= 1500 * 9 * I - 1500 * 9  + 1 - 9
	DO515 J=1,LIM
	N9= N9+ 9
515	READ DISCIDISC1,N9,(JKL(K,J),K=1,5),FO(J),SIG(J),AINT(J),SINT(J)
	IF ( IC(8) )520,520,525
520	II  = I - 11
	GO TO 526
525	II = I - 1
526	WRITE(ITYP,15) II
15	FORMAT(//   ' EQUIVILENT REFLECTIONS WITH SLOW MOVING INDEX =',I3
	1//   '    H   K   L IUN BATCH FSQ       SIGMA   SCL FAC   NO.   IN
	2T. I   SIGMA I'/)
530	IP=0
535	IT=0
	ITD=0
	DTEMP=0.0
	DO 536 K=1,10
536	DELTA(K)=0.0
	FTEMP=0.0
	STEMP=0.0
	TEMPI=0.0
	TEMPS=0.0
540	IP=IP+1
	IF(LIM-IP)505,570,545
545	IPACK = (JKL(1,IP)+50)*10000 + (JKL(2,IP)+50)*100 + (JKL(3,IP)+50)
	IMX1=JKL(4,IP)
	J=IP+1
	JPACK = (JKL(1,J)+50)*10000 + (JKL(2,J)+50)*100 + JKL(3,J)+50
	IMX2=JKL(4,J)
	IF( IPACK - JPACK)570,550,570
550	IF(IMX1-IMX2)554,558,551
551	WRITE(ITYP ,21)     JKL(5,J),(JKL(N,J),N=1,3),FO(J),JKL(5,IP),
	1(JKL(N,IP),N=1,3),FO(IP)
21	FORMAT( ' *****  OBSERVED-UNOBSERVED INCONSISTANCY- ONLY OBSERVED
	1REF. WILL BE PROCESSED'/  ' OBS BATCH',I2,3I3,' F='F10.4,'     UNO
	2BS BATCH',I2,3I3,' F=', F10.4)
	GO TO 540
554	DO 555 K=1,5
	N=JKL(K,J)
	JKL(K,J)=JKL(K,IP)
555	JKL(K,IP)=N
	SINT(J)=FO(J)
	FO(J)=FO(IP)
	FO(IP)=SINT(J)
	SINT(J)=SINT(IP)
	AINT(J)=AINT(IP)
	SIG(J)=SIG(IP)
	GO TO 551
558	IT=IT+1
	K=JKL(5,J)
	J=JKL(5,IP)
	AA=FO(IP)*SF(J)
	BB=SIG(IP)*SF(J)
	CC=AINT(IP)*SF(J)
	DD=SINT(IP)*SF(J)
	IF(J-K)5580,5580,5585
5580	ITD=ITD+1
	 DTEMP=DTEMP + AA
	DTEMP=DTEMP/ITD
	DELTA(J)=DTEMP
	ITD=0
	DTEMP=0.0
	GO TO 5589
5585	ITD=ITD+1
	DTEMP=DTEMP + AA
5589	WRITE(ITYP ,20)(JKL(K,IP),K=1,5),AA,BB,SF(J),IT,CC,DD
20	FORMAT(1X5I4,3F10.5,I4,F9.0,F9.4)
565	FTEMP=FTEMP+ AA
	STEMP=STEMP+ BB**2
	TEMPI= TEMPI + CC
	TEMPS=TEMPS+ DD**2
	GO TO540
570	IF(IT)590,590,575
575	IT=IT+1
	J=JKL(5,IP)
	AA=FO(IP)*SF(J)
	BB=SIG(IP)*SF(J)
	CC=AINT(IP)*SF(J)
	DD=SINT(IP)*SF(J)
	ITD=ITD+1
	DTEMP=DTEMP + AA
	DTEMP=DTEMP/ITD
	DELTA(J)=DTEMP
	FTEMP=FTEMP+ AA
	FTEMP=FTEMP/IT
	TEMPI= TEMPI + CC
	TEMPI=TEMPI/IT
	STEMP=STEMP+ BB**2
	STEMP=SQRT(STEMP)/IT
	TEMPS=TEMPS+ DD**2
	TEMPS=SQRT(TEMPS)/IT
	ITD=0
	DTEMP=0.0
	DO 577 K=1,10
	IF(DELTA(K))577,577,576
576	ITD=ITD+1
	DELTA(K)=FTEMP-DELTA(K)
	DTEMP=DTEMP +ABS(DELTA(K))
577	CONTINUE
	DTEMP=DTEMP/ITD
C  DTEMP AT THIS POINT IS THE AVERAGE DEVIATION OF EACH F FROM THE MEAN
C  SDR IS THE STANDARD DEVIATION RATIO  I.E.  THE AVERAGE MEAN DEVIATION
C  OVER THE AVERAGE STANDARD DEVIATION
	SDR=DTEMP/STEMP
	NSDR=NSDR+1
	SDRAV=SDRAV + SDR
	WRITE(ITYP ,20)(JKL(K,IP),K=1,5),AA,BB,SF(J),IT,CC,DD
	WRITE(ITYP ,25)     IT,FTEMP,STEMP ,TEMPI,TEMPS,DTEMP,SDR
25	FORMAT(  / ' AVERAGE OF',I3,' IS, FO=',F10.3,' SIG=',F10.6,' I=',F
	110.2,' SIG=',F10.6,/' AVERAGE MEAN DEVIATION =',F10.4,'     STANDA
	2RD DEVIATION RATIO =',F10.4/)
590	IF(IT)595,595,600
595	IT=1
	J=JKL(5,IP)
	FTEMP=FO(IP)*SF(J)
	STEMP=ABS(SIG(IP)*SF(J))
	TEMPI=AINT(IP)*SF(J)
	TEMPS=ABS(SINT(IP)*SF(J))
	IUNIQ=IUNIQ+1
	LL=LL+1
	IF(LL-LIM)600,596,596
596	WRITE(ITYP,26)II
26	FORMAT(/' THERE ARE NO EQUIVLENT REFLECTIONS WITH INDEX =',I3/)
600	LSOUT=LSOUT+1
	WRITE(IOUT )(JKL(K,IP),K=1,3),FTEMP,STEMP,JKL(4,IP),JKL(5,IP),TEMP
	1I,TEMPS
	IF(JKL(4,IP))535,535,605
605	IUNOB=IUNOB+1
	GO TO 535
505	CONTINUE
	SDRAV=SDRAV/NSDR
	IT=INTOT-IUNIQ
	WRITE(ITYP,30)     IT,IUNIQ,SDRAV
30	FORMAT(  // '  THE NUMBER OF REFLECTIONS AVERAGED =',I4/  '  THE N
	1UMBER OF REFLECTIONS OBSERVED ONLY ONCE =',I4  /  '  THE AVERAGE S
	2TANDARD DEVIATION RATIO =',F12.4/)
800	RETURN
	END
	SUBROUTINE SORT(LIM,MOVE)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  LIM= THE NUMBER OF DATA TO BE SORTED
	M1=LIM
51	M1=M1/2
	IF(M1)52,40,52
52	M2=LIM-M1
	M3=1
53	M4=M3
	CALL MOVE(M4,M1)
	M3=M3+1
	IF(M3-M2)53,53,51
40	RETURN
	END
	SUBROUTINE NJKL(M4,M1)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  NJKL IS CALLED FROM SORT AS MOVE
C  IT SORTS ON BATCH NUMBER,K1,K2, ANDK3 (HKL)
54	M5=M4+M1
	IF(JKL(K1,M4)-JKL(K1,M5))57,58,55
58	IF(JKL(K2,M4)-JKL(K2,M5))57,59,55
59	IF(JKL(K3,M4)-JKL(K3,M5))57,60,55
60	IF(JKL(5 ,M4)-JKL(5 ,M5))57,57,55
55	DO 56  I=1,5
	IHOLD=JKL(I,M4)
	JKL(I,M4)=JKL(I,M5)
56	JKL(I,M5)=IHOLD
	AHOLD=FO(M4)
	FO(M4)=FO(M5)
	FO(M5)=AHOLD
	AHOLD=SIG(M4)
	SIG(M4)=SIG(M5)
	SIG(M5)=AHOLD
	AHOLD=AINT(M4)
	AINT(M4)=AINT(M5)
	AINT(M5)=AHOLD
	AHOLD=SINT(M4)
	SINT(M4)=SINT(M5)
	SINT(M5)=AHOLD
	M4=M4-M1
	IF(M4-1)57,54,54
57	RETURN
	END
	SUBROUTINE MONO(J,K,L,IREJ)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  MONO CONVERTS ALL INDICES TO +H +K AND + OR -L FOR MONOCLINIC
	IREJ=0
	IF(J)20,200,10
10	IF(L)100,200,200
20	IF(L)200,100,100
100	J=IABS(J)
	K=IABS(K)
	L=-IABS(L)
	RETURN
200	J=IABS(J)
	K=IABS(K)
	L=IABS(L)
	RETURN
	END
	SUBROUTINE ORTHO(J,K,L,IREJ)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  ORTHO CONVERTS ALL INDICES TO +H +K +L FOR ORTHOROMBIC SPACE GROUPS
	IREJ=0
	J=IABS(J)
	K=IABS(K)
	L=IABS(L)
	RETURN
	END
	SUBROUTINE SPACE(J,K,L,IREJ)
	COMMON  JKL(5,1500)    ,FO(1500)      ,SIG(1500)     ,AINT(1500)
	COMMON  SINT(1500)     ,SUM(2,10)     ,IBTCH(10)     ,NUM(21)
	COMMON  SF(10)         ,IC(20)        ,K1     ,K2     ,K3
C  SUBROUTINE SPACE IS A USER SUPPLIED SUBROUTINE TO CONVERT ALL INDICES
C  FOR ANY SPACE GROUP OTHER THAN MONO OR ORTHO TO THE SAME OCTANT OR
C  QUADRANT ETC.
C  FOR EXAMPLES FOR LAUE GROUPS 2/M AND MMM SEE SUBROUTINES
C  ORTHO AND MONO OF THIS PROGRAM
	IREJ=0
C****FOR LAUE GROUP P 4/M -- POSITIVE "K" ONLY
	IF(J)1,1,2
1	KK=K
	K=-J
	J=KK
2	IF(L)3,4,5
4	M = J + K
	 M = M/2
	IF((J+K).NE.M*2)IREJ=1;GO TO 5
	GO TO 5
3	L=-L
5	RETURN
	END
