// FO	R
*IOCS	%CARD,TYPEWRITER,DISK)
*ONE 	WORD INTEGERS
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
// FO	R
*IOCS	%CARD,DISK,TYPEWRITER)
*ONE 	WORD INTEGERS
C     STRUCTURE FACTOR LEAST SQUARES REFINEMENT PROGRAM
C                          APRIL 1968
C
	DIMENSION  TS(3,24), IS(2,3,24)
	DIMENSION  HJ(6),H(3),HHJ(6)
	DIMENSION FM(10)
	DIMENSION PRCP(6)
	DIMENSION ANM(50), IANM(50), X(50), Y(50), Z(50)
	DIMENSION BETA(6,50), AOCP(50), KI(500), JSF(50)
	DIMENSION DADAI(50), DBDAI(50)
	DIMENSION DADX(3,50), DBDX(3,50), DADB(6,50), DBDB(6,50)
	DIMENSION  DFX(3),DFB(7)
	DIMENSION  XX(9,50), BB(35,50)
	DIMENSION  JPT(50),KIR(50)
	COMMON JCDI,JCDO,JTYP,NDAT
	COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM
	COMMON  PRCP,SCL,SCLR,DMPS,DMPO,DMPP,DMPT
	COMMON SS1,SS2,SS3,SS4,SS5,SUMD1,SUMD2,SUMF1,SUMF2
	COMMON  SUMD3,SUMF3,SUMD4,SUMF4
	COMMON XX,BB,ANM,IANM,X,Y,Z,BETA,AOCP,KI,JSF,TS,IS
	COMMON  JPT,KIR
	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  )
104	FORMAT  ( 80I1  )
105	FORMAT  (  3I4, 3X 6F8.2   )
120	FORMAT ( 25HNO. OF PARAMETERS REFINED   I4   /  )
121	FORMAT ( 12HNO. OF ATOMS I5,19H, NO. OF SYMMETRIES I5 /)
122	FORMAT (21HDAMP FACTORS,  SCALE F4.2,8H, OV. T. F4.2,7H, P.P. F4.2
	1  ,7H, T.P. F4.2   /    )
123	FORMAT (17HPARTIAL STRUCTURE /)
	IF  ( NRFM )  209,  209,  207
209	READ (JCDI,100 ) LCEN,LSYM,LTEM
	READ ( JCDI,100 ) LCYC,LATM,LANM
	LANM=LANM+1
	READ (JCDI,103 ) DMPS,DMPO,DMPP,DMPT
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
	WRITE (JTYP,121) LATM,LSYM
	GO TO ( 232, 233), LANM
233	WRITE (JTYP,123)
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
203	NP=10*LATM
	NPAR=0
	IF  ( LCYC )  214,  214,  206
214	LCYC=-1
	GO TO 215
206	READ (JCDI,104 ) ( KI(I),I=1,NP )
C     SET UP THE REFINEMENT INDICATORS FOR EACH ATOM
	DO  222  I=1,LATM
	KIR(I)=1
	KK=I*10-9
	K1=0
	DO  219  K=1,10
	K1=K1+KI(K K)
219	KK=KK+1
	IF  ( K1 )  218,  218,  222
218	KIR(I)=0
222	CONTINUE
	IF  ( DMPP )  234,  234,  235
234	DMPP=0.75
235	IF  ( DMPT )  236,  236,  237
236	DMPT=0.75
237	WRITE (JTYP, 122 ) DMPS,DMPO,DMPP,DMPT
	DO  208  I=1,NP
208	NPAR=NPAR+KI(I)
	WRITE  ( JTYP, 120 )  NPAR
C     FEED OUT THE LAST CARD
215	READ ( JCDI, 104 )
C     START A CYCLE OF REFINEMENT
207	NRFM=NRFM+1
	SCLR=1.0/SCL
C     CLEAR THE SUM AREA
	SS1=0.0
	SS2=0.0
	SS3=0.0
	SS4=0.0
	SS5=0.0
	SUMD1=0.0
	SUMD2=0.0
	SUMF1=0.0
	SUMF2=0.0
	SUMD3=0.0
	SUMD4=0.0
	SUMF3=0.0
	SUMF4=0.0
	DO  205  I=1,LATM
	DO  204  K=1,9
204	XX(K,I)=0.0
	DO  205  K=1,35
205	BB(K,I)=0.0
	NDAT=1
399	READ ( 1'NDAT ) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO,
	1   SINT, (FM(K),K=1,10 ), RA,RB
	IF  ( H(1)-999. ) 210,  211,  211
210	DO  212  I=1,LATM
	DADAI(I)=0.0
	DBDAI(I)=0.0
	DO  213  K=1,3
	DADX(K,I)=0.0
213	DBDX(K,I)=0.0
	DO  212  K=1,6
	DADB(K,I)=0.0
212	DBDB(K,I)=0.0
C      START LOOP THROUGH SYMMETRY
	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
	CALL PATCH (I,TSL,HJ,HHJ )
	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) )  311,  311,  315
315	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
C     IF ADD OR SUBTRACT THIS ATOM
311	IF ( JPT(I) )  314,  314,  356
356	COSIJ=-COSIJ
	SINIJ=-SINIJ
314	DADAI(I)=DADAI(I)+COSIJ
	IF  ( LCYC )  320,  320,  317
317	DO  316  K=1,3
316	DADX(K,I)=DADX(K,I)+HJ(K)*SINIJ
	GO TO ( 320,  321), LBMX
321	DO  323 K=1,6
323	DADB(K,I)=DADB(K,I)+HHJ(K)*COSIJ
C     BYPASS THE REST IF CENTROSYMMETRIC
320	IF  ( LCEN )  310,  310,  324
324	DBDAI(I)=DBDAI(I)+SINIJ
	IF  ( LCYC )  310,  310,  318
318	DO  325  K=1,3
325	DBDX(K,I)=DBDX(K,I)+HJ(K)*COSIJ
	GO TO ( 310, 326 ), LBMX
326	DO  328  K=1,6
328	DBDB(K,I)=DBDB(K,I)+HHJ(K)*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
	LBMX=1
	IF  ( BETA(2,I) )  340,  340,  341
340	TFI=EXP(-BETA(1,I)*RHO )
	LBMX=0
341	FTAT=FI*TFI*AOCP(I)
	FTCOS=FTAT*DADAI(I)
	GA=GA+FTCOS
	IF  ( LCYC )  346,  346,  319
319	IF ( KIR(I) )  346,  346,  357
357	DADAI(I)=FI*TFI*DADAI(I)
	PIFI=-6.28318531*FTAT
	DO  342  K=1,3
342	DADX(K,I)=PIFI*DADX(K,I)
	IF ( LBMX )  344,  344,  343
343	DO  345  K=1,6
345	DADB(K,I)=-FTAT*DADB(K,I)
	GO TO 346
344	DADB(1,I)=-RHO*FTCOS
C     COMPUTE B AND ITS DERIVATIVES
346	IF  ( LCEN )  347,  347,  348
348	FTSIN=FTAT*DBDAI(I)
	GB=GB+FTSIN
	IF  ( LCYC )  347,  347,  329
329	IF ( KIR(I) )  347,  347,  358
358	DBDAI(I)=FI*TFI*DBDAI(I)
	PIFI=-PIFI
	DO  349  K=1,3
349	DBDX(K,I)=PIFI*DBDX(K,I)
	IF ( LBMX )  350,  350,  351
351	DO  352  K=1,6
352	DBDB(K,I)=-FTAT*DBDB(K,I)
	GO TO 347
350	DBDB(1,I)=-RHO*FTSIN
347	CONTINUE
C     END OF ATOM LOOP
C     NEW OR PARTIAL CALCULATUON
	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
	CA=SIGN(1.0,GA)
	CB=0.0
	FCAL=ABS(AC)
	BC=0.0
	GO TO 374
371	GA=GA+AC
	GB=GB+BC
	FCAL=SQRT(GA*GA+GB*GB)
	AC=GA
	BC=GB
	IF  ( FCAL ) 373,  372,  373
372	CA=0.0
	CB=0.0
	GO TO 374
373	CA=GA/FCAL
	CB=GB/FCAL
374	CALL DATSW(0,JJ)
	SFOBS=SCL*FOBS
	SIG=SIG*SCL
	AO=SFOBS*CA
	BO=SFOBS*CB
	DELF=SFOBS-FCAL
	CALL  RSETW(SFOBS,FCAL,AC,BC,SIG,SINT,ID)
	IF  ( SIG )  336,  336,  335
335	WGT=1.0/(SIG*SIG)
	GO TO 337
336	WGT=0.0
337	WDEL=WGT*DELF
	FCALK=FCAL*SCL
	RHOCL=-RHO*FCAL
	SS1=SS1+WGT*FCALK*FCALK
	SS2=SS2+WGT*FCALK*RHOCL
	SS3=SS3+WGT*RHOCL*RHOCL
	SS4=SS4+WDEL*FCALK
	SS5=SS5+WDEL*RHOCL
	IF  ( ID )  360,  360,  361
360	SUMD1=SUMD1+ABS(DELF)
	SUMF1=SUMF1+SFOBS
	SUMD2=SUMD2+WDEL*DELF
	SUMF2=SUMF2+WGT*SFOBS*SFOBS
	GO TO 338
C     FOR UNOBSERVED REFLEXIONS ONLY
361	SUMD3=SUMD3+ABS(DELF)
	SUMF3=SUMF3+SFOBS
	SUMD4=SUMD4+WDEL*DELF
	SUMF4=SUMF4+WGT*SFOBS*SFOBS
338	IF ( LCYC )  229,  229,  339
C     SET UP THE NORMAL EQUATION
339	IF ( WGT )  230,  230,  322
322	DO  330  I=1,LATM
	IF ( KIR(I) )  330,  330,  240
240	DAF=CA*DADAI(I)+CB*DBDAI(I)
	DO  331  K=1,3
331	DFX(K)=CA*DADX(K,I)+CB*DBDX(K,I)
	IF  ( BETA(2,I) )  332,  332,  333
332	DFB(1)=CA*DADB(1,I)+CB*DBDB(1,I)
	GO TO 226
333	DO  334  K=1,6
334	DFB(K)=CA*DADB(K,I)+CB*DBDB(K,I)
226	XX(1,I)=XX(1,I)+DFX(1)*DFX(1)*WGT
	XX(2,I)=XX(2,I)+DFX(1)*DFX(2)*WGT
	XX(3,I)=XX(3,I)+DFX(1)*DFX(3)*WGT
	XX(4,I)=XX(4,I)+DFX(2)*DFX(2)*WGT
	XX(5,I)=XX(5,I)+DFX(2)*DFX(3)*WGT
	XX(6,I)=XX(6,I)+DFX(3)*DFX(3)*WGT
	XX(7,I)=XX(7,I)+DFX(1)*WDEL
	XX(8,I)=XX(8,I)+DFX(2)*WDEL
	XX(9,I)=XX(9,I)+DFX(3)*WDEL
	BB(1,I)=BB(1,I)+DAF*DAF*WGT
	BB(2,I)=BB(2,I)+DAF*DFB(1)*WGT
	BB(8,I)=BB(8,I)+DFB(1)*DFB(1)*WGT
	IF  ( BETA (2,I) )  220,  220,  221
221	DO  223  K=2,6
223	BB(K+1,I)=BB(K+1,I)+DAF*DFB(K)*WGT
	DO  224  K=2,6
224	BB(K+7,I)=BB(K+7,I)+DFB(1)*DFB(K)*WGT
	K1=14
	DO  225  K=2,6
	DO  225  KK=K,6
	BB(K1,I)=BB(K1,I)+DFB(K)*DFB(KK)*WGT
225	K1=K1+1
220	BB(29,I)=BB(29,I)+DAF*WDEL
	BB(30,I)=BB(30,I)+DFB(1)*WDEL
	IF  ( BETA(2,I) )  330,  330,  227
227	K1=31
	DO  228  K=2,6
	BB(K1,I)=BB(K1,I)+DFB(K)*WDEL
228	K1=K1+1
330	CONTINUE
C     END OF ATOM LOOP
230	GO TO ( 231, 399 ), JJ
231	IH=H(1)
	IK=H(2)
	IL=H(3)
	WRITE (JTYP,105 ) IH,IK,IL,SFOBS,FCAL,AO,AC,BO,BC
	GO TO 399
C     WRITE OUTPUT ONLY THE FINAL CYCLE
229	NDAT=NDAT-1
	FOBS=SFOBS
	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
	GO TO 230
C     END OF ALL REFLEXIONS
211	NDAT=NDAT-1
	NOBS=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)
C     END OF ONE CYCLE
	LCYC=LCYC-1
	IF  ( LCYC )  422,  402,  402
422	LCYC=LCYC+2
C     GO TO CALCULATE AGREEMENT
	CALL LINK( SF4 )
C     GO TO SOLVE SHIFTS
402	CALL LINK (SF3 )
	END
// DU	P
*DUMP	       WS  CD  SF2
// JO	B
// FO	R
*IOCS	%CARD,TYPEWRITER,DISK)
*ONE 	WORD INTEGERS
C     LEAST SQUARES PARAMETER SHIFTS CALCULATION
C                  THIS PART SOLVES THE PARAMETER SHIFTS
C               SF3
C
	DIMENSION TS(3,24),IS(2,3,24)
	DIMENSION PRCP(6),DANT(6)
	DIMENSION ANM(50),IANM(50),X(50),Y(50),Z(50)
	DIMENSION BETA(6,50),AOCP(50),KI(500),JSF(50)
	DIMENSION XX(9,50),BB(35,50)
	DIMENSION AA(7,7),AB(7),ASH(7)
	DIMENSION DFDX(3,50),DBDX(3,50)
	DIMENSION  JPT(50),KIR(50)
	COMMON JCDI,JCDO,JTYP,NDAT
	COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM
	COMMON  PRCP,SCL,SCLR,DMPS,DMPO,DMPP,DMPT
	COMMON SS1,SS2,SS3,SS4,SS5,SUMD1,SUMD2,SUMF1,SUMF2
	COMMON  SUMD3,SUMF3,SUMD4,SUMF4
	COMMON XX,BB,ANM,IANM,X,Y,Z,BETA,AOCP,KI,JSF,TS,IS
	COMMON  JPT,KIR
	DEFINE FILE  1 (5000, 52, U,NDAT )
C
102	FORMAT ( A4,A2,3X,F9.6,4F9.6  )
103	FORMAT ( 8F9.6  )
104	FORMAT ( /  37HTEMP. FACTOR IS NOT POSITIVE DEFINITE  /  )
105	FORMAT ( // 7H*****  , 12HCYCLE NUMBER    I4, 7H  *****  /   )
106	FORMAT (/16X1HX,9X1HY,9X1HZ,9X1HM,7X6HB(B11),5X3HB22,7X3HB33,
	1  7X3HB12,7X3HB13,7X3HB23      /     )
107	FORMAT (/ 53HQUAD. MEAN ERROR SQRT(SUM(W*(FO-FC)**2)/(NOBS-NPAR))=
	1  5XE12.4 /)
109	FORMAT (/ 28HFOR OBSERVED REFLEXIONS ONLY /)
110	FORMAT ( 2X5HSHIFT,3X10F10.5 )
111	FORMAT ( // A4, A2  /  )
112	FORMAT (/7HSUM(FO),5X1H=E12.4,3X7HSUM(DF)5X1H=,E12.4,11X3HR= F7.3
	1 //13HSUM(W*FO**2)=E12.4,3X13HSUM(W*DF**2)=E12.4,3X11HWEIGHTED R=
	2 F7.3 /)
113	FORMAT (/ 6HSCALE=,F6.3,14H, SCALE SHIFT= F6.3,
	1  20H,   OVERALL B SHIFT=  F6.3   /    )
114	FORMAT (/ 18HFOR ALL REFLEXIONS /)
115	FORMAT (2X6HE.S.D.2X10F10.5 )
116	FORMAT (2X3HNEW,5X10F10.5 )
C
	D=SS1*SS3-SS2*SS2
	DSL=(SS4*SS3-SS5*SS2)/D*DMPS
	DTO=((SS1*SS5-SS2*SS4)/D-SS5/SS3)*DMPO
	VAR=SQRT(SUMD2/FLOAT(NOBS-NPAR) )
	WRITE ( JTYP, 105 )  NRFM
	WRITE (JTYP,107 ) VAR
	DO  416  I=1,6
416	DANT(I)=DTO*PRCP(I)
	DO  415  I=1,LATM
	II=1
	DO  405  J=1,3
	AB(J)=XX(J+6,I)
	DO  405  K=J,3
	AA(J,K)=XX(II,I)
405	II=II+1
	JJ=10*I-9
	DO  417  J=1,3
	IF  ( KI(JJ) )  418,  418,  417
418	AB(J)=0.0
	DO  419  K=1,3
	AA(K,J)=0.0
419	AA(J,K)=0.0
	AA(J,J)=1.0
417	JJ=JJ+1
	DO  406  J=1,2
	DO  406  K=J,3
406	AA(K,J)=AA(J,K)
	CALL MATV(AA,AB,ASH,3 )
C     SHIFTS
	DO  407  J=1,3
	IF  ( ASH(J) )  439,  438,  439
438	DFDX(J,I)=0.0
	DBDX(J,I)=0.0
	GO TO 407
439	DFDX(J,I)=ASH(J)*DMPP
	DBDX(J,I)=VAR*SQRT(AA(J,J) )
407	CONTINUE
	II=1
	DO  408  J=1,7
	AB(J)=BB(J+28,I)
	DO  408  K=J,7
	AA(J,K)=BB(II,I)
408	II=II+1
	DO  409  J=1,6
	DO  409  K=J,7
409	AA(K,J)=AA(J,K)
C     RESET UNVARIED PARAMETERS
	JJ=10*I-6
	DO  410  J=1,7
	IF  ( KI(JJ) )  411,  411,  410
411	AB(J)=0.0
	DO  412  K=1,7
	AA(J,K)=0.0
412	AA(K,J)=0.0
	AA(J,J)=1.0
410	JJ=JJ+1
	CALL MATV(AA,AB,ASH,7 )
	DO  414  J=1,7
	IF  ( ASH(J) )  426,  413,  426
413	BB(J,I)=0.0
	BB(J+7,I)=0.0
	GO TO 414
426	BB(J,I)=ASH(J)*DMPT
	BB(J+7,I)=VAR*SQRT(AA(J,J) )
414	CONTINUE
	IF  ( KI(10*I-6) )  428,  428,  427
427	BB(1,I)=ASH(1)*DMPT-AOCP(I)*DSL/SCLR
428	IF  ( BETA(2,I) )  423,  423,  424
423	IF  ( KI(10*I-5) )  415,  415,  429
429	BB(2,I)=BB(2,I)+DTO
	GO TO 415
424	DO  425  J=1,6
	IF  ( BB(J+1,I) )  422,  425,  422
422	BB(J+1,I)=BB(J+1,I)+DANT(J)
425	CONTINUE
415	CONTINUE
	NEGT=0
	WRITE (JTYP,109 )
	R1=SUMD1/SUMF1
	R2=SQRT(SUMD2/SUMF2)
	WRITE (JTYP,112 ) SUMF1,SUMD1,R1,SUMF2,SUMD2,R2
	SUMD1=SUMD1+SUMD3
	SUMD2=SUMD2+SUMD4
	SUMF1=SUMF1+SUMF3
	SUMF2=SUMF2+SUMF4
	R1=SUMD1/SUMF1
	R2=SQRT(SUMD2/SUMF2)
	WRITE (JTYP,114)
	WRITE (JTYP,112 ) SUMF1,SUMD1,R1,SUMF2,SUMD2,R2
	SCLI=SCL
	DSL=-DSL/(SCLR*(SCLR+DSL) )
	SCL=SCLI+DSL
	WRITE ( JTYP, 113 )  SCLI,DSL,DTO
	WRITE ( JCDO, 103 )  SCL
	WRITE ( JTYP, 106 )
	DO  421  I=1,LATM
	WRITE ( JTYP,111 ) ANM(I),IANM(I)
	X(I)=X(I)+DFDX(1,I)
	Y(I)=Y(I)+DFDX(2,I)
	Z(I)=Z(I)+DFDX(3,I)
	AOCP(I)=AOCP(I)+BB(1,I)
	DO  420  J=1,6
	ASH(J)=BETA(J,I)
420	BETA(J,I)=BETA(J,I)+BB(J+1,I)
	ASF=JSF(I)
	CALL RESTX( I,X,Y,Z)
	CALL RESTB (I,BETA)
	IF ( BETA(2,I) )  401,  404,  401
404	IF ( BETA(1,I) )  403,  402,  402
403	BETA(1,I)=0.001
	GO TO 435
C     ANISOTROPIC TEMPERATURE FACTOR
401	DO  430  K=1,3
	IF  ( BETA(K,I) )  434,  430,  430
430	CONTINUE
	IF  (BETA(1,I)*BETA(2,I)-BETA(4,I)*BETA(4,I) ) 434, 431, 431
431	IF (BETA(1,I)*BETA(3,I)-BETA(5,I)*BETA(5,I) ) 434, 432, 432
432	IF ( BETA(2,I)*BETA(3,I)-BETA(6,I)*BETA(6,I) ) 434, 433, 433
433	IF ( BETA(1,I)*BETA(2,I)*BETA(3,I)+(BETA(4,I)*BETA(5,I)*BETA(6,I))
	1 *2.0-BETA(1,I)*BETA(6,I)**2-BETA(2,I)*BETA(5,I)**2-
	2  BETA(3,I)*BETA(4,I)**2 )  434,  402,  402
C     TEMPERATURE FACTOR NOT POSITIVE DEFINITE
434	DO  445  K=1,6
445	BETA(K,I)=ASH(K)
435	WRITE (JTYP,104 )
	NEGT=NEGT+1
402	WRITE ( JCDO,102 ) ANM(I),IANM(I),ASF,AOCP(I),X(I),Y(I),Z(I)
	WRITE  ( JCDO,103 ) (BETA(K,I),K=1,6 )
	IF  ( BETA(2,I) )  437,  436,  437
C     ISOTROPIC
436	WRITE ( JTYP,110) (DFDX(J,I),J=1,3), (BB(J,I),J=1,2 )
	WRITE (JTYP,116) X(I),Y(I),Z(I),AOCP(I),BETA(1,I)
	WRITE ( JTYP,115 ) (DBDX(J,I),J=1,3), (BB(J+7,I),J=1,2 )
	GO TO 421
437	WRITE ( JTYP,110 ) (DFDX(J,I),J=1,3), (BB(J,I),J=1,7 )
	WRITE (JTYP,116) X(I),Y(I),Z(I),AOCP(I),(BETA(K,I),K=1,6)
	WRITE (JTYP,115 ) (DBDX(J,I),J=1,3), (BB(J+7,I),J=1,7 )
421	CONTINUE
	IF  ( NEGT )  440,  440,  441
441	GO TO 440
440	CALL LINK (SF2 )
	END
// DU	P
*DUMP	       WS  CD  SF3
*ONE 	WORD INTEGERS
C     SUBROUTINE TO INVERT A MATRIX AND SOLVE THE SHIFTS
	SUBROUTINE MATV ( A,B,ANS,N )
	DIMENSION  A(7,7),B(7),ANS(7)
	DO  150  K=1,N
	IF  ( ABS(A(K,K) )-0.005 )  150,  150,  151
151	ADIV=1.0/A(K,K)
	DO  115  J=1,N
115	A(K,J)=A(K,J)*ADIV
	DO  140  I=1,N
	IF  ( I-K )  116,  140,  116
116	DO  130  J=1,N
	IF  ( J-K ) 117,  130,  117
117	A(I,J)=A(I,J)-A(I,K)*A(K,J)
130	CONTINUE
	A(I,K)=-ADIV*A(I,K)
140	CONTINUE
	A(K,K)=ADIV
150	CONTINUE
	DO  160  I=1,N
	ANS(I)=0.0
	DO  155  J=1,N
155	ANS(I)=ANS(I)+B(J)*A(I,J)
160	CONTINUE
	RETURN
	END
*DUMP	       WS  CD  MATV
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO TRANSFORM THE INDICES
	SUBROUTINE  PATCH(I,TSL,HJ,HHJ)
	DIMENSION  HJ(6),HHJ(6)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  PATCH
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO RESET THE TEMP. FACTORS
	SUBROUTINE RESTB(I,BETA)
	DIMENSION  BETA(6,50)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  RESTB
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO REST POSITIONAL PARAMETERS
	SUBROUTINE RESTX(I,X,Y,Z)
	DIMENSION  X(50),Y(50),Z(50)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  RESTX
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO MODIFY INDICES FOR A SPECIAL POSITION ETC.
	SUBROUTINE  PATCH(I,TSL,HJ,HHJ )
	DIMENSION  HJ(6),HHJ(6)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  PATCH
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO RESET THE TEMPERATURE PARAMETERS
	SUBROUTINE  RESTB (I,BETA)
	DIMENSION  BETA(6,50)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  RESTB
*ONE 	WORD INTEGERS
C     A SUBROUTINE TO RESET XYZ PARAMETERS FOR A SPECIAL POSITIONS ETC.
	SUBROUTINE RESTX (I,X,Y,Z)
	DIMENSION X(50),Y(50),Z(50)
	RETURN
	END
// DU	P
*DUMP	       WS  CD  RESTX
// AS	M
	              *             DUMMY SUBROUTINE RSETW
	                    ENT     RSETW
	              RSETW DC      *    RETURN ADDRESS
	                    MDX  L  RSETW,7   SEVEN PARAMETERS
	                    BSC  I  RSETW
	                    END
// DU	P
*DUMP	       WS  CD  RSETW
// AS	M
	              *             DUMMY SUBROUTINE PATCH
	                    ENT     PATCH
	              PATCH DC      *      RETURN ADDRESS
	                    MDX  L  PATCH,4    FOUR PARAMETERS
	                    BSC  I  PATCH
	                    END
// DU	P
*DUMP	       WS  CD  PATCH
// 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
