C     STRUCTURE FACTOR PROGRAM      PART I.

C                    FOR IBM 1130                         R.SHIONO

C                                 APRIL 1968

C
	DIMENSION   RCP(6),PRCP(6),AFM(11,51),FM(15)
	COMMON JCDI,JCDO,JTYP,NDAT

	COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM

	COMMON  PRCP

	DEFINE FILE 1 ( 5000, 52, U, NDAT )

1	FORMAT ( 3F7.3, 4F7.4    )
2	FORMAT   ( 7F10.4  )
3	FORMAT ( 4I5, 6F8.4  )

4	FORMAT ( 3I9,2F9.2,F9.0,I5,2F6.3 )
5	FORMAT( /   3H A=,F8.3,4H, B=,F8.3,4H, C=,F8.3,7H, COSA=,F7.4,

	1   7H, COSB=,F7.4,7H, COSC=,F7.4,9H, LAMBDA=,F7.4  /   )
6	FORMAT ( 3F3.0,2F7.2,2F8.2,F7.2,F3.3,F4.3,I2,1X6F4.2 )

7	FORMAT (3I4,6F7.2,F5.3,I3,F7.2 )

8	FORMAT (       23HSIGMA-S PUNCHED ON CARD   )

9	FORMAT (      26HHUGHES WEIGHTING,    FMIN=   F6.1   )

10	FORMAT (     22HCRUICKSHANK-S WEIGHTS,5H   A=E9.3,5H,  B=E9.3,

	1       5H,  C=E9.3   )

11	FORMAT (      27HWEIGHT=1/(SIN THETA/LAMBDA)     )

12	FORMAT  (/ 14HCONSTANTS USED  / / 8X 6E12.3 //  )

14	FORMAT (      25HATOMIC SCATTERING FACTORS  // 10X 10F8.1  )

15	FORMAT  (// 18HNO. OF REFLEXIONS=  I6   //  )

C     DEFINE I/O DEVICES

	JCDI=2

	JTYP=1

	JCDO=2

	NDAT=1

	RA=0.0
	RB=0.0
	Q=1.0

C     READ CELL CONSTANT CARD
	READ ( JCDI,1 ) A,B,C,CSAA,CSAB,CSAC,WAVE

	WRITE ( JTYP,5 ) A,B,C,CSAA,CSAB,CSAC,WAVE

	D=SQRT(1.+2.*CSAA*CSAB*CSAC-CSAA*CSAA-CSAB*CSAB-CSAC*CSAC)
	D=1./(D*A*B*C)
	SNAA=SQRT(1.-CSAA*CSAA)
	SNAB=SQRT(1.-CSAB*CSAB)
	SNAC=SQRT(1.-CSAC*CSAC)
	RCP(1)=D*B*C*SNAA
	RCP(2)=D*C*A*SNAB
	RCP(3)=D*A*B*SNAC
	RCP(4)=(CSAB*CSAC-CSAA)/(SNAB*SNAC)
	RCP(5)=(CSAC*CSAA-CSAB)/(SNAC*SNAA)
	RCP(6)=(CSAA*CSAB-CSAC)/(SNAA*SNAB)
	PRCP(1)=RCP(1)*RCP(1)*.25
	PRCP(2)=RCP(2)*RCP(2)*.25
	PRCP(3)=RCP(3)*RCP(3)*.25
	PRCP(4)=RCP(1)*RCP(2)*RCP(6)*.25
	PRCP(5)=RCP(1)*RCP(3)*RCP(5)*.25
	PRCP(6)=RCP(2)*RCP(3)*RCP(4)*.25
	NRFM=0

C     READ CONTROL CARD

	READ ( JCDI,3 )  JA,JW,JD,JC,CA,CB,CC,CD,CE,CF

	IF  ( JW-1 )  33,  32,  33

32	CA4=4.0*CA
33	JW=JW+1
	GO TO  ( 65, 66, 67, 68, 69 ), JW

65	WRITE ( JTYP,8 )

	GO TO 69

66	WRITE ( JTYP,9 ) CA

	GO TO 69

67	WRITE ( JTYP,10 ) CA,CB,CC

	GO TO 69

68	WRITE ( JTYP,11 )

69	FCAL=0.0

71	WRITE ( JTYP,12 ) CA,CB,CC,CD,CE,CF

70	AO=0.0

	JA=JA+1

	GO TO ( 34, 34, 35, 59),JA

C     ORIGINAL CARD INPUT

34	BO=0.0

	AC=0.
	BC=0.
	DO  31  I=1,11
	DO  31  J=1,51
31	AFM(I,J)=0.
C     READ ATOMIC SCATTERING FACTOR TABLES
	I=0
20	I=I+1
	READ ( JCDI,2 ) (AFM(I,J),J=1,7 )

	IF  ( AFM(I,1) )  21, 21, 22
22	READ ( JCDI,2 ) (AFM(I,J), J=8,51 )

	NATSC=I
	GO TO 20
C     END OF F TABLE,START READING REFLEXION DATA
21	JBB=1
	WRITE (JTYP,14) (AFM(I,1),I=1,NATSC)

	QSCL=1.0

C     INPUT FROM CARDS
	GO TO ( 60, 52, 35, 59), JA

60	READ ( JCDI,4 ) IH,IK,IL,FOBS,SIG,Q,ID,RA,RB

53	FH=IH

	FK=IK
	FL=IL
	IF  (IH)  25,  23,  25
23	IF  (IK)  25,  24,  25
24	IF  (IL)  25,  50,  25
25	IF  ( Q )  64,  64,  55

55	IF  ( Q-QSCL )  63,  63,  56

56	QSCL=Q

	GO TO 63

64	Q=1.0
63	RHO=FH*FH*PRCP(1)+FK*FK*PRCP(2)+FL*FL*PRCP(3)+2.*FH*FK*PRCP(4)+

	1       2.*FK*FL*PRCP(6)+2.*FL*FH*PRCP(5)
	SINT=SQRT(RHO)*WAVE
	IF  ( SINT-1.0 )  26,  60,  60

26	BRAG=SINT
	DO  27  I=2,51
	BRAG=BRAG-0.02
	IF  (BRAG)  28,  28,  27
27	CONTINUE
28	I=I-1
	FRAC=(BRAG+0.02)*50.
	DO  29  K=1,10
29	FM(K)=0.
	DO  30  K=1,NATSC
30	FM(K)=AFM(K,I)+(AFM(K,I+1)-AFM(K,I))*FRAC
38	GO TO ( 49, 41, 42, 43, 44 ), JW

41	IF  (FOBS)  45,  45,  46
45	SIG=0.
	GO TO 49
46	IF  ( FOBS-CA4 )  47,  47,  48
47	SIG=CA4
	GO TO 49
48	SIG=FOBS
	GO TO 49
42	SIG=SQRT(CA+CB*FOBS+CC*FOBS*FOBS)
	GO TO 49
43	SIG=SQRT(SQRT(RHO))
	GO TO 49
44	SIG=1.0
49	IF  ( JD-1 )  40,  57,  40

57	IF  ( ID-1 )  40,  58,  40

58	SIG=0.0

40	WRITE (1'NDAT) FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO,

	1  SINT,(FM(K),K=1,10),RA,RB

	GO TO ( 60, 52, 37, 59), JA

C     FOURIER INPUT, E CARDS

52	READ (JCDI,7 ) IH,IK,IL,FOBS,FCAL,AO,AC,BO,BC,SINT,ID,SIG

	GO TO 53

C     THE SF-LS OUTPUT CARDS WITH ATOMIC F,S

35	Q=1.0

	DO  36  K=1,10

36	FM(K)=0.0

	AO=0.0

	BO=0.0

37	READ (JCDI,6 ) FH,FK,FL,FOBS,FCAL,AC,BC,SIG,SINT,RHO,ID,

	1  (FM(K),K=1,6 )

	IF  ( FH )  38,  39,  38

39	IF  ( FK )  38,  51,  38

51	IF  ( FL )  38,  50,  38

50	FH=999.

	WRITE ( 1'NDAT) FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO,

	1   SINT,(FM(K),K=1,10),RA,RB

	NSCL=QSCL

	NREF=NDAT-2

	WRITE  ( JTYP,15 )  NREF

59	CALL LINK (SF2 )

	END

// DU	P

*DUMP	       WS  CD  SF1

// JO	B T

// FO	R

*IOCS	%CARD,TYPEWRITER,DISK)

*ONE 	WORD INTEGERS

C     STRUCTURE FACTOR CALCULATION ONLY               SF 20

C                          APRIL 1968

C

	DIMENSION  TS(3,24), IS(2,3,24)

	DIMENSION  HJ(6),H(3),HHJ(6)

	DIMENSION  FM(10), PRCP(6)

	DIMENSION ANM(100), IANM(100),X(100),Y(100),Z(100)

	DIMENSION BETA(6,100),AOCP(100),JSF(100)

	DIMENSION  DADAI(100),DBDAI(100)

	DIMENSION  JPT(100)

	COMMON JCDI,JCDO,JTYP,NDAT

	COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM

	COMMON  PRCP,SCL,SCLR,DAMP

	DEFINE FILE  1( 5000, 52, U, NDAT )

100	FORMAT (10I5 )

101	FORMAT  (  F11.6,2I2,F11.6,2I2,F11.6,2I2  )

102	FORMAT (  A4,A2,3X,F9.6,4F9.6,14X, I2   )

103	FORMAT  ( 8F9.6  )

105	FORMAT  (  3I4, 3X 6F8.2   )

107	FORMAT ( /  15HCENTROSYMMETRIC   /   )

108	FORMAT (  / 19HNON-CENTROSYMMETRIC  /   )

109	FORMAT (/13HNO. OF ATOMS  I4,21H,  NO. OF SYMMETRIES I4/)

110	FORMAT (/ 3X1HH,3X1HK,3X1HL,7X4HFOBS,4X4HFCAL,4X4HAOBS,4X4HACAL,

	1    4X4HBOBS, 4X4HBCAL  //    )

111	FORMAT (/7HSUM(FO) ,E12.4,10H,  SUM(FC) E12.4,5H,  R= F7.3,

	1  14H,  SUMFC/SUMFO  ,  F7.3   /    )

121	FORMAT (/17HPARTIAL STRUCTURE )

	LCYC=0

	READ (JCDI,100) LCEN,LSYM,LATM,LTEM,LANM,LEPH,LSCL

C     READ SYMMETRY CARDS

	READ ( JCDI,101 ) ((TS(I,J),(IS(K,I,J),K=1,2),I=1,3),J=1,LSYM)

	READ ( JCDI,103 )  SCL

	IF  ( LCEN )  204,  204,  205

204	WRITE  ( JTYP, 107 )

	GO TO 206

205	WRITE ( JTYP,108 )

206	WRITE (JTYP,109 ) LATM,LSYM

	LANM=LANM+1

	GO TO  ( 232,  233), LANM

233	WRITE  ( JTYP,121 )

C     ATOMIC PARAMETERS IN TWO CARDS

232	DO  200  I=1,LATM

	READ ( JCDI,102) ANM(I),IANM(I),ASF,AOCP(I),X(I),Y(I),Z(I),JPT(I)

	JSF(I)=ASF

200	READ  ( JCDI,103 )  ( BETA(K,I),K=1,6 )

C     CONVERT ISOTROPIC TO ANISOTROPIC TEMP. FACTORS

	IF ( LTEM )  203,  203,  201

201	DO  202  I=1,LATM

	IF  ( BETA(2,I) )  216,  216,  202

216	TFI=BETA(1,I)

	DO  217  K=1,6

217	BETA(K,I)=TFI*PRCP(K)

202	CONTINUE

C     CLEAR THE SUM AREA

203	SDELF=0.0

	SUMD1=0.0

	SUMD2=0.0

	SUMF1=0.0

	SUMF2=0.0

C     FEED OUT THE LAST CARD

	READ ( JCDI,100 )

	WRITE ( JTYP, 110 )

	NDAT=1

399	READ (1'NDAT) H(1),H(2),H(3),FOBS,ESF,AO,AC,BO,BC,SIG,Q,ID,RHO,

	1   SINT, (FM(K),K=1,10 ), RA,RB

	IF  ( H(1)-999. ) 210,  211,  211

C      START LOOP THROUGH SYMMETRY

210	DO  212  I=1,LATM

	DADAI(I)=0.0

212	DBDAI(I)=0.0

	DO  300  J=1,LSYM

C     STORE TRANSFORMED INDICES

	TSL=0.0

	DO  303  I=1,3

	HJ(I)=0.0

	TSL=TSL+H(I)*TS(I,J)

	DO  302  K=1,3

	DO  301  L=1,2

	M=IS(L,K,J)

	IF  ( M-I )  305,  306,  305

306	HJ(I)=HJ(I)+H(K)

	GO TO 301

305	IF  ( M+I)  301,  304,  301

304	HJ(I)=HJ(I)-H(K)

301	CONTINUE

302	CONTINUE

303	CONTINUE

C     PRODUCTS OF TRANSFORMED INDICES

	HHJ(1)=HJ(1)*HJ(1)

	HHJ(2)=HJ(2)*HJ(2)

	HHJ(3)=HJ(3)*HJ(3)

	HHJ(4)=2.0*HJ(1)*HJ(2)

	HHJ(5)=2.0*HJ(1)*HJ(3)

	HHJ(6)=2.0*HJ(2)*HJ(3)

	DO  310  I=1,LATM

	HX=TSL+HJ(1)*X(I)+HJ(2)*Y(I)+HJ(3)*Z(I)

	COSIJ=COS(6.28318531*HX)

	SINIJ=SIN(6.28318531*HX)

	LBMX=1

	IF ( BETA ( 2,I) )  315,  315,  311

311	LBMX=2

	HHB=0.0

	DO  313  K=1,6

313	HHB=HHB+HHJ(K)*BETA(K,I)

	EXPIJ=EXP(-HHB)

	COSIJ=COSIJ*EXPIJ

	SINIJ=SINIJ*EXPIJ

315	IF  ( JPT(I) )  314,  314,  356

356	COSIJ=-COSIJ

	SINIJ=-SINIJ

314	DADAI(I)=DADAI(I)+COSIJ

C     BYPASS THE REST IF CENTROSYMMETRIC

	IF  ( LCEN )  310,  310,  324

324	DBDAI(I)=DBDAI(I)+SINIJ

310	CONTINUE

300	CONTINUE

	GA=0.0

	GB=0.0

	DO  347  I=1,LATM

	II=JSF(I)

	FI=FM(II)

	TFI=1.0

	IF  ( BETA(2,I) )  340,  340,  341

340	TFI=EXP(-BETA(1,I)*RHO )

341	FTAT=FI*TFI*AOCP(I)

	FTCOS=FTAT*DADAI(I)

	GA=GA+FTCOS

	IF  ( LCEN )  347,  347,  348

348	FTSIN=FTAT*DBDAI(I)

	GB=GB+FTSIN

347	CONTINUE

C     END OF ATOM LOOP

	FOBS=FOBS*SCL

	GO TO ( 353, 354 ), LANM

353	AC=0.0

	BC=0.0

354	IF  ( LCEN )  370,  370,  371

370	GA=GA+GA+AC

	AC=GA

	FCAL=ABS(AC)

	BC=0.0

	AO=SIGN(FOBS,AC)

	BO=0.0

	IF (LEPH )  374,  374,  376

376	AC=SIGN(ESF,AC)

	GO TO 374

371	GA=GA+AC

	GB=GB+BC

	FCAL=SQRT(GA*GA+GB*GB)

	AC=GA

	BC=GB

	IF  ( FCAL )  373,  374,  373

373	CA=GA/FCAL

	CB=GB/FCAL

	AO=FOBS*CA

	BO=FOBS*CB

	IF  ( LEPH )  374,  374,  375

375	AC=ESF*CA

	BC=ESF*CB

374	CALL DATSW(0,JJ)

	DELF=ABS(FOBS-FCAL)

	SUMD1=SUMD1+DELF

	SUMF1=SUMF1+FOBS

	SUMF2=SUMF2+FCAL

	NDAT=NDAT-1

	WRITE (1'NDAT) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,

	1   RHO,SINT,(FM(K),K=1,10),RA,RB

	IH=H(1)

	IK=H(2)

	IL=H(3)

	GO TO ( 401, 399 ), JJ

401	WRITE ( JTYP,105) IH,IK,IL,FOBS,FCAL,AO,AC,BO,BC

	GO TO  399

C     END OF ALL REFLEXIONS

211	NDAT=NDAT-1

	WRITE (1'NDAT) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,

	1   RHO, SINT,(FM(K),K=1,10)

	R1=SUMD1/SUMF1

	R2=SUMF2/SUMF1

	WRITE ( JTYP,111 ) SUMF1,SUMF2,R1,R2

	SCL=R2

	NRFM=-1

	IF ( LSCL )  377,  377,  372

C     IF NO SCALING OF FOB,S DESIRED

372	NRFM=0

377	CALL LINK(SF4)

	END

// DU	P

*DUMP	       WS  CD  SF20

// JO	B

// FO	R

*IOCS	%CARD,TYPEWRITER,DISK)

*ONE 	WORD INTEGERS

C     STRUCTURE FACTOR PROGRAM      CALCULATE AGREEMENT INDICES

C     TERMINATE JOB AND PRINT OUT VARIOUS STATISTICS

C                                   MAY 1968

C

	DIMENSION MOBS(11),MUNO(11),WDOBS(11),WDUNO(11)
	DIMENSION MOSN(11),MUSN(11),WDOS(11),WDUS(11)
	DIMENSION NHKL(11),DHKL(11),SHKL(11),NKLS(11),DKLS(11),SKLS(11)

	DIMENSION NHKLS(11),DHKLS(11),SHKLS(11)

	DIMENSION  FM(10), IFM(10)

	DIMENSION X(4)

	DIMENSION  PRCP(6)

	COMMON JCDI,JCDO,JTYP,NDAT

	COMMON  NC, NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM

	COMMON  PRCP,SCL,SCLR,DAMP

	DEFINE FILE 1 ( 5000, 52, U, NDAT )

10	FORMAT (/14HNO. REFLEXIONS,7X11I9 )

11	FORMAT (/    14HAVER. W*DELTSQ, 7X  11F9.3 /  )

12	FORMAT (//     13HF VALUE UP TO, 14X3H10.,6X3H20.,6X3H30.,6X3H40.,
	1  6X3H50.,6X3H60.,6X3H70.,6X3H80.,6X3H90.,5X4H100.,9H OVER 100 / )
13	FORMAT (//     16HSINE THETA UP TO, 11X3H0.1,6X3H0.2,6X3H0.3,6X

	1  3H0.4,6X3H0.5,6X3H0.6,6X3H0.7,6X3H0.8,6X3H0.9,6X3H1.0  /     )
14	FORMAT ( // 12HEND SF/SF-LS    //  )

15	FORMAT ( 3I4,6F7.2,F5.3,I3,F7.2,I2   )

16	FORMAT (  3I3,2F7.2, 2F8.2, F7.2,I3,I4,I2,1X,6I4   )

20	FORMAT ( ///39HDISAGREEMENT INDICES FOR VARIOUS GROUPS   /  )

21	FORMAT (/    27X3HHKL,6X3HHK0,6X3H0KL,6X3HH0L,6X3HH00,6X3H0K0,

	1   6X3H00L,6X3HALL  /   )

23	FORMAT (/     8HR FACTOR  ,  13X 10F9.3  /  )

24	FORMAT (//    27X 3HEEE,6X3HEEO,6X3HEOE,6X3HOEE,6X3HEOO,6X3HOEO,

	1    6X3HOOE,6X3HOOO    /    )

25	FORMAT (//   9HOBS. ONLY,4X8HSUM FOBS,5X8HSUM FCAL,5X6HSCALE, ,

	1 3X11HUNOBS. ONLY,4X8HSUM FOBS,5X8HSUM FCAL,5X11HTOTAL SCALE  //

	2 9XF13.2,F13.2,F10.3,14X F13.2,F13.2,6X F10.3  //  )

	DO  110 I=1,11

	NHKL(I)=0

	DHKL(I)=0.0

	SHKL(I)=0.0

	NHKLS(I)=0

	DHKLS(I)=0.

	SHKLS(I)=0.

	NKLS(I)=0

	DKLS(I)=0.0

	SKLS(I)=0.0

	MOBS(I)=0
	MUNO(I)=0
	MOSN(I)=0
	MUSN(I)=0
	WDOBS(I)=0.0
	WDUNO(I)=0.0
	WDOS(I)=0.0
110	WDUS(I)=0.0
	SUM1=0.0

	SUM2=0.0

	SUM3=0.0

	SUM4=0.0

	DSIN=0.1
	DSTF=10.0
	CALL DATSW ( 2, LSW2 )

	NDAT=1

111	READ (1'NDAT) (X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO,

	1  SINT,(FM(I),I=1,10)

	IF  ( X(1)-999.0 )  162,  113,  162

162	IF  ( X(1) )  150,  151,  150

151	IF  ( X(2) )  153,  152,  153

C     00L

152	IREF=7

	GO TO 163

153	IF  ( X(3) )  155,  154,  155

154	IREF=6

	GO TO 163

155	IREF=3

	GO TO 163

150	IF  ( X(2) )  157,  156,  157

156	IF  ( X(3) )  159,  158,  159

158	IREF=5

	GO TO 163

159	IREF=4

	GO TO 163

157	IF  ( X(3) )  161,  160,  161

160	IREF=2

	GO TO 163

161	IREF=1

163	IH=X(1)

	IK=X(2)

	IL=X(3)

	IQ=X(4)

	SINE=SINT

	FIDH=IH/2

	FIDK=IK/2

	FIDL=IL/2

	IF  ( 0.5*X(1)-FIDH )  191,  190,  191

190	IF  ( 0.5*X(2)-FIDK )  195,  192,  195

192	IF  ( 0.5*X(3)-FIDL )  194,  193,  194

193	KLAS=1

	GO TO 205

194	KLAS=2

	GO TO 205

195	IF  ( 0.5*X(3)-FIDL )  197,  196,  197

196	KLAS=3

	GO TO 205

197	KLAS=5

	GO TO 205

191	IF  ( 0.5*X(2)-FIDK )  199,  198,  199

198	IF ( 0.5*X(3)-FIDL )  201,  200,  201

200	KLAS=4

	GO TO 205

201	KLAS=6

	GO TO 205

199	IF ( 0.5*X(3)-FIDL )  203,  202,  203

202	KLAS=7

	GO TO 205

203	KLAS=8

205	DO  131  J=1,10

	IF  ( SINE-DSIN )  132,  132,  131

131	SINE=SINE-DSIN

132	IF  ( NRFM )  133,  134,  134

C     FOR STRUCTURE FACTOR ONLY PROGRAM

133	YO=YO*SCL

	AO=AO*SCL

	BO=BO*SCL

134	DELT=ABS(YO-YC )

	NHKLS(J)=NHKLS(J)+1

	DHKLS(J)=DHKLS(J)+DELT

	SHKLS(J)=SHKLS(J)+YO

	NHKL(IREF)=NHKL(IREF)+1

	DHKL(IREF)=DHKL(IREF)+DELT

	SHKL(IREF)=SHKL(IREF)+YO

	NKLS(KLAS)=NKLS(KLAS)+1

	DKLS(KLAS)=DKLS(KLAS)+DELT

	SKLS(KLAS)=SKLS(KLAS)+YO

	IF  ( ID )  165,  164,  165

164	SUM1=SUM1+YO

	SUM2=SUM2+YC

	GO TO 166

165	SUM3=SUM3+YO

	SUM4=SUM4+YC

166	CALL DATSW (1,LSW )

	IE=0

	IF ( YO-2.0*YC)  187,  187,  186

186	IF (YO-3.0*YC )  178,  178,  179

178	IE=2

	GO TO 187

179	IF  ( YO-4.0*YC )  188,  188,  189

188	IE=3

	GO TO 187

189	IE=4

187	GO TO ( 176, 177 ), LSW

176	WRITE( JCDO,15) IH,IK,IL,YO,YC,AO,A,BO,B,SINT,ID,SIGYO,IE

	GO TO 136

177	GO TO ( 137, 136 ), LSW2

C     PUNCH CARD FOR THE INPUT OF REPEAT CALCULATION

137	ISIN=SINT*1000.0

	IRHO=RHO*1000.0

	DO  138  I=1,6

138	IFM(I)=FM(I)*100.0

	WRITE ( JCDO,16 ) IH,IK,IL,YO,YC,A,B,SIGYO,ISIN,IRHO,ID,

	1   ( IFM(I),I=1,6)

C     IF STRUCTURE FACTORS ONLY

136	IF  ( NC )  112,  111,  112

112	IF  ( SIGYO )  118,  114,  118

114	WDELT=0.0

	GO TO 121

118	WDELT=((YO-YC)/SIGYO)**2

121	I=1

	IF  ( YO )  117,  120,  117

117	DO  115 I=1,11

	IF  ( YO-DSTF )  116,  116,  115
115	YO=YO-DSTF
	I=11
116	IF  ( ID )  120,  119,  120

119	MOBS(I)=MOBS(I)+1
	WDOBS(I)=WDOBS(I)+WDELT
	MOSN(J)=MOSN(J)+1

	WDOS(J)=WDOS(J)+WDELT

	GO TO 135

120	MUNO(I)=MUNO(I)+1
	WDUNO(I)=WDUNO(I)+WDELT
	MUSN(J)=MUSN(J)+1

	WDUS(J)=WDUS(J)+WDELT

135	GO TO 111
C

C     END OF DATA
113	WRITE ( JTYP,20 )

	WRITE ( JTYP,13 )

	DO  174  I=1,10

	IF  ( SHKLS(I) )  174,  174,  175

175	SHKLS(I)=DHKLS(I)/SHKLS(I)

174	CONTINUE

	WRITE ( JTYP,10 ) (NHKLS(I),I=1,10 )

	WRITE ( JTYP,23 ) (SHKLS(I),I=1,10)

	WRITE ( JTYP,21 )

	DO  170  I=1,7

	NHKL(8)=NHKL(8)+NHKL(I)

	DHKL(8)=DHKL(8)+DHKL(I)

170	SHKL(8)=SHKL(8)+SHKL(I)

	DO  173  I=1,8

	IF  ( SHKL(I) )  171,  171,  172

171	DHKL(I)=0.0

	GO TO 173

172	DHKL(I)=DHKL(I)/SHKL(I)

173	CONTINUE

	WRITE ( JTYP,10 ) (NHKL(I),I=1,8 )

	WRITE ( JTYP,23 ) ( DHKL(I),I=1,8 )

	WRITE ( JTYP, 24 )

	DO  169 I=1,8

	IF  ( SKLS(I) )  168,  168,  167

168	DKLS(I)=0.0

	GO TO 169

167	DKLS(I)=DKLS(I)/SKLS(I)

169	CONTINUE

	WRITE ( JTYP,10 ) ( NKLS(I),I=1,8 )

	WRITE ( JTYP,23 ) ( DKLS(I),I=1,8 )

	IF  ( SUM1 )  181,  181,  180

180	SCL1=SUM2/SUM1

	GO TO 182

181	SCL1=0.0

182	IF  ( SUM1+SUM3 )  184,  184,  183

183	SCL2=(SUM2+SUM4)/(SUM1+SUM3)

	GO TO 185

184	SCL2=0.0

185	WRITE (JTYP,25 ) SUM1,SUM2,SCL1,SUM3,SUM4,SCL2

	IF  ( NC )  207,  208,  207

207	WRITE ( JTYP,12 )

	DO  140  I=1,11
	IF  ( MOBS(I) )  141,  140,  141
141	FNUMB=MOBS(I)
	WDOBS(I)=WDOBS(I)/FNUMB
140	CONTINUE
	WRITE ( JTYP,10 ) ( MOBS(I),I=1,11 )

	WRITE ( JTYP,11 ) ( WDOBS(I),I=1,11 )

	DO  142  I=1,11
	IF  ( MUNO(I) )  143,  142,  143
143	FNUMB=MUNO(I)
	WDUNO(I)=WDUNO(I)/FNUMB
142	CONTINUE
	WRITE ( JTYP,10 ) ( MUNO(I),I=1,11 )

	WRITE ( JTYP,11 ) ( WDUNO(I),I=1,11 )

	WRITE ( JTYP,13 )

	DO  144  I=1,10
	IF  ( MOSN(I) )  145,  144,  145
145	FNUMB=MOSN(I)
	WDOS(I)=WDOS(I)/FNUMB
144	CONTINUE
	WRITE ( JTYP,10 ) ( MOSN(I),I=1,10 )

	WRITE ( JTYP,11 ) ( WDOS(I),I=1,10 )

	DO  146  I=1,10
	IF  ( MUSN(I) )  147,  146,  147
147	FNUMB=MUSN(I)
	WDUS(I)=WDUS(I)/FNUMB
146	CONTINUE
	WRITE ( JTYP,10 ) ( MUSN(I),I=1,10 )

	WRITE ( JTYP,11 ) ( WDUS(I),I=1,10 )

208	WRITE ( JTYP, 14 )

	CALL EXIT

	END

// DU	P

