C***********************************************************************
C
C********  LEAST SQUARES PROGRAM  ***********
C********  FULL MATRIX WITH BLOCK DIAGONAL OPTION
C
C	VERSION FOR VAX/780
C	1.MAI  1981
C     MUELHEIM/RUHR
C     MAX - PLANCK - INSTITUT FUER KOHLENFORSCHUNG    1980
C     X-RAY-LAB
C     *********
C	GROSSE VERSION VON FMLS
C	*********
C*******************************************************************
C	AM   99 000    
C
C	IBI ETWAS HOEHER ALS ATOM, USW. DIMENSIONIEREN
C	LVI       "
C	LPM       "
C	MORD      "
C
C     TAPE ASSIGNMENTS FROM OPERATOR  OR INPUT CARD 2
C
C     DIMENSIONS FOR 5 SCALE FACTORS, 149 ATOMS AND 1500 PARAMETERS
C     THE SECOND SCALE FACTOR IS AN EXTINCTION PARAMETER
C     AFTER LARSON, 1970
C     CALCULATES INTRAMOLECULAR DISTANCES
C     WRITES SD ON PARAMETER FILE
C     ZWBT, ZWBU, ZWBV, ZWBW, ZWBX(IOW), ZWBY(IOR), ZWBZ
C     ZWBU   INPUT TAPE FOR PARAMETERS
C     ZWBV   OUTPUT TAPE FOR PARAMETERS
C     ZWBT   INPUT TAPE FOR OBSERVATIONS
C     ZWBW   FOURIER OUTPUT TAPE
C     ZWBZ   SCRATCH TAPE
C***********************************************************************
	CHARACTER DATUM*9,ZEIT1*8,TITLE*72,ITEXT*20,ATOM(150)*8,DUMMI*5
	CHARACTER*4 LABEL(2,2,13)
	CHARACTER*5 DATIN,TAPEIN,FURAUS,TAPAUS,PARIN,PARAUS,PABAIN,PABAUS
	CHARACTER*8 ZYZEIT
	CHARACTER*70 WSCHEMA(-5:2)
	INTEGER ZWBV, ZWBW, ZWBX, ZWBY, ZWBZ, ZWBT,ZWBU
	INTEGER H
	INTEGER HH1,HH2,MM1,MM2,SS1,SS2
	REAL MM,MMNEU
	REAL KOSHIFT,ANSHIFT,ISSHIFT
	DIMENSION SC(5),DFDS(5)
	DIMENSION KB(150),ITF(150),SF(150),AI(150),XYZ(3,150)
	DIMENSION BETA(6,150),DADFI(150),DBDFI(150),DFDAI(150),DADX(3,150)
	DIMENSION DBDX(3,150),DFDX(3,150),DADB(6,150),DBDB(6,150),DFDB(6,150)
	DIMENSION IBI(160),LVI(160),LPM(160),NPM(150),MORD(160)
	DIMENSION P(1500),KI(1500),DC(1500),DV(1500),V(1500),PD(1500),
     *	DIAG(1500)
	DIMENSION AM(99000),W(1500),ROW(1500),FX(32,20),TS(3,24),FS(3,3,24)
	DIMENSION RCP(6),PRCP(6),ALPHA(6),DTO(7)
	DIMENSION IHKL(3),H(4),SDCOEF(6),HJ(3),HHJ(6)
	DIMENSION G1(3,3),G2(3,3),IH(1,1),OME(1,1),VM(1,1,1),IR(1,1)
	DIMENSION PM(1,1,1),SICO(1,1) ,JT(2,3),RM(1,1,1),XI(1,1)
	DIMENSION NAME(2,2),KIS(1),KBS(1),SP(1),DS(1),DEP(1)
	DIMENSION PDT(9),VD(150)
        DIMENSION DADFN(150),DBDFN(150),DADXN(3,150),DBDXN(3,150)
        DIMENSION DADBN(6,150),DBDBN(6,150)
	COMMON ISENT,FRAC,SC,DFDS,KB,ITF,SF,AI,XYZ,BETA,DADFI,DBDFI
	COMMON DFDAI,DADX,DBDX,DFDX,DADB,DBDB,DFDB,IBI,LVI,LPM,NPM,MORD
	COMMON P,KI,DC,DV,V,PD,DIAG,AM,W,ROW,FX,TS,FS
	COMMON RCP,PRCP,ALPHA,DTO,IHKL,H,SDCOEF,HJ,HHJ
	COMMON NC,NVO,NX,ID,IW,IP,IT,IFSQ,NF,NA,ICENT,NS,NQ,NV,NNA,NP,NO
	COMMON IC,NCY,NINC,IQ,ISING,ISTOP,SITETL,SINMIN
	COMMON TJ,HX,HHB,RHO,SINTHL,SQTO,A,B,FC,SQRTAB,FINC,DINC,YO,YC,DY
	COMMON SQRTW,WDY,SIG,SQSIG
	COMMON NAME,KIS,KBS,SP,DS,DEP,XI
	COMMON VOL,G1,G2,NMOL,NG,IH,OME,VM,PM,SICO,NT,IR,JT,RM
	COMMON ND,ZWBX,ZWBY,ZWBZ,ZWBT,ZWBU,ZWBV,ZWBW
	COMMON NKAS,FI1S(3),RFIS(3),FLAMDA,CONST,EXTAL,IWHSO,EXTN,IWBCD
        COMMON DADFN,DBDFN,DADXN,DBDXN,DADBN,DBDBN
	COMMON /B1/ATOM,TITLE,LABEL,PARIN,PARAUS,DATIN
C***********************************************************************
	DATA ATOM(1) /'AVERAGE '/
	DATA WSCHEMA /
     *'W = SQRT(1/SIG**2 * EXP(a * SINTHL**2) / [ b + EXP(a * SINTHL**2)
     * ] )',
     *'W = SQRT(1/SIG**2 * EXP(a * SINTHL**2))',
     *'W = 1/SIG, IF SINTHL.GE.a ; OTHERWISE  W = 0.0',
     *'W = 1.0',
     *'W = 1/SIG',' ',' ',
     *'W CALCULATED WITH a1,a2,...,a6 (INPUT DESCRIPTION)'/
	DATA (((LABEL(II,L,K),II=1,2),L=1,2),K=1,13)
	1/'   S','CALE',' FAC','TOR ','   O','CCUP','ANCY','    ','   X',
	2'    ','    ','    ','   Y','    ','    ','    ','   Z','    ',
	3'    ','    ','   U','(1,1',')   ','    ','   U','(2,2',')   ',
	4       '    ','   U','(3,3',')   ','    ','   U','(1,2',')   ',
	5'    ','   U','(2,3',')   ','    ','   U','(1,3',')   ','    ',
	6'   U','(ISO','TROP','IC) ','   E','NANT','IOPO','L   '/
C***********************************************************************
C
C     FORMAT STATEMENTS
C
C***********************************************************************
	EXTAL=1.
	ZWBX = 23
	ZWBY = 1
	ZWBZ = 24
C	CALL RENAME('GFMLS.CDR','INPUT.DAT')
	OPEN(UNIT=ZWBY,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME='GFMLX.CDR')
	OPEN(UNIT=ZWBX,ACCESS='SEQUENTIAL',TYPE='NEW',NAME='GFMLX.DAT')
	CALL DATE(DATUM)
	CALL TIME (ZEIT1)
C     READ TITLE AND CONTROL CARD
	READ(ZWBY,2250) TITLE
	WRITE(ZWBX,2260) TITLE
	WRITE(ZWBX,2880)
	WRITE(ZWBX,2670)DATUM,ZEIT1
	READ(ZWBY,2270)ICARD,NC,NVO,NX,ID,IW,IP,IT,IXFE,IWHSO,IWHET,IWHRT,
	1IWHTF,IWBCD,IWHPS,IWHPK,ICORK
	IF (ICARD.EQ.1)  GO TO 10
	WRITE(ZWBX,2680) ICARD
	CALL EXIT
10	WRITE(ZWBX,2660) NC,NVO,NX,ID,IW,IP,IT,IXFE,IWHSO,IWHET,IWHRT,
	1IWHTF,IWBCD,IWHPS,IWHPK,ICORK
	READ(ZWBY,2140) ZWBT,DATIN,TAPEIN,ZWBW,FURAUS,TAPAUS,ITAP,KOPERA
	IF(KOPERA.NE.0)  GO TO 40
	IF(ZWBT.NE.0)  GO TO 20
	TYPE 2710
	ACCEPT 2730,ZWBT
20	IF(IWHET.EQ.0)  GO TO 40
	IF(ZWBW.NE.0)  GO TO 30
	TYPE 2710
	ACCEPT 2730,ZWBW
30	CONTINUE
40	IF(IP.EQ.0.AND.IT.EQ.0)  GO TO 60
	READ(ZWBY,2140)ZWBU,PARIN,PABAIN,ZWBV,PARAUS,PABAUS
	IF(IP.EQ.0)  GO TO 50
	IF(ZWBU.NE.0)  GO TO 50
	IF(KOPERA.NE.0)GO TO 50
	TYPE 2710
	ACCEPT 2730, ZWBU
	ZWBU=ZWBU+8
50	IF(IT.EQ.0)  GO TO 60
	IF(ZWBV.NE.0)  GO TO 60
	IF(KOPERA.NE.0)GO TO 60
	TYPE 2710
	ACCEPT 2730, ZWBV
	ZWBV=ZWBV+8
60	IF(KOPERA.NE.2)GO TO 70
	ZWBT=20
	ZWBW=21
	ZWBU=25
	ZWBV=22
70	WRITE(ZWBX,2150) DATIN,TAPEIN,ZWBT
	IF(IWHET.NE.0)  WRITE(ZWBX,2160) FURAUS,TAPAUS,ZWBW
	IF(IP.NE.0)  WRITE(ZWBX,2170) PARIN,ZWBU
	IF(IT.NE.0)  WRITE(ZWBX,2180)PARAUS,ZWBV
	IF(KOPERA.EQ.2)GO TO 80
	ZWBT = ZWBT + 8
	ZWBW = ZWBW + 8
80	   REWIND ZWBZ
	OPEN(UNIT=ZWBT,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=DATIN,
     *	BLOCKSIZE=2*8192,BUFFERCOUNT=2)
90	IF(IWHET)100,110,100
100	REWIND ZWBW
	OPEN(UNIT=ZWBW,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=FURAUS,
     *	BLOCKSIZE=2*8192,BUFFERCOUNT=2)
	WRITE(ZWBX,2740)
C
110	IF(IP)    120,  120,  130
120	WRITE(ZWBX,2310)
	GO TO   140
C
130	WRITE(ZWBX,2320)IP
C
140	IF(IT-1)    150,  160,  170
150	WRITE(ZWBX,2600)
	GO TO 190
160	WRITE(ZWBX,2610)
	GO TO 180
170	WRITE(ZWBX,2620)
180	REWIND ZWBV
	OPEN(UNIT=ZWBV,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=PARAUS)
190	IF(ID)200,210,220
200	WRITE(ZWBX,2410)
	GO TO 230
210	WRITE(ZWBX,2420)
	GO TO 230
220	WRITE(ZWBX,2430)ID
230	IF(IWHTF)250,240,250
240	WRITE(ZWBX,2780)
	GOTO260
250	WRITE(ZWBX,2770)
260	IF(IWHSO)270,280,270
270	WRITE(ZWBX,2790)
	GO TO 290
280	WRITE(ZWBX,2800)
C
C     READ TRIAL PARAMETERS
290	IPWCH=IP
C	FEATURE TO READ SEPARATE MODEL FORBIDDEN BY NEW COMPILER
C	IF(IWHPS) 530,530,535
300	IWHPS=1
310	DO2070IWALT=1,IWHPS
C	CALL PRELIM(IWALT)
	CALL PRELIM
	WRITE(ZWBX,2280)NC,IC
	IF(IWALT-1)    320,  320, 340
320	WRITE(ZWBX,2340)NP
	DO330IKS=1,NP
330	KI(IKS)=0
	READ(ZWBY,2350)ICARD,ISENT,(H(I),I=1,3),SCALE
	KENN1=0
	IF(ICARD.EQ.6)  KENN1=6
	READ(ZWBY,2380)ICARD,(SDCOEF(I),I=1,6)
	KENN2=0
	IF(ICARD.EQ.7)  KENN2=7
340	     IF(NC)  460,460,350
350	READ(ZWBY,2370)(KI(I),I=1,NP)
C----   DO NOT REFINE ENANATIOPOL FOR CENTROSYMMETRIC OR F''
        IF((ICENT.NE.2).OR.(NKAS.LE.1)) KI(NQ+1) = 0
C----   FIX THE OVERALL ISOTROPIC TEMPERATURE REFINEMENT
        KI(NQ+2) = 0
C      CALL WAIT
	CALL TIME(ZEIT1)
	WRITE(ZWBX,2890)ZEIT1
	IF(IWHPK.EQ.0) CLOSE(UNIT=ZWBY)
C READ OBSERVATIONS TO SENTINEL FROM DECTAPE ZWBT (DATAP OUTPUT FORMAT)
360	WRITE(ZWBX,2750)
	DUMMI='IJUNK'
	OPEN(UNIT=ZWBZ,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=DUMMI,
     *	FORM='UNFORMATTED',BLOCKSIZE=2*8192,BUFFERCOUNT=2)
	NO=0
	NU=0
	NUNU = 0
370	READ(ZWBT,2700)(H(I),I=1,3),FO,SDHKL,H(4)
	NUNU = NUNU + 1
	IF(H(1).EQ.99.AND.H(2).EQ.99.AND.H(3).EQ.99)GO TO 420
	IF(SDHKL.EQ.0.0)SDHKL=ABS(FO)/3
	SDHKL = 1/SDHKL**2
	IF(FO.LE.0.0) SDHKL=0.0
C	UMWANDLUNG SIGMA IN GEWICHTE
380	SINTHL=SQRT (H(1)**2*PRCP(1)+H(2)**2*PRCP(2)+H(3)**2*PRCP(3)
	1+2.*H(1)*H(2)*PRCP(4)+2.*H(2)*H(3)*PRCP(5)+2.*H(1)*H(3)*PRCP(6))
	IF(SINTHL - SITETL)390,370,370
390	IF(SINTHL - SINMIN)  370,370,400
400	WRITE(ZWBZ)(H(I),I=1,4),FO,SDHKL
	NO=NO+1
	IF(FO)410,410,370
410	NU=NU+1
	GO TO 370
420	ENDFILE ZWBZ
	REWIND ZWBZ
	CLOSE(UNIT=ZWBT)
	IF(KENN1.EQ.6)  GO TO 430
	WRITE(ZWBX,2810) ICARD
C       KOEFF.-KARTE WIRD IMMER EINGELESEN
	CALL EXIT
430	    IF(ISENT.EQ.-1)WRITE(ZWBX,2900)
	 IF(ISENT.EQ.-2)WRITE(ZWBX,2910)
	IF(KENN2.EQ.7)  GO TO 440
	CALL EXIT
440	WRITE(ZWBX,2300) (SDCOEF(I),I=1,6)
	WRITE(ZWBX,2305) WSCHEMA(ISENT)
450	WRITE(ZWBX,2360) NUNU,NO,NU
C     READ KEY INTEGERS AND PARAMETER INCREMENTS IF SPECIFIED
C
C     PUT OUT TRIAL PARAMETERS, KEY INTEGERS, AND PARAMETER INCREMENTS
460	WRITE(ZWBX,2560)
C
	WRITE(ZWBX,2570) (I,P(I),KI(I),I=1,NQ+2)
	IF((NQ+2).EQ.NP)  GO TO 490
	III=NQ+3
	IF (IWBCD.NE.3) WRITE(ZWBX,2590)
	GO TO 480
470	III = III + 5
	IF (IWBCD.NE.3) WRITE(ZWBX,2590)
480	     WRITE(ZWBX,2580)(I,P(I),KI(I),I=III,III+4)
	IF((III+4).GE.NP)  GO TO 490
	GO TO 470
490	CONTINUE
C************* SHIFT/ERROR *************************************
	IF (SC(2).NE.0.0) THEN
	NKU=5
	ELSE
	NKU=4
	END IF
	DO K=2,NNA
	IF (ITF(K).LE.1) THEN
	NLU=4
	ELSE
	NLU=9
	END IF
	NUU=0
	DO L=NKU,NKU+NLU
	NUU=NUU+1
	IF (NUU.GE.2.AND.NUU.LE.4.AND.KI(L).NE.0) THEN
	NKOS=NKOS+1
	ELSE IF (NLU.EQ.4.AND.NUU.EQ.5.AND.KI(L).NE.0) THEN
	NISS=NISS+1
	ELSE IF(NLU.EQ.9.AND.NUU.GE.5.AND.KI(L).NE.0) THEN
	NANS=NANS+1
	END IF
	END DO
	NKU=NKU+NLU+1
	END DO
C********************************************************************
C***************
	IF (SC(2).NE.0.0) 
     *	OPEN(UNIT=50,ACCESS='SEQUENTIAL',TYPE='NEW',NAME='FOEXT.DAT',
     *	BLOCKSIZE=2*8192,BUFFERCOUNT=2)
C*************
C
C     START LOOP TO PERFORM NC CYCLES AND ONE FINAL CALCULATION OF Y
	NCY=IC+NC
	DO 2015 ICY=IC,NCY
C***************************************************************
	CALL TIME(ZYZEIT)
	IF (ICY.LT.NCY) TYPE 495,ICY,ZYZEIT
495	FORMAT(' BEGIN VON ZYKLUS',I4,10X,'ZEIT : ',A)
	CALL JOBTIM(ICPU)
	READ(ZYZEIT(1:2),FMT=499) HH1
	READ(ZYZEIT(4:5),FMT=499) MM1
	READ(ZYZEIT(7:8),FMT=499) SS1
	MM = FLOAT(HH1)*60. + FLOAT(MM1) + FLOAT(SS1)/60.
499	FORMAT(I2)
C******************************************************************
	IF(ID-ICY)510,500,510
500	ID=-1
510	CALL TEST
	IF(IWHTF)520,530,520
520	IF(ISTOP)2020,530,2020
530	IF(ICY-NCY)540,760,760
540	IF(IWHPK)550,570,550
550	IF(ICY-IC)570,570,560
560	READ(ZWBY,2370)(KI(I),I=1,NP)
C----   FIX THE ENANTIOPOL PARAMETER IF CENTRO OR NO F''
        IF((ICENT.NE.2).OR.(NKAS.LE.1)) KI(NQ+1)=0
C----   FIX ISOTROPIC OVERALL TEMPERATURE FACTOR REFINEMENT
        KI(NQ+2) = 0
570	CONTINUE
	NV=0
	NM=0
	IB=1
	IM=1
	MAX = NNA + 2
	DO 720 JB=1,MAX
	MORD(IB)=0
	L=0
	DO 700 IN = 1,NNA
	IF(ITF(IN)-1)580,580,590
580	N=5
	GO TO 600
590	N=10
600	IF(IN-1)610,610,620
610	N=N-3+NQ
620	IF(KB(IN)-JB+1)700,630,700
630	M=0
	DO 650  J = 1,N
	IF(KI(L+J))650,650,640
640	M=M+1
650	CONTINUE
	NPM(IM)=N
	LPM(IM)=L
	LVI(IN)=NV
	IBI(IN)=IB
	NV=NV+M
	MORD(IB)=MORD(IB)+M
	IM=IM+1
	IF(IN-1)660,660,670
660	NV1=M
	LM1=NM
670	IF(JB-1)680,680,700
680	IF(M)700,700,690
690	NM=NM+M*(M+1)/2
	IB=IB+1
	MORD(IB)=0
700	L=L+N
	IF(MORD(IB))720,720,710
710	NM=NM+MORD(IB)*(MORD(IB)+1)/2
	IB=IB+1
720	CONTINUE
730	NBLOC=IB-1
	DO 740 I=1,NV
740	V(I)=0.0
	IF(NM.GT.99000)  GO TO 2120
	 WRITE(ZWBX,2870)NM
	DO 750 I=1,NM
750	AM(I)=0.0
760	WRITE(ZWBX,2290)NVO
	SIG=0.0
	RNUM=0.0
	RDEN=0.0
	RZNUM=0.0
	RZDEN=0.0
	WRNUM=0.0
	WRDEN=0.0
	NINC=0
	IF (IWBCD.EQ.1.AND.(ICY.EQ.IC+1.OR.ICY.EQ.NCY)) GO TO 780
	IF (IWBCD)  790,780,770
770	IF (ICY - IC)  780,771,771
771	IF(ICY-NCY)790,780,780
780	WRITE(ZWBX,2260) TITLE
	WRITE(ZWBX,2390)ICY
	WRITE(ZWBX,2400)
C
C     START LOOP THROUGH NO OBSERVATIONS
790	OPEN(UNIT=ZWBZ,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=DUMMI,
     *	FORM='UNFORMATTED',BLOCKSIZE=2*8192,BUFFERCOUNT=2)
800	DO 1170 I=1,NO
	READ(ZWBZ)   (H(J),J=1,4),FO,SDHKL
C     ENTER USERS SUBROUTINE TO COMPUTE Y(CALC) AND DERIVATIVES
	CALL CALC
C     OBTAIN WEIGHT AND CALCULATE QUANTITIES FROM Y(OBS)-Y(CALC)
810	FINC = FO
	IF(IFSQ-1)820,820,830
820	YO = ABS(FO)
	FC=ABS(YC)
	GO TO 840
830	YO = FO**2
	FC=SQRT(YC)
840	DY=YO-YC
	DINC=ABS(FINC)-FC
	CALL WEIGHT(SDHKL)
	CALL THOLD(FINC,DINC,NINC,SQRTW)
	WDY=SQRTW*DY
	SIG=SIG+WDY*WDY
	RZNUM=RZNUM+ABS(DINC)
	RZDEN=RZDEN+ABS(FINC)
	WRNUM=WRNUM+WDY**2
	WRDEN=WRDEN+(SQRTW*YO)**2
	IF(FO)860,860,850
C
850	RNUM=RNUM+ABS(DINC)
C
	RDEN=RDEN+ABS(FINC)
C     PUT OUT Y(CALC) AND OTHER INFORMATION FOR ONE OBSERVATION
860	DO  870 K=1,3
C
870	IHKL(K) = H(K)
	SQTO=SC(IQ)
	IF(IWHSO)890,880,890
880	IF (FLAMDA.EQ.0.0) THEN
	WCH1 = FO
	WCH2=DINC
	WCH3=FC
	AA=A*SQTO
	BB=B*SQTO
	ELSE
	WCH1=FO*(1.0+0.0001*SC(NQ)*FO*FO/(SINTHL*FLAMDA))
	WCH3=FC/EXTN
	WCH2=ABS(WCH1)-WCH3
	AA=A*SQTO/EXTN
	BB=B*SQTO/EXTN
	END IF
	GO TO 900
890	IF(FLAMDA.EQ.0.0)THEN
	WCH1 = FO/SQTO
	WCH2=DINC/SQTO
	WCH3=FC/SQTO
	AA=A
	BB=B
	ELSE
	WCH1=(FO/SQTO)*(1.0+0.0001*SC(NQ)*FO*FO/(SQTO*SQTO*SINTHL*FLAMDA))
	WCH3=FC/(SQTO*EXTN)
	WCH2=ABS(WCH1)-WCH3
	AA=A/EXTN
	BB=B/EXTN
	END IF
C----   THE FOLLOWING PART REMOVED BY H.D.FLACK.  SEE ALSO THE CALC SECTION
C900	IF(ICENT-1)910,910,930
C910	     IF(NKAS)930,920,930
C920	AA=2.0*AA
C	BB=0.0
900	CONTINUE
930	IF (IWBCD.EQ.1.AND.(ICY.EQ.IC+1.OR.ICY.EQ.NCY)) GO TO 961
	IF(IWBCD)970,960,940
C	LISTE NUR NACH LETZTEM CYKLUS DRUCKEN
940	IF(ICY-IC)960,950,950
950	IF(ICY-NCY)1050,960,960
C!!!!!!!!  SAVER = R*100.  BEI KURZER LISTE GRENZE FUER FO-FC-AUSDRUCK
C
960	IF (ABS(WCH2).LT.SAVER.AND.(IWBCD.EQ.2.OR.IWBCD.EQ.3)) GO TO 970
961	WRITE(ZWBX,2450)(IHKL(K),K=1,3),WCH1,WCH3,AA,BB,WCH2,SQRTW,WDY,
     *	IQ,SINTHL
970	IF(ICY-NCY)1050,980,980
980	IF(IWHET-1)1040,1030,990
990	IZERO=0
	 TEMP=ABS(WCH3/WCH1)
	IF(FO)1010,1010,1000
1000	    IF(TEMP.GE.FRAC)GO TO 1020
1010	    IF(I.EQ.NO)IZERO=2
	 IF(IZERO.EQ.0)  GO TO 1040
1020	      IF(I.EQ.NO)IZERO=2
	IF (WCH1.GE.0.0) WRITE(ZWBW,2850)(IHKL(K),K=1,3),WCH1,AA,BB
	GOTO1040
1030	CONTINUE
1040	CONTINUE
C****** AUSGABE VON FOEXT NACH DEM LETZTEN ZYKLUS ********
	IF (SC(2).NE.0.0) THEN
	IF (IHKL(1).EQ.99.AND.IHKL(2).EQ.99.AND.IHKL(3).EQ.99) THEN
	SIGEXT=0.0
	WCH1=0.0
	ELSE IF (SQRTW.EQ.0.0) THEN
	SIGEXT=ABS(FO)/3.
	ELSE
	SIGEXT=1./SQRTW
	SIGEXT=(WCH1/FO)*SIGEXT
	END IF
	WRITE(50,2700) (IHKL(K),K=1,3),WCH1,SIGEXT,H(4)
	END IF
C********************************************************
C
C     BY-PASS DERIVATIVE AND MATRIX SET-UP ON FINAL CALC OF Y
	IF(ICY-NCY)1050,1170,1170
C
1050	IM=1
	LM=0
	LV=0
	DO 1160 IB=1,NBLOC
	IV=0
1060	IF(IV-MORD(IB))1070,1110,1110
1070	L=LPM(IM)+1
	M=L+NPM(IM)-1
	DO 1090 J=L,M
	IF(KI(J))1090,1090,1080
1080	IV=IV+1
	DV(IV)=SQRTW*DC(J)
1090	CONTINUE
1100	IM=IM+1
	GO TO 1060
1110	DO 1160 II=1,IV
	IF(DV(II))1130,1120,1130
1120	LM=LM+IV-II+1
	GO TO 1150
1130	DO 1140 JJ=II,IV
	LM=LM+1
1140	AM(LM)=AM(LM)+DV(II)*DV(JJ)
1150	LV=LV+1
1160	V(LV)=V(LV)+DV(II)*WDY
C     END LOOP TO STORE MATRIX AND VECTOR
C
1170	CONTINUE
	IF(ICY-NCY)1200,1180,1180
1180	IF(IWHET-1)1200,1190,1190
1190	KKL=99
	WRITE(ZWBW,2920)KKL,KKL,KKL
	IF (SC(2).NE.0.0) WRITE(50,2920)KKL,KKL,KKL
1200	   REWIND ZWBZ
C     END LOOP THROUGH NO OBSERVATIONS
C     COMPUTE AND PUT OUT AGREEMENT FACTORS
	SIG=SIG/FLOAT(NINC-NVO)
	SQSIG=SQRT(SIG)
	NSKIP=NZEILE/60*60
	NSKIP=NZEILE-NSKIP
	IF (NSKIP.LT.30) WRITE(ZWBX,2465)
	WRITE(ZWBX,2460)ICY,NINC,SQSIG
	R=RNUM/RDEN
	RZ=RZNUM/RZDEN
	WR=WRNUM/WRDEN
	 WR=SQRT(WR)
	WRITE(ZWBX,2230)RNUM,RDEN,R
C!!!!!!!!!!!!
	SAVER = R*100.
C!!!!!!!!!!!
	WRITE(ZWBX,2220)RZNUM,RZDEN,RZ
	WRITE(ZWBX,2240)WRNUM,WRDEN,WR
	NVO=NV
C     BY-PASS MATRIX INVERSION AND PARAMETER OUTPUT ON FINAL CYCLE
	IF(ICY-NCY)1230,1210,1210
1210	IF(ID)1220,1800,1800
1220	WRITE(ZWBX,2520)ICY
	GO TO 1620
C----   THIS SECTION ADDS ON ONE EXTRA BLOCK TO THE NORMAL EQUATIONS 
C----   MATRIX CONTAINING JUST THE OVERALL TEMPERATURE FACTORS AS
C----   VARIABLES.  SUPPOSE IT'S FOR THE LOST CORRELATION
1230	IB=IBI(1)
	M=MORD(IB)
	L=0
	DO 1250 I=1,NQ+1
	IF(KI(I))1250,1250,1240
1240	L=L+1
1250	CONTINUE
	LV=LVI(1)+L
	LM=LM1+L*M-L*(L-1)/2
	M=M-NV1
	N=NV1-L
	IF(N)1290,1290,1260
1260	DO 1280 I=1,N
	DO 1270 J=I,N
1270	AM(NM+J)=AM(LM+J)
	V(NV+I)=V(LV+I)
	NM=NM+N-I
1280	LM=LM+M+N-I
	NM=NM+N
	NBLOC=NBLOC+1
	MORD(NBLOC)=N
C     START LOOP TO SOLVE NORMAL EQUATIONS, BY BLOCKS
1290	LV=0
	IV=1
	MK=0
	DO 1490 IB=1,NBLOC
	NK=MORD(IB)
	ISING=0
	II=1
	IE=NK
C     START LOOP TO TEST FOR ZERO DIAGONAL ELEMENT
	DO 1320 I=1,NK
	IF(AM(II))1310,1300,1310
1300	ISING=1
	WRITE(ZWBX,2490)IB,I
1310	II=II+IE
1320	IE=IE-1
	IF(ISING)1350,1330,1350
1330	CALL INVERT(AM,NK,1,NK,MK,ISING,DET,W)
	IF(ISING)1340,1370,1340
1340	WRITE(ZWBX,2500)IB
	CALL EXIT
1350	DO 1360 I=1,NK
	PD(IV)=0.0
	DIAG(IV)=0.0
1360	IV=IV+1
	GO TO 1480
1370	DO 1420 I=1,NK
	PDI=0.0
	IJ = MK+I
	IJD=NK-1
	DO 1410 J=1,NK
	PDI=PDI-AM(IJ)*V(LV+J)
	IF(J-I)1380,1390,1400
1380	IJ=IJ+IJD
	IJD=IJD-1
	GO TO 1410
1390	DIAG(LV+I)=SQRT(-AM(IJ))
1400	IJ=IJ+1
1410	CONTINUE
	PD(IV)=PDI
1420	IV=IV+1
	IF(SCALE)1430,1440,1430
C     PUT OUT VARIANCE MATRIX
1430	WRITE(ZWBX,2470)SCALE,IB
1440	DO 1470 J=1,NK
	JI=J
	JID=NK-1
	DO 1450 I=1,J
	JK=MK+JI
	ROW(I)=-SIG*AM(JK)*SCALE
	AM(JK)=-AM(JK)/(DIAG(LV+I)*DIAG(LV+J))
	JI=JI+JID
1450	JID=JID-1
	   IF(SCALE)1460,1470,1460
1460	WRITE(ZWBX,2480)J,(ROW(I),I=1,J)
1470	CONTINUE
1480	MK=MK+NK*(NK+1)/2
	LV=LV+NK
1490	CONTINUE
	IF(N)1590,1590,1500
1500	IF(ITF(1)-1)  1510,1510,1530
1510	DTO(7)=PD(NV+1)
	DO 1520 J=1,6
1520	DTO(J)=ALPHA(J)*DTO(7)
	GO TO 1610
1530	JV=1
	Q = 0.0
	S=0.0
	DO 1560 J=1,6
	IF(KI(NQ+1+J))1550,1550,1540
1540	DTO(J)=PD(NV+JV)
	Q=Q+ALPHA(J)*DTO(J)
	S=S+ALPHA(J)*ALPHA(J)
	JV=JV+1
	GO TO 1560
1550	DTO(J)=0.0
1560	CONTINUE
	IF(S)1580,1580,1570
1570	DTO(7)=Q/S
	GO TO 1610
1580	DTO(7)=0.0
	GO TO 1610
1590	DO 1600 J=1,7
1600	DTO(J)=0.0
C     END LOOP FOR MATRIX VECTOR MULTIPLICATION
C
1610	IF(IWBCD.EQ.3.AND.ICY.NE.IC.AND.ICY.NE.NCY-1) GO TO 1620
	WRITE(ZWBX,2260) TITLE
	WRITE(ZWBX,2510)ICY
	NZEILE=6
C
C     START LOOP TO CORRECT AND PUT OUT PARAMETERS
1620	CONTINUE
C
1630	LD=1
	N=1
	J=1
C
	IF(.NOT.(IWBCD.EQ.3.AND.ICY.NE.IC.AND.ICY.NE.NCY-1)) THEN
C

	DO 1790 I=1,NP
	IF(I-NQ-1)1640,1645,1635
1635    IF(I-NQ-2)1650,1650,1660
1640	K=1
	GO TO 1710
1645    K=13
        GO TO 1710
1650	IF (KI(I).EQ.0) GO TO 1655
	WRITE(ZWBX,2440)ATOM(1),IBI(1)
	NZEILE=NZEILE+2
1655	K=6
	GO TO 1690
1660	K=K+1
	IF(K-12)1680,1670,1670
1670	N=N+1
	J=1
	LLL=I
	DO LL=1,NPM(N)
	IF (KI(LLL).NE.0) THEN
	IMERKE=1
	END IF
	LLL=LLL+1
	END DO
	IF (IMERKE.EQ.0) GO TO 1675
	WRITE(ZWBX,2440)ATOM(N),IBI(N)
	IMERKE=0
	NZEILE=NZEILE+2
1675	K=2
	GO TO 1710
1680	IF(K-6)1710,1690,1710
1690	IF(ITF(N)-1)1700,1700,1710
1700	K=12
1710	IF(ICY-NCY)1730,1720,1720
1720	WRITE(ZWBX,2530)((LABEL(II,L,K),II=1,2),L=1,2),P(I)
	NZEILE=NZEILE+1
	GO TO 1790
1730	IF (KI(I).EQ.0) GO TO 1790
C1730	IF(KI(I))1740,1740,1750
C1740	WRITE(ZWBX,2530)((LABEL(II,L,K),II=1,2),L=1,2),P(I),P(I)
C	GO TO 1790
1750	L=LVI(N)
	CI=KI(I)
	CI=0.125*CI
	SHIFT=PD(L+J)
	POLD=P(I)
	P(I)=POLD+CI*SHIFT
	SIGP=SQSIG*DIAG(L+J)
	IF(IBI(N)-IBI(1))1760,1780,1760
1760	IF(K-6)1780,1770,1770
1770	P(I)=P(I)-CI*DTO(K-5)
1780	WRITE(ZWBX,2540 )((LABEL(II,L,K),II=1,2), L=1,2),POLD,SHIFT,CI,
	1P(I),SIGP
C*********** SHIFT/ERROR **********************
	IF (ICY.EQ.NCY-1) THEN
	IF (K.GE.3.AND.K.LE.5) THEN
	KOSHIFT=KOSHIFT+ABS(SHIFT)/SIGP
	ELSE IF (K.GE.6.AND.K.LE.11) THEN
	ANSHIFT=ANSHIFT+ABS(SHIFT)/SIGP
	ELSE IF (K.EQ.12) THEN
	ISSHIFT=ISSHIFT+ABS(SHIFT)/SIGP
	END IF
	END IF
C*************************************************
	NZEILE=NZEILE+1
	J=J+1
1790	CONTINUE
C
	ELSE
C
C	KURZE LISTE FUER DIE VAX 730
C
	DO 11790 I=1,NP
	IF(I-NQ-1)11640,11645,11635
11635   IF(I-NQ-2)11650,11650,11660
11640	K=1
	GO TO 11710
11645   K=13
        GO TO 11710
11650	K=6
	GO TO 11690
11660	K=K+1
	IF(K-12)11680,11670,11670
11670	N=N+1
	J=1
	LLL=I
	DO LL=1,NPM(N)
	IF (KI(LLL).NE.0) THEN
	IMERKE=1
	END IF
	LLL=LLL+1
	END DO
11675	K=2
	GO TO 11710
11680	IF(K-6)11710,11690,11710
11690	IF(ITF(N)-1)11700,11700,11710
11700	K=12
11710	IF(ICY-NCY)11730,11720,11720
11720	GO TO 11790
11730	IF (KI(I).EQ.0) GO TO 11790
11750	L=LVI(N)
	CI=KI(I)
	CI=0.125*CI
	SHIFT=PD(L+J)
	POLD=P(I)
	P(I)=POLD+CI*SHIFT
	SIGP=SQSIG*DIAG(L+J)
	IF(IBI(N)-IBI(1))11760,11780,11760
11760	IF(K-6)11780,11770,11770
11770	P(I)=P(I)-CI*DTO(K-5)
C*********** SHIFT/ERROR **********************
11780	IF (ICY.EQ.NCY-1) THEN
	IF (K.GE.3.AND.K.LE.5) THEN
	KOSHIFT=KOSHIFT+ABS(SHIFT)/SIGP
	ELSE IF (K.GE.6.AND.K.LE.11) THEN
	ANSHIFT=ANSHIFT+ABS(SHIFT)/SIGP
	ELSE IF (K.EQ.12) THEN
	ISSHIFT=ISSHIFT+ABS(SHIFT)/SIGP
	END IF
	END IF
C*************************************************
	NZEILE=NZEILE+1
	J=J+1
11790	CONTINUE
C
	END IF
C
	NZEILE=NZEILE+4
C     END LOOP TO CORRECT AND PUT OUT PARAMETERS
C
	CALL PTOSB(P,SC,AI,XYZ,BETA,ITF,NNA,NQ,NP)
C
C     WRITE CORRECTED PARAMETERS ON AUXILIARY FILE IF
C     DESIRED
1800	IF(IT-1)1950,1810,1820
1810	IF(ICY-NCY)1950,1820,1820
1820	CONTINUE
	WRITE(ZWBV,2250) TITLE
	WRITE(ZWBV,2930)(RCP(I),I=1,6)
	IDUM=0
	DO 1830 I=1,NS
	IF(I.EQ.NS)IDUM=1
	WRITE(ZWBV,2940)IDUM,(TS(I13,I),(FS(I14,I13,I),I14=1,3),I13=1,3)
1830	CONTINUE
	 ICAR=4
	ITEXT='SCALEFACTOR  CARD   '
	NNQ=NQ
	IF(FLAMDA.GT.0.0)  NNQ=NQ-1
	 WRITE(ZWBV,2950)ITEXT,ICAR,(SC(I),I=1,NNQ)
	 ICAR=51
        ITEXT='EXTINCTION  CARD    ' 
	EXTOUT=SC(NQ)
	IF(FLAMDA.EQ.0) EXTOUT = 0.0
	 WRITE(ZWBV,2960)ITEXT,ICAR,ICY,FLAMDA,EXTOUT,AI(1)
	IF(NKAS.NE.0) THEN
        ICAR = 52
	ITEXT='DISPERSION  CARD    '
         WRITE(ZWBV,2961) ITEXT,ICAR,ICY,
	1(FI1S(I),RFIS(I),I=1,NKAS)
	ENDIF
	IF(ITF(1)-2)1840,1850,1850
1840	J=NQ+3
	GO TO 1860
1850	J =NQ+8
1860	DO 1940 I= 2,NNA
	KK = 1
	DO 1900 JJ =1,3
	IF(KI(J+JJ))1870,1880,1870
1870	KKKK=LVI(I)+KK
	PDT(JJ)=SQSIG*DIAG(KKKK)
	GO TO 1890
1880	PDT(JJ)=0
	GO TO 1900
1890	KK = KK+1
1900	CONTINUE
	IF(ITF(I)-2)1910,1920,1920
1910	J=J+5
	GO TO 1930
1920	J = J+10
1930	CONTINUE
	WRITE(ZWBV,2190)ATOM(I),KB(I),SF(I),AI(I),(XYZ(K,I),K=
	11,3),(PDT(JJ),JJ=1,3)
C
1940	WRITE(ZWBV,2200)ITF(I),(BETA(K,I),K=1,4),BETA(6,I),BETA(5,I)
C
C     PRINT INTRAMOLECULAR DISTANCES
1950	IF(ND-1)2010,1960,1970
1960	IF(ICY-NCY)  2010,1970,2010
1970	WRITE(ZWBX,2820)ICY
	IF (IWBCD.NE.3) THEN
	DO 2000 I=2,NNA
	DO 1990 J = 2,I
	VD(J) = 0
	DO 1980 K=1,3
	DO 1980 L =1,3
1980	VD(J)=VD(J)+(XYZ(K,I)-XYZ(K,J))*G1(K,L)*(XYZ(L,I)-XYZ(L,J))
1990	VD(J)=SQRT(VD(J))
2000	WRITE(ZWBX,2830) ATOM(I),(VD(J),J=2,I)
	ELSE
	DO I=2,NNA
	DO  J = 2,I
	VD(J) = 0
	DO  K=1,3
	DO  L =1,3
	VD(J)=VD(J)+(XYZ(K,I)-XYZ(K,J))*G1(K,L)*(XYZ(L,I)-XYZ(L,J))
	END DO
	END DO
	VD(J)=SQRT(VD(J))
	END DO
	WRITE(ZWBX,2833) ATOM(I),(VD(J),J=2,I)
	END DO
	END IF
C**********************************************************
2010	IF (ICY.LT.NCY) THEN
	CALL JOBTIM(ICPU2)
	CALL TIME(ZYZEIT)
	ICPU3=ICPU2-ICPU
	CPUT=FLOAT(ICPU3)
	CPUT=CPUT/6000.
	TYPE 2005,ICY,CPUT
2005	FORMAT(' CPU-ZEIT FUER ZYKLUS ',I2,' :',F,' MIN.')
	READ(ZYZEIT(1:2),FMT=499) HH2
	READ(ZYZEIT(4:5),FMT=499) MM2
	READ(ZYZEIT(7:8),FMT=499) SS2
	MMNEU = FLOAT(HH2)*60. + FLOAT(MM2) + FLOAT(SS2)/60.
	IF (MMNEU.LT.MM) THEN
	MM = 24.*60. - MM + MMNEU
	ELSE
	MM = MMNEU - MM
	END IF
	TYPE 2007,ICY,MM
2007	FORMAT(' VERWEILZEIT FUER ZYKLUS ',I2,' :',F,' MIN.')
	END IF
C*********************************************************
2015	CONTINUE
C     END LOOP TROUGH NC CYCLES AND FINAL CALC OF Y
C
C     TERMINATE JOB
	CLOSE(UNIT=50)
	IF(NC)2070,2070,2030
C
C     TERMINATE JOB IF INDICATED BY USERS SUBROUTINE TEST
2020	WRITE(ZWBX,2550)
C     PUT OUT CORRELATION MATRIX FOR EACH BLOCK
2030	WRITE(ZWBX,2260) TITLE
	IF(ICORK.NE.1)  GO TO 2070
	M=0
	DO 2060 K=1,NBLOC
	WRITE(ZWBX,2630)K
	NK=MORD(K)
	DO 2050 J=1,NK
	JI=J
	JID=NK-1
	DO 2040 I=1,J
	ROW(I)=AM(JI+M)
	JI=JI+JID
2040	JID=JID-1
2050	WRITE(ZWBX,2640)J,(ROW(I),I=1,J)
2060	M=M+NK*(NK+1)/2
2070	CONTINUE
C
2080	IF(IT)2100,2100,2090
2090	ENDFILE ZWBV
	REWIND ZWBV
C
2100	IF(IWHET)2110,2130,2110
2110	CONTINUE
	ENDFILE ZWBW
	REWIND ZWBW
C
	GO TO 2130
2120	      TYPE 2840
	 TYPE 2970,NM
2130	CONTINUE
	CLOSE(UNIT=ZWBZ,DISPOSE='DELETE')
	CALL TIME (ZEIT1)
	CALL DATE(DATUM)
	WRITE(ZWBX,2670) DATUM,ZEIT1
C*********** SHIFT/ERROR *******************************
	IF (NKOS.NE.0) KOSHIFT=KOSHIFT/NKOS
	IF (NANS.NE.0) ANSHIFT=ANSHIFT/NANS
	IF (NISS.NE.0) ISSHIFT=ISSHIFT/NISS
	WRITE(ZWBX,9000) KOSHIFT,ANSHIFT,ISSHIFT
9000	FORMAT(//,10X,' AVE. SHIFT/ERROR OF THE COORDINATES',T70,
     *	F20.8,/,10X,' AVE. SHIFT/ERROR OF THE ANISOTROPIC TEMP. FACTORS',
     *	T70,F20.8,/,10X,' AVE. SHIFT/ERROR OF THE ISOTROPIC TEMP. 
     *FACTORS',T70,F20.8)
	WRITE(ZWBX,9010) NKOS,NANS,NISS
9010	FORMAT(/,10X,' NUMBER OF REFINED COORDINATES ',T70,I8,/,
     *	10X,' NUMBER OF REFINED ANISOTROPIC PARAMETERS ',T70,I8,/,
     *	10X,' NUMBER OF REFINED ISOTROPIC PARAMETERS ',T70,I8)
	WRITE(ZWBX,9015) NVO
9015	FORMAT(10X,' TOTAL NUMBER OF REFINED PARAMETERS ',T70,I8)
	NOBS=NO-NU
	WRITE(ZWBX,9020) NO,NOBS,NU
9020	FORMAT(/,10X,' TOTAL NUMBER OF REFLECTIONS ',T70,I8,/,
     *	10X,' TOTAL NUMBER OF OBSERVED ',T70,I8,/,10X,' TOTAL NUMBER OF 
     *UNOBSERVED ',T70,I8)
	NOBREF=NOBS/NVO
	WRITE(ZWBX,9030) NOBREF
9030	FORMAT(/,10X,' NUMBER OF OBSERVED REFLECTIONS PER REFINED 
     *PARAMETERS',T70,I8)
C********************************************************
	 ENDFILE ZWBX
C	CALL RENAME ('INPUT.DAT','GFMLS.CDR')
	STOP
2140	FORMAT(20X,I5,5X,A5,5X,A5,5X,I5,5X,A5,5X,A5,I3,I2)
2150	FORMAT(1H0,20X,' DATA-FILE ',A5,' ',A5,' ON UNIT',I3)
2160	FORMAT(1H0,20X,' FOURIER-FILE ',A5,' ',A5,' ON UNIT ',I3)
2170	FORMAT(1H0,21X,'PARAMETER - INPUT  FILE ',A5,'ON LOGICAL UNIT'
	1,I3 )
2180	FORMAT(1H0,21X,'PARAMETER - OUTPUT FILE ',A5,' ON LOGICAL UNIT'
	1,I3)
2190	FORMAT(A8,I3,5F9.6,3F8.6)
2200	FORMAT(I6,6F9.6)
2210	FORMAT(1H061X,29HNUMERATOR   DENOMINATOR     R)
2220	FORMAT(1H0,20X,30H R FACTOR INCLUDING UNOBSERVED,10X,E,E,3
	1X,F7.5)
2230	FORMAT(1H0,20X,29H R FACTOR OMITTING UNOBSERVED,11X,E,E,3X
	1,F7.5)
2240	FORMAT(1H0,20X,18H WEIGHTED R FACTOR,22X,E,E,1X,F9.5/1H )
2250	FORMAT(A72)
2260	FORMAT(1H1,20X,A72/)
2270	FORMAT(20X,17I3)
2280	FORMAT(1H0,20X,I2,2X,'CYCLES TO BE COMPUTED',/,22X,
	1'STARTING AT CYCLE' ,I5)
2290	FORMAT(1H0,20X,I9,29H PARAMETERS HAVE BEEN REFINED)
2300	FORMAT(1H ,20X,' CONSTANTS FOR WEIGHT ROUTINE',6F9.4,/,1H )
2305	FORMAT(1H ,/,21X,' WEIGHTING SCHEME :',A,/)
2310	FORMAT(1H0,20X,' INPUT PARAMETERS READ FROM CARD-FILE ')
2320	FORMAT(1H0,20X,32H0INPUT PARAMETERS READ FROM FILE)
2330	FORMAT(3I3,I1,F7.2,F8.3)
2340	FORMAT(1H0,21X,I3,' PARAMETERS READ, MAXIMUM IS 1500 ')
2350	FORMAT(20X,I3,I3,3I9,F9.0)
2360	FORMAT(1H ,20X,I5,'  REFLECTIONS READ,',I5,' WITHIN LIMITS,FROM WH
	1ICH ',I5,' NOT OBSERVED'/)
2370	FORMAT(72I1)
2380	FORMAT(20X,I3,6F9.4)
2390	FORMAT(1H0,30X,46H CALCULATED Y BASED ON PARAMETERS BEFORE CYCLEI4
	1)
2400	FORMAT(1H0,20X,
	1108H   H   K   L     F(OBS)    F(CALC)        A          B        F
	2O-FC      1/S.D. (YO-YC)/SD    GROUP  SINTH/L/1H )
2410	FORMAT(1H0,20X,59H OVERALL THERMAL PARAMETER RESET TO ZERO BEFORE 
	1EVERY CYCLE)
2420	FORMAT(1H0,20X,49H OVERALL THERMAL PARAMETER ACCUMULATED SEPARATEL
	1Y)
2430	FORMAT(1H0,20X,53H OVERALL THERMAL PARAMETER RESET TO ZERO BEFORE
	1CYCLE,I4)
2440	FORMAT(1H0,A8,I12)
2450	FORMAT(1H ,20X,3I4,7F11.4,I7,F11.4)
2460	FORMAT(20X,53H DISCREPANCY FACTORS BASED ON PARAMETERS BEFORE 
	1CYCLEI4/21X,5H NO =I6/21X,34H SQRT(SUM(W*(YO-YC)**2)/(NO-NV)) =F10
	2.4)
2465	FORMAT(1H1)
2470	FORMAT (1H0,20X,18H VARIANCE MATRIX XF10.2,8H,  BLOCK,I3)
2480	FORMAT (1H0I3,10F11.9/(/4X10F11.9))
2490	FORMAT(2H0,30X,31H ZERO DIAGONAL ELEMENT IN BLOCKI3, 5H, ROWI3)
2500	FORMAT(2H0,30X,26H SINGULAR MATRIX FOR BLOCKI3)
2510	FORMAT (1H030X22HPARAMETERS AFTER CYCLEI3/12H0  PARAMETER6X5HBLOCK
	18X3HOLD9X5HSHIFT8X2HCI8X3HNEW10X4HS.D.)
2520	FORMAT(27H1PARAMETERS ON OUTPUT CYCLEI4)
2530	FORMAT(1H ,4A4,F20.7,22X,F13.7)
2540	FORMAT(1H ,4A4,7X,2F13.7,F9.3,2F13.7)
2550	FORMAT(54H0 JOB TERMINATED BECAUSE OF NEGATIVE THERMAL PARAMETER)
2560	FORMAT(1H0,/,1H0,20X,'INPUT PARAMETER AND SHIFTS')
2570	FORMAT(1H ,20X,3(I3,F12.6,I3,2X,'*'))
2580	FORMAT(1H ,20X,5(I3,F12.6,I3,2X,'*'))
2590	FORMAT(1H ,20X,5(20X,'*'))
2600	FORMAT(1H0,20X,51H CORRECTED PARAMETERS NOT TO BE SAVED FOR LATER 
	1USE)
2610	FORMAT(1H0,20X,42H PARAMETERS TO BE WRITTEN AFTER LAST CYCLE)
2620	FORMAT(1H0,20X,42H PARAMETERS TO BE WRITTEN AFTER EACH CYCLE)
2630	FORMAT(1H0,20X,26H CORRELATION MATRIX, BLOCKI3)
2640	FORMAT(1H0,5X,1H I3,13F9.4/(1H 9X,13F9.4))
2650	FORMAT(2H ,30X,'*****   CARD',I3,'(SCDCOEF) IN WRONG ORDER')
2660	FORMAT(1H0,21X,'CONTROL CARD: ',
	1'    NC = ',I2,'   NVO = ',I2,'    NX = ',I2,'    ID = ',I2,
	2'    IW = ',I2,'    IP = ',I2,'    IT = ',I2,/,36X,
	3'  IXFE = ',I2,' IWHSO = ',I2,' IWHET = ',I2,' IWHRT = ',I2,
	4' IWHTF = ',I2,' IWBCD = ',I2,' IWHPS = ',I2,/,36X,
	5' IWHPK = ',I2,' ICORK = ',I2)
2670	FORMAT(1H-,21X,A9,10X,A5,/)
2680	FORMAT(1H0,30X,' **** CARD ONE NOT IN SEQUENCE  ******')
2690	FORMAT(1H0,20X, 'COMPUTING - TIME : ',I6,'  SEC')
C	FORMAT AB ANALYSE 500 GEAENDERT
2700	FORMAT(3I3,F7.2,F6.2,1X,I1)
2710	FORMAT(1H ,' BITTE EINHEIT EINGEBEN: '$)
2720	FORMAT(A1)
2730	FORMAT(I)
2740	FORMAT(1H0,20X,37H EXTRA FILE WRITTEN FOR FOURIER INPUT       )
2750	FORMAT(1H0,20X,55H REFLECTION DATA ENTERED FROM FILE AND WRITTEN
	1 ON DISK,//)
2760	FORMAT(1H0,20X,34H REFLECTION DATA ENTERED FROM FILE)
2770	FORMAT(1H0,20X,38H STOPS ON NEGATIVE THERMAL PARAMETERS )
2780	FORMAT(1H0,20X,36H ACCEPTS NEGATIVE THERMAL PARAMETERS)
2790	FORMAT(1H0,20X,25H SCALES F(OBS) TO F(CALC))
2800	FORMAT(1H0,20X,25H SCALES F(CALC) TO F(OBS))
2810	FORMAT(2H ,20X,'*****CARD ',I3,'IN WRONG ORDER ')
2820	FORMAT(1H1,20X,38H INTRAMOLECULAR DISTANCES BEFORE CYCLEI4)
2830	FORMAT(1H0,10X,A8,2X,15F6.3/(1H ,20X,15F6.3))
2833	FORMAT(1H0,A8,20F6.3,/(1H ,8X,20F6.3))
2840	FORMAT(1H3,' SORRY,STORAGE CAPACITY EXEEDED')
2850	FORMAT(3I3,3F7.2)
2860	FORMAT(44X,I2)
2870	      FORMAT(1H0,20X,' AM-VECTOR SIZE IS 'I6,'  MAXIMUM IS 99000')
2880	FORMAT(1H0,20X,'** FULL MATRIX  LEAST SQUARES PROGRAM *****')
2890	FORMAT(1H0,///,20X,'  BEGIN OF COMPUTATION: ',A5,//)
2900	     FORMAT(1H ,21X,'STATISTICAL WEIGHTS USED FOR REFINEMENT',/)
2910	     FORMAT(1H ,21X,'UNIT WEIGHTS USED FOR REFINEMENT',/)
2920	FORMAT(3I3)
2930	FORMAT(6F9.5)
2940	FORMAT(I1,F14.10,3F3.0,F15.10,3F3.0,F15.10,3F3.0)
2950	     FORMAT(A20,I3,5F9.6)
2960	     FORMAT(A20,2I3,F9.6,2F9.4)
2961         FORMAT(A20,2I3,6F6.3)
2970	      FORMAT('  VECTOR-SIZE NEEDED IS ',I10, ' GFMLS: 80 000 ')
	END
	SUBROUTINE CALC
	CHARACTER*5 PARIN,PARAUS,DATIN
	CHARACTER ATOM(150)*8,TITLE*72,LABEL(2,2,12)*4
	INTEGER H
	DIMENSION SC(5),DFDS(5)
	DIMENSION KB(150),ITF(150),SF(150),AI(150),XYZ(3,150)
	DIMENSION BETA(6,150),DADFI(150),DBDFI(150),DFDAI(150),DADX(3,150)
	DIMENSION DBDX(3,150),DFDX(3,150),DADB(6,150),DBDB(6,150),DFDB(6,150)
	DIMENSION IBI(160),LVI(160),LPM(160),NPM(150),MORD(160)
	DIMENSION P(1500),KI(1500),DC(1500),DV(1500),V(1500),PD(1500),
     *	DIAG(1500)
	DIMENSION AM(99000),W(1500),ROW(1500),FX(32,20),TS(3,24),FS(3,3,24)
	DIMENSION RCP(6),PRCP(6),ALPHA(6),DTO(7)
	DIMENSION IHKL(3),H(4),SDCOEF(6),HJ(3),HHJ(6)
	DIMENSION NAME(2,2),KIS(1),KBS(1),SP(1),DS(1),DEP(1)
	DIMENSION G1(3,3),G2(3,3),IH(1,1),OME(1,1),VM(1,1,1),IR(1,1)
	DIMENSION PM(1,1,1),SICO(1,1) ,JT(2,3),RM(1,1,1),XI(1,1)
	 DIMENSION SS(3),SSS(6)
        DIMENSION DADFN(150),DBDFN(150),DADXN(3,150),DBDXN(3,150)
        DIMENSION DADBN(6,150),DBDBN(6,150)
	COMMON ISENT,FRAC,SC,DFDS,KB,ITF,SF,AI,XYZ,BETA,DADFI,DBDFI
	COMMON DFDAI,DADX,DBDX,DFDX,DADB,DBDB,DFDB,IBI,LVI,LPM,NPM,MORD
	COMMON P,KI,DC,DV,V,PD,DIAG,AM,W,ROW,FX,TS,FS
	COMMON RCP,PRCP,ALPHA,DTO,IHKL,H,SDCOEF,HJ,HHJ
	COMMON NC,NVO,NX,ID,IW,IP,IT,IFSQ,NF,NA,ICENT,NS,NQ,NV,NNA,NP,NO
	COMMON IC,NCY,NINC,IQ,ISING,ISTOP,SITETL,SINMIN
	COMMON TJ,HX,HHB,RHO,SINTHL,SQTO,A,B,FC,SQRTAB,FINC,DINC,YO,YC,DY
	COMMON SQRTW,WDY,SIG,SQSIG
	COMMON NAME,KIS,KBS,SP,DS,DEP,XI
	COMMON VOL,G1,G2,NMOL,NG,IH,OME,VM,PM,SICO,NT,IR,JT,RM
	 COMMON ND,ZWBX,ZWBY,ZWBZ,ZWBT,ZWBU,ZWBV,ZWBW
	 COMMON NKAS,FI1S(3),RFIS(3),FLAMDA,CONST,EXTAL,IWHSO,EXTN,IWBCD
        COMMON DADFN,DBDFN,DADXN,DBDXN,DADBN,DBDBN
	COMMON /B1/ATOM,TITLE,LABEL,PARIN,PARAUS,DATIN
        IFLACK = 0
	 IF(ICENT-1)30,30,20
20	    AMULT=1.0
         IF(NKAS.GT.1) IFLACK=1
	 GO TO 40
30	    AMULT=2.0
40	    CONTINUE
	DO 60 I=1,NNA
	DADFI(I)=0.0
	DBDFI(I)=0.0
        DADFN(I)=0.0
        DBDFN(I)=0.0
	DO 50 K=1,3
        DADXN(K,I)=0.0
        DBDXN(K,I)=0.0
	DADX(K,I)=0.0
50	DBDX(K,I)=0.0
	DO 60 K=1,6
        DADBN(K,I)=0.0
        DBDBN(K,I)=0.0
	DADB(K,I)=0.0
60	DBDB(K,I)=0.0
	TOPISQ=19.7392088
	RHO=H(1)**2*PRCP(1)+H(2)**2*PRCP(2)+H(3)**2*PRCP(3)
	1+2.*H(1)*H(2)*PRCP(4)+2.*H(2)*H(3)*PRCP(5)+2.*H(1)*H(3)*PRCP(6)
	TPSS=4.*TOPISQ*RHO
	DO 300 J=1,NS
	TJ=0.0
	DO80I=1,3
	TJ=TJ+H(I)*TS(I,J)
	HJ(I)=0.0
	DO70K=1,3
70	HJ(I)=HJ(I)+H(K)*FS(I,K,J)
80	CONTINUE
	HHJ(1)=TOPISQ*(HJ(1)*RCP(1))**2
	HHJ(2)=TOPISQ*(HJ(2)*RCP(2))**2
	HHJ(3)=TOPISQ*(HJ(3)*RCP(3))**2
	HHJ(4)=2.*TOPISQ*HJ(1)*HJ(2)*RCP(1)*RCP(2)
	HHJ(5)=2.*TOPISQ*HJ(2)*HJ(3)*RCP(2)*RCP(3)
	HHJ(6)=2.*TOPISQ*HJ(1)*HJ(3)*RCP(1)*RCP(3)
	IF(ITF(1)-1)90,90,100
90	HBO=TPSS*BETA(1,1)
	GO TO 120
100	HBO=0.0
	DO 110 K=1,6
110	HBO=HBO+HHJ(K)*BETA(K,1)
120	DO 290 I=2,NNA
	IF(AI(I))130,290,130
130	HX=TJ
	DO 140 K=1,3
140	HX=HX+HJ(K)*XYZ(K,I)
	HX=6.28318531*HX
	CJ=COS(HX)
	SJ=SIN(HX)
	IF(ITF(I)-1)150,150,160
150	HHB=HBO+TPSS*BETA(1,I)
	GO TO 180
160	HHB=HBO
	DO 170 K=1,6
170	HHB=HHB+HHJ(K)*BETA(K,I)
180	EXPIJ=EXP(-HHB)
190	COSIJ=CJ*EXPIJ
	SINIJ=SJ*EXPIJ
200	DADFI(I)=DADFI(I)+COSIJ
	DO 210 K=1,3
210	DADX(K,I)=DADX(K,I)+HJ(K)*SINIJ
220	DO 230 K=1,6
230	DADB(K,I)=DADB(K,I)+HHJ(K)*COSIJ
240	IF(ICENT-1)290,290,250
250	DBDFI(I)=DBDFI(I)+SINIJ
	DO 260 K=1,3
260	DBDX(K,I)=DBDX(K,I)+HJ(K)*COSIJ
270	DO 280 K=1,6
280	DBDB(K,I)=DBDB(K,I)+HHJ(K)*SINIJ
290	CONTINUE
300	CONTINUE
	 A=0.0
	B=0.0
        AN=0.0
        BN=0.0
	IF(NF)310,320,310
310	SINTHL=SQRT(RHO)
	LSF=0
320	DO 640 I=2,NNA
	IF(AI(I))330,640,330
330	IF(NF)350,340,350
340	FI=SF(I)
	GO TO 390
350	L=SF(I)
	IF(L-LSF)360,430,360
360	LSF=L
	IF(L)  380,370,380
370	FI=1.0
	GO TO 390
380	PT=2.0+SINTHL/FX(1,2*L-1)
	IPT=PT
	FRACPT=PT-FLOAT(IPT)
	CRACPT=1.-FRACPT
	FI=CRACPT*(FX(IPT,2*L-1)+(CRACPT**2-1.)*FX(IPT,2*L)/6.)+FRACPT*(FX
	1(IPT+1,2*L-1)+(FRACPT**2-1.)*FX(IPT+1,2*L)/6.)
390	     IF(NF)400,420,400
400	     IF(L-NKAS)410,410,420
410	     FI1=FI1S(L)
	 RFI=RFIS(L)
	 FI=FI+FI1
	 GO TO 430
420	     FI1=0.0
	 RFI=0.0
430	     FTA=FI*AI(I)
	 RFTA=RFI*AI(I)
440	     FTACOS=FTA*DADFI(I)-RFTA*DBDFI(I)
	 A=A+FTACOS
	 S1=DADFI(I)
	 DADFI(I)=FI*DADFI(I)-RFI*DBDFI(I)
         IF(IFLACK.NE.0) THEN
         FTANCS=FTA*S1+RFTA*DBDFI(I)
	 AN=AN+FTANCS
	 DADFN(I)=FI*S1+RFI*DBDFI(I)
	 ENDIF
	 PIFI=-6.28318531*FTA
	 RPIFI=-6.28318531*RFTA
	 DO 450 K=1,3
	 SS(K)=DADX(K,I)
	 IF(IFLACK.NE.0) DADXN(K,I)=PIFI*SS(K)-RPIFI*DBDX(K,I)
450	     DADX(K,I)=PIFI*DADX(K,I)+RPIFI*DBDX(K,I)
	 IF(ITF(1)-1)460,460,470
460	     DADB(1,1)=DADB(1,1)-TPSS*FTACOS
	 IF(IFLACK.NE.0) DADBN(1,1)=DADBN(1,1) - TPSS*FTANCS
	 GO TO 490
470	     DO 480 K=1,6
	 IF(IFLACK.NE.0) DADBN(K,1)=DADBN(K,1)-FTA*DADB(K,I)-RFTA*DBDB(K,I)
480	     DADB(K,1)=DADB(K,1)-FTA*DADB(K,I)+RFTA*DBDB(K,I)
490	     IF(ITF(I)-1)520,520,500
500	     DO 510 K=1,6
	 SSS(K)=DADB(K,I)
	 IF(IFLACK.NE.0) DADBN(K,I)=-FTA*DADB(K,I)-RFTA*DBDB(K,I)
510	     DADB(K,I)=-FTA*DADB(K,I)+RFTA*DBDB(K,I)
	 GO TO 530
520	     DADB(1,I)=-TPSS*FTACOS
	 IF(IFLACK.NE.0) DADBN(1,I) = -TPSS*FTANCS
530	     IF(ICENT-1)540,540,550
540	     IF(NKAS)550,640,550
550	     FTASIN=FTA*DBDFI(I)+RFTA*S1
	 B=B+FTASIN
	 IF(IFLACK.NE.0) THEN
	 FTANSN = -FTA*DBDFI(I) + RFTA*S1
	 BN = BN + FTANSN
	 DBDFN(I) =-FI*DBDFI(I) + RFI*S1
	 ENDIF
	 DBDFI(I)=FI*DBDFI(I)+RFI*S1
	 PIFI=-PIFI
	 DO 560 K=1,3
	 IF(IFLACK.NE.0) DBDXN(K,I)=-PIFI*DBDX(K,I)+RPIFI*SS(K)
560	     DBDX(K,I)=PIFI*DBDX(K,I)+RPIFI*SS(K)
	 IF(ITF(1)-1)570,570,580
570	     DBDB(1,1)=DBDB(1,1)-TPSS*FTASIN
	 IF(IFLACK.NE.0)DBDBN(1,1)=DBDBN(1,1)-TPSS*FTANSN
	 GO TO 600
580	     DO 590 K=1,6
	 IF(IFLACK.NE.0)DBDBN(K,1)=DBDBN(K,1)+FTA*DBDB(K,I)+
     1 RFTA*SSS(K)
590	     DBDB(K,1)=DBDB(K,1)-FTA*DBDB(K,I)+RFTA*SSS(K)
600	     IF(ITF(I)-1)630,630,610
610	     DO 620 K=1,6
	  IF(IFLACK.NE.0) DBDBN(K,I)= FTA*DBDB(K,I)-RFTA*SSS(K)
620	     DBDB(K,I)=-FTA*DBDB(K,I)-RFTA*SSS(K)
	 GO TO 640
630	     DBDB(1,I)=-TPSS*FTASIN
	 IF(IFLACK.NE.0) DBDBN(1,I) =-TPSS*FTANSN
640	     CONTINUE
	DO 650 I=1,NQ
650	     DFDS(I)=0.0
	 IQ=H(4)
	 SQTO=SC(IQ)*AMULT
	 IF(IFSQ-1)660,660,730
C----	REFINEMENT ON F
660	     IF(ICENT-1)670,670,690
670	     IF(NKAS)690,680,690
680	     CA=SIGN(SQTO,A)
	 CB=0.0
	 YC=CA*A
	 SQRTAB=ABS(A)
	 GO TO 720
690	 IF(IFLACK.EQ.0) THEN 
	SQRAB = A*A + B*B
	ELSE
	SQRAB=(1.0-AI(1))*(A**2+B**2)+AI(1)*(AN**2+BN**2)
	ENDIF
	IF(SQRAB.GE.0.0) THEN
	SQRTAB=SQRT(SQRAB)
	ELSE
	SQRTAB = 0.0
	ENDIF
	 YC=SQTO*SQRTAB
	 IF(SQRTAB)710,700,710
700	     CA=0.0
	 CB=0.0
	CAN = 0.0
	CBN = 0.0
	 GO TO 720
710	IF(IFLACK.EQ.0) THEN
	CA = SQTO*A/SQRTAB
	CB = SQTO*B/SQRTAB
	ELSE
	CA = (1.0-AI(1))*SQTO*A/SQRTAB
	CB = (1.0-AI(1))*SQTO*B/SQRTAB
	CAN = AI(1)*SQTO*AN/SQRTAB
	CBN = AI(1)*SQTO*BN/SQRTAB
C----	ENANTIOMORPH DERIVATIVE
	DFDAI(1)=0.5*SQTO*(-A*A-B*B+AN*AN+BN*BN)/SQRTAB
	ENDIF
720	     DFDS(IQ)=YC/SC(IQ)
	 GO TO 780
C----	REFINEMENT ON F**2
730	     SQTO=SQTO**2
	 IF(ICENT-1)740,740,760
740	     IF(NKAS)760,750,760
750	     CA=2.0*SQTO*A
	 CB=0.0
	 YC=CA*A/2.0
	 SQRTAB=ABS(A)
	 GO TO 770
760	IF(IFLACK.EQ.0) THEN
   	     YC=SQTO*(A*A+B*B)
	 CA=2.0*SQTO*A
	 CB=2.0*SQTO*B
	 SQRTAB=SQRT(A*A+B*B)
	ELSE
	YC=SQTO*((1.0-AI(1))*(A*A+B*B)+AI(1)*(AN*AN+BN*BN))
	CA = 2.0*(1.0-AI(1))*SQTO*A
	CB = 2.0*(1.0-AI(1))*SQTO*B
	CAN = 2.0*AI(1)*SQTO*AN
	CBN = 2.0*AI(1)*SQTO*BN
	SQRTAB = SQRT(AMAX1(0.0,YC/SQTO))
C----	DERIVATIVE OF THE ENTANTIOPOL W.R.T. F**2
	DFDAI(1)=SQTO*(-A*A-B*B+AN*AN+BN*BN)
	ENDIF
770	     DFDS(IQ)=2.0*YC/SC(IQ)
C----	APPLY GENERAL FACTORS
780	     A=A*AMULT
	 B=B*AMULT
	AN=AN*AMULT
	BN=BN*AMULT
	EXTN=1.0
	IF(FLAMDA.EQ.0.0)  GOTO 790
C************************************************************
C	A MESSAGE FROM H.D.FLACK ON THE 6TH. APRIL 1984.  THERE
C	SEEMS TO ME TO BE A FAIR NUMBER OF ERRORS IN THE CALCULATION
C	BOTH OF THE EXTINCTION CORRECTION AND ITS DERIVATIVES. I 
C	SHOULDN'T THINK THAT IT HAS EVER BEEN USED IN F**2 REFINEMENT
C
C
	SINTH = SINTHL * FLAMDA
	EXTN = 1.0 - 0.0001*SC(NQ)*YC*YC / (SINTH*SQTO*SQTO )
	A = A * EXTN
	B = B * EXTN
	YC = YC * EXTN
	DFDS(IQ) = DFDS(IQ) * EXTN
	DFDS(NQ) = - 0.0001*YC**3 / (SINTH*SQTO**3)
C****************************************************************
790	 DO 870 I=1,NNA
	 IF(I-1)830,830,800
800	     IF(AI(I))810,870,810
810	     DFDAI(I)=(CA*DADFI(I)+CB*DBDFI(I))*EXTAL
	IF(IFLACK.NE.0) DFDAI(I)=DFDAI(I)+
     1 (CAN*DADFN(I)+CBN*DBDFN(I))*EXTAL
	 DO 820 K=1,3
   	     DFDX(K,I)=(CA*DADX(K,I)+CB*DBDX(K,I))*EXTAL
	IF(IFLACK.NE.0)DFDX(K,I)=DFDX(K,I)+
     1  (CAN*DADXN(K,I)+CBN*DBDXN(K,I))*EXTAL
820	CONTINUE
830	     IF(ITF(I)-1)840,840,850
840	     DFDB(1,I)=(CA*DADB(1,I)+CB*DBDB(1,I))*EXTAL
	IF(IFLACK.NE.0) DFDB(1,I) = DFDB(1,I) +
     1  (CAN*DADBN(1,I)+CBN*DBDBN(1,I))*EXTAL
	 GO TO 870
850	     DO 860 K=1,6
   	     DFDB(K,I)=(CA*DADB(K,I)+CB*DBDB(K,I))*EXTAL
	IF(IFLACK.NE.0) DFDB(K,I)=DFDB(K,I) +
     1 (CAN*DADBN(K,I)+CBN*DBDBN(K,I))*EXTAL
860	CONTINUE
870	     CONTINUE
	 CALL SBTOP(DC,DFDS,DFDAI,DFDX,DFDB,ITF,NNA,NQ,NP)
880	     RETURN
	 END
	 SUBROUTINE PRELIM
	CHARACTER*5 PARIN,PARAUS,DATIN
	CHARACTER ATOM(150)*8,TITLE*72,LABEL(2,2,12)*4
	 INTEGER ZWBX,ZWBY,ZWBU
	 DIMENSION SC(5),DFDS(5)
	 DIMENSION KB(150),ITF(150),SF(150),AI(150),XYZ(3,150)
	 DIMENSION BETA(6,150),DADFI(150),DBDFI(150),DFDAI(150),DADX(3,150)
	 DIMENSION DBDX(3,150),DFDX(3,150),DADB(6,150),DBDB(6,150),DFDB(6,150)
	 DIMENSION IBI(160),LVI(160),LPM(160),NPM(150),MORD(160)
	DIMENSION P(1500),KI(1500),DC(1500),DV(1500),V(1500),PD(1500),
     *	DIAG(1500)
	DIMENSION AM(99000),W(1500),ROW(1500),FX(32,20),TS(3,24),FS(3,3,24)
	DIMENSION RCP(6),PRCP(6),ALPHA(6),DTO(7)
	DIMENSION IHKL(3),H(4),SDCOEF(6),HJ(3),HHJ(6),RMT(3,3),RMT1(3,3)
	DIMENSION NAME(2,2),KIS(1),KBS(1),SP(1),DS(1),DEP(1)
	DIMENSION G1(3,3),G2(3,3),IH(1,1),OME(1,1),VM(1,1,1),IR(1,1)
	DIMENSION PM(1,1,1),SICO(1,1) ,JT(2,3),RM(1,1,1),XI(1,1)
	DIMENSION DADFN(150),DBDFN(150),DADXN(3,150),DBDXN(3,150)
	DIMENSION DADBN(6,150),DBDBN(6,150)
	COMMON ISENT,FRAC,SC,DFDS,KB,ITF,SF,AI,XYZ,BETA,DADFI,DBDFI
	COMMON DFDAI,DADX,DBDX,DFDX,DADB,DBDB,DFDB,IBI,LVI,LPM,NPM,MORD
	COMMON P,KI,DC,DV,V,PD,DIAG,AM,W,ROW,FX,TS,FS
	COMMON RCP,PRCP,ALPHA,DTO,IHKL,H,SDCOEF,HJ,HHJ
	COMMON NC,NVO,NX,ID,IW,IP,IT,IFSQ,NF,NA,ICENT,NS,NQ,NV,NNA,NP,NO
	COMMON IC,NCY,NINC,IQ,ISING,ISTOP,SITETL,SINMIN
	COMMON TJ,HX,HHB,RHO,SINTHL,SQTO,A,B,FC,SQRTAB,FINC,DINC,YO,YC,DY
	COMMON SQRTW,WDY,SIG,SQSIG
	COMMON NAME,KIS,KBS,SP,DS,DEP,XI
	COMMON VOL,G1,G2,NMOL,NG,IH,OME,VM,PM,SICO,NT,IR,JT,RM
	COMMON ND,ZWBX,ZWBY,ZWBZ,ZWBT,ZWBU,ZWBV,ZWBW
	 COMMON NKAS,FI1S(3),RFIS(3),FLAMDA,CONST,EXTAL,IWHSO,EXTN,IWBCD
	COMMON DADFN,DBDFN,DADXN,DBDXN,DADBN,DBDBN
	COMMON /B1/ATOM,TITLE,LABEL,PARIN,PARAUS,DATIN
	ITF(1)=0
	BETA(1,1)=0.0
C OVERALL TEMP. FAC. FEATURE REMOVED
10	READ(ZWBY,320) ICARD,IFSQ,NF,NA,ICENT,NS,NQ,ND,SITETL,SINMIN,
	1FRAC ,NKAS
	IF(ICARD.EQ.2)  GO TO 20
	WRITE(ZWBX,540) ICARD
	CALL EXIT
20	IF(NA.GT.149)  CALL EXIT
	 IF(IFSQ-1)30,30,40
30	WRITE(ZWBX,330)
	GO TO50
40	WRITE(ZWBX,340)
	 IF(SITETL.EQ.0)  SITETL=1.
C     CARDS 00031-00040 HAVE BEEN REMOVED. ISOTROPIC AND ANISOTROPIC
C     ATOMS CAN BE REFINED SIMULTANEOUSLY.
50	WRITE(ZWBX,350)NF
	IF(NF.GT.10) CALL EXIT
	WRITE(ZWBX,360)NA
	IF(ICENT-1)60,60,70
60	WRITE(ZWBX,370)
	GO TO 80
70	WRITE(ZWBX,380)
80	WRITE(ZWBX,390)NS
	WRITE(ZWBX,400)NQ
	IF(NF)90,110,90
90	I2NF=2*NF
	IF(SITETL.NE.0)WRITE(ZWBX,550)SITETL
	IF(SINMIN.NE.0)WRITE(ZWBX,560)SINMIN
	 IF(FRAC.NE.0)WRITE(ZWBX,570)FRAC
	READ(ZWBY,410)((FX(I,J),I=1,32),J=1,I2NF)
	DO 100 J=1,NF
	WRITE(ZWBX,420)J
	K=2*J
	M=2*J-1
100	WRITE(ZWBX,430)(FX(I,M),I=1,32),(FX(I,K),I=1,32)
110	READ(ZWBY,440)(IDUM,(TS(I,J),(FS(K,I,J),K=1,3),I=1,3),J=1,NS)
	WRITE(ZWBX,450)
	WRITE(ZWBX,460)((TS(I,J),(FS(K,I,J),K=1,3),I=1,3),J=1,NS)
	READ(ZWBY,470)(RCP(K),K=1,6)
	 IF(RCP(5).LE.1.)GO TO 120
	 RCP(4)=COS(RCP(4)*3.1415926/180.)
	 RCP(5)=COS(RCP(5)*3.1415926/180.)
	 RCP(6)=COS(RCP(6)*3.1415926/180.)
120	  IF(RCP(1).LE.1.)GO TO 140
130	  RMT(1,1)=RCP(1)*RCP(1)
	 RMT(2,2)=RCP(2)*RCP(2)
	 RMT(3,3)=RCP(3)*RCP(3)
	 RMT(1,2)=RCP(1)*RCP(2)*RCP(6)
	 RMT(1,3)=RCP(1)*RCP(3)*RCP(5)
	 RMT(2,3)=RCP(2)*RCP(3)*RCP(4)
	 RMT(2,1)=RMT(1,2)
	 RMT(3,1)=RMT(1,3)
	 RMT(3,2)=RMT(2,3)
	 WRITE(ZWBX,610)(RCP(K),K=1,6)
	 CALL INVERS(RMT,RMT1)
	 RCP(1)=SQRT(ABS(RMT1(1,1)))
	 RCP(2)=SQRT(ABS(RMT1(2,2)))
	 RCP(3)=SQRT(ABS(RMT1(3,3)))
	 RCP(6)=RMT1(1,2)/(RCP(1)*RCP(2))
	 RCP(5)=RMT1(1,3)/(RCP(1)*RCP(3))
	 RCP(4)=RMT1(2,3)/(RCP(2)*RCP(3))
140	    WRITE(ZWBX,620)(RCP(K),K=1,6)
	  PRCP(1)=RCP(1)**2*.25
	PRCP(2)=RCP(2)**2*.25
	PRCP(3)=RCP(3)**2*.25
	PRCP(4)=RCP(1)*RCP(2)*RCP(6)*.25
	PRCP(5)=RCP(2)*RCP(3)*RCP(4)*.25
	PRCP(6)=RCP(1)*RCP(3)*RCP(5)*.25
	VOL=1.0/((RCP(1)*RCP(2)*RCP(3))**2*(1.0+2.0*RCP(4)*RCP(5)*RCP(6)-R
	1CP(4)**2-RCP(5)**2-RCP(6)**2))
	DO 150 I=1,3
150	G2(I,I)=4.0*PRCP(I)
	G2(1,2)=4.0*PRCP(4)
	G2(2,1)=G2(1,2)
	G2(1,3)=4.0*PRCP(6)
	G2(3,1)=G2(1,3)
	G2(2,3)=4.0*PRCP(5)
	G2(3,2)=G2(2,3)
	G1(1,1)=VOL*(G2(2,2)*G2(3,3)-G2(2,3)**2)
	G1(2,2)=VOL*(G2(1,1)*G2(3,3)-G2(1,3)**2)
	G1(3,3)=VOL*(G2(1,1)*G2(2,2)-G2(1,2)**2)
	G1(1,2)=VOL*(G2(2,3)*G2(1,3)-G2(1,2)*G2(3,3))
	G1(2,1)=G1(1,2)
	G1(2,3)=VOL*(G2(1,3)*G2(1,2)-G2(2,3)*G2(1,1))
	G1(3,2)=G1(2,3)
	G1(1,3)=VOL*(G2(1,2)*G2(2,3)-G2(1,3)*G2(2,2))
	G1(3,1)=G1(1,3)
	ALPHA(1)=1.0
	ALPHA(2)=1.0
	ALPHA(3)=1.0
	ALPHA(4)=RCP(6)
	ALPHA(5)=RCP(4)
	ALPHA(6)=RCP(5)
	NNA=NA+1
	READ(ZWBY,480) ICARD,(SC(I),I=1,NQ)
	WRITE(ZWBX,630) (SC(I),I=1,NQ)
	IF(ICARD.EQ.4)  GO TO 160
	WRITE(ZWBX,510) ICARD
	CALL EXIT
160	READ(ZWBY,500) ICARD,IC,FLAMDA,EXTIN,AI(1)
	IF(FLAMDA.LE.0.0)    GOTO 170
	NQ=NQ+1
	SC(NQ)=EXTIN
	CONST=0.079398*FLAMDA**3/VOL
C	REFINEMENT OF OVERALL TEMP.FACTOR REMOVED
C	REFINEMENT OF EXTINCTION PARAMETER ADDED
C	READ IN ON PREVIOUS CARD
C	REFINEMENT OF ENTPOL HAS BEEN ADDED BY H.D.FLACK
C	THE ENTPOL PARAMETER IS KEPT IN THE SLOT OF THE POPULATION
C	PARAMETER OF THE BUSING AND LEVY PSEUDO FIRST ATOM	
170	     WRITE(ZWBX,660) IC,EXTIN,FLAMDA,AI(1)
	IF(ICARD.EQ.51)  GO TO 180
	WRITE(ZWBX,540)ICARD
	CALL EXIT
180	IF(NKAS.EQ.0) GO TO 190
   	READ(ZWBY,501)ICARD,IC,(FI1S(I),RFIS(I),I=1,NKAS)
	 WRITE(ZWBX,640)NKAS
	 WRITE(ZWBX,650)(FI1S(I),RFIS(I),I=1,NKAS)
   	IF(ICARD.EQ.52) GO TO 190
	WRITE(ZWBX,540) ICARD
	CALL EXIT
190	IF(IP)200,210,200
200	NT = ZWBU
	REWIND ZWBU
	OPEN(UNIT=ZWBU,ACCESS='SEQUENTIAL',TYPE='UNKNOWN',NAME=PARIN)
	GO TO 220
210	NT = ZWBY
220	KB(1) = 1
	NP=NQ-3
	WRITE(ZWBX,580)
	IF (IWBCD.NE.3) THEN
	DO 230 I=2,NNA
	READ(NT,520)ATOM(I),KB(I),SF(I),AI(I),(XYZ(K,I),K=1,3)
	 IF(AI(I).GT.2)  CALL EXIT
	READ(NT,530)ITF(I),(BETA(K,I),K=1,4),BETA(6,I),BETA(5,I)
	WRITE(ZWBX,590)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3)
230	WRITE(ZWBX,600) (BETA(K,I),K=1,6)
	ELSE
	DO I=2,NNA
	READ(NT,520)ATOM(I),KB(I),SF(I),AI(I),(XYZ(K,I),K=1,3)
	 IF(AI(I).GT.2)  CALL EXIT
	READ(NT,530)ITF(I),(BETA(K,I),K=1,4),BETA(6,I),BETA(5,I)
	WRITE(ZWBX,8111)ATOM(I),SF(I),AI(I),(XYZ(K,I),K=1,3),(BETA(L,I),L=1,6)
8111	FORMAT(1H0,A5,2X,' SF-TAB ',F4.2,' OCC ',F4.2,' X=',F8.5,' Y=',
     *	F8.5,' Z=',F8.5,'     U =',6F8.5)
	END DO
	END IF
	DO 290 I=1,NNA
	IF(ITF(I)-2)280,270,240
240	DO 250 K=2,6
250	BETA(K,I)=ALPHA(K)*BETA(1,I)
260	ITF(I)=2
270	NP=NP+10
	GOTO290
280	NP=NP+5
290	CONTINUE
	 IF(NP.GT.1500)GO TO 300
	 GO TO 310
300	    TYPE 670,NP
	CALL EXIT
310	CALL SBTOP(P,SC,AI,XYZ,BETA,ITF,NNA,NQ,NP)
	RETURN
320	FORMAT(20X,8I3,3F6.4,I3)
330	FORMAT(1H0,20X,33H WEIGHTED R FACTOR BASED ON Y = F)
340	FORMAT(1H0,20X,40H WEIGHTED R FACTOR BASED ON Y = F SQUARE)
350	FORMAT (1H0,20X,36H NUMBER OF SCATTERING FACTOR TABLES-I3)
360	FORMAT (1H0,20X,36H NUMBER OF ATOMS IN ASYMMETRIC UNIT-I3,' MAXIMU
	1M IS 149')
370	FORMAT (1H0,20X,16H CENTROSYMMETRIC)
380	FORMAT (1H0,20X,'NON-CENTROSYMMETRIC')
390	FORMAT (1H0,20X,' NUMBER OF SYMMETRY ELEMENTS- ',I3)
400	FORMAT (1H0,20X,25H NUMBER OF SCALE FACTORS-I3)
410	FORMAT (8F9.3)
420	FORMAT (1H0,30X,24H SCATTERING FACTOR TABLEI3/1H )
430	FORMAT (1H 8F12.3)
440	FORMAT (I1,F14.10,3F3.0,F15.10,3F3.0,F15.10,3F3.0)
450	FORMAT(1H0,30X,
	121H SYMMETRY INFORMATION/'0                TRANSFORMED X   
	2            TRANSFORMED Y                      TRANSFORMED Z'/1H )
460	FORMAT(1H  ,4X,F6.4,3H + ,F4.1,4HX + ,F4.1,4HY + ,F4.1,3HZ  ,
	1            4X,F6.4,3H + ,F4.1,4HX + ,F4.1,4HY + ,F4.1,3HZ  ,
	2            4X,F6.4,3H + ,F4.1,4HX + ,F4.1,4HY + ,F4.1,3HZ  )
470	FORMAT (6F9.6)
480	FORMAT(20X,I3,5F9.6)
490	FORMAT(2H ,30X,'*****CARD',I3,'(SCALE FACTORS) IN WRONG ORDER **')
500	FORMAT(20X,2I3,F9.6,2F9.4)
501	FORMAT(20X,2I3,6F6.3)
510	FORMAT(2H0,30X,'****CARD',I3,'(OVERALL TEMP.FAC.) IN WRONG ORDER')
520	FORMAT(A8,I3,5F9.6)
530	FORMAT(I6,6F9.6)
540	FORMAT(2H ,'***** CARD ',I3,' RECORD IN WRONG ORDER *****')
550	FORMAT(1H0,20X,' SIN THETA/LAMDA  MAX.LIMIT IS ',F6.4)
560	FORMAT(1H0,20X,' SIN THETA/LAMDA  MIN.LIMIT IS ',F6.4)
570	FORMAT(1H0,20X,' REFLECTIONS WITH FC/FO LESS THAN ',F6.4,' ARE OMI
	1TTED ')
580	FORMAT(1H0,21X,'ATOMIC PARAMETERS',/)
590	FORMAT(1H0,21X,A8,2X,' SF-TABLE ',F4.2,' OCCUPANCY ',F4.2,' X =',
	1F8.5,' Y= ',F8.5,' Z = ',F8.5)
600	FORMAT(1H0,32X,'U    =    ',6F8.5)
610	   FORMAT(1H0,20X,' REAL CELL DIMENSIONS   ',6F11.6)
620	   FORMAT(1H0,20X,' RECIPROCAL CELL DIMENSIONS ',6F11.6)
630	FORMAT(1H0,21X,17HSCALE FACTORS    ,6F11.6/1H ,37X,6F11.6)
640	      FORMAT(1H0,21X,'CORRECTION FOR'I3,'  ANOMALOUS SCATTERERS DE
	1LTA F'4X,9H DELTA F1)
650	      FORMAT(1H0,(63X,F6.3,6X,F6.3,/))
660	FORMAT(1H0,21X,'STARTING CYCLE NUMBER    ',I3/
	11H0,21X,'EXTINCTION PARAMETER    '    ,F9.5/
	21H0,21X,'WAVELENGTH USED        ',F9.6/
	31H0,21X,'ENANTIOMORPH-POLARITY PARAMETER',F9.6)
670	     FORMAT(1H0,20X,I4,' PARAMETERS ;LIMIT IS 1500')
	END
	SUBROUTINE TEST
	CHARACTER*5 PARIN,PARAUS,DATIN
	CHARACTER ATOM(150)*8,TITLE*72,LABEL(2,2,12)*4
	INTEGER ZWBX
	DIMENSION SC(5),DFDS(5)
	DIMENSION KB(150),ITF(150),SF(150),AI(150),XYZ(3,150)
	DIMENSION BETA(6,150),DADFI(150),DBDFI(150),DFDAI(150),DADX(3,150)
	DIMENSION DBDX(3,150),DFDX(3,150),DADB(6,150),DBDB(6,150),DFDB(6,150)
	DIMENSION IBI(160),LVI(160),LPM(160),NPM(150),MORD(160)
	DIMENSION P(1500),KI(1500),DC(1500),DV(1500),V(1500),PD(1500),
     *	DIAG(1500)
	DIMENSION AM(99000),W(1500),ROW(1500),FX(32,20),TS(3,24),FS(3,3,24)
	DIMENSION RCP(6),PRCP(6),ALPHA(6),DTO(7)
	DIMENSION IHKL(3),H(4),SDCOEF(6),HJ(3),HHJ(6)
	DIMENSION NAME(2,2),KIS(1),KBS(1),SP(1),DS(1),DEP(1)
	DIMENSION G1(3,3),G2(3,3),IH(1,1),OME(1,1),VM(1,1,1),IR(1,1)
	DIMENSION PM(1,1,1),SICO(1,1) ,JT(2,3),RM(1,1,1),XI(1,1)
	DIMENSION U(6)
	DIMENSION DADFN(150),DBDFN(150),DADXN(3,150),DBDXN(3,150)
	DIMENSION DADBN(6,150),DBDBN(6,150)
	COMMON ISENT,FRAC,SC,DFDS,KB,ITF,SF,AI,XYZ,BETA,DADFI,DBDFI
	COMMON DFDAI,DADX,DBDX,DFDX,DADB,DBDB,DFDB,IBI,LVI,LPM,NPM,MORD
	COMMON P,KI,DC,DV,V,PD,DIAG,AM,W,ROW,FX,TS,FS
	COMMON RCP,PRCP,ALPHA,DTO,IHKL,H,SDCOEF,HJ,HHJ
	COMMON NC,NVO,NX,ID,IW,IP,IT,IFSQ,NF,NA,ICENT,NS,NQ,NV,NNA,NP,NO
	COMMON IC,NCY,NINC,IQ,ISING,ISTOP,SITETL,SINMIN
	COMMON TJ,HX,HHB,RHO,SINTHL,SQTO,A,B,FC,SQRTAB,FINC,DINC,YO,YC,DY
	COMMON SQRTW,WDY,SIG,SQSIG
	COMMON NAME,KIS,KBS,SP,DS,DEP,XI
	COMMON VOL,G1,G2,NMOL,NG,IH,OME,VM,PM,SICO,NT,IR,JT,RM
	 COMMON ND,ZWBX,ZWBY,ZWBZ,ZWBT,ZWBU,ZWBV,ZWBW
	 COMMON NKAS,FI1S(3),RFIS(3),FLAMDA,CONST,EXTAL,IWHSO,EXTN,IWBCD
	COMMON DADFN,DBDFN,DADXN,DBDXN,DADBN,DBDBN
	COMMON /B1/ATOM,TITLE,LABEL,PARIN,PARAUS,DATIN
	DATA ZWBX/3/
	ISTOP=0
	IF(ITF(1)-1)10,10,30
10	DO 20 K=2,6
20	BETA(K,1)=ALPHA(K)*BETA(1,1)
30	DO 220 I=2,NNA
	IF(ITF(I)-1)40,40,100
40	DO 50 K=1,6
50	U(K)=ALPHA(K)*BETA(1,I)+BETA(K,1)
	IF(ID)60,130,130
60	IF(ITF(1)-1)70,70,80
70	BETA(1,I)=U(1)
	GO TO 130
80	ITF(I)=2
	DO 90 K=1,6
90	BETA(K,I)=U(K)
	NP=NP+5
	GO TO 130
100	DO 120 K=1,6
	U(K)=BETA(K,I)+BETA(K,1)
	IF(ID)110,120,120
110	BETA(K,I)=U(K)
120	CONTINUE
130	CONTINUE
140	DO 160 K=1,3
150	IF(U(K))210,160,160
160	CONTINUE
170	IF(U(1)*U(2)-U(4)*U(4))210,180,180
180	IF(U(2)*U(3)-U(5)*U(5))210,190,190
190	IF(U(1)*U(3)-U(6)*U(6))210,200,200
200	IF(U(1)*U(2)*U(3)+2.0*U(4)*U(5)*U(6)-U(1)*U(5)*U(5)-U(2)*U(6)*U(6)
	1-U(3)*U(4)*U(4))210,220,220
210	WRITE(ZWBX,260)ATOM(I)
	ISTOP=1
220	CONTINUE
	IF(ID)230,250,250
230	DO 240 K=1,6
240	BETA(K,1)=0.0
250	CALL SBTOP(P,SC,AI,XYZ,BETA,ITF,NNA,NQ,NP)
	RETURN
260	FORMAT(28H0TEMPERATURE FACTOR OF ATOM ,A8,25H IS NOT POSITIVE-DEF
	1INITE)
	END
	SUBROUTINE SBTOP(P,SC,AI,XYZ,BETA,ITF,NNA,NQ,NP)
	DIMENSION P(1500),SC(5),AI(150),XYZ(3,150),BETA(6,150),ITF(150)
10	I=1
20	DO 40 J=1,NQ
30	P(I)=SC(J)
40	I=I+1
50	DO 200 J=1,NNA
60	P(I)=AI(J)
70	I=I+1
	IF(J-1)110,110,80
80	DO 100 K=1,3
90	P(I)=XYZ(K,J)
100	I=I+1
110	IF(ITF(J)-1)120,120,150
120	P(I)=BETA(1,J)
130	I=I+1
140	GO TO 200
150	IF(ITF(J)-2)160,170,160
160	CONTINUE
170	DO 190 K=1,6
180	P(I)=BETA(K,J)
190	I=I+1
200	CONTINUE
	RETURN
	END
	SUBROUTINE PTOSB(P,SC,AI,XYZ,BETA,ITF,NNA,NQ,NP)
	DIMENSION P(1500),SC(5),AI(150),XYZ(3,150),BETA(6,150),ITF(150)
10	I=1
20	DO 40 J=1,NQ
30	SC(J)=P(I)
40	I=I+1
50	DO 200 J=1,NNA
60	AI(J)=P(I)
70	I=I+1
	IF(J-1)110,110,80
80	DO 100 K=1,3
90	XYZ(K,J)=P(I)
100	I=I+1
110	IF(ITF(J)-1)120,120,150
120	BETA(1,J)=P(I)
130	I=I+1
140	GO TO 200
150	IF(ITF(J)-2)160,170,160
160	CONTINUE
170	DO 190 K=1,6
180	BETA(K,J)=P(I)
190	I=I+1
200	CONTINUE
	RETURN
	END
	SUBROUTINE WEIGHT(STDHKL)
	CHARACTER*5 PARIN,PARAUS,DATIN
	CHARACTER ATOM(150)*8,TITLE*72,LABEL(2,2,12)*4
	DIMENSION SC(5),DFDS(5)
	DIMENSION KB(150),ITF(150),SF(150),AI(150),XYZ(3,150)
	DIMENSION BETA(6,150),DADFI(150),DBDFI(150),DFDAI(150),DADX(3,150)
	DIMENSION DBDX(3,150),DFDX(3,150),DADB(6,150),DBDB(6,150),DFDB(6,150)
	DIMENSION IBI(160),LVI(160),LPM(160),NPM(150),MORD(160)
	DIMENSION P(1500),KI(1500),DC(1500),DV(1500),V(1500),PD(1500),
     *	DIAG(1500)
	DIMENSION AM(99000),W(1500),ROW(1500),FX(32,20),TS(3,24),FS(3,3,24)
	DIMENSION RCP(6),PRCP(6),ALPHA(6),DTO(7)
	DIMENSION IHKL(3),H(4),SDCOEF(6),HJ(3),HHJ(6)
	DIMENSION NAME(2,2),KIS(1),KBS(1),SP(1),DS(1),DEP(1)
	DIMENSION G1(3,3),G2(3,3),IH(1,1),OME(1,1),VM(1,1,1),IR(1,1)
	DIMENSION PM(1,1,1),SICO(1,1) ,JT(2,3),RM(1,1,1),XI(1,1)
	DIMENSION DADFN(150),DBDFN(150),DADXN(3,150),DBDXN(3,150)
	DIMENSION DADBN(6,150),DBDBN(6,150)
	COMMON ISENT,FRAC,SC,DFDS,KB,ITF,SF,AI,XYZ,BETA,DADFI,DBDFI
	COMMON DFDAI,DADX,DBDX,DFDX,DADB,DBDB,DFDB,IBI,LVI,LPM,NPM,MORD
	COMMON P,KI,DC,DV,V,PD,DIAG,AM,W,ROW,FX,TS,FS
	COMMON RCP,PRCP,ALPHA,DTO,IHKL,H,SDCOEF,HJ,HHJ
	COMMON NC,NVO,NX,ID,IW,IP,IT,IFSQ,NF,NA,ICENT,NS,NQ,NV,NNA,NP,NO
	COMMON IC,NCY,NINC,IQ,ISING,ISTOP,SITETL,SINMIN
	COMMON TJ,HX,HHB,RHO,SINTHL,SQTO,A,B,FC,SQRTAB,FINC,DINC,YO,YC,DY
	COMMON SQRTW,WDY,SIG,SQSIG
	COMMON NAME,KIS,KBS,SP,DS,DEP,XI
	COMMON VOL,G1,G2,NMOL,NG,IH,OME,VM,PM,SICO,NT,IR,JT,RM
	 COMMON ND,ZWBX,ZWBY,ZWBZ,ZWBT,ZWBU,ZWBV,ZWBW
	 COMMON NKAS,FI1S(3),RFIS(3),FLAMDA,CONST,EXTAL,IWHSO,EXTN,IWBCD
	COMMON DADFN,DBDFN,DADXN,DBDXN,DADBN,DBDBN
	COMMON /B1/ATOM,TITLE,LABEL,PARIN,PARAUS,DATIN
	 IF(SDCOEF(6))  10,30,30
10	   IF(FINC)  20,30,30
20	    SQRTW = 0.0
	 GO TO 60
30	   IF(ISENT.EQ.-1)  GO TO 100
	 IF(ISENT.EQ.-2)  GO TO 90
	IF (ISENT.EQ.-3) THEN
	SQRTW=0.0
	IF (SINTHL.GE.SDCOEF(1)) SQRTW=SQRT(STDHKL)
	GO TO 60
	END IF
	IF (ISENT.EQ.-4) THEN
	XX = SDCOEF(1)*SINTHL*SINTHL
	SQRTW = STDHKL * EXP(XX)
	SQRTW = SQRT(SQRTW)
	GO TO 60
	END IF
	IF (ISENT.EQ.-5) THEN
	XX = SDCOEF(1)*SINTHL*SINTHL
	YY = SDCOEF(2) + EXP(XX)
	SQRTW = STDHKL * EXP(XX) / YY
	SQRTW = SQRT(SQRTW)
	GO TO 60
	END IF
	SDSQ=SC(IQ)**2*(SDCOEF(1)**2+4.0*RHO*SDCOEF(4)**2+(4.0*RHO*SDCOEF(
	15)**2)**4)+(0.5*SDCOEF(2)*FINC)**2/STDHKL+(SDCOEF(3)*FINC)**6
	SQRTW=1.0/SQRT(SDSQ)
	IF(IFSQ-1)60,60,40
40	IF(FINC)70,10,50
50	SQRTW=SQRTW/(2.0*ABS(FINC))
60	RETURN
70	IF(SDCOEF(6)+FINC)50,50,80
80	SQRTW=SQRTW/(2.0*SDCOEF(6))
	GO TO 60
90	    SQRTW = 1.0
	 GO TO 60
100	   SQRTW = SQRT(STDHKL)
	 GO TO 60
	END
	SUBROUTINE THOLD(FINC,DINC,NINC,SQRTW)
	IF(FINC)10,20,30
10	IF(DINC)30,30,20
20	FINC=0.0
	DINC=0.0
	SQRTW=0.0
	GO TO 50
30	IF(SQRTW)50,50,40
40	NINC=NINC+1
50	RETURN
	END
	SUBROUTINE INVERT(T,N,KK,KKK,MK,NSING,DET,V)
	DIMENSION T (99000), V(1500)
	EPS = 10.E-11
	MK1 = MK + 1
	LIMT = MK + N*(N+1)/2
	IF (1 - KK)    20, 10, 10
10	DET = 1.0
20	DO 70 K = KK, KKK
	IF(T(MK1) - EPS)  80, 80, 30
C     IF T(MK1) IS ZERO OR NEGATIVE, MATRIX IS SINGULAR
30	PIVOT = 1.0 / T(MK1)
	DO 40 I = 2, N
40	V(I-1) = T(MK+I)
	NN = N - 1
	L = MK + N
	JJ = MK1
	M = N
	DO 60 I = 1, NN
	T(L) = - V(I) * PIVOT
	Y = T(L)
	L = L + N - I
	DO 50 J = I, NN
	T(JJ) = T(JJ + M) + V(J) * Y
50	JJ = JJ + 1
	M = M - 1
60	JJ = JJ + 1
70	T(LIMT) = -PIVOT
C AT THIS POINT WE HAVE -(T INVERSE)
	NSING = 0
	RETURN
80	NSING = K
	END
	SUBROUTINE INVERS(A,B)
	DIMENSION A(3,3),B(3,3)
	DET=A(1,1)*A(2,2)*A(3,3)+A(1,2)*A(2,3)*A(3,1)+A(1,3)*A(2,1)*A(3,2)
	1-A(1,1)*A(3,2)*A(2,3)-A(2,1)*A(1,2)*A(3,3)-A(1,3)*A(2,2)*A(3,1)
	B(1,1)=(A(2,2)*A(3,3)-A(2,3)*A(3,2))/DET
	B(1,2)=(A(1,3)*A(3,2)-A(1,2)*A(3,3))/DET
	B(1,3)=(A(1,2)*A(2,3)-A(1,3)*A(2,2))/DET
	B(2,1)=(A(2,3)*A(3,1)-A(2,1)*A(3,3))/DET
	B(2,2)=(A(1,1)*A(3,3)-A(1,3)*A(3,1))/DET
	B(2,3)=(A(1,3)*A(2,1)-A(1,1)*A(2,3))/DET
	B(3,1)=(A(2,1)*A(3,2)-A(2,2)*A(3,1))/DET
	B(3,2)=(A(1,2)*A(3,1)-A(1,1)*A(3,2))/DET
	B(3,3)=(A(1,1)*A(2,2)-A(1,2)*A(2,1))/DET
	RETURN
	END
	SUBROUTINE TIME(ZEIT1)
	CHARACTER*8  ZEIT1
	ZEIT1 = 'GENFTIME'
	RETURN
	END
	SUBROUTINE DATE(DATUM)
	CHARACTER*9 DATUM
	DATUM = 'GENFDATUM'
	RETURN
	END
	SUBROUTINE JOBTIM(IJ)
	IJ=0
	RETURN
	END

