C  THIS IS THE SHIONO VERSION OF ORFLS ADAPTED FROM THE FORTRAN 2 FORM
C  FOR THE IBM 7090 TO FORTRAN 4 FOR THE IBM 360/75
C      OCTOBER 1969   BY  R. SNYDER
C
C  THE THREE LINKS OF THE 7090 PROGRAM HAVE BEEN PRESERVED BY USING
C  THE FOLLOWING MAIN CALLING PROGRAM AND TREATING EACH OF THE LINKS AS
C  A SUBROUTINE  THE OVERLAY STRUCTURE IS SPECIFIED IN THE JCL
C
	DIMENSION  PRCP(6),TITLE(12), ABEL(2,14)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  FM(10)
	DIMENSION  FMA(10),FMB(10)
	DIMENSION  X(4),IHKL(4),HJ(3),HHJ(6)
	DIMENSION  SC(20)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  V(181),DV(181)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  DADFI(85),DBDFI(85),DADAI(85),DBDAI(85)
	DIMENSION  DADX(3,85),DBDX(3,85),DADB(6,85),DBDB(6,85)
	DIMENSION  P(811),KI(811)
	DIMENSION  DFDS(20)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB    , X      , SQSIG
	COMMON  NCY    , IC     , SIG    , YC     , YO     , SIGYO
	COMMON  IHKL   , TJ     , HX     , HHB    , EXPIJ  , COSIJ
	COMMON  SINIJ  , A      , B      , RHO    , SINTHL , FTA
	COMMON  FTACOS , FTASIN , TFI    , PIFI   , IQ     , SQTO
	COMMON  SQRTAB , F      , DFDTO  , CA     , CB     , V
	COMMON  DV     , HJ     , HHJ    , FM     , DADFI  , DBDFI
	COMMON  DADAI  , DBDAI  , DADX   , DBDX   , DADB   , DBDB
	COMMON  DFDS
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
10	CALL LINK1
C
	CALL LINK2(IGOTO)
C
	IF( IGOTO ) 10, 10, 20
C
20	CALL LINK3
C
	STOP
	END
	BLOCK DATA
	DIMENSION TITLE(12), ABEL(2,14), ATOM(85)
	COMMON /BLOCK/ TITLE, ABEL, ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
	DATA ABEL(1,1)/6HSCALE /, ABEL(2,1)/6HFACTOR/, ABEL(1,2)/6HOVERAL/
	DATA ABEL(2,2)/6H B   L/, ABEL(1,3)/6HFORM F/, ABEL(2,3)/6HACTOR /
	DATA ABEL(1,4)/6HMULTIP/, ABEL(2,4)/6HLIER  /, ABEL(1,5)/6HX     /
	DATA ABEL(2,5)/6H      /, ABEL(1,6)/6HY     /, ABEL(2,6)/6H      /
	DATA ABEL(1,7)/6HZ     /, ABEL(2,7)/6H      /, ABEL(1,8)/6HBETA(1/
	DATA ABEL(2,8)/6H,1)  1/, ABEL(1,9)/6HBETA(2/, ABEL(2,9)/6H,2)  2/
	DATA ABEL(1,10)/6HBETA(3/,ABEL(2,10)/6H,3)   /
	DATA ABEL(1,11)/6HBETA(1/, ABEL(2,11)/6H,2)   /
	DATA ABEL(1,12)/6HBETA(1/, ABEL(2,12)/6H,3)   /
	DATA ABEL(1,13)/6HBETA(2/, ABEL(2,13)/6H,3)   /
	DATA ABEL(1,14)/6HATOMIC/, ABEL(2,14)/6H B    /
	END
	SUBROUTINE LINK1
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     OR-FLS MODIFIED FOR MORE PARAMETERS AND DATA ON A TAPE
C     MAIN PROGRAM PART 1.      PRELIMINARY
C                                      APRIL 1965         R.SHIONO
C  CONVERTED TO THE IBM 360/75  OCTOBER 1969 BY R. SNYDER
C     NO. OF ATOMS  85, NO. OF PARAMETERS  811,  TO BE REFINED  181.
C          NX(MAX)=4, NF(MAX)=10, NS(MAX)=24, NQ(MAX)=20
	DIMENSION  PRCP(6),TITLE(12),ABEL(2,14)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  SC(20)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  P(811),KI(811)
	DIMENSION  FMA(10),FMB(10)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
C     FORMAT STATEMENTS
5	   FORMAT (11H0BASED ON F)
8	   FORMAT (19H0BASED ON F SQUARED)
12	FORMAT ( 1H0, 39HISOTROPIC AND ANISOTROPIC TEMP. FACTORS )
17	   FORMAT (43H0ISOTROPIC TEMPERATURE FACTORS CONVERTED TO,
	1      28H ANISOTROPIC BEFORE REFINING)
20	FORMAT (38H0NUMBER OF SCATTERING FACTOR TABLES IS I3)
21	FORMAT ( 1H0, 36HPARTIAL STRUCTURE FACTOR CALCULATION    )
22	FORMAT (38H0NUMBER OF ATOMS IN ASYMMETRIC UNIT IS I3)
23	FORMAT ( 1H0,46HNUMBER OF ATOMS WITH DISPERSION CORRECTION IS ,I3)
25	   FORMAT (16H0CENTROSYMMETRIC)
28	   FORMAT (20H0NON-CENTROSYMMETRIC)
30	FORMAT (28H0NUMBER OF SYMMETRY CARDS IS I3)
32	FORMAT (27H0NUMBER OF SCALE FACTORS IS I3)
35	FORMAT ( 1H0, 42HINPUT DATA FOR ORFFE TO BE WRITTEN ON TAPE I5 )
00051	 FORMAT(12A6)
00052	 FORMAT(1H112A6)
53	FORMAT  ( 16I5)
00067	 FORMAT(29H0NUMBER OF PARAMETERS READ ISI4)
68	FORMAT ( 1H0, 37HNUMBER OF PARAMETERS TO BE REFINED IS  , I5  )
70	FORMAT (F11.6,2I2,F11.6,2I2,F11.6,2I2)
71	FORMAT  ( 72I1 )
74	FORMAT (21H0SYMMETRY INFORMATION/67H0     TRANSFORMED X
	1TRANSFORMED Y           TRANSFORMED Z/1H )
76	FORMAT (1H F13.6,2I2,F20.6,2I2,F20.6,2I2)
91	FORMAT(1H0,4HATOM,5X1HF,9X1HO,11X1HX,10X1HY,10X1HZ,8X6HB(B11),
	1  6X3HB22,8X3HB33,8X3HB12,8X3HB13,8X3HB23    /     )
92	FORMAT (11H0INPUT DATA/20H0SCALE   P(I)  KI(I)/1H )
00093	 FORMAT(1H I3,F10.4,I4)
94	FORMAT ( 1H0, I2,F10.2,I2, 10(F9.4,I2 )   )
97	FORMAT(1H069HNO. OF PARAMETERS TO BE VARIED DOES NOT AGREE WITH TH
	1E SELECTION CARD   // )
170	   FORMAT (8F9.6)
200	FORMAT  ( A6,3X 5F9.6,2F6.2 )
C     SYSTEM TAPE ASSIGNMENT
C  NTPA IS LOGICAL UNIT NUMBER OF THE READER
	NTPA = 105
C  NTPB IS THE LOGICAL UNIT NUMBER OF THE PRINTER
	NTPB = 108
C  NTPF IS THE LOGICAL UNIT NUMBER OF THE CARD PUNCH
	NTPF = 106
C  NTPG IS THE INPUT TAPE LOGICAL 10
C     DATA TAPE ADDRESS
	NTPG = 10
C  NTPE IS THE OUTPUT DATA TAPE  LOGICAL 4
	NTPE = 4
C  NTPC IS THE OUTPUT TAPE FOR ORFFE LOGICAL 9
	NTPC = 9
	REWIND NTPG
	READ  (NTPA,51)(TITLE(I),I=1,12)
	WRITE (NTPB,00052)(TITLE(I),I=1,12)
	       CALL SCAT (NTPA,NTPB,NTPC,NTPG )
	      REWIND NTPE
C     STORE HEADINGS FOR THE OUTPUT OF PARAMETERS
C     READ AND PUT OUT CONTROL INFORMATION
	READ  (NTPA,53)NC,NA,NQ,ITF,NV,NAS,NPT,NPRN,NR,NRW,ISTOP
	NR=NR+1
	READ  (NTPA,53)NF,ICENT,NS,IFSQ,IXFE
	NX=4
222	IF  ( IXFE-1 )  226,  225,  301
225	WRITE (NTPB,35)NTPC
	REWIND NTPC
226	IF(  IXFE  )  227,301,301
227	WRITE(NTPB,228)NTPC
228	FORMAT(1H0,' COORDINATES AND ERRORS, BASED ON DIAGONAL ELEMENTS, T
	1O BE WRITTEN ON FILE',I5,' (INPUT FOR PROGRAM ANGLE)')
	REWIND NTPC
301	IF(IFSQ-1)4,4,7
4	   WRITE (NTPB,5)
	   GO TO 9
7	   WRITE (NTPB,8)
9	IF  ( ITF )    31,  31,  16
16	    WRITE (NTPB,17)
	GO TO 19
31	WRITE (NTPB,12)
19	WRITE (NTPB,20)NF
	WRITE (NTPB,22)NA
	WRITE (NTPB,23)NAS
	IF  ( NPT )  56,  56,  55
55	WRITE (NTPB,21)
56	IF  ( ICENT-1 )  24,  24,  27
24	   WRITE (NTPB,25)
	   GO TO 29
27	   WRITE (NTPB,28)
29	 WRITE (NTPB,30)NS
	WRITE (NTPB,32)NQ
C     READ AND PUT OUT SYMMETRY TRANSFORMATIONS
	READ  (NTPA,70)((TS(I,J),(IS(K,I,J),K=1,2),I=1,3),J=1,NS)
	WRITE (NTPB,74)
	WRITE (NTPB,76)((TS(I,J),(IS(K,I,J),K=1,2),I=1,3),
	1              J=1,NS)
C     READ RECIPROCAL CELL PARAMETERS FROM DATA TAPE
	READ  (NTPG)(PRCP(K),K=1,6)
	REWIND NTPG
	NT=NTPA
C     IF RE-CYCLING, BYPASS THE PARAMETER READING
	GO TO ( 169, 169, 177, 177 ), NR
169	READ  (NTPA,170)(SC(I),I=1,NQ)
	DO  171  I=1,NQ
171	SC(I)=1.0/SC(I)
C     NAS MAXIMUM IS 10.
	   DO 190 I=1,NA
	     IF  ( I-NAS )  192,  192,  191
192	READ  (NT,200)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3),          FMA(I
	1),FMB(I)
	GO TO 190
191	READ  (NT,200)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3)
190	      READ  (NT,170)(BETA(K,I),K=1,6)
C     CONVERT ISOTROPIC TEMPERATURE FACTOR TO ANISOTROPIC IF SPECIFIED
	IF  ( ITF )  320,  320,  230
230	DO  260  I=1,NA
	IF  ( BETA(2,I) )  231,  231,  260
231	TFI=BETA(1,I)
	DO  232  K=1,6
232	BETA(K,I)=TFI*PRCP(K)
260	CONTINUE
C     COPY PARAMETERS INTO THE ARRAY P
320	CALL SBTP(P(1),SC(1),SF(1),AI(1),XYZ(1,1),BETA(1,1),NA,NQ,NP)
	WRITE (NTPB,00067)NP
177	WRITE (NTPB,68)NV
	DO  1302  I=1,NP
1302	KI(I)=0
C     READ KEY INTEGERS IF REFINEMENT IS TO BE MADE
	IF(NC)01601,01601,01301
1301	READ  (NTPA,71)(KI(I),I=1,NP)
	NUMK=0
	DO  1303  I=1,NP
	KI(I)=IABS(KI(I))
1303	NUMK=NUMK+KI(I)
	IF  (NV-NUMK)  1602,  1601,  1602
C     INITIALIZE PROBLEM
01601	 NM=(NV*(NV+1))/2
C     PUT OUT TRIAL PARAMETERS AND KEY INTEGERS
	WRITE (NTPB,00092)
	DO  1603  I=1,NQ
	DIAG(I)=1.0/SC(I)
1603	WRITE (NTPB,93)I,DIAG(I),KI(I)
	WRITE (NTPB,91)
	JJ=NQ+1
	DO  173  I=1,NA
	J=JJ
	IF  ( BETA(2,I) )  174,  174,  175
174	JMX=J+5
	JJ=J+6
	GO TO 176
175	JMX=J+10
	JJ=J+11
176	WRITE (NTPB,94)I, (P(L),KI(L),L=J,JMX )
173	CONTINUE
C     SET UP THE INDICATORS FOR REFINEMENT OF EACH PARAMETERS
	I1=NQ+1
	DO  60  I=1,NA
	I1=I1+2
	JSUM=KI(I1)+KI(I1+1)+KI(I1+2)
	I1=I1+3
	KATM(I)=1
	IF  ( JSUM )  62,  62,  61
61	KATM(I)=2
62	IF  ( BETA(2,I) )  63,  63,  64
63	JSUM=KI(I1)
	I1=I1+1
	GO TO 65
64	JSUM=KI(I1)+KI(I1+1)+KI(I1+2)+KI(I1+3)+KI(I1+4)+KI(I1+5)
	I1=I1+6
65	IF  ( JSUM )  60,  60,  66
66	KATM(I)=KATM(I)+2
60	CONTINUE
	RETURN
1602	WRITE (NTPB,97)
	STOP
	END
	SUBROUTINE SCAT( NTPA,NTPB,NTPC,NTPG )
C     PRELIMINARY PROGRAM FOR ORFLS LEAST SQUARES PROGRAM
C                     FOR IBM 7090
C                                           R.SHIONO
C  ADAPTED FOR THE IBM 360/75  OCTOBER 1969  BY  R. SNYDER
C
	DIMENSION   RCP(6),PRCP(6),AFM(11,51),FM(15)
1	FORMAT ( 3F7.3, 4F7.4    )
2	FORMAT   ( 7F10.4  )
3	FORMAT (5I5,6F8.4)
4	FORMAT ( 3I9,2F9.2,F9.0,I5,2F6.3 )
5	FORMAT( 1H0,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(/51H REMOVE THE PRIVATE TAPE, IF USED AND SO SPECIFIED. //)
7	FORMAT ( 1H0,39HEND OF PROCESSING. THE DATA ARE ON TAPE , I3 / )
8	FORMAT ( 1H0 , 23HSIGMA-S PUNCHED ON CARD   )
9	FORMAT ( 1H0, 26HHUGHES WEIGHTING,    FMIN=   F6.1   )
10	FORMAT ( 1H0,22HCRUICKSHANK-S WEIGHTS,5H   A=E9.3,5H,  B=E9.3,
	1       5H,  C=E9.3   )
11	FORMAT ( 1H0, 27HWEIGHT=1/(SIN THETA/LAMBDA)     )
12	FORMAT (1H0, 25HSUBROUTINE MODIFY IS USED // 10X 6E10.3  )
13	FORMAT (1H0, 14HDATA FROM TAPE    I4  )
14	FORMAT ( 1H0, 25HATOMIC SCATTERING FACTORS  // 10X 10F8.1  )
15	FORMAT ( 1H0,  37HNUMBER OF SCALE FACTORS SPECIFIED IS    ,  I6 )
C     NTPA=SYSTEM INPUT, NTPB=SYSTEM OUTPUT, NTPG=DATA TAPE
	REWIND NTPG
C     READ CONTROL CARD
	READ  (NTPA,3)JB,JA,JW,JC,JD,CA,CB,CC,CD,CE,CF
	IF  ( JB-3 )  34,  37,  34
34	IF  (JW-1)   33,  32,  33
32	CA4=4.0*CA
33	JW=JW+1
	RA=0.0
	RB=0.0
C     READ CELL CONSTANT CARD
	READ  (NTPA,1)A,B,C,CSAA,CSAB,CSAC,WAVE
	WRITE (NTPB,5)A,B,C,CSAA,CSAB,CSAC,WAVE
	D=SQRT(1.0+2.0*CSAA*CSAB*CSAC-CSAA*CSAA-CSAB*CSAB-CSAC*CSAC)
	D=1.0/(D*A*B*C)
	SNAA=SQRT(1.0-CSAA*CSAA)
	SNAB=SQRT(1.0-CSAB*CSAB)
	SNAC=SQRT(1.0-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
C     WRITE THE RECIPROCAL AND THE DIRECT CELL CONSTANTS AS FIRST RECORD
	WRITE (NTPG)(PRCP(I),I=1,6),A,B,C,CSAA,CSAB,CSAC,WAVE
	GO TO  ( 65, 66, 67, 68, 69 ), JW
65	WRITE (NTPB,8)
	GO TO 69
66	WRITE (NTPB,9)CA
	GO TO 69
67	WRITE (NTPB,10)CA,CB,CC
	GO TO 69
68	WRITE (NTPB,11)
69	FCAL=0.0
	IF  ( JC )  70,  70,  71
71	WRITE (NTPB,12)CA,CB,CC,CD,CE,CF
70	AO=0.0
	BO=0.0
	AC=0.0
	BC=0.0
	DO  31  I=1,11
	DO  31  J=1,51
31	AFM(I,J)=0.0
C     READ ATOMIC SCATTERING FACTOR TABLES
	I=0
20	I=I+1
	READ  (NTPA,2)(AFM(I,J),J=1,7 )
	IF  ( AFM(I,1) )  21, 21, 22
22	READ  (NTPA,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 (NTPB,14)(AFM(I,1),I=1,NATSC )
	QSCL=1.0
	IF  ( JB-1 )  60,  59,  60
C     BYPASS THE FIRST RECORD
59	REWIND NTPC
	READ  (NTPC)
	JBB=2
60	GO TO ( 61, 62 ), JBB
C     INPUT FROM CARDS
61	READ  (NTPA,4)IH,IK,IL,FOBS,SIG,Q,ID,RA,RB
	FH=IH
	FK=IK
	FL=IL
	IF  (IH)  25,  23,  25
23	IF  (IK)  25,  24,  25
24	IF  (IL)  25,  50,  25
C     IF INPUT IS FROM TAPE
62	READ  (NTPC)FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO,SINT,    (
	1FM(K),K=1,10),RA,RB
	IF  ( FH-999.0 )  25,  50,  50
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.0*FH*FK*PRCP(4)+
	1        2.0*FK*FL*PRCP(6)+2.0*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.0
	DO  29  K=1,10
29	FM(K)=0.0
	DO  30  K=1,NATSC
30	FM(K)=AFM(K,I)+(AFM(K,I+1)-AFM(K,I))*FRAC
	GO TO (49, 41, 42, 43, 44 ), JW
41	IF  (FOBS)  45,  45,  46
45	SIG=0.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  ( JA )  52,  51,  52
52	FOBS=FOBS*FOBS
	SIG=SIG*SIG
51	IF  ( JD-1 )  40,  57,  40
57	IF  ( ID-1 )  40,  58,  40
58	SIG=0.0
40	IF ( JC )  54,  38,  54
C     USER,S SUBROUTINE TO MODIFY ANYTHING HE LIKES
54	CALL MODIFY(FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,SINT,CA,CB,
	1    CC,CD,CE,CF,RA,RB )
38	IF  ( ID-10 )  53,  60,  53
53	WRITE (NTPG)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
50	FH=999.0
	WRITE (NTPG)FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO,
	1           SINT,(FM(K),K=1,10),RA,RB
	END FILE NTPG
	NSCL=QSCL
	WRITE (NTPB,15)NSCL
	REWIND NTPG
	IF  ( JB-2 )  35,  36,  35
36	WRITE (NTPB,7)NTPG
	 PRINT 6
	CALL EXIT
37	WRITE (NTPB,13)NTPG
35	RETURN
	END
	SUBROUTINE  SBTP(P,SC,SF,AI,XYZ,BETA,NA,NQ,NP)
C     COPY PARAMETERS FROM ARRAYS USED BY SUBROUTINES TO ARRAY P
C     FOR PART 1. OF THE PROGRAM
	DIMENSION  P(691),SC(20),SF(65),AI(65),XYZ(3,65),BETA(6,65)
	DO  40  J=1,NQ
40	P(J)=SC(J)
	I=NQ+1
	DO  220  J=1,NA
	P(I)=SF(J)
	P(I+1)=AI(J)
	I=I+2
	DO  130  K=1,3
	P(I)=XYZ(K,J)
130	I=I+1
	IF  ( BETA(2,J) )  150,  150,  151
150	P(I)=BETA(1,J)
	I=I+1
	GO TO 220
151	DO  210  K=1,6
	P(I)=BETA(K,J)
210	I=I+1
220	CONTINUE
	NP=I-1
	RETURN
	END
	SUBROUTINE MODIFY(FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,SINT,CA,
	1  CB,CC,CD,CE,CF,RA,RB  )
C     A SUBROUTINE TO MODIFY THE WEIGHT ETC.
C
	RETURN
	END
	SUBROUTINE LINK2(IGOTO)
C        MAIN PROGRAM       PART 2.
C                      CORRECTION FOR ANOMALOUS DISPERSION
C     NO. OF ATOMS  85, NO. OF PARAMETERS  811,  TO BE REFINED  181.
C          NX(MAX)=4, NF(MAX)=10, NS(MAX)=24, NQ(MAX)=20
	DIMENSION  PRCP(6),TITLE(12), ABEL(2,14)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  FM(10)
	DIMENSION  FMA(10),FMB(10)
	DIMENSION  X(4),IHKL(4),HJ(3),HHJ(6)
	DIMENSION  SC(20)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  V(181),DV(181)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  DADFI(85),DBDFI(85),DADAI(85),DBDAI(85)
	DIMENSION  DADX(3,85),DBDX(3,85),DADB(6,85),DBDB(6,85)
	DIMENSION  P(811),KI(811)
	DIMENSION  DFDS(20)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB    , X      , SQSIG
	COMMON  NCY    , IC     , SIG    , YC     , YO     , SIGYO
	COMMON  IHKL   , TJ     , HX     , HHB    , EXPIJ  , COSIJ
	COMMON  SINIJ  , A      , B      , RHO    , SINTHL , FTA
	COMMON  FTACOS , FTASIN , TFI    , PIFI   , IQ     , SQTO
	COMMON  SQRTAB , F      , DFDTO  , CA     , CB     , V
	COMMON  DV     , HJ     , HHJ    , FM     , DADFI  , DBDFI
	COMMON  DADAI  , DBDAI  , DADX   , DBDX   , DADB   , DBDB
	COMMON  DFDS
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
00031	 FORMAT( 8F9.6,8X )
33	FORMAT (  A6, 3X 5F9.6,2F6.2 )
00041	 FORMAT(1H041X,29HNUMERATOR   DENOMINATOR     R)
00042	 FORMAT(25H0R FACTOR INCLUDING UNOBS,F26.3,F13.3,F9.3)
00043	 FORMAT(24H0R FACTOR OMITTING UNOBS,F27.3,F13.3,F9.3)
44	FORMAT(34H0WEIGHTED R FACTOR INCLUDING UNOBS,F17.3,F13.3,F9.3)
46	FORMAT(33H0WEIGHTED R FACTOR OMITTING UNOBS,F18.3,F13.3,F9.3)
00052	 FORMAT (1H112A6  )
72	FORMAT(46H0CALCULATED F BASED ON PARAMETERS BEFORE CYCLEI2)
73	FORMAT(97H0   H   K   L    F(OBS)    F(CALC)        A          B
	1        SINE    SIG(O)  (O-C)/SIG(O)   IQ, 5H   ID / 1H   )
00078	 FORMAT(1H0A6)
79	FORMAT ( 1H ,3I4,4F11.4,F11.3,2F11.4,I7,I5  )
00080	 FORMAT(51H0AGREEMENT FACTORS BASED ON PARAMETERS BEFORE CYCLE I2/
	120H0SUM(W*(O-C)**2) IS E11.4/35H0SQRTF(SUM(W*(O-C)**2)/(NO-NV)) IS
	2 F10.4)
00081	 FORMAT(60H0ESTIMATED AGREEMENT FACTORS BASED ON PARAMETERS AFTER C
	1YCLE I2/20H0SUM(W*(O-C)**2) IS E11.4/35H0SQRTF(SUM(W*(O-C)**2)/(NO
	2-NV)) IS F10.4)
00083	 FORMAT(62H MATRIX HAS A ZERO DIAGONAL ELEMENT CORRESPONDING TO PAR
	1AMETERI3,16H OF THOSE VARIED)
00085	 FORMAT(40H SINGULARITY RETURN FROM MATRIX INVERTER)
00086	 FORMAT(37H0PARAMETERS AFTER LEAST SQUARES CYCLEI2/64H0 PARAMETER
	1        OLD        CHANGE         NEW         ERROR)
00088	 FORMAT(1H02A6,F14.7,13X,F13.7)
00089	 FORMAT(1H02A6,1X,4F13.7)
00090	 FORMAT(66H0SUBROUTINE TEST INDICATES THAT JOB IS TO BE TERMINATED
	1FOR REASONI2)
C     START LOOP TO PERFORM NC CYCLES AND ONE FINAL CALCULATION OF Y
	ISTP=ISTOP
	SQSIG=0.0
	NCY=NC+1
	DO 08501 IC=1,NCY
C        CLEAR ARRAYS AM AND V EXCEPT ON LAST CYCLE
	   IF(IC-NCY)01851,02001,02001
01851	       DO 01852 I=1,NM
01852	          AM(I)=0.0
	      DO 01902 I=1,NV
01902	          V(I)=0.0
C        INITIALIZE FOR CYCLE IC AND PUT OUT CAPTION FOR LIST OF Y(CALC)
2001	     SQSGO=SQSIG
	   SIG=0.0
	   RNUM=0.0
	   RZNUM=0.0
	RDEN=0.0
	   RZDEN=0.0
	   WRNUM=0.0
	   WRZNUM=0.0
	   WRZDEN=0.0
	WRDEN=0.0
	WRITE (NTPB,00052)(TITLE(I),I=1,12)
	WRITE (NTPB,00072)IC
	WRITE (NTPB,00073)
C        START LOOP THROUGH NO OBSERVATIONS
C     SPACE OVER THE FIRST RECORD           RECIPROCAL CELL CONST.
	READ  (NTPG)(PRCP(I),I=1,6),AA,BB,CC,COSA,COSB,COSC,WAVE
	WRITE (NTPE)(PRCP(I),I=1,6),AA,BB,CC,COSA,COSB,COSC,WAVE
C     READ ONE REFLEXION AT A TIME TILL THE LAST
	NO=0
2201	READ  (NTPG)(X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO,
	1        SINT,(FM(K),K=1,10),RA,RB
	IF  (X(1)-999.0)   2204,  5400,  2204
C           ENTER SUBROUTINE CALC TO COMPUTE Y(CALC) AND DERIVATIVES
2204	         CALL CALC (X(1),YC,AKEEP,BKEEP)
	       IQ=IQ
	NO=NO+1
C           OBTAIN WEIGHT AND CALCULATE QUANTITIES FROM Y(OBS)-Y(CALC)
	DYO=YO-F
	YOYO=YO*YO
	          YO=YO/SC(IQ)
	        AO=YO*AKEEP/YC
	        BO=YO*BKEEP/YC
C     CALL RSETW IF CHANGES ARE MADE TO SIGYO
	CALL RSETW(YO,YC,A,B,SIGYO,SINT,ID,IC,NCY,NPRN)
	IF ( SIGYO )  2202,  2202,  2203
2202	SQRTW=0.0
	GO TO 2205
2203	SQRTW=1.0/SIGYO
2205	WDYY=SQRTW*DYO
	WYO=SQRTW*SQRTW*YOYO
	        DY=YO-YC
	      WDY=SQRTW*DY
	        SIG=SIG+WDYY*WDYY
	        RZNUM=RZNUM+ABS(DY)
	        RZDEN=RZDEN+ABS(YO)
	        WRZNUM=WRZNUM+WDYY*WDYY
	        WRZDEN=WRZDEN+WYO
	IF (ID)  02801,  02752,  02801
02752	              RNUM=RNUM+ABS(DY)
	RDEN=RDEN+ABS(YO)
	        WRNUM=WRNUM+WDYY*WDYY
	        WRDEN=WRDEN+WYO
C           PUT OUT Y(CALC) AND OTHER INFORMATION FOR ONE OBSERVATION
2801	IF  ( IC-NCY )  2804,  2803,  2803
2804	IF  ( NPRN )  2803,  2803,  2805
2803	 DO  2802  K=1,4
02802	      IHKL(K)=X(K)
	WRITE (NTPB,79)(IHKL(K),K=1,3), YO,YC,A,B,SINT,
	1          SIGYO,WDYY,IHKL(4),ID
2805	WRITE (NTPE)(X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO,
	1       SINT,(FM(I),I=1,10),RA,RB
C           BY-PASS DERIVATIVE AND MATRIX SET-UP ON FINAL CALC OF Y
	      IF(IC-NCY)03001,05101,05101
C              START LOOP TO STORE AN ARRAY OF NV DERIVATIVES
3001	CALL DTOD
C              START LOOP TO STORE MATRIX AND VECTOR. SEE GLOSSARY FOR
C                                                     STORAGE SCHEME
	DO  3010  J=1,NV
3010	DV(J)=DV(J)*SQRTW
	         JK=NM
	         DO 05001 J=1,NV
04301	             IF(DV(J))04501,04401,04501
C                    BY-PASS IF DERIVATIVE IS ZERO
04401	                JK=JK-NV+J-1
	               GO TO 05001
04501	                DO 04801 K=J,NV
	                  AM(JK)=AM(JK)+DV(J)*DV(K)
	                  JK=JK-1
04801	                   CONTINUE
	             V(J)=V(J)+DV(J)*WDYY
05001	                CONTINUE
C                    END LOOP TO STORE MATRIX AND VECTOR
05101	 GO TO  2201
C              END LOOP THROUGH NO OBSERVATIONS
C     END OF ALL DATA
05400	 REWIND NTPG
	WRITE (NTPE)(X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO,
	1       SINT,(FM(I),I=1,10),RA,RB
	END FILE NTPE
	REWIND NTPE
C        COMPUTE AND PUT OUT AGREEMENT FACTORS
	SQSIG=SQRT(SIG/FLOAT(NO-NV))
	WRITE (NTPB,80)IC,SIG,SQSIG
	       WRNUM=SQRT(WRNUM)
	       WRZNUM=SQRT(WRZNUM)
	        WRDEN=SQRT(WRDEN)
	       WRZDEN=SQRT(WRZDEN)
	        R=RNUM/RDEN
	   RZ=RZNUM/RZDEN
	        WR=WRNUM/WRDEN
	   WRZ=WRZNUM/WRZDEN
	WRITE (NTPB,00041)
	WRITE (NTPB,00042)RZNUM,RZDEN,RZ
	WRITE (NTPB,43)RNUM,RDEN,R
	WRITE (NTPB,00044)WRZNUM,WRZDEN,WRZ
	WRITE (NTPB,46)WRNUM,WRDEN,WR
C        BY-PASS MATRIX INVERSION AND PARAMETER OUTPUT ON FINAL CYCLE
	   IF(IC-NCY)05401,08701,08701
C           START LOOP TO TEST FOR ZERO DIAGONAL ELEMENT
05401	       ISING=0
	      II=NM
	      IID=NV
	      DO 05801 I=1,NV
	         IF(AM(II))05701,05601,05701
05601	             ISING=1
	     WRITE (NTPB,00083)I
05701	          II=II-IID
	         IID=IID-1
05801	          CONTINUE
C              END LOOP TO TEST FOR ZERO DIAGONAL ELEMENT
C           TERMINATE JOB IF ZERO DIAGONAL ELEMENT WAS FOUND
	IF  ( ISING )  8701,  6001,  8701
C              ENTER SUBROUTINE TO REPLACE MATRIX WITH INVERSE
06001	          CALL SMI(AM( 1),NV,ISING)
	         IF(ISING)06201,06301,06201
C                 TERMINATE JOB IF SINGULAR MATRIX WAS FOUND
06201	      WRITE (NTPB,00085)
	        GO TO 8701
C                 START LOOP FOR MATRIX VECTOR MULTIPLICATION FOR
C                                               PARAMETER CHANGES
06301	             DO 07201 I=1,NV
	               PDI=0.0
	               IJ=NM-I+1
	               IJD=NV-1
	               DO 07001 J=1,NV
	                  PDI=PDI+AM(IJ)*V(J)
	                  IF(J-I)06701,06801,06901
06701	                      IJ=IJ-IJD
	                     IJD=IJD-1
	                     GO TO 07001
C                          SAVE DIAGONAL ELEMENTS OF INVERSE MATRIX
06801	                      DIAG(I)=AM(IJ)
06901	                      IJ=IJ-1
07001	                      CONTINUE
	DV(I)=PDI
	               SIG=SIG-PDI*V(I)
07201	                CONTINUE
C                    END LOOP FOR MATRIX VECTOR MULTIPLICATION
C                 RECOMPUTE AGREEMENT FACTOR USING MODIFIED SIG
	RZ=SQRT(SIG/FLOAT(NO-NV))
C                 PUT OUT CAPTION FOR LIST OF CORRECTED PARAMETERS
	WRITE (NTPB,00052)(TITLE(I),I=1,12)
	WRITE (NTPB,00086)IC
C     PRESERVE THE CURRENT TEMP. FACTOR VALUES
	DO  7202  I=1,NA
	DO  7202  J=1,6
7202	DBDB(J,I)=BETA(J,I)
C                 START LOOP TO CORRECT AND PUT OUT PARAMETERS
	            J=1
	            N=1
	NQA=NQ-2
	            DO 08001 I=1,NP
	POLD=P(I)
C                    SET K TO SELECT APPROPRIATE LABEL
	IF  ( I-NQ )  7452,  7452,  7456
07452	                   K=1
	POLD=1.0/P(I)
	                  GO TO 07501
7456	K=I-NQA
	IF  ( BETA(2,N) )  7457,  7457,  7461
7457	 IF  ( K-8 )  7462,  7459,  7459
7459	             K=14
	        NQA=NQA+6
7453	        N=N+1
	             GO TO 7501
7461	 IF  ( K-13 )  7462,  7455,  7455
7455	NQA=NQA+11
	        GO TO 7453
7462	IF  ( K-3 )  7501,  7463,  7501
07463	       WRITE (NTPB,00078)ATOM(N)
C                    TEST KEY INTEGERS
07501	                IF(KI(I))07601,07601,07701
7601	WRITE (NTPB,88)(ABEL(L,K),L=1,2),POLD,POLD
	                  GO TO 08001
7701	   SIGP=SQRT(DIAG(J))*SQSIG
	  IF  (K-1)  7702,  7703,  7702
7702	   PNEW=P(I)+DV(J)
	    PSHFT=DV(J)
	GO TO 7704
7703	       PSHFT=-DV(J)/((P(I)+DV(J))*P(I))
	       PNEW=POLD+PSHFT
	SIGP=SIGP*PNEW*PNEW
7704	 P(I)=P(I)+DV(J)
	WRITE (NTPB,89)(ABEL(L,K),L=1,2),POLD,PSHFT,PNEW,SIGP
	                  J=J+1
08001	                CONTINUE
C                    END LOOP TO CORRECT AND PUT OUT PARAMETERS
C                 PUT OUT ESTIMATED AGREEMENT FACTORS
	WRITE (NTPB,81)IC,SIG,RZ
C                 ENTER SUBROUTINE TO TEST PARAMETERS
	ISTOP=0
	CALL TEST ( DBDB(1,1))
	                  NT=NTPF
C     PUNCH OUT PROPER SCALE FACTORS(INVERTED)
	           DO  8205  I=1,NQ
8205	                       DV(I)=1.0/SC(I)
	     WRITE (NT,31)(DV(I),I=1,NQ)
	               DO 08209 I=1,NA
	        IF  (I-NAS )  8207,  8207,  8206
8207	WRITE (NT,33)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3),             FMA
	1(I),FMB(I)
	             GO TO 8209
8206	 WRITE (NT,33)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3)
8209	   WRITE (NT,31)(BETA(K,I),K=1,6)
	IF ( SQSGO )  8303,  8302,  8303
8303	IF ( SQSGO-SQSIG )  8304,  8302,  8302
8304	ISTOP=2
08401	                   WRITE (NTPB,00090)ISTOP
	               GO TO 08701
C                 TERMINATE JOB IF INDICATED BY USERS SUBROUTINE TEST
8302	IF ( ISTP )  8301,  8301,  8402
8301	IF ( ISTOP )  8401,  8402,  8401
8402	IF  ( IC-NCY+1 )  8501,  8403,  8403
8403	GO TO ( 8501, 8404, 8404, 8501 ), NR
08501	                CONTINUE
C                    END LOOP THROUGH NC CYCLES AND FINAL CALC OF Y
8701	IGOTO = 1
	RETURN
C     GO BACK TO THE PART 1 AND RECYCLE
8404	IGOTO = 0
	RETURN
	END
	SUBROUTINE  CALC(H,Y,AKEEP,BKEEP)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     CALCULATE STRUCTURE FACTOR AND DERIVATIVES FOR ONE REFLECTION
C     CORRECTION FOR ANORMALOUS DISPERSION
C          NX(MAX)=4, NF(MAX)=10, NS(MAX)=24, NQ(MAX)=20
	DIMENSION  PRCP(6),TITLE(12),ABEL(2,14)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  FMA(10),FMB(10)
	DIMENSION  X(4),IHKL(4),HJ(3),HHJ(6)
	DIMENSION  FM(10)
	DIMENSION  H(4),SS(3),SSS(6)
	DIMENSION  SC(20)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  V(181),DV(181)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  DADFI(85),DBDFI(85),DADAI(85),DBDAI(85)
	DIMENSION  DADX(3,85),DBDX(3,85),DADB(6,85),DBDB(6,85)
	DIMENSION  P(811),KI(811)
	DIMENSION  DFDS(20)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB    , X      , SQSIG
	COMMON  NCY    , IC     , SIG    , YC     , YO     , SIGYO
	COMMON  IHKL   , TJ     , HX     , HHB    , EXPIJ  , COSIJ
	COMMON  SINIJ  , A      , B      , RHO    , SINTHL , FTA
	COMMON  FTACOS , FTASIN , TFI    , PIFI   , IQ     , SQTO
	COMMON  SQRTAB , F      , DFDTO  , CA     , CB     , V
	COMMON  DV     , HJ     , HHJ    , FM     , DADFI  , DBDFI
	COMMON  DADAI  , DBDAI  , DADX   , DBDX   , DADB   , DBDB
	COMMON  DFDS
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
C     COMPUTE REQUIRED SUMS OVER NS SYMMETRY TRANSFORMATIONS
C                                         FOR EACH OF NA ATOMS
C     TO CORRECT THE MULTIPLICITY OF SF FOR ANOMALOUS CASE
	AMULT=1.0
	IF  ( ICENT-1 )  3,  1,  3
1	IF  ( NAS )  2,  3,  2
2	AMULT=2.0
C     CLEAR STORAGE ARRAYS
3	DO 109 I=1,NA
	   DADFI(I)=0.0
	   DBDFI(I)=0.0
	     DBDAI(I)=0.0
	   DO 106 K=1,3
	      DADX(K,I)=0.0
106	      DBDX(K,I)=0.0
	   DO 109 K=1,6
	      DADB(K,I)=0.0
109	      DBDB(K,I)=0.0
C     START LOOP THROUGH THE NS SYMMETRY TRANSFORMATIONS
	DO 2301 J=1,NS
C        STORE TRANSFORMED INDICES
	   TJ=0.0
	   DO 316 I=1,3
	      TJ=TJ+H(I)*TS(I,J)
	      HJ(I)=0.0
	      DO 315 K=1,3
	         DO 314 L=1,2
	            M=IS(L,K,J)
	            IF(M-I)312,311,312
311	               HJ(I)=HJ(I)+H(K)
	               GO TO 314
312	            IF(M+I)314,313,314
313	               HJ(I)=HJ(I)-H(K)
314	            CONTINUE
315	         CONTINUE
316	      CONTINUE
C        COMPUTE PRODUCTS OF TRANSFORMED INDICES
	   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        START LOOP THROUGH THE NA ATOMS
	   DO 2201 I=1,NA
	JRF=KATM(I)
C           ENTER USERS SUBROUTINE TO SET INDICES FOR SPECIAL POSITIONS
	      CALL PATCH(I,TJ,HJ(1),HHJ(1))
C           COMPUTE TRIGONOMETRIC TERMS
	      HX=TJ
	      DO 603 K=1,3
603	         HX=HX+HJ(K)*XYZ(K,I)
	        COSIJ=COS(6.283185  *HX)
	        SINIJ=SIN(6.283185  *HX)
C           COMPUTE ANISOTROPIC TEMPERATURE FACTOR
	ITFB=1
	IF  ( BETA(2,I) )  901,  901,  801
801	ITFB=2
	HHB=0.0
	         DO 803 K=1,6
803	            HHB=HHB+HHJ(K)*BETA(K,I)
	             EXPIJ=EXP(-HHB)
	         COSIJ=COSIJ*EXPIJ
	         SINIJ=SINIJ*EXPIJ
C           ACCUMULATE REQUIRED SUMS
901	      DADFI(I)=DADFI(I)+COSIJ
	GO TO ( 1501, 320, 321, 320 ), JRF
320	DO  1101  K=1,3
1101	         DADX(K,I)=DADX(K,I)+HJ(K)*SINIJ
	GO TO ( 1501, 1501, 321, 321 ), JRF
321	GO TO ( 1501, 1301 ), ITFB
1301	         DO 1401 K=1,6
1401	            DADB(K,I)=DADB(K,I)+HHJ(K)*COSIJ
C           BYPASS REMAINING SUMS IF CENTROSYMMETRIC
1501	IF  ( ICENT-1 )  2201,  2201,  1601
1601	      DBDFI(I)=DBDFI(I)+SINIJ
	GO TO ( 2201, 322, 323, 322 ), JRF
322	DO  1801  K=1,3
1801	         DBDX(K,I)=DBDX(K,I)+HJ(K)*COSIJ
	GO TO ( 2201, 2201, 323, 323 ), JRF
323	GO TO ( 2201, 2001 ), ITFB
2001	         DO 2101 K=1,6
2101	            DBDB(K,I)=DBDB(K,I)+HHJ(K)*SINIJ
2201	      CONTINUE
C           END LOOP THROUGH THE NA ATOMS
2301	   CONTINUE
C        END LOOP THROUGH THE NS SYMMETRY TRANSFORMATIONS
C     COMPUTE A AND B AND THEIR DERIVATIVES
	IF  ( NPT )  240,  240,  241
240	A=0.0
	B=0.0
	AKEEP=0.0
	BKEEP=0.0
	GO TO 242
C     IF PARTIAL STRUCTURE TO BE ADDED
241	AKEEP=A
	BKEEP=B
242	IF  ( NF )  2701,  2801,  2701
2701	     SINTHL=SQRT(RHO)
C     START LOOP THROUGH NA ATOMS
2801	DO 5201 I=1,NA
	JRF=KATM(I)
C        OBTAIN SCATTERING FACTOR
	ITFB=1
	RFI=0.0
	FI1=0.0
	IF  (NF)  3101,  3001,  3101
3001	    FI=SF(I)
	      GO TO 3201
3101	     L=SF(I)
	          FI=FM(L)
	IF ( NAS-I)  3201,  100,  100
100	   FI1=FMA(I)
	             RFI=FMB(I)
C        COMPUTE ISOTROPIC TEMPERATURE FACTOR
3201	IF  ( BETA(2,I) )  3401,  3401,  3203
3203	ITFB=2
	    TFI=1.0
	      GO TO 3501
3401	             TFI=EXP(-BETA(1,I)*RHO)
C        COMPUTE A AND ITS DERIVATIVES
3501	FTAT=FI*TFI*AI(I)
	AKEEP=FTAT*DADFI(I)+AKEEP
	BKEEP=FTAT*DBDFI(I)+BKEEP
	FI=FI+FI1
	FTA=FI*TFI*AI(I)
	RFTA=RFI*TFI*AI(I)
	FTACOS=FTA*DADFI(I)-RFTA*DBDFI(I)
	   A=A+FTACOS
	  S1=DADFI(I)
	DADAI(I)=TFI*(FI*DADFI(I)-RFI*DBDFI(I))
	   DADFI(I)=AI(I)*TFI*DADFI(I)
	GO TO ( 4301, 325, 326, 325 ), JRF
325	PIFI=-6.28318531*FTA
	RPIFI=PIFI*RFTA/FTA
	   DO 3801 K=1,3
	SS(K)=DADX(K,I)
3801	DADX(K,I)=PIFI*DADX(K,I)+RPIFI*DBDX(K,I)
	GO TO ( 4301, 4301, 326, 326 ), JRF
326	GO TO ( 4201, 4001 ), ITFB
4001	      DO 4101 K=1,6
	SSS(K)=DADB(K,I)
4101	DADB(K,I)=-FTA*DADB(K,I)+RFTA*DBDB(K,I)
	      GO TO 4301
4201	      DADB(1,I)=-RHO*FTACOS
C        COMPUTE B AND ITS DERIVATIVES UNLESS CENTROSYMMETRIC
4301	IF  ( ICENT-1)  4302,  4302,  4401
4302	IF  ( NAS-I )  5201,  4401,  4401
4401	FTASIN=FTA*DBDFI(I)+RFTA*S1
	   B=B+FTASIN
	DBDAI(I)=TFI*(FI*DBDFI(I)+RFI*S1)
	   DBDFI(I)=AI(I)*TFI*DBDFI(I)
	GO TO ( 5201, 327, 328, 327 ), JRF
327	PIFI=-PIFI
	   DO 4701 K=1,3
4701	DBDX(K,I)=PIFI*DBDX(K,I)+RPIFI*SS(K)
	GO TO ( 5201, 5201, 328, 328 ), JRF
328	GO TO ( 5101, 4901 ), ITFB
4901	      DO 5001 K=1,6
5001	DBDB(K,I)=-FTA*DBDB(K,I)-RFTA*SSS(K)
	      GO TO 5201
5101	      DBDB(1,I)=-RHO*FTASIN
5201	   CONTINUE
C        END LOOP THROUGH NA ATOMS
C     CLEAR DERIVATIVES WITH RESPECT TO SCALE FACTORS
5301	DO 5302 I=1,NQ
5302	   DFDS(I)=0.0
C     COMPUTE SCALE FACTOR TIMES OVERALL TEMPERATURE FACTOR
	IQ=H(4)
	OVERT=AMULT
	SQTO=SC(IQ)*OVERT
	AKEEP=AKEEP*OVERT
	BKEEP=BKEEP*OVERT
	A1=A*OVERT
	B1=B*OVERT
C     CALCULATE F OR F**2 FOR CENTROSYMMETRIC OR NON-CENTROSYMMETRIC
C                                                           STRUCTURES
	IF(IFSQ-1)5601,5601,6001
5601	IF  ( ICENT-1 )  5702,  5702,  5801
5702	IF  ( NAS )  5701,  5701,  5801
5701	      CA=SIGN(2.0*SQTO,A)
	      CB=0.0
	      F=CA*A
	       A1=A1+A1
	    AKEEP=A1
	   Y=ABS(A1)
	      GO TO 5901
5801	             SQRTAB=SQRT(A**2+B**2)
	      F=SQTO*SQRTAB
	   Y=SQRT(A1*A1+B1*B1)
	      IF(SQRTAB)5807,5804,5807
5804	         CA=0.0
	         CB=0.0
	         GO TO 5901
5807	      CA=SQTO*A/SQRTAB
	      CB=SQTO*B/SQRTAB
5901	   DFDS(IQ)=F/SC(IQ)
	   GO TO 6501
6001	   SQTO=SQTO**2
	IF ( ICENT-1 )  6202,  6202,  6301
6202	IF  ( NAS )  6201,  6201,  6301
6201	      CA=8.0*SQTO*A
	      CB=0.0
	      F=CA*A/2.0
	   A1=A1+A1
	    AKEEP=A1
	   Y=A1*A1
	      GO TO 6401
6301	      F=SQTO*(A**2+B**2)
	      CA=2.0*SQTO*A
	      CB=2.0*SQTO*B
	   Y=A1*A1+B1*B1
6401	   DFDS(IQ)=2.0*F/SC(IQ)
6501	 A=A1
	    B=B1
C     COMPUTE DERIVATIVES OF F OR F**2
C     START LOOP THROUGH NA ATOMS
	IF  ( IC-NCY)  7010,  7011,  7011
7010	DO  7501  I=1,NA
	JRF=KATM(I)
	DADFI(I)=CA*DADFI(I)+CB*DBDFI(I)
	DADAI(I)=CA*DADAI(I)+CB*DBDAI(I)
	GO TO ( 7501, 330, 331, 330 ), JRF
330	DO  7001  K=1,3
7001	DADX(K,I)=CA*DADX(K,I)+CB*DBDX(K,I)
	GO TO ( 7501, 7501, 331, 331 ), JRF
331	IF  ( BETA(2,I) )  7201,  7201,  7301
7201	DADB(1,I)=CA*DADB(1,I)+CB*DBDB(1,I)
	      GO TO 7501
7301	      DO 7401 K=1,6
7401	DADB(K,I)=CA*DADB(K,I)+CB*DBDB(K,I)
7501	   CONTINUE
C        END LOOP THROUGH NA ATOMS
7011	RETURN
	END
	SUBROUTINE SBTOP (P,SC,SF,AI,XYZ,BETA,DADB,NA,NQ)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     COPY DERIVATIVES FROM CALC TO ARRAY DC
	DIMENSION  P(691),SC(20),SF(65),AI(65),XYZ(3,65),BETA(6,65)
	DIMENSION  DADB(6,65)
	DO  40  J=1,NQ
40	P(J)=SC(J)
	I=NQ+1
	DO  220  J=1,NA
	P(I)=SF(J)
	P(I+1)=AI(J)
	I=I+2
	DO  130  K=1,3
	P(I)=XYZ(K,J)
130	I=I+1
C     TEST THE TEMPERATURE PARAMETER
	IF ( DADB(2,J) )  150,  150,  151
150	P(I)=BETA(1,J)
	I=I+1
	GO TO  220
151	DO  210  K=1,6
	P(I)=BETA(K,J)
210	I=I+1
220	CONTINUE
	RETURN
	END
	SUBROUTINE PTOSB (P,SC,SF,AI,XYZ,BETA,NA,NQ)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     COPY PARAMETERS FROM ARRAY P TO ARRAYS USED BY SUBROUTINES
	DIMENSION  P(691),SC(20),SF(65),AI(65),XYZ(3,65),BETA(6,65)
	DO  40  J=1,NQ
40	SC(J)=P(J)
	I=NQ+1
	DO  220  J=1,NA
	SF(J)=P(I)
	AI(J)=P(I+1)
	I=I+2
	DO  130  K=1,3
	XYZ(K,J)=P(I)
130	I=I+1
	IF  ( BETA(2,J) )  150,  150,  151
150	BETA(1,J)=P(I)
	I=I+1
	GO TO 220
151	DO  210  K=1,6
	BETA(K,J)=P(I)
210	I=I+1
220	CONTINUE
	RETURN
	END
	SUBROUTINE DTOD
C     SUBROUTINE TO STORE THE DERIVATIVES IN DV
	DIMENSION  PRCP(6),TITLE(12), ABEL(2,14)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  FM(10)
	DIMENSION  FMA(10),FMB(10)
	DIMENSION  X(4),IHKL(4),HJ(3),HHJ(6)
	DIMENSION  SC(20)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  V(181),DV(181)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  DADFI(85),DBDFI(85),DADAI(85),DBDAI(85)
	DIMENSION  DADX(3,85),DBDX(3,85),DADB(6,85),DBDB(6,85)
	DIMENSION  P(811),KI(811)
	DIMENSION  DFDS(20)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB    , X      , SQSIG
	COMMON  NCY    , IC     , SIG    , YC     , YO     , SIGYO
	COMMON  IHKL   , TJ     , HX     , HHB    , EXPIJ  , COSIJ
	COMMON  SINIJ  , A      , B      , RHO    , SINTHL , FTA
	COMMON  FTACOS , FTASIN , TFI    , PIFI   , IQ     , SQTO
	COMMON  SQRTAB , F      , DFDTO  , CA     , CB     , V
	COMMON  DV     , HJ     , HHJ    , FM     , DADFI  , DBDFI
	COMMON  DADAI  , DBDAI  , DADX   , DBDX   , DADB   , DBDB
	COMMON  DFDS
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
	I1=1
	DO  20  I=1,NQ
	IF  ( KI(I) )  20,  20,  19
19	DV(I1)=DFDS(I)
	I1=I1+1
20	CONTINUE
	I2=NQ+1
	DO  30  I=1,NA
	IF  ( KI(I2) )  22,  22,  21
21	DV(I1)=DADFI(I)
	I1=I1+1
22	IF  ( KI(I2+1) )  24,  24,  23
23	DV(I1)=DADAI(I)
	I1=I1+1
24	I2=I2+2
	DO  40  K=1,3
	IF  ( KI(I2) )  40,  40,  41
41	DV(I1)=DADX(K,I)
	I1=I1+1
40	I2=I2+1
	IF  ( BETA(2,I) )  42,  42,  45
42	IF  ( KI(I2) )  43,  43,  44
44	DV(I1)=DADB(1,I)
	I1=I1+1
43	I2=I2+1
	GO TO 30
45	DO  49  K=1,6
	IF  ( KI(I2) )  49,  49,  46
46	DV(I1)=DADB(K,I)
	I1=I1+1
49	I2=I2+1
30	CONTINUE
	RETURN
	END
	SUBROUTINE TEST (DBDB)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     TEST FOR NON-POSITIVE-DEFINITE TEMPERATURE FACTORS
	DIMENSION  PRCP(6),TITLE(12),ABEL(2,14)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  SC(20)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  FMA(10),FMB(10)
	DIMENSION  P(811),KI(811)
	DIMENSION  DBDB(6,85)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
200	   FORMAT(28H0TEMPERATURE FACTOR OF ATOM I2,25H IS NOT POSITIVE-DE
	1FINITE)
C     STORE ADJUSTED PARAMETERS IN VARIOUS ARRAYS
	CALL PTOSB (P(1),SC(1),SF(1),AI(1),XYZ(1,1),BETA(1,1),NA,NQ)
C     ENTER USERS SUBROUTINE TO RESET SYMMETRY-RELATED COORDINATES
	CALL RESETX(XYZ(1,1))
C     ENTER USERS SUBROUTINE TO RESET SYMMETRY-RELATED ANISOTROPIC
C                                    TEMPERATURE FACTOR COEFFICIENTS
	CALL RESETB(BETA(1,1))
C     START LOOP THROUGH NA ATOMS
60	DO 220 I=1,NA
	IF ( BETA(2,I) )  130,  90,  130
C     ISOTROPIC TEMPERATURE FACTOR
90	IF ( BETA(1,I) )  91,  220,  220
C     SET B POSITIVE
91	BETA(1,I)=0.001
	GO TO 191
C           TEST ANISOTROPIC TEMPERATURE FACTOR COEFFICIENTS
130	      DO 145 K=1,3
140	         IF(BETA(K,I))190,145,145
145	         CONTINUE
150	      IF(BETA(1,I)*BETA(2,I)-BETA(4,I)**2)190,160,160
160	      IF(BETA(1,I)*BETA(3,I)-BETA(5,I)**2)190,170,170
170	      IF(BETA(2,I)*BETA(3,I)-BETA(6,I)**2)190,180,180
180	      IF(BETA(1,I)*BETA(2,I)*BETA(3,I)
	1      +(BETA(4,I)*BETA(5,I)*BETA(6,I))*2.0
	2      -BETA(1,I)*BETA(6,I)**2-BETA(2,I)*BETA(5,I)**2
	3      -BETA(3,I)*BETA(4,I)**2)190,220,220
190	DO  192  K=1,6
192	BETA(K,I)=DBDB(K,I)
C        PUT OUT ERROR STATEMENT
191	WRITE (NTPB,200)I
	ISTOP=1
220	   CONTINUE
C        END LOOP THROUGH NA ATOMS
C     COPY PARAMETERS INTO THE ARRAY P
	CALL SBTOP(P(1),SC(1),SF(1),AI(1),XYZ(1,1),BETA(1,1),BETA(1,1),NA,
	1NQ)
	RETURN
	END
	SUBROUTINE PATCH(I,TJ,HJ,HHJ)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     DUMMY SUBROUTINE TO BE REPLACED BY USER IF NECESSARY
	RETURN
	END
	SUBROUTINE RESETX(XYZ)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     DUMMY SUBROUTINE TO BE REPLACED BY USER IF NECESSARY
	RETURN
	END
	SUBROUTINE RESETB(BETA)
C     OR FLS, FORTRAN CRYSTALLOGRAPHIC LEAST SQUARES
C     DUMMY SUBROUTINE TO BE REPLACED BY USER IF NECESSARY
	RETURN
	END
	SUBROUTINE RSETW(FO,FC,A,B,SIGFO,SINT,IUN,IC,NCY,NPRN)
C  SUBROUTINE RESETW EXCLULES ALL UNOBSERVED REFLECTIONS, FOR WHICH
C  FC .LE. FO, FROM REFINEMENT.  I.E.  THE INPUT FO FOR UNOBSERVED
C  REFLECTIONS SHOULD BE THE OBSERVATIONAL THRESHOLD.  THUS IF  FC .GT.
C  FO  IT DISAGREES WITH THE OBSERVATION AND SHOULD BE REFINED .  IF
C  FC .LE. FO IT AGREES WITH THE OBSERVATION AND NOTHING FUTHER CAN BE
C  SAID SO IT IS EXCLUDED FROM REFINEMENT  (SIG IS SET TO 0.0)
C
C        FOBS AT THIS POINT HAS BEEN ALREADY SCALED. FCAL IS TRUE VALUE
C
	IF( IUN ) 30,30,5
5	IF(FO-FC) 10,20,20
10	IF( IC- NCY )11,12,12
11	IF( NPRN )12,12,16
12	PRINT 15
15	FORMAT(1X,' ***** INCLUDED IN REFINEMENT *****')
16	RETURN
20	IF( IC - NCY )21,22,22
21	IF ( NPRN ) 22,22,26
22	PRINT 25
25	FORMAT(10X' EXCLUDED')
26	SIGFO=0.0
30	RETURN
	END
	SUBROUTINE SMI(AM,N,NFAIL)
	DIMENSION  AM(1)
	IWN = (N*(N + 1))/2 + 1
	K = IWN - 1
	IF(N-1)10,8,9
8	AM(1)=1.0/AM(1)
	GO TO 204
9	DO 7 M=1,N
	IMAX=M-1
	DO 6 L=M,N
	SUMA= 0.0
	KLI=IWN-L
	KMI=IWN-M
	IF(IMAX)23,23,1
1	DO2 I=1,IMAX
	SUMA = SUMA + AM(KLI)*AM(KMI)
	J = N - I
	KLI=KLI - J
2	KMI = KMI - J
23	TERM = AM(K) - SUMA
	IF(L-M)3,3,5
3	IF(TERM)10,10,4
4	DENOM=SQRT (TERM)
	AM(K)=DENOM
	GO TO 6
10	NFAIL = IWN - K
	GO TO 300
5	AM(K) = TERM/DENOM
6	K = K - 1
7	CONTINUE
100	AM(IWN-1)=1.0/AM(IWN-1)
	KDM=IWN-1
	DO 104 L=2,N
	KDM=KDM-N+L-2
	TERM=1.0/AM(KDM)
	AM(KDM)=TERM
	KMI=IWN
	KLI=IWN - L
	IMAX = L - 1
	DO 103 M = 1,IMAX
	K = KLI
	SUMA = 0.0
	DO 102 I=M,IMAX
	II = KMI - I
	SUMA = SUMA - AM(KLI)*AM(II)
102	KLI=KLI - N + I
	AM(K)=SUMA * TERM
	J = N - M
	KLI = K - J
103	KMI = KMI - J
104	CONTINUE
200	K = IWN - 1
	DO 203 M = 1,N
	KLI = K
	DO 202 L=M,N
	KMI = K
	IMAX = N - L + 1
	SUMA = 0.0
	DO 201 I= 1,IMAX
	SUMA = SUMA + AM(KLI) * AM(KMI)
	KLI = KLI - 1
201	KMI = KMI - 1
	AM(K) = SUMA
202	K = K - 1
203	CONTINUE
204	NFAIL = 0
300	RETURN
	END
	SUBROUTINE LINK3
C     TERMINATE JOB AND PRINT OUT VARIOUS STATISTICS
C          NX(MAX)=4, NF(MAX)=10, NS(MAX)=24, NQ(MAX)=20
	DIMENSION  PRCP(6),TITLE(12),ABEL(2,14)
	DIMENSION  TS(3,24),IS(2,3,24)
	DIMENSION  DIAG(181),AM(16652)
	DIMENSION  P(811),KI(811)
	DIMENSION  ATOM(85),SF(85),AI(85),XYZ(3,85),BETA(6,85),KATM(85)
	DIMENSION  FMA(10),FMB(10),X(4),SC(20)
	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  ROW(200),DUMMY(2,3)
	COMMON  NTPA   , NTPB   , NTPC   , NTPD   , NTPE   , NTPF
	COMMON  NTPG   , NC     , NA     , NQ     , ITF    , NV
	COMMON  NAS    , NPT    , NPRN   , NR     , NRW    , NF
	COMMON  ICENT  , NS     , IFSQ   , IXFE   , NP     , NM
	COMMON  NX     , ISING  , ISTOP  , PRCP
	COMMON  P      , KI     , AM     , DIAG   , TO
	COMMON  SC     , SF     , AI     , XYZ    , BETA   , TS
	COMMON  IS     , KATM   , FMA    , FMB    , X      , SQSIG
	COMMON  NCY    , IC     , SIG    , YC     , YO     , SIGYO
	COMMON  IHKL   , TJ     , HX     , HHB
	COMMON /BLOCK/ TITLE,ABEL,ATOM
	DOUBLE PRECISION TITLE, ABEL, ATOM
26	FORMAT ( 8F9.4 )
27	FORMAT ( 6E12.6 )
52	FORMAT (1H112A6)
53	FORMAT (24I3)
70	FORMAT (72I1)
00071	 FORMAT(10F12.8)
00097	 FORMAT(19H0CORRELATION MATRIX)
98	FORMAT (1H0I3,13F9.4/(1H 3X,13F9.4))
99	FORMAT(1X,8E15.8)
10	FORMAT (1H0,14HNO. REFLEXIONS,7X 11I9 )
11	FORMAT ( 1H0,14HAVER. W*DELTSQ, 7X  11F9.3 /  )
12	FORMAT (// 1H0,13HF VALUE UP TO, 14X3H10.,6X3H20.,6X3H30.,6X3H40.,
	1  6X3H50.,6X3H60.,6X3H70.,6X3H80.,6X3H90.,5X4H100.,9H OVER 100 / )
13	FORMAT (// 1H0,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  /     )
20	FORMAT ( 1H1, 37HDISAGREEMENT INDEX FOR VARIOUS GROUPS    /   )
21	FORMAT ( 1H0,27X3HHKL,6X3HHK0,6X3H0KL,6X3HH0L,6X3HH00,6X3H0K0,
	1   6X3H00L,6X3HALL  /   )
23	FORMAT ( 1H0, 8HR FACTOR  ,  13X 10F9.3  /  )
24	FORMAT (/1H0, 27X 3HEEE,6X3HEEO,6X3HEOE,6X3HOEE,6X3HEOO,6X3HOEO,
	1    6X3HOOE,6X3HOOO    /    )
25	FORMAT (/1H0,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  //  )
28	FORMAT (//1H0,11HOUTPUT TAPE I4,30H HAS BEEN COPIED ON INPUT TAPE
	1  I4/ )
C     IF STRUCTURE FACTORS ONLY
	IF  ( NC )  11701,  11701,  101
C  IF ZERO DIAGONAL OR SINGULAR MATRIX IS FOUND, PRINT OUT THE ELEMENTS
101	IF  ( ISING )  8800,  8801,  8800
8800	WRITE (NTPB,00099)( AM(I),I=1,NM )
	     GO TO 11701
C        CALCULATE AND PUT OUT CORRELATION MATRIX
08801	    WRITE (NTPB,00052)(TITLE(I),I=1,12)
	      WRITE (NTPB,00097)
	   DO 09101 I=1,NV
	        DIAG(I)=1.0/SQRT(DIAG(I))
09101	       CONTINUE
	   IJ=NM
	   DO 10201 I=1,NV
	      DO 09601 J=1,NV
	         ROW(J)=0.0
09601	          CONTINUE
	      DO 10001 J=I,NV
	         ROW(J)=AM(IJ)*DIAG(I)*DIAG(J)
	         IJ=IJ-1
10001	          CONTINUE
	WRITE (NTPB,98)I,(ROW(J),J=I,NV)
10201	       CONTINUE
C     WRITE DATA REQUIRED FOR FUNCTION AND ERROR PROGRAM
10501	 IF  ( IXFE-1 )  11701,  123,  122
123	WRITE (NTPC,53)ITF,NQ,NP
	WRITE (NTPC,71)(P(I),I=1,NP )
	WRITE (NTPC,70)(KI(I),I=1,NP )
	WRITE (NTPC,53)NV
	GO TO 124
C     PUNCH CARDS FOR ORFFE
122	WRITE (NTPF,26)( P(I),I=1,NP )
	WRITE (NTPF,70)(KI(I),I=1,NP )
124	VARI=SQSIG*SQSIG
	   DO 10703 I=1,NM
10703	       AM(I)=AM(I)*VARI
	   K=NM/2
	   DO 11201 I=1,K
	      HOLD=AM(I)
	      AM(I)=AM(L)
	      AM(L)=HOLD
	      L=L-1
11201	       CONTINUE
	IF  ( IXFE-1 )  125,  125,  126
125	WRITE (NTPC,99)( AM(I),I=1,NM )
	END FILE NTPC
	GO TO 11701
126	WRITE (NTPF,27)( AM(I),I=1,NM )
C   READ FIRST RECORD FROM DATA TAPE
11701	 REWIND NTPE
	READ(NTPE)(PRCP (I),I=1,6),A,B,C,COSA,COSB,COSC
C  WRITE OUTPUT FOR PROGRAM ANGLE ON FILE NTPC
	IF( IXFE.GE.0) GO TO 2000
	WRITE(NTPC)A,B,C,COSA,COSB,COSC
	WRITE(NTPC)NS
	DO 910 J=1,NS
	DO 900 K=1,2
	DO 900 I=1,3
900	DUMMY(K,I)=IS(K,I,J)
910	WRITE(NTPC)(TS(I,J),(DUMMY(K,I),K=1,2),I=1,3)
	N = 1
	NQA = NQ + 3
	NVA = NQ
	IF(KI(NQA-2).NE.0) NVA = NVA + 1
	IF(KI(NQA-1).NE.0) NVA = NVA + 1
1000	IF(KI(NQA))1001,1001,1002
1001	SIGX = 0.0
	GO TO 1003
1002	NVA = NVA + 1
	SIGX = SQSIG / DIAG(NVA)
1003	NQA = NQA + 1
	IF(KI(NQA))1004,1004,1005
1004	SIGY = 0.0
	GO TO 1006
1005	NVA = NVA + 1
	SIGY = SQSIG / DIAG(NVA)
1006	NQA = NQA + 1
	IF(KI(NQA))1007,1007,1008
1007	SIGZ = 0.0
	GO TO 1009
1008	NVA = NVA + 1
	SIGZ = SQSIG / DIAG(NVA)
1009	WRITE(NTPC)     ATOM(N),P(NQA-2),SIGX,P(NQA-1),SIGY,P(NQA),SIGZ
	IF( BETA(2,N)) 1030,1020,1030
1020	II = 3
	GO TO 1040
1030	II = 8
1040	N = N + 1
	DO 1045 I = 1,II
	IF ( KI(NQA + I) .EQ. 1 ) NVA = NVA + 1
1045	CONTINUE
	NQA = NQA + II + 1
	IF( NQA - NP )1000,1050,1050
1050	END FILE NTPC
	REWIND NTPC
C
2000	DO  110 I=1,11
	NHKL(I)=0
	DHKL(I)=0.0
	SHKL(I)=0.0
	NHKLS(I)=0
	DHKLS(I)=0.0
	SHKLS(I)=0.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
111	READ  (NTPE)(X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO,
	1    SINT
	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)
	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  ( SINT-DSIN )  132,  132,  131
131	SINT=SINT-DSIN
132	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
C     IF STRUCTURE FACTORS ONLY
166	IF  ( NC )  112,  111,  112
112	IF  ( SIGYO )  118,  114,  118
114	WDELT=0.0
	GO TO 121
118	WDELT=((YO-YC)*SC(IQ)/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	REWIND NTPE
	WRITE (NTPB,20)
	WRITE (NTPB,13)
	DO  174  I=1,10
	IF  ( SHKLS(I) )  174,  174,  175
175	SHKLS(I)=DHKLS(I)/SHKLS(I)
174	CONTINUE
	WRITE (NTPB,10)(NHKLS(I), I=1,10 )
	WRITE (NTPB,23)( SHKLS(I), I=1,10 )
	WRITE (NTPB,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 (NTPB,10)( NHKL(I), I=1,8 )
	WRITE (NTPB,23)( DHKL(I), I=1,8 )
	WRITE (NTPB,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 (NTPB,10)( NKLS(I), I=1,8 )
	WRITE (NTPB,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 (NTPB,25)SUM1,SUM2,SCL1,SUM3,SUM4,SCL2
	IF  ( NC )  207,  208,  207
207	WRITE (NTPB,12)
	DO  140  I=1,11
	IF  ( MOBS(I) )  141,  140,  141
141	FNUMB=MOBS(I)
	WDOBS(I)=WDOBS(I)/FNUMB
140	CONTINUE
	WRITE (NTPB,10)(MOBS(I),I=1,11)
	WRITE (NTPB,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 (NTPB,10)( MUNO(I), I=1,11 )
	WRITE (NTPB,11)( WDUNO(I), I=1,11 )
	WRITE (NTPB,13)
	DO  144  I=1,10
	IF  ( MOSN(I) )  145,  144,  145
145	FNUMB=MOSN(I)
	WDOS(I)=WDOS(I)/FNUMB
144	CONTINUE
	WRITE (NTPB,10)( MOSN(I), I=1,10 )
	WRITE (NTPB,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 (NTPB,10)( MUSN(I), I=1,10 )
	WRITE (NTPB,11)( WDUS(I), I=1,10 )
C     COPY BACK THE FINAL OUTPUT ONTO THE INPUT TAPE 10
208	IF  ( NRW )  210,  210,  209
209	REWIND NTPG
	READ  (NTPE)(PRCP(I),I=1,6),AA,BB,CC,COSA,COSB,COSC,WAVE
	WRITE (NTPG)(PRCP(I),I=1,6),AA,BB,CC,COSA,COSB,COSC,WAVE
211	READ  (NTPE)(ROW(I),I=1,26)
	WRITE (NTPG)(ROW(I),I=1,26)
	IF  ( ROW(1)-999.0 )  211,  212,  212
212	END FILE NTPG
	REWIND NTPG
	REWIND NTPE
	WRITE (NTPB,28)NTPE,NTPG
210	RETURN
	END
