            SUBROUTINE CALREF(INP,IOUTP,LINE,MAXLIN,IMARK)                      
C                                                                               
C     ------  MAIN PROGRAM FOR THE LEAST-SQUARES PROGRAM REFINE -------         
C     -----------------   BY UDO ZUCKER MPI-FKF  ----------------------         
C                                                                               
C                                                                               
C     INPUT-VARIABLES                                                           
C     ---------------                                                           
C                                                                               
C     LINE(11) IS A ARRAY FOR THE NAME OF THE MAN WHO TAKES   CARE  FOR         
C                             THE PROGRAMME                                     
C     MAXLIN = MAXIMUM NUMBER OF LINES OF A PAGE FOR THE COMPUTER USED.         
C      IMARK = 0/1 FOR NORMAL/SHORT PRINT OUT                                   
C                                                                               
C                                                                               
      DIMENSION LINE(11)                                                        
C                                                                               
C     THE COMMON /LSMAT/ INCLUDES THE ARRAY 'A', WHICH  CAN BE USE WITH         
C     VARIABLE DIMENSION. THE NUMBER OF ELEMENTS DEPENDS ON  THE NUMBER         
C          OF REFINED PARAMETERS AND ON THE NUMBER OF CONSTRAINTS.              
C                                                                               
C     FORMULA FOR DIMENSION         DIM = MDEGN + ( MRANK*(MRANK+1) )/2         
C                                                                               
      COMMON/LSMAT/B(200),IEXT,IPARA(1000),MRANK,KCYL,LABEL(3),JSCRF(10         
     &       ),NRSF,SIGMA,MDEGN,MAXIMA,IALFA(60),RDAMP(200),IDAMP(200),         
     &                           A(10500)                                       
C                                                                               
C     THE FOLLOWING COMMONS ARE NECESSARY, IF THE  PROGRAM  RUNS  UNDER         
C     A  OVERLAY STRUCTURE.    (SPECIALLY FOR A HONEY-WELL BULL SYSTEM)         
C                                                                               
            COMMON/TAPE/IN,INN,IOUT,ISC1,ISC2,ISC3,ISC4,ISC5,IPUN               
                     COMMON/EXTI/II,JJ,RNURSO(100)                              
                       COMMON/ILABEL/IDATA1(49)                                 
C                                                                               
    4 FORMAT(3A4,2X,I2)                                                         
    6 FORMAT(10(/),2X,38(1H*)/2X,1H*,36X,1H*/2X,1H*,1X,                         
     &32HPARAMETERS WRITTEN OUT TO UNIT  ,I2,1X ,   1H*/2X,1H*,36X,             
     &1H*/2X,38(1H*))                                                           
C                                                                               
C     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++         
C     +                                                               +         
C     + THE VALUE OF  MAXIMA  MUST BE EQUAL TO THE  DIMENSION OF THE  +         
C     + ARRAY  'A' IN COMMOM 'LSMAT'.                                 +         
C     + IF SOMEONE IGNORES  THIS RULE, HE WOULD  GET UNFORESEEN  BUT  +         
C     + NORMALY  FATAL CONSEQUENCES.                                  +         
C     + IF THE PROGRAM 'REFINE' PRINTS THE MESSAGE, THAT  NOT SUFFI-  +         
C     + CIENT CORE IS AVAILABLE, DO THE FOLLOWING.                    +         
C     +            MAY THE CURRENT VALUE OF MAXIMA FOR EXAMPLE 2200   +         
C     + AND MAY THE VALUE NECESSARY FOR EXAMPLE 2812.  CHANGE FIRST   +         
C     + THE  BELOW  VALUE OF MAXIMA FROM '2200' TO AT LEAST '2812'.   +         
C     + THEN CHANGE THE VALUE OF THE DIMENSION OF 'A' IN THE  ABOVE   +         
C     + COMMON LIST /LSMAT/  TO AT LEAST 2812.    THAT'S ALL ......   +         
C     +                                                               +         
C     +                                                               +         
                         MAXIMA=10500                                           
C     +                                                               +         
C     +        MAXIMA HAVE TO BE GREATER THAN 346                     +         
C     +                                                               +         
C     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++         
C                                                                               
C     DEFINITIONS                                                               
C                                                                               
C     ICFILE  =  NUMBER OF THE UNIT ISC1 = MAIN UNIT DURING INPUT.              
C                DEFAULT VALUE FOR  ISC1 = SEE BLOCK DATA                       
C                                                                               
C---- FILL IN THE INPUT AND OUTPUT UNIT                                         
C                                                                               
      IN = INP                                                                  
      IOUT = IOUTP                                                              
C                                                                               
C---- READ LABEL OF PROGRAMME (WILL LATER BE IGNORED IF THIS IS NOT  AN         
C     "A PRIORI" RUN. ICFILE SEE ABOVE.                                         
C                                                                               
      READ(IN,4)LABEL,ICFILE                                                    
      IF(ICFILE.NE.0) ISC1=ICFILE                                               
C                                                                               
C---- NOW ADMINISTRATION OF THE RUN GOES TO SUBROUTINE REFINE.                  
C                                                                               
      CALL REFINE(LINE,MAXLIN,IMARK)                                            
C                                                                               
C---- IF NO OUTPUT HAD BEEN WRITTEN TO THE 'MAINUNIT' ISC1 , ISC1=0             
C                                                                               
      IF(ISC1.EQ.0) GOTO 7                                                      
C                                                                               
C---- OUTPUT HAD BEEN WRITTEN TO MAINUNIT.                                      
C                                                                               
      WRITE(IOUT,6)ISC1                                                         
C                                                                               
C                                                                               
   7  RETURN                                                                    
      END                                                                       
C                                                                               
      BLOCK DATA                                                                
      COMMON/IND23/IND2(2,6),IND3(3,10)                                         
      COMMON/TAPE/IN,INN,IOUT,ISC1,ISC2,ISC3,ISC4,ISC5,IPUN                     
      COMMON/ILABEL/IDATA1(49)                                                  
      DATA IND2/1,1,2,2,3,3,1,2,1,3,2,3/,IND3/1,1,1,2,2,2,3,3,3,1,1,2,1,        
     &2,2,1,1,3,1,3,3,2,2,3,2,3,3,1,2,3/                                        
C                                                                               
C---- UNITS AND THEIR MEANINGS                                                  
C     IN   = STANDARD INPUT-UNIT         IOUT = STANDARD OUTPUT-UNIT            
C     IPUN = STANDARD PUNCH-UNIT         ISC1 = MAINFILE                        
C     ISC2 = AUXILLARY FILE FOR STRUCTURE FACTORS OF CURRENT STRUCTURE          
C     ISC3 = FILE FOR ALTERNATIVE (INSTEAD OF HKL-CARDS VIA INPUT IN )          
C            STRUCTURE FACTORS                                                  
C     ISC4 = FOURIERFILE                                                        
C     ISC5 = AUXILLARY-FILE FOR CONSTRAINTS INFORMATION (SCRATCH FILE)          
C                                                                               
      DATA IPUN,ISC1,ISC2,ISC3,ISC4,ISC5/7,10,11,12,13,14/                      
C                                                                               
      DATA IDATA1 / 4H NO ,4HEXTI,4HNCTI,4HON C,4HORRE,4HCTIO,4HN   ,           
     &4H* IS,4HANIS,4HOTRO,4HPIC ,4HTYPE,4H 1  ,4H 2  ,4HGAUS,4HSIAN,           
     &4H  LO,4HRENT,4HZIAN,4H DIS,4HTRIB,4HUTIO,4HN   ,4HGENE,4HRAL ,           
     &4HCASE,4H    ,4HON P,4HARAM,4HETER,4HS  X,4H 10*,4H*-4 ,4HMOSA,           
     &4HIC S,4HPREA,4HD IN,4H SEC,4HONDS,4H OF ,4HARC ,4HDOMA,4HIN S,           
     &4HIZE ,4HIN C,4HENTI,4HMETE,4HRS  ,4H    /                                
      END                                                                       
C                                                                               
      SUBROUTINE INPOL(RHOO,M,RESULT)                                           
C                                                                               
C     FOUR POINTS INTERPOLATION FOR SCATTERING FACTORS GIVEN IN TABU-           
C     LATING FORM.   (AITKINS METHOD, EXTRACTED FROM XRAY 72 PROGRAM)           
C                                                                               
C     BY UDO ZUCKER   OCTOBER 1978                                              
C                                                                               
C     VARIABLES AND THEIR MEANINGS                                              
C     ----------------------------                                              
C     RHOO   =  (SIN(THETA)/LAMDA)**2                                           
C     M      =  NUMBER OF SCATTTERING CURVE                                     
C     RESULT =  VALUE OF THE SCATTERING FACTOR FOR THE GIVEN SIN(THETA)         
C               OVER LAMBDA VALUE.                                              
C                                                                               
C     IN THE CURRENT VERSION A MAXIMUM OF  35 INTERPOLATION  POINTS CAN         
C     BE GIVEN.  IMPORTANT IS THAT THE METHOD OF INTERPOLATION FAILS,IF         
C     THE GIVEN INTERPOLATION POINTS DO NOT FALL  IN  A  MONOTONIC WAY.         
C     A FIVE PERCENT DEVIATION FROM MONOTONY CAN BE ACCEPTED    WITHOUT         
C     FATAL ERRORS.                                                             
C                                                                               
      COMMON/G/BUFF(1023),FCURVE(9,20),IFMT(18),IWT,NSCAT,BETFAC,WVLNTH         
     &,WTFAC                                                                    
      COMMON/POL/INTER(20),X(35,4),Y(35,4),INTPOL                               
C                                                                               
      DIMENSION U(35),V(35),DIF(5)                                              
C                                                                               
      RHO=SQRT(RHOO)                                                            
C                                                                               
C---- FIRST CRACK OUT FIELD DESIGNATOR AND NUMBER OF INTERPOLATION              
C     POINTS                                                                    
C                                                                               
C     IF YOUR COMPUTER   DO NOT CUT A   INTEGER DIVISION  TO  THAT              
C     INTEGER WHICH IS LESS OR EQUAL TO THE REAL RESULT,     WRITE              
C                                                                               
C     IPOL=INT(FLOAT(INTER(M))/100.)                                            
C                                                                               
      IPOL=INTER(M)/100                                                         
      NO  =INTER(M)-IPOL*100                                                    
C                                                                               
C---- IPOL IS DESIGNATOR AND NO  NUMBER OF INTERPOLATION POINTS.                
C                                                                               
      DO 1201 J=1,NO                                                            
C                                                                               
      U(J)=X(J,IPOL)                                                            
      V(J)=Y(J,IPOL)                                                            
 1201 CONTINUE                                                                  
      K=1                                                                       
 1203 IF(RHO-U(K)) 1207,1206,1204                                               
 1204 K=K+1                                                                     
      IF(K-NO+1) 1203,1206,1206                                                 
 1206 RESULT=V(K)                                                               
      GO TO 9999                                                                
 1207 K=K-1                                                                     
      DO 1208 I=1,3                                                             
      J=K+I                                                                     
 1208 DIF(I)=((V(K)*(U(J)-RHO))-(V(J)*(U(K)-RHO)))/                             
     &((U(J))-(U(K)))                                                           
      DIF(4)=((DIF(1)*(U(K+2)-RHO))-(DIF(2)*(U(K+1)-RHO)))/                     
     &(U(K+2)-U(K+1))                                                           
      DIF(5)=((DIF(1)*(U(K+3)-RHO))-(DIF(3)*(U(K+1)-RHO)))/                     
     &(U(K+3)-U(K+1))                                                           
      RESULT=((DIF(4)*(U(K+3)-RHO))-(DIF(5)*(U(K+2)-RHO)))/                     
     &(U(K+3)-U(K+2))                                                           
C                                                                               
 9999 RETURN                                                                    
      END                                                                       
C                                                                               
                   SUBROUTINE REFINE(LINE,MAXPG,IMARK)                          
C                                                                               
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++          
C +                                                                  +          
C +    STRUCTURE FACTOR CALCULATION AND LEAST SQUARES REFINEMENT     +          
C +            MAXIMUM OF 60 ATOMS, 10 SCALE FACTORS,                +          
C +      20 SCATTERING FACTORS, 200 LEAST-SQUARES PARAMETERS         +          
C +                 AND 24 SYMMETRY OPERATIONS                       +          
C +                                                                  +          
C +                JULY  1966    BY L. W. FINGER                     +          
C +                                                                  +          
C +    MODIFIED NOV 7,1966 FOR BLOCKED STRUCTURE FACTOR RECORDS      +          
C +       MODIFIED JAN 30,1967 FOR EXTINCTION CORRECTION             +          
C +        SPECIAL PARAMETER REFINEMENT ADDED FEB. 1972              +          
C +            THIS ROUTINE REVISED  APRIL 12,1972                   +          
C +                                                                  +          
C +                                                                  +          
C +        ADDITIONS BY UDO ZUCKER, MAX-PLANCK INSTITUT FUER         +          
C +            FESTKOERPERFORSCHUNG  STUTTGART  GERMANY.             +          
C +                                                                  +          
C +        EXTICTION CORRECTION OF BECKER&COPPENS (JAN. 1979)        +          
C +       SUBROUTINES TAKE PATTERN FROM THE EXCELLENT X-RAY 80       +          
C +                         PROGRAMME.                                          
C +       STRUCTURE FACTOR EQUATIONS CORRESPONDING TO THE GRAM-      +          
C +       CHARLIER-SERIES EXPANSION AND TO A SERIES OF MODIFIED      +          
C +        HERMIT-POLYNOMS IN THREE DIMENSIONS.    (JULY 1979)       +          
C +           GENERAL POLARISATION CORRECTIONS (DEC. 1979)           +          
C +      ADDITION OF ANHARMONIC THERMAL VIBRATIONS OF FIFTH AND      +          
C +                   SIXTH ORDER (FEB. 1980)                        +          
C +                                                                  +          
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++          
C                                                                               
C                                                                               
C     INPUT VARIABLES                                                           
C     ---------------                                                           
C     LINE     NAME OF MAN WHO TAKES CARE OF THE PROGRAMME                      
C     MAXPG    MAXIMUM NUMBER OF LINES PER PAGE OF CURRENT PRINTER.             
C                                                                               
                                                                                
C                                                                               
      DIMENSION IBUFF(1023),KREJ(6),NEW(8),R(36),FBUF(504),IFBUF(504)           
      DIMENSION EGGY(6),  BBETA(6,60),SIGB(6,60),SIGO(60),SIGXYZ(3,60)          
      DIMENSION TFB(6),IOCCUP(60),ER(21,6),FR(28,6),ISTAND(17)                  
      DIMENSION IBDF(2),IBEKER(2),HOLDP(60),HOLDO(60),ISH(3,120)                 
      DIMENSION SAVE(60),KDEGN(2640),AA(2640),LINE(11),IBKC(6),ITYP(6)          
      DIMENSION FMINS1(36),FMINS2(36),SQRTR1(36),SQRTR2(36),istern(3)      
      dimension bffd(360),jir(84,60)
C                                                                               
      COMMON/A/BETA(6,60),G(3,3),ISOT(60),NATOM,TAG(2,60),TITLE(18),XYZ(        
     &3,60),PI,CR(10,60),DR(15,60),ALF(60),ITTYP(60)                            
      COMMON/LSMAT/B(200),IEXT,IPARA(1000),MRANK,KCYL,LABEL(3),JSCRF(10         
     &),NRSF,SIGMA,MDEGN,MAXIMA,IALFA(60),RDAMP(200),IDAMP(200),                
     & A(10500)                                                                 
      COMMON/D/ACALC,AIND(60),ANOM(2,20),BCALC,BIND(60),DADB(6,60),DADO(        
     & 60),DADX(3,60),DBDB(6,60),DBDO(60),DBDX(3,60),H(3),IH(3),ISCAT(2,        
     & 60),ISCL,MFSEL,OCCA(60),OCCUP(60),SCALE(10),SCAT(20),SITE(60)            
     &,DADC(10,60),DBDC(10,60),DADD(15,60),DBDD(15,60),AMINUS,BMINUS            
     &,DRDE(7),NDEGN,VORFAK,IPAREX(7),DAALFA(60),DBALFA(60),jirl(5040)        
      COMMON/TAPE/IN,INN,IOUT,ISC1,ISC2,ISC3,ISC4,ISC5,IPUN                     
      COMMON/XPAR/NPAR,ATOX(3,3),XTOA(3,3),PAR(60),PARNAM(2,60),IPAR(60)        
     &,IRPAR(60),OXYZ(3),SXYZ(3),OXP(3),T(3,3),EL(3,3),S(3,3),TRNS(3,3)         
     &  ,TTRNS(3,3),TRANSI(3,3),TTRNSI(3,3),RTEM(3),BTEM(6),GTEM(10)            
      COMMON/C/CELLP(3,4),ICENT,JCELL,NSYM,RMAT(3,3,24),TRANS(3,24)             
      COMMON/E/DMAX,DMIN,RECELL(6),EXANG(6),EXTRAN(12)                          
      COMMON/F/DELTA,FCALC,FOBS,FOMAX,FOMIN,IREJ,MREF,MREJ,NREJ,NUMBER(3        
     & 6),RDEN(36),RHO,RHOMN,RHOMX,RNUM(36),WT,EXBETA,EXX,EXY,GAMMAP            
     &,FISGN,IFSGN,EXTIN(6),KEXTRF(7),DELMAX,IANIGC,GAMMAS,IZACH,RNEUEX(        
     &7),NEUEXT,NDISTR,NIEXT,WTA(3),WTB(3),RHODIV                               
      COMMON /FBUF/ FBUF                                                        
      COMMON/G/BUFF(1023),FCURVE(9,20),IFMT(18),IWT,NSCAT,BETFAC,WVLNTH         
     &,WTFAC                                                                    
      COMMON/COPPEN/YEXT,BDF(16),JUNK6                                          
      COMMON/POL/INTER(20),X(35,4),Y(35,4),INTPOL                               
      COMMON/FOUR/WINKEL(3),IUB,AG,BG,CG                                        
      COMMON/H/UB(9),CHI,PHI,TH,UBINV(9),TBAR,DIN(3),DOUT(3),IEQMPT,            
     &BBETA                                                                     
      COMMON/LIMIT/UNTEN,OBEN,IREJEC                                            
      COMMON/ILABEL/IDATA1(49)                                                  
	COMMON/LEVER/ILEVER
C                                                                               
      EQUIVALENCE (IBUFF,BUFF),(FBUF,IFBUF)                                     
      EQUIVALENCE (IBDF,BDF) ,(DBALFA,HOLDO) ,(ISH,BBETA)                       
      EQUIVALENCE (SAVE,AIND),(KDEGN,AA,DADC(1,37)),(dadb(1,1),bffd(1))    
      EQUIVALENCE (DR(1,41),ER),(DR(7,49),FR),(DAALFA,HOLDP)                    
C                                                                               
C                                                                               
      DATA KREJ/2H  ,2HLT,2H  ,2HRJ,2H  ,2HNP/                                  
      DATA IBEKER/3,0/                                                          
      DATA JTEMP,JO,JT,J1/15,1HP,1HT,1H1/                                       
      DATA IBKC,ITYP  /2,3,2,4,10,3,1H0,1H1,1H4,1H7,1HA,1HD/                    
      DATA ISTAND/4H(A4,,4H 9X,,4H3I3,,4H I3,,4H 3X,,4H, 9X,4HF9.0,             
     & 4H,F5.,4H0)  ,4H3X,2,4H3I3),4HSTAN,4H    ,4HPSI ,4H0,F7,4H.2) ,
     & 4HI3,2/  
      data istern /3H   ,3H * ,3H **/           
C                                                                               
C                                                                               
C                                                                               
    1 FORMAT(         25X,80H P R O M E T H E U S  HAS BEEN CALLED FOR          
     &S T R U C T U R E R E F I N E M E N T   //                                
     &40X,50H REFINEMENTS OF  STRUCTURES  WITH  NOT  MORE  THAN/                
     &40X,50H SIXTY ATOMS PER ASYMMETRIC UNIT AND NOT MORE THAN/                
     &40X,50H TWENTY  DIFFERENT  SCATTERING   CURVES   CAN   BE/                
     &40X,50H PERFORMED.  THERMAL  MOTIONS UP TO SIXTH ORDER IN/                
     &40X,50H FOUR DIFFERENT STRUCTURE FACTOR EQUATIONS  CAN BE/                
     &40X,50H INVESTIGATED.            EXTINCTION CORRECTION OF/                
     &40X,50H ZACHARIASEN  REVISED BY HAMILTON AND COPPENS   AS/                
     &40X,50H WELL AS THE EXTINCTION CORRECTION OF BECKER   AND/                
     &40X,50H COPPENS ARE INCLUDED.     GENERAL CONSTRAINTS FOR/                
     &40X,50H 'SHAPE REFINEMENT' ETC.  AND  SPECIAL  PARAMETERS/                
     &40X,50H       FOR 'RIGID BODY' MOTIONS ARE AVAILABLE.    /                
     &40X,50H INFORMATION  ABOUT THIS  PROGRAM   IS   AVAILABLE/                
     &40X, 6H  FROM,11A4)                                                       
    2 FORMAT(18A4)                                                              
    4 FORMAT(A1,3I1,1X,5I1,1X,8I1,3F8.0,1X,I1,1X,3I1,1X,I1)                     
    5 FORMAT(/18H0CONTROL-PARAMETER/1X,17(1H-)//1X,A1,3I2,2X,5I2,2X,8I2         
     & ,3(F8.3,2X),2X,I2,2X,3I2,5X,I2)                                          
    6 FORMAT(9F8.0,2A4)                                                         
    8 FORMAT(19H1TITLE OF THE CYCLE/1X,18(1H-)//1X,18A4)                        
    9 FORMAT(14H1STARTING TIME/1X,13(1H-)//)                                    
   16 FORMAT(1X,2A3,I4,2X,2F6.3,/,2I2,1X,A1,2X,3F7.5,6F7.4,I2)
   19 FORMAT(4I1)                                                               
   20 FORMAT(1H1,18A4,5X,17HSTRUCTURE FACTORS,10X,4HPAGE,I3/1H0,7X,1HH,         
     & 4X,1HK,4X,1HL,6X,6HF(OBS),5X,7HF(CALC),5X,7HA(CALC),5X,7HB(CALC),        
     & 5X,7HDELTA F,3X,11HDELT/WEIGHT,3X,11HEXT. FACTOR,6X,8HSINT/LAM//)        
   22 FORMAT(4X,3I5,F12.3,1X,A2,F10.3,3F12.3,F14.4,a3,f11.4,f14.4,2X,A2,
     & 1X,A2)                
   23 FORMAT(4X,3I5,F12.3,1X,A2,F10.3,F12.3,12X,F12.3,F14.4,a3,f11.4,
     & f14.4,2X,A2,1X,A2) 
   24 FORMAT(1H1,18A4,5X,40HRESULTS OF STRUCTURE FACTOR CALCULATIONS/           
     & 78X,29HSTRUCTURE FACTOR EQUATION NO.,I4)                                 
   26 FORMAT(10X,10HWEIGHTED R,4X,2F15.2,I10,F11.3//10X,12HUNWEIGHTED R,        
     & 2X,2F15.2,I10,F11.3//14X,16HRANGES OF F(OBS)/8(24X,2F15.2,I10,F11        
     & .3/)/14X,32HRANGES OF (SIN(THETA)/LAMBDA)**2/8(24X,2F15.2,I10,F11        
     & .3/))                                                                    
   27 FORMAT(2I1,7F8.4)                                                      
   28 FORMAT(16H0ALL REFLECTIONS,14X,9HNUMERATOR,4X,11HDENOMINATOR,4X,          
     & 6HNUMBER,6X,7HR(INT) /1H )                                               
   30 FORMAT(23H UNREJECTED REFLECTIONS/1H )                                    
   32 FORMAT(/  10H SUM FCALC,19X,F15.2/    32H WEIGHTED    "GOODNESS OF        
     & FIT"  ,F12.2)                                                            
   33 FORMAT(36H0PARAMETERS READ FROM MAIN UNIT NO.  ,I6,6X,8HLABEL IS,         
     & 6X,2H**,2X,3A4,2X,2H**)                                                  
   88 FORMAT(//, 19H TITLE OF THE CYCLE/1X,18(1H-)//1X,18A4)                    
   90 FORMAT(I4)                                                                
   93 FORMAT(13H0ERRORMESSAGE/1X,12(1H-)// 22H CORE IS INSUFFICIENT.,           
     &70H0YOU HAVE TO CHANGE THE DIMENSION OF 'A' IN COMMON 'LSMAT' TO A        
     &T LEAST ,I10,1H./17H0CURRENT VALUE IS,I9,1H.//16H0JOB TERMINATED.)        
  144 FORMAT(13H0ERRORMESSAGE/1X,12(1H-)//                                      
     & 40H NO DATAS HAD BEEN FOUND ON MAINUNIT NO.,I6,2H .                      
     &/60H0CHECK YOUR PARAMETERS NEW(1) UP TO NEW(8) AND IFILE.        )        
  146 FORMAT(52H0** ERROR ** ENCOUNTERED WHILE READING RECORD TWO OF,           
     & 31H THE FILE MAIN (LOGICAL NO. WAS,I4,2H).)                              
  240 FORMAT(/////, 43X,29H LABEL  OF THE UNIT MAIN  =     ,3A4,              
     &6(/),35X,10HSUBSTANCE=,15X,12HTEMPERATURE=,15X,8HSPECIAL= )              
  251 FORMAT(5X,I3,15X,F9.5,17X,F9.5,2(14X,F8.4))                               
  618 FORMAT(I2,3I1,F8.0,7F6.4)                                                 
  620 FORMAT(49H0ALL HKL'S GIVEN ON UNIT 16 WILL NOT BE INCLUDED.)              
  637 FORMAT(I2,2F8.4)                                                          
  941 FORMAT(1H1,18A4,5X,17HSTRUCTURE FACTORS,10X,4HPAGE,I3/1H0,7X,1HH,         
     & 4X,1HK,4X,1HL,6X,6HF(OBS),5X,7HF(CALC),5X,7HPHASE  ,5X,7H       ,        
     & 5X,7HDELTA F,3X,11HDELT/WEIGHT,3X,11HEXT. FACTOR,6X,8HSINT/LAM//)        
 1801 FORMAT(9F8.4)                                                             
 2032 FORMAT(49H0++++  R-VALUES BEFORE THE FIRST REFINEMENT  ++++ )             
 2037 FORMAT(10X,10HWEIGHTED R,4X,2F15.2,I10,F11.3//10X,12HUNWEIGHTED R,        
     &2X,2F15.2,I10,F11.3//14X,16HRANGES OF F(OBS),55X,8H LOWER -, 9X,          
     &7HUPPER -,6X,6HLIMIT /8(24X,2F15.2,I10,F11.3,6X,F10.3,6X,F10.3/)/         
     &14X,32HRANGES OF  SIN(THETA)/LAMBDA     / 8(24X,2F15.2,I10,F11.3          
     &,6X,F10.3,6X,F10.3/))                                                     
 2521 FORMAT(1H1,25HRESULTS IN SHORTENED FORM/1X,25(1H-)//,                     
     &           68H DETAILED RESULTS OF THE FOLLOWING CYCLES ARE WRITTE        
     &N TO  UNIT  NO. ,I5//                                                     
     &16H0NUMBER OF CYCLE,3X,21HR(W) <UNREJ. REFLEC.>,5X,19HR  <UNREJ. R        
     &EFLEC.>,5X,15HGOODNESS OF FIT,5X,15HMAX.SHIFT/ERROR//)                    
 3037 FORMAT(10X,10HWEIGHTED R,4X,2F15.2,I10,F11.3//10X,12HUNWEIGHTED R,        
     &2X,2F15.2,I10,F11.3//14X,16HRANGES OF F(OBS),55X,8H LOWER -, 9X,          
     &7HUPPER -,6X,6HLIMIT / 8(24X,2F15.2,I10,F11.3/)/                          
     &14X,32HRANGES OF  SIN(THETA)/LAMBDA     / 8(24X,2F15.2,I10,F11.3          
     &,6X,F10.3,6X,F10.3/))                                                     
 4762 FORMAT(/37H0PARTIAL STRUCTURE FACTOR CALCULATION/1X,36(1H-)//1H )         
 4763 FORMAT(I2)                                                                
 4764 FORMAT(1X,2A3,8HDELETED.)                                                 
 5000 FORMAT(////36H0USED STRUCTURE FACTOR EQUATION WAS  ,6X,3HNO.,I2/          
     & 1X,34(1H-),///)                                                          
 5011 FORMAT(1X, 88(1H*)/1X,1H*,86X,1H*/1X,1H*,9X,2H--,75X,1H*/1X,1H*,9X        
     &,1H|,19X, 1HK,11X,3HKLM,11X,2HKL,12X,4HKLMN,13X,1H*/1X,                   
     &1H*,9X,1H/,4X,64HF *EXP(I(2PI*H X  - H H H *C   ) - (H H *B   -H H        
     & H H *D     )) ,9X,1H*/1X,                                                
     &1H*,9X,2H--,3X,1HJ,12X,3HK J,4X,8HK L M  J,8X,6HK L  J,4X,10HK L M        
     & N  J,16X,1H*/1X,1H*,9X,1HJ,76X,1H*/1X,88(1H*),5X,13HPDF = EDGEWOR        
     &,9HTH-SERIES //)                                                          
 5013 FORMAT(1X ,88(1H*)/1X,1H*,86X,1H*/1X,1H*,9X,2H--,75X,1H*/1H*,9X,          
     &1H|,19X,1HK,11X,3HKLM,11X,2HKL,12X,4HKLMN,13X,1H*/1X,                     
     &1H*,9X,1H/,4X,64HF *EXP(I(2PI*H X  - H(KLM)*C   ) - (H H *B   -H(K        
     &LMN) *D     )) ,9X,1H*/1X,                                                
     &1H*,9X,2H--,3X,1HJ,12X,3HK J,4X,8H       J,8X,6HK L  J,4X,12H             
     &      J,14X,1H*/1X,1H*,9X,1HJ,76X,1H*/1X,88(1H*),2X,11H PDF = MOD.        
     &,13HEDGEW.-SERIES// )                                                     
 5014 FORMAT(1X,98(1H*)/1X,1H*,96X,1H*/1X,1H*,2X,2H--,92X,1H*/1X,1H*,2X,        
     &1H|,19X,1HK,9X,2HKL,4X,2HI-,22X,3HKLM,22X,7HKLMN -I,2X,1H*/1X,            
     &1H*,2X,1H/,4X,93HF *EXP(I*2PI*H X  - H H *B   )* I 1-I*4/3*PI**3*H        
     &(KLM)*C   + 2/3*PI**4*H(KLMN) *D      I  *  /1X,                          
     &1H*,2X,2H--,3X,1HJ,12X,3HK J,4X,6HK L  J,5X,2HI-,15X,8H       J,15        
     &X,16H         J    -I , 2X,1H*/1X,1H*,2X,1HJ,93X,1H*/1X,98(1H*),3X        
     &,22HPDF = MOD. G&C.-SERIES //)                                            
 5012 FORMAT(1X,98(1H*)/1X,1H*,96X,1H*/1X,1H*,2X,2H--,92X,1H*/1X, 1H*,2X        
     &,1H|,19X,1HK,9X,2HKL,4X,2HI-,22X,3HKLM,22X,7HKLMN -I,2X,1H*/1X,           
     &1H*,2X,1H/,3X,93HF *EXP(I*2PI*H X  - H H *B   )* I 1-I*4/3*PI**3*H        
     & H H *C   + 2/3*PI**4*H H H H *D      I  *   / 1X,                        
     &1H*,2X,2H--,3X,1HJ,12X,3HK J,4X,6HK L  J,5X,2HI-,15X,8HK L M  J,15        
     &X,16HK L M N  J    -I  ,2X,1H*/1X,1H*,2X,1HJ,93X,1H*/1X,98(1H*),3X        
     &,26HPDF = GRAM-CHARLIER-SERIES  //)                                       
 7087 FORMAT(37H WRONG VALUE OF NFLAG,ACTUAL VALUE IS,I3)                       
 7092 FORMAT(4HATOM,3X,2A3,3F8.4/3HBIJ,4X,2A3,6F8.4,1X,1H4)                     
 7094 FORMAT(1P,10E7.1E1,0P,I1)
 7095 FORMAT(1P,10E7.1E1,0P,/,1P,5E7.1E1,0P,35X,I1)
 7097 FORMAT(10F7.3)
 7195 FORMAT(2(1P,10E7.1E1,0P,/),0P,E7.1E1,0P,63X,I1)
 7295 FORMAT(2(1P,10E7.1E1,0P,/),0P,8E7.1E1,0P)
C 7295 FORMAT(1P,10E7.1E1,0P)
 7296 FORMAT(3HEND) 
 7395 FORMAT(60A1)  
 8003 FORMAT(/41H0ABSORPTION WEIGHTED AVERAGED PATH LENGTH/1X,40(1H-)//         
     & 32H AVERAGED PATHLENGTH OF THE BEAM,F7.2,12H MICROMETER.)                
 8004 FORMAT(2I1,2F8.0)                                                         
 8005 FORMAT(/21H0MEASURING CONDITIONS/1X,20(1H-))                              
 8006 FORMAT( 54H0REFLECTIONS  ARE MESURED WITH   X R A Y    RADIATION.)        
 8007 FORMAT( 54H0REFLECTIONS ARE  MEASURED  WITH   NEUTRON  RADIATION.)        
 8008 FORMAT( 54H0L O R E N T Z P O L A R I S A T I O N S  - CORRECTION)        
 8009 FORMAT( 54H0L O R E N T Z - CORRECTION FOR EULER CRADLE GEOMETRY.)        
 8010 FORMAT(28H0CAUTION. FOR THE REFLECTION,3(I2,2X),14HTHE EXTINCTION         
     &,60H COEFFICIENT ENCOUNTERED GREATER ONE.                       )         
 9101 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /58H0REJECT REFLECTIONS OUTSIDE THE SIN(THETA)/LAMBDA INTERVAL,          
     & F 8.2,2X,4HTILL,F10.2,4X,30H(1/ANGSTROMS)  AND ALL LTHAN. )              
 9102 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /54H0REJECT LTHAN REFLECTIONS IF F(CALC) LESS THAN F(OBS).)              
                                                                                
 9103 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /58H0REJECT REFLECTIONS OUTSIDE THE SIN(THETA)/LAMBDA INTERVAL,          
     & F 8.2,2X,4HTILL,F10.2,4X,30H(1/ANGSTROMS)  AND ALL LTHAN  ,              
     & 28HIF F(CALC) LESS THAN F(OBS).)                                         
 9104 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /51H0THIS IS ONLY A DUMMY ROUTINE FOR SPECIAL  WISHES. )                 
 9106 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /30H0ALL REFLECTIONS ARE INCLUDED.)                                      
 9107 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /59H0REFLECTIONS ARE REJECTED MARKED AS LESS-THAN ON HKL-CARDS.)         
 9108 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /59H0REFLECTIONS ARE REJECTED MARKED AS LESS-THAN ON HKL-CARDS./         
     &  58H0REFLECTIONS ARE REJECTED IF ABS(F(OBS)-F(CALC)) LESS THAN           
     & ,F6.1,10H / WEIGHT.)                                                     
 9109 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     &  58H0REFLECTIONS ARE REJECTED IF ABS(F(OBS)-F(CALC)) LESS THAN           
     & ,F6.1,10H / WEIGHT.)                                                     
 9110 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     & /59H0REFLECTIONS ARE REJECTED MARKED AS LESS-THAN ON HKL-CARDS./         
     &  58H0REFLECTIONS ARE REJECTED IF ABS(F(OBS)-F(CALC)) LESS THAN           
     & ,F6.1,10H / SIGMA. )                                                     
 9111 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),                                
     &  58H0REFLECTIONS ARE REJECTED IF ABS(F(OBS)-F(CALC)) LESS THAN           
     & ,F6.1,10H / SIGMA. )                                                     
 9112 FORMAT(58H0DELMAX HAS BEEN CALCULATED AS THE MEDIAN OF THE FUNCTIO        
     &N /27H0ABS(F(OBS)-F(CALC))/SIGMA.)                                        
 9113 FORMAT(58H0DELMAX HAS BEEN CALCULATED AS THE MEDIAN OF THE FUNCTIO        
     &N /28H0ABS(F(OBS)-F(CALC))*WEIGHT.)                                       
 9114 FORMAT(/17H0REJECT-PARAMETER,/,1X,16(1H-),/,                              
     &49H0REFLECTIONS WITH I/SIGMA(I) (OR F/SIGMA(F)) .LT. ,                    
     &F8.2,15H  ARE REJECTED. )                                                 
 9411 FORMAT(1H1,18A4,5X,17HSTRUCTURE FACTORS,10X,4HPAGE,I3/1H0,7X,1HH,         
     & 4X,1HK,4X,1HL,6X,6HF(TOT),5X,7HF(REST),5X,7HPHASE  ,5X,7H       ,        
     & 5X,7HDELTA F,3X,11HDELT/WEIGHT,3X,11HEXT. FACTOR,6X,8HSINT/LAM//)        
 9450 FORMAT(19H0INTENSITY ON CARD.)                                            
 9451 FORMAT(27H0STRUCTURE FACTORS ON CARD.)                                    
 9462 FORMAT(37H0STANDARD DEVIATIONS OF F**2 ON CARD.,20X,                      
     &65H SIGMA(F) = SIGMA(F*F)/(2*F)          IF F*F  GREATER  SIGMA(F*        
     &F)/57X,65H SIGMA(F) = SQUAREROOT(SIGMA(F*F))/2  IF F*F LESS THAN S        
     &IGMA(F*F)/57X,65H FORMULAS  FROM  REES  ACTA CRYSTALLOGRAPHICA  A3        
     &2, P.483 (1976).)                                                         
 9463 FORMAT(37H0STANDARD DEVIATIONS OF  F   ON CARD.)                          
 9464 FORMAT(17H0WEIGHT ON CARDS.)                                              
 9465 FORMAT(36H0STANDARD DEVIATIONS OF F*F ON CARD.,3X,                        
     & 41HTHESE ARE ALTERED BY AN IGNORANCE FACTOR. / 39X,                      
     & 52HSIGMA WILL BE COMPUTED  BY  SQRT(SIGMA**2 + (I(OBS)*,                 
     & F6.3,1X,5H)**2)/ 38X,                                                    
     &65H SIGMA(F) = SIGMA(F*F)/(2*F)          IF F*F  GREATER  SIGMA(F*        
     &F)/38X,65H SIGMA(F) = SQUAREROOT(SIGMA(F*F))/2  IF F*F LESS THAN S        
     &IGMA(F*F)/38X,65H FORMULAS  FROM  REES  ACTA CRYSTALLOGRAPHICA  A3        
     &2, P.483 (1976).)                                                         
 9466 FORMAT(1H+,39X,45HTHESE WILL BE ALTERED BY AN IGNORANCE FACTOR.)          
 9467 FORMAT(1H+,18X,51HWEIGHT IS INTERPRETED AS WEIGHT = 1/(SIGMA(I)**2        
     &) .)                                                                      
 9468 FORMAT(/24X,56HSPECIAL ROUTINE WEIGHT USED FOR COMPUTATION OF WEIG        
     &HTS. ,/,56H0SIGMA(F) WILL BE CALCULATED DIFFERENTLY ABOVE AND BELO        
     &W,1X,F8.5,2X,9HSINT/LAM.,/,10X,5HBELOW,8X,10HSIGMA(F) =,                  
     &12H SIGMAR(F)*(,F6.4,10H+SINT/LAM*,F6.4,13H+SINT/LAM**2*,F6.4,1H),        
     &/,10X,5HABOVE,8X,10HSIGMA(F) =,12H SIGMAR(F)*(,F6.4,10H+SINT/LAM*,        
     &F6.4,13H+SINT/LAM**2*,F6.4,1H),/,34X,24HSIGMAR(F) IS CALCULATED ,         
     &45HACCORDING TO REES (SEE ABOVE).               )                         
 9469 FORMAT(1H+,18X,51HWEIGHT IS INTERPRETED AS WEIGHT = 1/(SIGMA(F)**2        
     &) .)                                                                      
 9471 FORMAT(19X,47HSIGMA WILL BE COMPUTED BY SIGMA=SQRT(SIGMA**2+(,F6.4        
     &,7H*F)**2))                                                               
 9472 FORMAT(19X,41HSIGMA ARE ALTERED BY AN IGNORANCE FACTOR. / 19X,            
     & 52HSIGMA WILL BE COMPUTED  BY  SQRT(SIGMA**2 + (I(OBS)*,                 
     & F6.3,1X,5H)**2)//19X,                                                    
     &65H SIGMA(F) = SIGMA(F*F)/(2*F)          IF F*F  GREATER  SIGMA(F*        
     &F)/19X,65H SIGMA(F) = SQUAREROOT(SIGMA(F*F))/2  IF F*F LESS THAN S        
     &IGMA(F*F)/19X,65H FORMULAS  FROM  REES  ACTA CRYSTALLOGRAPHICA  A3        
     &2, P.483 (1976).)                                                         
 9473 FORMAT(36H0STANDARD DEVIATIONS OF F*F ON CARD.,10X,23HSIGMA(F)=0.5        
     &*SIGMA(I) .)                                                              
 9488 FORMAT(36H0STANDARD DEVIATIONS OF F*F ON CARD.,                           
     & 10X,41HSIGMA ARE ALTERED BY AN IGNORANCE FACTOR. / 46X,                  
     & 52HSIGMA WILL BE COMPUTED  BY  SQRT(SIGMA**2 + (I(OBS)*,                 
     & F6.3,1X,5H)**2)//46X,  29H SIGMA(F) = SIGMA(F*F)/(2*F). )                
 9502 FORMAT(2F8.0,I2)                                                          
 9511 FORMAT(  21H0MONOCHROMATOR ANGLE ,F6.2,4X,13HCOS(2THM)**2 ,F9.5,          
     &  //1X,17HDIHEDRALE  ANGLE   ,F7.0)                                       
 9512 FORMAT( 54H0DEFAULTVALUES SETTING FOR THE PHILIPS-DIFFRACTOMETER./        
     &   54H0GRAPHITMONOCHROMATOR  DIHEDRALE  ANGLE =90 MO-KALPHA.)             
 9668 FORMAT(/28H0PARAMETERS OF  HKL-CARDS   /1X,24(1H-)//                      
     & 37H0FORMAT FOR STRUCTURE FACTOR INPUT   ,1X,18A4/)                       
 9669 FORMAT(40X,47HSIGMA WILL  BE   COMPUTED   BY  SQRT(SIGMA**2+(,F6.4        
     &,7H*F)**2))                                                               
 9670 FORMAT(25H0WAVE LENGTH (ANGSTROMS) ,F12.6/)                               
 9671 FORMAT(/16H0CORE ALLOCATION /1X,15(1H-)//                                 
     & 42H DIMENSION OF ARRAY 'A' (COMMON LSMAT ) =  ,2X,I5,15X,                
     & 19HCURRENT MAXIMUM IS ,I6/)                                              
 9672 FORMAT(24H0++++ NUMBER OF CYCLE = ,I10,10H   ++++      )                  
 9673 FORMAT(/1X,5(9H*WARNING*),/100H0YOU CHANGED THE MONOCHROMATOR PARA        
     &METERS IN ACCORDANCE TO THE WAVELENGTH, DIDN'T YOU .             )        
 9998 FORMAT(/10X,23H WEIGHT IS UNIT WEIGHT.)                                   
 9999 FORMAT(/10X,41H*** WARNING *** THE EXTINCTION TENSOR IS                   
     &,23H NOT POSITIVE DEFINITE. )                                             
C                                                                               
C ----------------------- INITIALIZE JOB ------------------------------         
C *                                                                             
C *   NPAR   = NUMBER OF SPECIAL PARAMETERS.                                    
C *   DELMAX = PARAMETER OF REJECTION  FUNCTION. (COMPARE WITH MANUAL).         
C *   FISGN  = REFINED ENANTIMORPHIC ORIENTATION NO/YES.                        
                                                                                
C *            UNIT.                                                            
C *   KCYL   = NUMBER OF CURRENT CYCLE.                                         
C *   IFIRST = NUMBER OF CURRENT  CYCLE FOR THIS JOB.                           
C *   IWROTE = FOURIERFILE NOT/ IS CREATED.    (IMPORTANT FOR THE SUB -         
C *            ROUTINE MEDWT, WHICH CAN ONLY USED, IF IWROTE=1)                 
C *   MODELL = 1 STRUCTURE FACTOR EQUATION IS  FOURIER-TRANSFORM OF THE         
C *            EDGEWORTH SERIES EXPANSION.                                      
C *          = 2 STRUCTURE FACTOR EQUATION IS FOURIER-TRANSFORM  OF THE         
C *            GRAM-CHARLIER SERIES EXPANSION.(EXPANDED TILL 6TH ORDER)         
C *          = 3 STRUCTURE FACTOR EQUATION IS A  EXPANSION  OF POLYNOMS         
C *            SIMILAR TO THE HERMIT POLYNOMS.      FOURIERTRANSFORM IS         
C *            A  SERIES  SIMILAR  TO THE  EDGEWORTH  SERIES EXPANSION.         
C *          = 4 LIKE 3, BUT NOW SIMILARITY TO GRAM CHARLIER EXPANSION.         
C *   IREJ   = REJECTION MODUS. INITIAL VALUE= INCLUDE ALL REFLECTIONS.         
C *   NWT    = 1/2 MEANS   REFIENEMENT ON WEIGHTED/UNITWEIGHT R-VALUES.         
C *   NDEGN  = NUMBER OF CONSTRAINTS (INITIAL VALUE IS ZERO.)                   
C *   GOF    = SUM(W*(FOBS-FCALC)**2)    IN CASE OF REFINEMENT ON IOBS.         
C *                                                                             
C *   THE VALUES OF ISOTROPIC EXTINCTION   EXTIN(1),  OF A  EXTINCCTION         
C *   MODEL ARE SET TO ZERO. THIS  HAS TO BE DONE  TO GIVE * A PRIORI *         
C *   VALUES FOR THE FIRST CYCLE.    (THESE INITIAL VALUES CAN BE OVER-         
C *   WRITTEN BY INPUT.)                                                        
C *                                                                             
C ---------------------------------------------------------------------         
C                                                                               
      PI      = ACOS(-1.0)                                                      
      NPAR    = 0                                                               
      DELMAX  = 1000.0                                                          
      FISGN   = 1.0                                                             
      ISKI = 0                                                                  
      KCYL    = -1                                                              
      IFIRST  = -1                                                              
      IWROTE  = 0                                                               
      MODELL  = 0                                                               
      EXTIN(1)= 0.0                                                             
      IEXT    = 0                                                               
      IREJ    = 1                                                               
      MREF    = 0
      NWT     = 1                                                               
      NDEGN   = 0                                                               
      GOF     = 0.0                                                             
      UNTEN = 0.                                                                
      OBEN = 0.                                                                 
C                                                                               
      JCURR   = IOUT                                                            
C                                                                               
      REWIND ISC1                                                               
      REWIND ISC2                                                               
C                                                                               
C---- STARTING POINT FOR CYCLE (READ TITLE- AND CONTROL CARD)                   
C     IBUFF(1[B2) WILL BE NEW IREJ, IF NOT ZERO.                                  
C     IBUFF(13) WILL BE NEW DELMAX IF NEW IREJ IS 3,4,5,6.                      
C     IBUFF(1)  0/1 DO NOT/DO WRITE HARMONIC PARAMETERS ON UNIT IHARMO.         
C     IBUFF(31) 0/1 DO NOT/ DO READ SPECIAL PARAMETERS                          
C                                                                               
  100 READ(IN,2)TITLE                                                           
      READ(IN,4)IEEF,MFSEL,MRFF,IBUFF(12),MSF,MCORR,MBODAN,MELVIB,IFILE         
     &,NEW,RLOW,RHIGH,BUFF(13),IPART,IBUFF(1),IBUFF(31),IFSGN,IOVER             
C                                                                               
C---- ONE CYCLE MORE (OF THIS RUN)                                              
      IFIRST=IFIRST+1                                                           
C                                                                               
C---- INITIALIZE CYCLE.                                                         
C                                                                               
C   * NBUFF =  POINTER FOR THE BLOCKED INPUT OF FILES ISC1,ISC2.                
C   * NFBR  =  POINTER FOR THE BLOCKED INPUT OF THE FOURIER FILE ISC4.          
C   * IWARN1=1 IF EXTINCTION TENSOR IS NOT POSITIVE DEFINITE.                   
C   * LREF1 =  0/1 FIRST/NOT FIRST REFLECTION PROCESSED.                        
C                                                                               
      NBUFF = 0                                                                 
      IWARN1= 0                                                                 
      NFBR  = 0                                                                 
      LREF1 = 0 
      ifiref = 0                                                                
C                                                                               
C---- INCREASE NUMBER OF CYCLES BY ONE                                          
      KCYL=KCYL+1                                                               
C                                                                               
C---- CHECK IF FIRST CYCLE OF RUN                                               
C                                                                               
      IF(IFIRST)140,110,140                                                     
  110                        DO 120 I=1,8                                       
      IF(NEW(I))120,130,120                                                     
  120 CONTINUE                                                                  
C                                                                               
C---- ALL PARAMETERS NEW, DO NOT READ SAVE UNIT                                 
C                                                                               
      GO TO 140                                                                 
C                                                                               
C---- READ SAVE UNIT TO START OF REFLECTION LIST                                
C                                                                               
  130 READ(ISC1,ERR=143)                                                        
     &KCYL,LABEL,RECELL,G,VOL,NSYM,NATOM,NSCAT,JCELL,MRANK,NPARA,NSF,DMI        
     &N,DMAX,DELMAX,ICENT,(((RMAT(I,J,K),I=1,3),J=1,3),K=1,NSYM),((TRANS        
     &(I,J),I=1,3),J=1,NSYM),((CELLP(I,J),I=1,3),J=1,JCELL),(IPARA(I),I=        
     &1,NPARA),((FCURVE(I,J),I=1,9),J=1,NSCAT),(SCALE(I),I=1,NSF),IREJ,F        
     &OMAX,FOMIN,RHOMN,RHOMX,(JSCRF(I),I=1,NSF),NRSF,WINKEL,AG,BG,CG            
     &,NPAR,(PAR(I),(PARNAM(J,I),J=1,2),IPAR(I),IRPAR(I),I=1,NPAR),FISGN        
     &,IFSGN,EGGY,KEXTRF,BDF,GAMMAP,WVLNTH,INTPOL,JUNK6,INEUT,NWT,IWT           
     &,(INTER(I),I=1,NATOM),((X(J,I),I=1,INTPOL),J=1,35),((Y(J,I),I=1,IN        
     &TPOL),J=1,35),IUB,EXTRAN,IZACH,IREJEC,UNTEN,OBEN,MODELL,(ALF(I),I=        
     &1,NATOM),(IALFA(I),I=1,NATOM),(RDAMP(I),IDAMP(I),I=1,MRANK),IEQPMT        
      READ(ISC1,END=145)                                                        
     &((ANOM(J,I),J=1,2),I=1,NSCAT),IEXT,EXTIN,((TAG(J,I),J=1,2),ISOT(I)        
     &,(ISCAT(J,I),J=1,2),OCCA(I),OCCUP(I),SITE(I),(XYZ(J,I),J=1,3),            
     &(BETA(J,I),J=1,6),(CR(J,I),J=1,10),(DR(J,I),J=1,15),I=1,NATOM),           
     &LDEGN,(KDEGN(I),I=1,LDEGN),HELPE,HELPF,IHIGH,((ER(J,I),J=1,21),(FR        
     &(J,I),J=1,28),I=1,IHIGH),IZAEHL                                           
C                                                                               
C---- UPDATE NUMBER OF CONSTRAINTS AND NUMBER OF CYCLE                          
C                                                                               
      NDEGN=LDEGN/2                                                             
      KCYL=KCYL+1
C
C---- reset ITTYP to Uij's in any case (who still wants betaij's?)
C
      DO 131 J=1,60
  131 ITTYP(J) = 1
C                                                                               
C---- REFINEMENT ON R(W) OR ON R(UNIT-WEIGHT)                                   
C                                                                               
  140 IF(MRFF) 238,239,238                                                      
C                                                                               
C---- CHANGING OF REFIENEMENT TYPE                                              
C                                                                               
  238 NWT=2                                                                     
      MREF = MRFF
      IF(MREF.EQ.1.OR.MREF.EQ.3) NWT = 1
      IF(MRFF.GE.3) MREF = 1
      IF(MRFF.LT.3) MREF = 0
C                                                                               
C     NWT=1  REF. ON WEIGHTED R , NWT=2 REF. ON R(UNIT-WEIGHT)                  
C                                                                               
  239 CONTINUE                                                                  
C                                                                               
C---- CHECK RANGE OF PARAMETER *MODELL* . ONLY IF IOVER .NE.0 THAN              
C     MODELL CAN BE CHANGED IN A SEQUENTIAL RUN.                                
      IF(IOVER.NE.0) MODELL = 0                                                 
C                                                                               
      IF ( MFSEL.GT.7) MFSEL=1                                                  
      IF ( MFSEL.GT.1 .AND. MFSEL.LT.4 .AND. MODELL.EQ.0) MODELL=2              
      IF ( MFSEL.GT.3 .AND. MFSEL.LT.6 .AND. MODELL.EQ.0) MODELL=3              
      IF ( MFSEL.GT.5 .AND. MODELL.EQ.0) MODELL=4                               
      IF (MODELL .EQ.0 ) MODELL=1                                               
C                                                                               
C---- MFPRI IS ONLY A SCRATCH PARAMETER FOR THE OUTPUT. MFSEL IS  FLAG          
C     FOR REFINEMENT OR ONLY STRUCTURE FACTOR CALCULATION.                      
      MFPRI=MFSEL                                                               
      MFSEL=MOD(MFSEL,2)                                                        
C                                                                               
C                                                                               
C---- PRINT COVER IN THE FIRST CYCLE OF THIS JOB.                               
C                                                                               
      IF(IFIRST.NE.0) GO TO 241                                                 
      IF(IMARK.NE.0) GOTO 2411                                                  
      CALL SPACE(1,6,28,IOUT,MAXPG)                                             
      WRITE(IOUT,1)LINE                                                         
      WRITE(IOUT,240)LABEL                                                      
      CALL SPACE(2,6,28,IOUT,MAXPG)                                             
C
	WRITE(*,2518)
2518	FORMAT(1X,'Cycle     R(weight,unrej.)     R(unrej.)        ',
     &     'G-of-fit      Max(shift/error)',/)

C---- PRINT STARTING TIME.                                                      
 2411 WRITE(IOUT,9)                                                             
      CALL ANFANG(0,IOUT)                                                            
C---- WRITE TITLE OF CYCLE.                                                     
      WRITE(IOUT,88)TITLE
      GOTO 242                                                                  
C                                                                               
C---- TEMPORARY OUTPUT?                                                
C                                                                               
  241 IF(IEEF.EQ.JO .AND. IOUT.NE.JCURR) IOUT=JCURR                             
      IF(IEEF.EQ.JT .AND. IOUT.NE.JTEMP) IOUT=JTEMP                             
C                                                                               
      WRITE(IOUT,8)TITLE
C                                                                               
C---- IF THIS CYCLE HAS ONLY INTERMEDIATE OUTPUT, POINT IT OUT.                 
  242 IF(IOUT.EQ.JCURR) IZEIT=0                                                 
      IF(IOUT.NE.JTEMP) GOTO 2520                                               
      IF(IZEIT.NE.0) GOTO 2311                                                  
      WRITE(JCURR,2521)JTEMP                                                    
      IZEIT=1                                                                   
 2311 WRITE(JCURR,251)KCYL,R(19),R(20),TEMP,SEMAX                               
C                                                                               
C---- WRITE CONTROL CARD                                                        
C                                                                               
 2520 WRITE(IOUT,5)IEEF,MFPRI,MRFF,IBUFF(12),MSF,MCORR,MBODAN,MELVIB,           
     &IFILE,NEW,RLOW,RHIGH,BUFF(13),IPART,IBUFF(1),IBUFF(31),IFSGN,             
     &IOVER                                                                     
C
C	IF MCORR>2,THEN SET ILEVER AND OUTPUT DERIVATES IN MATRIX-ROUTINE
C                                                
	ILEVER=0
	IF(MCORR.GT.1)THEN
	   MCORR=MCORR-2
	   ILEVER=1
	ENDIF
c
c---- set flag for short Fo-Fc list
c
      ishort = 0
      if(msf.gt.3) ishort = 1                                      
C---- IF IBUFF(31).NE.0 THEN SPECIAL PARAMETERS SHOULD BE READ.                 
C     IF IBUFF( 1).NE.0 THEN HARMONIC PARAMETERS SHOULB BE WRITTEN TO           
      IF(NEW(5).EQ.0 .AND. IBUFF(31).NE.0) NEW(5)=5                             
      IF(IBUFF(1).NE.0 .AND. NEW(7).NE.0) NEW(7)=2                              
      IF(IBUFF(1).NE.0 .AND. NEW(7).EQ.0) NEW(7)=3                              
C                                                                               
C---- IF THIS WAS NOT A 'A PRIORI' RUN, WRITE NAME OF MAINUNIT USED.            
C                                                                               
      IF(IFIRST.EQ.0.AND.KCYL.NE.0)WRITE(IOUT,33)ISC1,LABEL                     
C                                                                               
C---- LOAD NEW PARAMETERS. (FALLS NEW(1-8)=0 NO MODIFICATIONS ARE DONE)         
C                                                                               
C <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<        
C                                                                               
C          CALL THE OVERLAY INCLUDING SUBROUTINE LOADNW.                        
C                     CALL LLINK("R1OV1")                                       
C                                                                               
C <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<        
C                                                                               
      CALL LOADNW(NEW,EGGY,IFIRST,NSF,NPARA,VOL,IOCCUP,MODELL,                  
     & IZAEHL,IHIGH,IEQPMT)                                                     
C                                                                               
C---- IS THERE A PARTIAL TRUCTURE CALCULATION REQUESTED WITH CONSTANT           
C     PHASE?                                                                    
C                                                                               
      IF(IPART) 2523,2523,2522                                                  
C---- YES, ONE HAS REQUESTED .                                                  
C                                                                               
 2522 IPART = MIN0(IPART,2)                                                     
      MFSEL = 0                                                                 
      IFILE = 1                                                                 
C                                                                               
C---- IS (CONSTRAINTS? AND (LSFIT? OR 1.ZYKLUS OF JOBS)= TRUE THEN THE          
C     OVERLAY R1OV3 WILL BE LOADED CONTAINING SUBROUTINE  DERIVS.               
C                                                                               
 2523 IF(NDEGN.NE.0.AND.(MFSEL.NE.0.OR.IFIRST.EQ.0)) GOTO 141                   
      GOTO 142                                                                  
C                                                                               
C---- PARAMETERS ARE CORRECTLY READ FROM INPUT OR SAVE UNIT.                    
C                                                                               
  141 CONTINUE                                                                  
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C     LOAD OVERLAY                                                              
C     CALL LLINK("R1OV3")                                                       
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL DERIVS(NEW(7))                                                       
  142 IF(NDEGN.EQ.0)MDEGN=0                                                     
C                                                                               
C---- LSFIT OR STRUCTURE FACTOR CALCULATION ONLY                                
C                                                                               
      IF(MFSEL)612,616,612                                                      
C---- IF A LEAST SQUARES FIT REQUIRED, INITIALIZE MATRIX.                       
C      CALCULATION OF CORE ALLOCATIONS AND COMPARISON WITH ACTUAL NUMBER        
C      MDEGN=2*NUMBER OF CONSTRAINTS , MRANK = NUMBER OF FREE PARAMETERS        
C                                                                               
  612 IC=MDEGN                                                                  
      MEMSZ=(MRANK*(MRANK+1))/2+IC                                              
C                                                                               
C---- IS THERE ENOUGH CORE TO RUN JOB?                                          
C                                                                               
      IF(MAXIMA-MEMSZ)91,92,92                                                  
C---- NO                                                                        
   91 WRITE(IOUT,93)MEMSZ,MAXIMA                                                
      CALL EXIT                                                                 
C---- YES, PRINT ACTUAL VALUE AND MAXIMUM                                       
   92 WRITE(IOUT,9671)MEMSZ,MAXIMA                                              
C                                                                               
C---- ARE DATAS ON ISC4 AND PARAMETER IREJ 3,4 THEN COMPUTE DELMAX.             
      IF(IWROTE.NE.0.AND.IREJ.EQ.3.OR.IREJ.EQ.4)  GOTO 9979                     
      GOTO 9972                                                                 
 9979 CONTINUE                                                                  
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C     CALL LLINK("R3OV2")                                                       
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL MEDWT(MEMSZ,DELMAX)                                                  
C                                                                               
C                                                                               
C---- CLEAR MATRICES                                                            
C                                                                               
 9972                        DO 614 IA=1,MRANK                                  
      B(IA)=0.0                                                                 
                             DO 614 IB=IA,MRANK                                 
      IC=IC+1                                                                   
  614 A(IC)=0.0                                                                 
C                                                                               
C---- INITIALIZE FOR CYCLE                                                      
C     OVERLAY R1OV4 INCLUDING  THE SUBROUTINES INPUT,SFAC,MATRIX,RCALC          
C     EXTICA,CREC,REZREA,ORTHO,ANA,ABLEIT                                       
C                                                                               
  616 IF(NEW(8))629,629,617                                                     
C                                                                               
C---- READ FORMAT FOR HKL CARDS, INFORMATION ABOUT INFO ON CARD.                
C                                                                               
  617 READ(IN,2)IFMT                                                            
C                                                                               
C---- SET DEFAULT VALUE FOR FORMAT DEPENDING ON PARAMETER NEW(8) IF             
C     IFMT(1)=ISTAND(12). PROGRAMMING IS VIA COMPUTED GOTO TO  MAKE             
C     CHANGES EASY.                                                             
C     IF IFMT(1)=ISTAND(14) PSI VALUES ARE TO BE READ IN 
      IF(IFMT(1).NE.ISTAND(12).AND.IFMT(1).NE.ISTAND(14)) GOTO 7000 
C                                                                               
      GOTO (6291,6292,6293,6294,6295),NEW(8)                                    
C                                                                               
C---- NEW(8)=1 OR NEW(8)=6  FORMAT=(A4,9X,3I3,3X,I3,3X,F9.0,9X,F5.0)            
C                                                                               
 6291 IFMT(4) = ISTAND(5)                                                       
      IFMT(5) = ISTAND(4)                                                       
      IFMT(6) = ISTAND(5)                                                       
      IFMT(7) = ISTAND(7)                                                       
      IFMT(8) = ISTAND(6)                                                       
      IFMT(9) = ISTAND(8)                                                       
      IFMT(10)= ISTAND(9)                                                       
      GOTO 6295                                                                 
C                                                                               
C---- NEW(8)=2 OR NEW(8)=7  FORMAT=(A4,9X,3I3,3X,I3,3X,2F9.0,F5.0)              
C                                                                               
 6292 IFMT(4) = ISTAND(5)                                                       
      IFMT(5) = ISTAND(4)                                                       
      IFMT(6) = ISTAND(10)                                                      
      IFMT(7) = ISTAND(7)                                                       
      IFMT(8) = ISTAND(8)                                                       
      IFMT(9) = ISTAND(9)                                                       
      IFMT(10)= ISTAND(13)                                                      
      GOTO 6295                                                                 
C                                                                               
C---- NEW(8)=3 OR NEW(8)=8  FORMAT=(A4,9X,5I3,3X,F9.0,9X,F5.0)                  
C                                                                               
 6293 IFMT(4) = ISTAND(4)                                                       
      IFMT(5) = ISTAND(4)                                                       
      IFMT(6) = ISTAND(5)                                                       
      IFMT(7) = ISTAND(7)                                                       
      IFMT(8) = ISTAND(6)                                                       
      IFMT(9) = ISTAND(8)                                                       
      IFMT(10)= ISTAND(9)                                                       
      GOTO 6295                                                                 
C                                                                               
C---- NEW(8)=4 OR NEW(8)=9  FORMAT=(A4,9X,3I3,3X,2I3,2F9.0,F5.0)                    
C                                                                               
 6294 IFMT(4) = ISTAND(5)                                                       
      IFMT(5) = ISTAND(4)                                                       
      IFMT(6) = ISTAND(17)                                                      
      IFMT(7) = ISTAND(7)                                                       
      IFMT(8) = ISTAND(8)                                                       
      IFMT(9) = ISTAND(9)                                                       
      IFMT(10)= ISTAND(13)                                                      
      GOTO 6295                               
C
C---- MODIFY FORMAT IN CASE PSI-VALUES ARE READ IN
C
 6295 IPSI = 0
      IF(IFMT(1).NE.ISTAND(14)) GOTO 6297
      IPSI = 1
      GOTO (6391,6392,6391,6392,6297), NEW(8)
 6391 IFMT(10) = ISTAND(15)
      IFMT(11) = ISTAND(16)
C---- CLEAR PART NOT USED
      DO 6397 I=12,18
 6397 IFMT(I) = ISTAND(13)
      GOTO 6398
 6392 IFMT(9) = ISTAND(15)
      IFMT(10) = ISTAND(16)     
C                                                                               
C---- CLEAR PART OF ARRAY NOT USED, BUT MAYBE  CONTAINING INFO.                 
 6297 DO 6296 I=11,18                                                           
 6296 IFMT(I) = ISTAND(13)                                                      
C---- FILL IN FOR EACH VALUE OF NEW(8) THE FIRST 12 CHARACTERS OF FORM.         
 6398 IFMT(1) = ISTAND(1)                                                       
      IFMT(2) = ISTAND(2)                                                       
      IFMT(3) = ISTAND(3)                                                       
C---- CHARACTER 9 TILL 12 ARE DIFFERENT IF NEW(8)=5                             
      IF(NEW(8).NE.5) GOTO 6299                                                 
      IFMT(3) = ISTAND(11)                                                      
C---- BUT MORE ELEMENTS OF IFMT ARE EMPTY.                                      
      DO 6298 I=4,10                                                            
 6298 IFMT(I) = ISTAND(13)                                                      
C 
 7000 CONTINUE                                                                              
C---- IBUFF(11) = 0/1 STANDARD INPUT UNIT / ISC3 IS INPUT UNIT (FOR             
C                     HKL-CARDS.)                                               
 6299 READ(IN,618)IBUFF(11),IFOBS,IWT,ISKI,WTFAC,RHODIV,WTA,WTB                 
      IWT  = MIN0(IWT,5) + 1                                                    
      IF(ABS(WTFAC).GT.1.E-4 .AND. IWT.LT.5) IWT=IWT+6                          
C                                                                               
  629 CONTINUE                                                                  
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>          
C                                                                               
C                            CALL OVERLAY                                       
C                        CALL LLINK("R1OV4")                                    
C                                                                               
C                        CALL LLINK("R3OV3")                                    
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>          
C                                                                               
C---- CORRESPONDING TO THE EXTINCTION MODEL USED THE RECORD LENGTH FOR          
C     THE BLOCKED UNITS ISC1,ISC2 ARE CALCULATED.                               
C                                                                               
      NSC9=NSCAT+12+IBEKER(IZACH+1)                                             
      LBUFF=1022/NSC9                                                           
      LBUFF=NSC9*LBUFF+1                                                        
C---- NPRINT = NUMBER OF LINES FOR THE CURRENT PAGE OF A RELECTION LIST-        
C     ING.                                                                      
      NPRINT=0                                                                  
C                                                                               
C---- INITIALIZE VARIABLES FOR THE RELIABILITY LISTING.                         
      SUMFC=0.0                                                                 
      RMINUS=0.0                                                                
                             DO 630 ID=1,36                                     
      RNUM(ID)=0.0                                                              
      RDEN(ID)=0.0                                                              
  630 NUMBER(ID)=0              
C                                                                               
C                                                                               
      IF(MSF.lt.2.or.msf.eq.4)goto 634             
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
C     THIS SECTION SHOULD PREPARE TO WRITE A STRUCTURE FACTOR FILE              
C     FOR A FOURIER PROGRAM                                                     
C     USING 2 FOURIER FILES PER JOB CHANGES THE UNIT FROM ISC4 TO ICHANG        
C                                                                               
      REWIND ISC4                                                               
      WRITE(ISC4)LABEL,TITLE,WINKEL,AG,BG,CG,IWT                                
      WRITE(ISC4)NSYM,VOL,(((RMAT(I,J,K),I=1,3),J=1,3),K=1,NSYM),((TRANS        
     &(J,I),J=1,3),I=1,NSYM),RECELL                                             
C                                                                               
C     WINKEL,AG,BG,CG = REAL LATTICE PARAMETERS.                                
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
C                                                                               
  634 IF(IBUFF(12))636,636,635                                                  
C                                                                               
C---- READ REJECTION MODE (AND CORRESPONDING PARAMETERS.)                       
C                                                                               
  635 DELMAX=BUFF(13)                                                           
      IREJ=IBUFF(12)                                                            
      IF(IBUFF(12).LT.7)GOTO 6351                                               
      IREJEC = IBUFF(12) - 6                                                    
      IREJ = 7                                                                  
      IREJEC=MIN0(IREJEC,4)                                                     
      UNTEN = RLOW                                                              
      OBEN  = RHIGH                                                             
C                                                                               
C---- IF NEW(8)=0 GOTO TO PRINT SECTION AND THEN COME BACK.                     
C                                                                               
 6351 IF(NEW(8).EQ.0) GOTO 6353                                                 
 6352 CONTINUE                                                                  
C                                                                               
C---- SHOULD HKL-CARDS READ FROM STANDARD INPUT UNIT  IN  OR FROM               
C     FILE ISC3?  YES,THEN  NEW(8) IS NOT ZERO.                                 
C     IN SEQUENTIAL RUNS INFORMATION IS READ FROM ISC2.                         
C                                                                               
C---- GENERATE A FLAG TO PREVENT COMPUTING OF DERIVATIVES IN SFAC FOR           
C     SURELY REJECTED REFELCTIONS.                                              
C                                                                               
  636 IF(IREJ.EQ.2 .OR. IREJ.EQ.3 .OR. IREJ. EQ.5 .OR. (IREJ.EQ.7 .AND.         
     & IREJEC.EQ.1)) IRAUS=1                                                    
      IF(NEW(8))665,640,665                                                     
C---- NEW STRUCTURE FACTORS NOT TO BE READ                                      
  640 IF(IFIRST)660,650,660                                                     
C---- FIRST CYCLE, STRUCTURE FACTORS FROM SAVE TAPE                             
  650 ASSIGN 700 TO INTYPE                                                      
      GO TO 700                                                                 
C                                                                               
C---- NOT FIRST CYCLE, STRUCTURE FACTORS FROM INTERMEDIATE UNIT                 
C                                                                               
  660 ASSIGN 830 TO INTYPE                                                      
      GO TO 830                                                                 
C                                                                               
C---- NEW(8)  WAS NOT ZERO. NEW STRUCTURE FACTORS READ.                         
C                                                                               
C                                                                               
C---- IF IFOBS=1 THEN  F(OBS) ON CARD   OR   ON FILE INN.                       
C     IF IFOBS=0 THEN  INTENSITIES ARE ON CARD OR ON INN.                       
C     INN IS GIVEN ON THE DATA DEFINING CARD (NORMALLY ISC3)                    
C                                                                               
 665  IFOBS=MAX0(MIN0(IFOBS,1),0)                                               
C                                                                               
      IF(IBUFF(11))667,666,667                                                  
C---- NEW STRUCTURE FACTORS FROM STANDARD INPUT UNIT IN                         
  666 INN=IN                                                                    
      GO TO 668                                                                 
C---- NEW STRUCTURE FACTORS FROM UNIT  GIVEN ON CARD                            
  667 INN=IBUFF(11)                                                             
C                                                                               
C---- SAVE PARAMETERS DELMAX  (MEANING SEE DESCRIPTION)                         
  668 DELMAX=BUFF(13)                                                           
C                                                                               
C---- FOMAX,FOMIN,RHOMAX,RHOMIN ARE MAXIMUM & MINIMUM FOR THE UNSCALED          
C   * INTENSITIES AND (SIN(THETA)/LAMBDA)**2 OF THE REFLECTION READ IN          
C                                                                               
      FOMAX=0.0                                                                 
      FOMIN=1.0E+6                                                              
      RHOMN=1.0E+6                                                              
      RHOMX=0.0                                                                 
C                                                                               
C---- READ AND WRITE FORMAT-INFORMATION FOR THE HKL-CARDS.                      
      WRITE(IOUT,9668)IFMT                                                      
C                                                                               
C---- WRITE INFO. ABOUT HKL-CARDS                                               
C                                                                               
      IF(IFOBS.EQ.0) WRITE(IOUT,9450)                                           
      IF(IFOBS.EQ.1) WRITE(IOUT,9451)                                           
C                                                                               
      GOTO (9452,9453,9454,9458,9459,9461,9455,9456,9457,9477) ,IWT             
 9452 WRITE(IOUT,9462)                                                          
      GOTO 9460                                                                 
 9453 WRITE(IOUT,9463)                                                          
      GOTO 9460                                                                 
 9454 WRITE(IOUT,9464)                                                          
      IF(MREF.EQ.0) WRITE(IOUT,9469)                                            
      IF(MREF.NE.0) WRITE(IOUT,9467)                                            
      GOTO 9460                                                                 
 9455 WRITE(IOUT,9465)WTFAC                                                     
      GOTO 9460                                                                 
 9456 WRITE(IOUT,9463)                                                          
      WRITE(IOUT,9466)                                                          
      WRITE(IOUT,9669)WTFAC                                                     
      GOTO 9460                                                                 
 9457 WRITE(IOUT,9464)                                                          
      IF(MREF)9171,9474,9171                                                    
 9474 WRITE(IOUT,9469)                                                          
      WRITE(IOUT,9471)WTFAC                                                     
      GOTO 9460                                                                 
 9171 WRITE(IOUT,9467)                                                          
      WRITE(IOUT,9472)WTFAC                                                     
      GOTO 9460                                                                 
 9458 WRITE(IOUT,9473)                                                          
      GOTO 9460                                                                 
 9459 WRITE(IOUT,9462)                                                          
      WRITE(IOUT,9468) RHODIV,WTA,WTB                                           
      GOTO 9460                                                                 
 9461 WRITE(IOUT,9463)                                                          
      WRITE(IOUT,9468) RHODIV,WTA,WTB                                           
      GOTO 9460                                                                 
 9477 WRITE(IOUT,9488)WTFAC                                                     
C                                                                               
 9460 CONTINUE                                                                  
C                                                                               
C---- HANDLING OF MONOCHROMATOR AND CORRECTIONS.                                
      IMONO=0                                                                   
C                                                                               
C     INEUT =  0/1  INDICATOR FOR XRAY AND NEUTRON RADIATION                    
C           =  2    IN  THE XRAY-CASE PARAMETERS OF MONOCHROMATOR READ          
C     LPCORR=  0/1  DO NOT /DO A LORENTZ(POLARISATION) CORRECTION.              
C     WVLNTH=  WAVELENGTH IN ANGSTROMS                                          
C     TBAR  =  AVERAGED MEAN PATH LENGTH OF BEAM IN CRYSTAL                     
C     IREJEC=  NUMBER OF ENTRY IN SUBROUTINE WEIGHT (ENTRY REJECT)              
C     UNTEN =  LOWER LIMIT FOR SIN(THETA)/LAMBDA FOR REJECT ROUTINE.            
C     OBEN  =  SAME AS ABOVE FOR UPPER LIMIT.                                   
C                                                                               
      READ(IN,8004)INEUT,LPCORR,WVLNTH,TBAR                                     
C                                                                               
C---- IN CASE OF ANISOTROPIC EXTINCTION AND BUSING AND LEVY  GEOMETRY           
C     OF THE EULER CRADLE THE ORIENTATION MATRICES MUST MULTIPLIED BY           
C     THE WAVELENGTH.                                                           
C                                                                               
      IF(IEQPMT.EQ.1 .OR. IUB.EQ.0) GOTO 9175                                   
      DO 9176 I=1,9                                                             
      UB(I)   = UB(I)*WVLNTH                                                    
 9176 UBINV(I)= UBINV(I)/WVLNTH                                                 
C                                                                               
 9175 INEUT=MAX0(MIN0(INEUT,2),0)                                               
      IF(INEUT.GT.1)IMONO=1                                                     
      INEUT=MOD(INEUT,2)                                                        
 6353 IF(OBEN.LE.0.09)OBEN=2.0                                                  
C                                                                               
C---- IF IREJ IS SEVEN PRINT MESSAGE.                                           
      IF(IREJ.LT.7) GOTO 8105                                                   
C                                                                               
      GOTO (8101,8102,8103,8104),IREJEC                                         
 8101 WRITE(IOUT,9101)UNTEN,OBEN                                                
      GOTO 9500                                                                 
 8102 WRITE(IOUT,9102)                                                          
      GOTO 9500                                                                 
 8103 WRITE(IOUT,9103)UNTEN,OBEN                                                
      GOTO 9500                                                                 
 8104 WRITE(IOUT,9104)                                                          
      GOTO 9500                                                                 
C                                                                               
C---- PRINT REJECTION MODE IF IREJ LESS THAN 7                                  
C                                                                               
 8105 GOTO (8106,8107,8108,8109,8108,8109) ,IREJ                                
 8106 WRITE(IOUT,9106)                                                          
      GOTO 9500                                                                 
 8107 IF(DELMAX.GT.0.0) GOTO 8110                                               
      WRITE(IOUT,9107)                                                          
      GOTO 9500                                                                 
 8108 IF(IWT.EQ.3.OR.IWT.GT.5) WRITE(IOUT,9108)DELMAX                           
      IF(IWT.LT.6.AND.IWT.NE.3) WRITE(IOUT,9110)DELMAX                          
      IF(IWROTE.NE.0.AND.IREJ.EQ.3.AND.IWT.LT.6.AND.IWT.NE.3)                   
     & WRITE(IOUT,9112)                                                         
      IF(IWROTE.NE.0.AND.IREJ.EQ.3.AND.(IWT.EQ.3.OR.IWT.GT.5))                  
     & WRITE(IOUT,9113)                                                         
      GOTO 9500                                                                 
 8109 IF(IWT.EQ.3.OR.IWT.GT.5) WRITE(IOUT,9109)DELMAX                           
      IF(IWT.LT.6.AND.IWT.NE.3) WRITE(IOUT,9111)DELMAX                          
      IF(IWROTE.NE.0.AND.IREJ.EQ.4.AND.IWT.LT.6.AND.IWT.NE.3)                   
     & WRITE(IOUT,9112)                                                         
      IF(IWROTE.NE.0.AND.IREJ.EQ.4.AND.(IWT.EQ.3.OR.IWT.GT.5))                  
     & WRITE(IOUT,9113)                                                         
      GOTO 9500                                                                 
 8110 WRITE(IOUT,9114) DELMAX                                                   
C                                                                               
C---- IF NEW(8)=0 THEN GO BACK TO 6352.  (ONLY WRITE SECTION)                   
C                                                                               
 9500 IF(ISKI.EQ.1) WRITE(IOUT,620)                                             
      IF(NEW(8).EQ.0) GOTO 6352                                                 
C                                                                               
C---- BETA(THETA)/TBAR FOR ZACHARIASSEN EXTINCTION WILL BE CALCULATED.          
      BETFAC=WVLNTH**3/VOL**2*2000.                                             
      IF(INEUT.EQ.0) BETFAC=0.76384*BETFAC                                      
C---- GAMMAS UND GAMMAP ARE COEFFICIENTS IN THE BECKER-COPPENS EXTINCT.         
      GAMMAP=1.5*WVLNTH**4/VOL**2                                               
      IF(INEUT.EQ.0)GAMMAP=GAMMAP/12.5947885                                    
      GAMMAS=WVLNTH**3/VOL**2*10000.                                            
      IF(INEUT.EQ.0) GAMMAS=GAMMAS/12.5947885                                   
C                                                                               
C---- DEFAULT-VALUES FOR THE  PHILIPS-DIFFRACTOMETER PW1100 .                   
C   * GRAPHIT MONOCHROMATOR.  DIHEDRALE ANGLE=90.  MO-K(ALPHA) RADIA.           
      HELPE=1.0                                                                 
      HELPF=0.95563                                                             
      COST2M=HELPF                                                              
C                                                                               
C---- READ DATAS FOR MONOCHROMATOR IF DESIRED.                                  
      IF(IMONO.EQ.0) GOTO 9501                                                  
      READ(IN,9502)DIHED,TM,ICOS                                                
C                                                                               
      IF(ICOS)9507,9507,9508                                                    
C---- INPUT OF TM WAS IN DEGREES.                                               
 9507 COS2TM=TM*0.034906586                                                     
      COS2TM=COS(COS2TM)**2                                                     
      GOTO 9509                                                                 
C---- TM=COS(2*MONOCHROMATOR-ANGLE)**2                                          
 9508 COS2TM=TM                                                                 
      TM=ACOS(SQRT(COS2TM))*28.64789                                            
 9509 SIN2D=SIN(DIHED*0.017453293)**2                                           
      COS2D=1.0-SIN2D                                                           
      HELPE=SIN2D+COS2D*COS2TM                                                  
      HELPF=COS2D+SIN2D*COS2TM                                                  
C                                                                               
C---- OUTPUT OF PARAMETERS OF MEASURING.                                        
C                                                                               
 9501 WRITE(IOUT,8005)                                                          
      IF(INEUT.EQ.0)WRITE(IOUT,8006)                                            
      IF(INEUT.NE.0)WRITE(IOUT,8007)                                            
      IF(IMONO.NE.0)WRITE(IOUT,9511)TM,COS2TM,DIHED                             
      IF(IMONO.EQ.0 .AND. INEUT.EQ.0 )WRITE(IOUT,9512)                          
      IF(LPCORR.GT.0 .AND. INEUT.EQ.0)WRITE(IOUT,8008)                          
      IF(LPCORR.GT.0 .AND. INEUT.EQ.1)WRITE(IOUT,8009)                          
      WRITE(IOUT,9670)WVLNTH                                                    
C                                                                               
C---- WRITE A WARNING, IF NOT MO-K(ALPHA) RADIATION IN THE  XRAY  CASE          
C     USED BUT NO MONOCHROMATOR CARD HAD BEEN READ IN.                          
      IF( ABS(WVLNTH-.7069).GT..01 .AND. INEUT.EQ.0 .AND. IMONO.EQ.0 )          
     & WRITE(IOUT,9673)                                                         
C                                                                               
C---- IN DEPENDENCE OF NEW(8) THE NUMBER AND THE SEQUENCE OF THE INPUT-         
C     PARAMETERS OF THE HKL-CARDS ARE DIFFERENT.                                
      IF(NEW(8).NE.1 .AND. NEW(8).NE.3) GO TO 669                               
C                                                                               
C---- FOR ALL REFLECTIONS A CONSTANT TBAR SHOULD BE USED.                       
      IF(TBAR.LE.0.1)TBAR=300.                                                  
      WRITE(IOUT,8003)TBAR                                                      
      GAMMAS=TBAR*0.0001*GAMMAS                                                 
      BETFAC=BETFAC*0.0001*TBAR                                                 
C                                                                               
C---- PRINT OUT THE STRUCTURE FACTOR FORMULA USED.                              
  669 WRITE(IOUT,5000)MODELL                                                    
      GOTO (5001,5002,5003,5004),MODELL                                         
C---- STRUKTURFACTOR EQUATION = FOURIER TRANSFORM OF TF=EDGEWORTH SERIE         
 5001 WRITE(IOUT,5011)                                                          
      GOTO 5007                                                                 
C---- FOURIER TRANS. OF A  GRAM CHARLIER SERIES EXPANSION.                      
 5002 WRITE(IOUT,5012)                                                          
      GOTO 5007                                                                 
C---- MODIF. CUMULANTEN EXPANSION                                               
 5003 WRITE(IOUT,5013)                                                          
      GOTO 5007                                                                 
C---- MODIF. GRAM - CHARLIER SERIES EXPANSION.                                  
 5004 WRITE(IOUT,5014)                                                          
C                                                                               
C---- READ IN HKL-CARDS VIA SUBROUTINE INPUT AND WRITE IT ON ISC2 USING         
C     RECORD LENGTH LBUFF.                                                      
C                                                                               
 5007 ASSIGN 671 TO INTYPE                                                      
C                                                                               
C---- READ FROM UNIT 16 ALL HKL'S WHICH SHOULD NOT BE INCLUDED                  
C                                                                               
      IF(ISKI.NE.1) GOTO 6702                                                   
      DO 6700 J=1,120                                                            
      READ(16,6701,END=6703) (ISH(I,J),I=1,3)                                   
 6701 FORMAT(3I4)                                                               
 6700 CONTINUE                                                                  
      J = 120                                                                    
 6703 J = J - 1                                                                 
 6702 IBUFF(1)=0                                                                
      NBUFF=1                                                                   
  671 IEF=NEW(8)                                                                
      IVW = 0                                                                   
      CALL INPUT(IEF,INEUT,LPCORR,IFOBS,HELPE,HELPF,COS2TM,IEQPMT,              
     &ISKI,IVW,J,IPSI)                                                        
      IF(IVW.EQ.1) GOTO 671                                                     
      IF(LBUFF-NBUFF)672,672,673                                                
  672 WRITE(ISC2)(IBUFF(I),I=1,LBUFF)                                           
      NBUFF=1                                                                   
  673 IBUFF(NBUFF+1)=IH(1)                                                      
      IBUFF(NBUFF+2)=IH(2)                                                      
      IBUFF(NBUFF+3)=IH(3)                                                      
      BUFF(NBUFF+4)=FOBS                                                        
C                                                                               
C---- BE CAREFUL   WEIGHT MAY NOT BE SIGMA OF OBSERVATION. IT DEPENDS           
C     ON THE  PARAMETER IWT.                                                    
      BUFF(NBUFF+5)=WT                                                          
      BUFF(NBUFF+6)=RHO                                                         
      IBUFF(NBUFF+7)=ISCL                                                       
      BUFF(NBUFF+8)=EXBETA                                                      
      IBUFF(NBUFF+9)=MREJ                                                       
      DO 6740 I=10,12+IBEKER(IZACH+1)                                           
 6740 BUFF(NBUFF+I)=EXANG(I-9)                                                  
                             DO 674 I=1,NSCAT                                   
  674 BUFF(I+NBUFF+12+IBEKER(IZACH+1))=SCAT(I)                                  
C                                                                               
      NBUFF=NBUFF+NSC9                                                          
C                                                                               
C---- LAST REFLECTION READ ? IF NO THEN IEF = 0.                                
C                                                                               
      IF(IEF)675,870,675                                                        
C---- YES. WRITE LAST RECORD ON ISC2 AND MARK IT.                               
  675 IBUFF(1)=1                                                                
      IBUFF(NBUFF-NSC9+1)=3000                                                  
      WRITE(ISC2)(IBUFF(I),I=1,LBUFF)                                           
  691 END FILE ISC2                                                             
C                                                                               
      IF(IFILE.LT.2)GO TO 2000                                                  
C     READ SAVED SIGMA. FIRST SKIP OVER CONSTRAINTS AND VAR-COV MATRIX.         
      READ(ISC1)IBUFF(1)                                                        
      READ(ISC1)IBUFF(1)                                                        
      READ(ISC1)((BBETA(J,I),J=1,6),SIGO(I),(SIGXYZ(J,I),J=1,3),(SIGB(J,        
     &I),J=1,6),I=1,NATOM)                                                      
      GO TO 2000                                                                
C                                                                               
C                                                                               
C---- READ STRUCTURE FACTORS FROM SAVE UNIT ----------------------------        
C                                                                               
  700 IF(NBUFF)708,701,708                                                      
  701 READ(ISC1)(IBUFF(I),I=1,LBUFF)                                            
      IF(NEW(4))702,707,702                                                     
C             NEW SCATTERING FACTORS                                            
  702 ITEMP=7-NSC9                                                              
  703 ITEMP=ITEMP+NSC9                                                          
      IF(ITEMP-LBUFF)704,707,707                                                
  704 RHO=BUFF(ITEMP)                                                           
                             DO 706 I=1,NSCAT                                   
      IF(INTER(I))1201,1205,1201                                                
 1201 III=I                                                                     
      CALL INPOL(RHO,III,TEMP)                                                  
      TEMP=TEMP+ANOM(1,I)                                                       
      GOTO 706                                                                  
 1205 TEMP=FCURVE(9,I)+ANOM(1,I)                                                
      DO 7069 M=1,8,2                                                           
      TEMP=TEMP+FCURVE(2*J-1,I)*EXP(-FCURVE(2*J,I)*RHO)                         
 7069 CONTINUE                                                                  
  706 BUFF(I+ITEMP+6)=TEMP                                                      
      GO TO 703                                                                 
  707 WRITE(ISC2)(IBUFF(I),I=1,LBUFF)                                           
      NBUFF=1                                                                   
C                                                                               
  708 IH(1)  = IBUFF(NBUFF+1)                                                   
      IH(2)  = IBUFF(NBUFF+2)                                                   
      IH(3)  = IBUFF(NBUFF+3)                                                   
      FOBS   = BUFF(NBUFF+4)                                                    
      WT     = BUFF(NBUFF+5)                                                    
      RHO    = BUFF(NBUFF+6)                                                    
      ISCL   = IBUFF(NBUFF+7)                                                   
      EXBETA = BUFF(NBUFF+8)                                                    
      MREJ   = IBUFF(NBUFF+9)                                                   
        DO 712  I = 10,12+IBEKER(IZACH+1)                                       
  712 EXANG(I-9)= BUFF(NBUFF+I)                                                 
        DO 709 I=1,NSCAT                                                        
  709 SCAT(I)=BUFF(I+NBUFF+12+IBEKER(IZACH+1))                                  
C                                                                               
      NBUFF=NBUFF+NSC9                                                          
      IF(LBUFF-NBUFF)710,710,711                                                
  710 NBUFF=0                                                                   
  711                        DO 770 I=1,3                                       
  770 H(I)=IH(I)                                                                
      IF(IH(1)-3000)870,691,870                                                 
C                                                                               
C---- READ FROM INTERMEDIATE TAPE                                               
C                                                                               
  830 IF(NBUFF)832,831,832                                                      
  831 READ(ISC2)(IBUFF(I),I=1,LBUFF)                                            
      NBUFF=1                                                                   
  832 IH(1)  = IBUFF(NBUFF+1)                                                   
      IH(2)  = IBUFF(NBUFF+2)                                                   
      IH(3)  = IBUFF(NBUFF+3)                                                   
      FOBS   = BUFF(NBUFF+4)                                                    
      WT     = BUFF(NBUFF+5)                                                    
      RHO    = BUFF(NBUFF+6)                                                    
      ISCL   = IBUFF(NBUFF+7)                                                   
      EXBETA = BUFF(NBUFF+8)                                                    
      MREJ   = IBUFF(NBUFF+9)                                                   
        DO 836  I = 10,12+IBEKER(IZACH+1)                                       
  836 EXANG(I-9)= BUFF(NBUFF+I)                                                 
        DO 833 I=1,NSCAT                                                        
  833 SCAT(I)=BUFF(I+NBUFF+12+IBEKER(IZACH+1))                                  
      NBUFF=NBUFF+NSC9                                                          
      IF(LBUFF-NBUFF)834,834,835                                                
  834 NBUFF=0                                                                   
  835                        DO 840 I=1,3                                       
  840 H(I)=IH(I)                                                                
      IF(IH(1)-3000)870,2000,870                                                
C                                                                               
C---- END OF HANDLING  SAVE UNIT -------------------------------------          
C                                                                               
C                                                                               
C---- TO THIS POINT THE PROGRAM BRANCHS, IF A REFLECTION WAS READ FROM          
C     HKL-CARDS VIA 'INPUT' OR FROM SAVE UNIT.                                  
C     *     IZRUN ARE COUNTING NUMBER OF CALLINGS OF ROUTINE SFAC   IN          
C     *     CASE OF A PARTIAL STRUCTURE FACTOR CALCULATION.                     
C     *     BEFORE THE FIRST REFLECTION  WILL  BE  PROCESSED, ATOMS TO          
C     *     DELETE ARE READ.                                                    
C                                                                               
  870 IZRUN=0                                                                   
C                                                                               
      IF(IPART) 8701,871,8701                                                   
C                                                                               
C---- FIRST REFLECTION WILL BE PROCESSED, THEN READ ATOMS TO DELETE.            
C                                                                               
 8701 IF(LREF1)871,8702,871                                                     
 8702 LREF1=1                                                                   
      DO 4761 I=1,NATOM                                                         
 4761 IOCCUP(I)=1                                                               
      WRITE(IOUT,4762)                                                          
  476 READ(IN,4763)I                                                            
      IF(I)871,871,477                                                          
  477 IOCCUP(I)=0                                                               
      WRITE(IOUT,4764)(TAG(J,I),J=1,2)                                          
      GOTO 476                                                                  
C                                                                               
C---- CALCULATE STRUCTURE FACTOR DEPENDENT FROM THE MODEL USED .                
C                                                                               
  871 CALL SFAC(MODELL,IZAEHL,IRAUS)                                            
C                                                                               
C---- PARTIAL STRUCTURE FACTOR CALCULATION REQUIRED?                            
      IF(IPART.EQ.0) GOTO 8711                                                  
C---- YES.                                                                      
      IZRUN=IZRUN+1                                                             
      IF(IZRUN.EQ.1)GOTO 9000                                                   
      IF(IZRUN.EQ.2)GOTO 9002                                                   
C                                                                               
 8711 NONPOS=1                                                                  
C---- TAKE ABSOLUTE VALUE SQUARED.                                              
      FCALC=ACALC**2+BCALC**2                                                   
C                                                                               
C---- CALCULATE EXTINCTION.                                                     
      IF(IZACH.EQ.0) GOTO 8011                                                  
C                                                                               
C---- USE MODEL OF ZACHARIASSEN.                                                
C                                                                               
      CALL EXCALC                                                               
C---- EXTINCTION COEFFICIENTS GREATER ONE ARE MEANING LESS.                     
      IF(EXX.LT.-1)WRITE(IOUT,8010)IH                                           
      EXY=1.0/SQRT(ABS(1.0+EXX))                                                
      FCALC=SQRT(FCALC*EXY)                                                     
      GO TO 8012                                                                
C                                                                               
C---- EXTINCTION CORRECTION OF  BECKER-COPPENS.                                 
C                                                                               
 8011 CALL EXTICA(NONPOS,INEUT,HELPE,HELPF)                                     
C---- REFLECTION FOUND WITH UNPHYSICALLY ANISOTROPIC EXTINCTION CORREC.?        
      IF(NONPOS.EQ.2)IWARN1=1                                                   
      FCALC=SQRT(YEXT*FCALC)                                                    
      EXY =YEXT                                                                 
C                                                                               
C---- UPDATE ORIENTI., SCALING AND REJECTION .                                  
C                                                                               
 8012 IF(IFSGN.NE.0)FMINUS=SQRT(EXY*(AMINUS**2+BMINUS**2))                      
C                                                                               
      SUMFC=SUMFC+FCALC                                                         
      NREJ=0                                                                    
      FOBS=FOBS/SCALE(ISCL)                                                     
      SIGF=WT/SCALE(ISCL)                                                       
C                                                                               
C---- SHOULD PROGRAMME INCLUDE REFLECTION INTO MATRIX                           
C                                                                               
  880 GO TO (930,890,900,902,900,902,920),IREJ                                  
C---- REJECT IF LESS THAN MIN OBS                                               
  890 NREJ=MREJ                                                                 
C---- ATTENTION PLEASE: REJECTION WITH RESPECT TO F/SIGMA(F) WILL               
C     BE DONE IN ROUTINE INPUT !                                                
C                                                                               
      GO TO 930                                                                 
C---- REJECT IF LESS THAN MIN OBS OR DELTA GR DELMAX                            
  900 IF(MREJ)890,902,890                                                       
C---- REJECT IF DELTA F GR DELMAX                                               
  902 IF(ABS(FOBS-FCALC)/SIGF-DELMAX)930,930,904                                
  904 NREJ=1                                                                    
      GO TO 930                                                                 
C---- USE SPECIAL ROUTINE REJECT                                                
  920 CALL REJECT                                                               
C                                                                               
C---- CALCULATE CONTRIBUTION TO R                                               
C                                                                               
C---- RCALC ALSO CONVERTS 'WT' TO A WEIGHT.  (SIGMA(F) TO HERE,                 
C     IF ROUTINE WEIGHT NOT USED AND REFINEMENT IS ON F.                        
C                                                                               
  930 CALL RCALC(SCALE(ISCL),NWT,GOF)                                           
C                                                                               
C---- UPDATE VALUE INCASE OF  ORIENTATION                                       
C                                                                               
      IF(NREJ.NE.0.OR.IFSGN.EQ.0)GO TO 931                                      
      TEMP=FOBS-FMINUS                                                          
      IF(MREF.NE.0)TEMP=FOBS**2-FMINUS**2                                       
      RMINUS=RMINUS+WT*TEMP**2                                                  
C                                                                               
C---- PARTIAL STRUCTURE FACTORS >>  IZRUN = 1 PHASE CALCULATIONS                
C                                   IZRUN = 2 AMPLITUDE CALCULATION             
C                                                                               
  931 IF(IZRUN.NE.2) GOTO 9310                                                  
C---- PARTIAL STRUCTURE FACTOR CALCULATION HAD BEEN DESIRED.                    
      ACALC=ASAVE                                                               
      BCALC=BSAVE                                                               
C                                                                               
C---- IS A REFLECTION LISTING REQUIRED.                                         
C                                                                               
 9310 IF(MSF)932,980,932                                                        
C---- YES, FOURIER FILE TOO ?                                                   
  932 IF(MSF-3)934,970,934                                                      
C---- YES, WRITE FOURIER FILE TOO (NPAGE = CURRENT NO. OF  PAGE )               
  934 NPAGE=NPRINT/(MAXPG-4)+1                                                  
      IF((MAXPG-4)*(NPAGE-1)-NPRINT) 950,940,950                                
C---- PAGE OUTPUT (MEANS HEADING OF PAGE)                                       
  940 if(ifiref.eq.1) goto 950
      IF(IPART.EQ.0) GOTO 942                                                   
      IF(IPART.EQ.1) WRITE(IOUT,941)TITLE,NPAGE                                 
      IF(IPART.EQ.2) WRITE(IOUT,9411)TITLE,NPAGE                                
      GOTO 950                                                                  
  942 WRITE(IOUT,20)TITLE,NPAGE     
      ifiref = 1                                            
C                                                                               
C---- PRINT STRUCTURE FACTOR                                                    
  950 TEMP=FOBS-FCALC                                                           
      TEMP1=DELTA/SIGF
      istar = 1                                                          
      if(abs(temp1).gt.3.) istar = 2
      if(abs(temp1).gt.5) istar = 3
C---- RELFECTION LISTING.   RRO=SIN(THETA)/LAMBDA. IN CAES OF A PART-           
C     IAL STRUCTURE FACTOR CALCULATION ACALC,BCALC IS REPLACED BY THE           
C     PHASE IN DEGREES.                                                         
C                                                                               
      RRO=SQRT(RHO)                                                             
C---- PARTIAL STRUCTURE FACTORS CALCULATED?                                     
      IF (IPART.EQ.0) GOTO 951                                                  
C---- YES.                                                                      
      PHASE=ATAN2(BCALC,ACALC)*57.29578                                         
      WRITE(IOUT,23)IH,FOBS,KREJ(MREJ+1),FCALC,PHASE,TEMP,TEMP1,istern
     &(istar),EXY,RRO,KREJ(NREJ+3),KREJ(NONPOS+4)               
      GOTO 955                                                                  
C---- NO.                                                                       
 951  if(ishort.ne.1.or.istar.gt.1)
     &WRITE(IOUT,22)IH,FOBS,KREJ(MREJ+1),FCALC,ACALC,BCALC,TEMP,TEMP1,          
     & istern(istar),EXY ,RRO,KREJ(NREJ+3),KREJ(NONPOS+4)      
      if(ishort.ne.1.or.istar.gt.1)NPRINT=NPRINT+1                                                           
      IF((MAXPG-4)*(NPAGE-1)-NPRINT.ne.0) ifiref = 0                                
      goto 960
 955  nprint = nprint + 1
C                                                                               
  960 IF(MSF.lt.2.or.msf.eq.4) goto 980                              
C                                                                               
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
C      THIS SECTION SHOULD ADD THE CURRENT REFLECTION TO THE FOURIER            
C      FILE.                                                                    
C                                                                               
 970  IFBUF(NFBR+1) = IH(1)                                                     
      IFBUF(NFBR+2) = IH(2)                                                     
      IFBUF(NFBR+3) = IH(3)                                                     
      FBUF(NFBR+4)  = FOBS                                                      
      FBUF(NFBR+5)  = FCALC                                                     
      FBUF(NFBR+6)  = ACALC                                                     
      FBUF(NFBR+7)  = BCALC                                                     
      IFBUF(NFBR+8) = NREJ                                                      
C                                                                               
C---- ADD SIGMA F AND EXTINCTION PARAMETER TO LIST                              
C     CAUTION. IF ROUTINE WEIGHT USED, THEN SIGF MAY NOT LONGER BE              
C     SIGMA F.                                                                  
      FBUF(NFBR+9)=SIGF                                                         
      FBUF(NFBR+10)=EXY                                                         
      NFBR=NFBR+10                                                              
      IF(NFBR-500)980,972,972                                                   
 972  WRITE(ISC4)FBUF                                                           
      NFBR=0                                                                    
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
C                                                                               
C                                                                               
C---- IS ONLY A STRUCTURE FACTOR CALCULATION DESIRED, THEN GOTO 990.            
C                                                                               
C---- NO,A LEAST SQUARES FIT IS REQUESTED.   GOTO 1000.                         
C                                                                               
  980 IF(MFSEL)1000,990,1000                                                    
C                                                                               
C---- GO TO GET NEW STRUCTURE FACTOR                                            
  990 GO TO INTYPE,(830,700,671)                                                
 1000 IF(NREJ)990,1010,990                                                      
C---- ADD TO LEAST SQUARES MATRICES IF REFLECTION NOT REJECTED                  
 1010 CALL MATRIX(MODELL)                                                       
      GO TO 990                                                                 
C                                                                               
C---- LAST REFLECTION PROCESSED.                                                
C                                                                               
C---- END OF LIST FOUND, REWIND TAPES                                           
 2000 REWIND ISC1                                                               
      REWIND ISC2                                                               
C                                                                               
      IF(MSF.lt.2.or.msf.eq.4) goto 2020                                
C                                                                               
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
      IFBUF(NFBR+1)=99                                                          
      WRITE(ISC4)FBUF                                                           
      IWROTE=1                                                                  
C*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*        
C                                                                               
C                COMPUTE AND PRINT OUT R FACTORS                                
C                -------------------------------                                
C                                                                               
C---- PRINT TITLE AND MODELL AND NUMBER OF CYCLE                                
C                                                                               
 2020 WRITE(IOUT,24)TITLE,MODELL                                                
      IF(KCYL.NE.0)GOTO 2031                                                    
      WRITE(IOUT,2032)                                                          
      GOTO 2033                                                                 
 2031 WRITE(IOUT,9672)KCYL                                                      
C                                                                               
 2033 NUMBER(2)=NUMBER(1)                                                       
      NUMBER(20)=NUMBER(19)                                                     
                             DO 2030 I=1,36                                     
      IF(NUMBER(I))2024,2022,2024                                               
 2022 R(I)=0.0                                                                  
      GO TO 2030                                                                
 2024 J=(I/19)*18+1                                                             
      IF(I.NE.2.AND.I.NE.20)RDEN(I)=RDEN(J)*(FLOAT(NUMBER(I))/FLOAT(NUMB        
     &ER(J)))                                                                   
      RNUM(I)=SQRT(RNUM(I))                                                     
      RDEN(I)=RDEN(I)                                                           
      R(I)   =RNUM(I)/SQRT(RDEN(I))                                             
 2030 CONTINUE                                                                  
C                                                                               
C---- CALCULATE SQRT(RDEN(I)) FOR OUTPUT                                        
C                                                                               
      DO 2034 I=1,36                                                            
 2034 RDEN(I)=SQRT(RDEN(I))                                                     
C                                                                               
C---- FOR THE UNWEIGHTED R-VALUE THE SQUARE ROOT WAS ILLEGAL                    
C                                                                               
      RNUM(2) = RNUM(2)**2                                                      
      RDEN(2) = RDEN(2)**2                                                      
      R(2)    = R(2)**2                                                         
      RNUM(20)= RNUM(20)**2                                                     
      RDEN(20)= RDEN(20)**2                                                     
      R(20)   = R(20)**2                                                        
C                                                                               
C---- GOODNESS OF FIT                                                           
C                                                                               
      TEMP=SQRT(RNUM(19)**2/FLOAT(NUMBER(19)-MRANK))                            
      GOF =SQRT(GOF/FLOAT(NUMBER(19)-MRANK))                                    
C                                                                               
      WRITE(IOUT,28)                                                            
C                                                                               
C---- IN ALL CYCLES EXCEPT THE FIRST ONE THE "RANGES OF FOBS"                   
C     AND THE "RANGES OF SIN(THETA)/LAMDA"  WILL BE PRINTED.                    
C     (THE PRINTING OF THE "RANGES OF FOBS" IS ONLY POSSIBLE,                   
C     IF ONLY ONE SCALING-FACTOR IS SELECTED.)                                  
C                                                                               
      IF(NEW(8).EQ.0 ) GOTO 2035                                                
C                                                                               
C---- OUTPUT FOR THE FIRST CYCLE.                                               
      WRITE(IOUT,26)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=1,18)                     
      WRITE(IOUT,30)                                                            
      WRITE(IOUT,26)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=19,36)                    
      GOTO 2039                                                                 
C                                                                               
C---- OUTPUT FOR SEQUENTIAL    CYCLES.                                          
C                                                                               
 2035 SS=SCALE(1)                                                               
      FODELT=(FOMAX-FOMIN)/(8.*SS)                                              
      RODELT=(RHOMX - RHOMN) /8.                                                
      IF(NSF.NE.1) GOTO 3035                                                    
      DO 2041 I=3,10                                                            
      FMINS1(I) = FOMIN/SS+(I-3)*FODELT                                         
 2041 FMINS2(I) = FOMIN/SS+(I-2)*FODELT                                         
      DO 2042 I=11,18                                                           
      SQRTR1(I) = SQRT(RHOMN+(I-11)*RODELT)                                     
      SQRTR2(I) = SQRT(RHOMN+(I-10)*RODELT)                                     
 2042 CONTINUE                                                                  
C                                                                               
C---- ONLY ONE SCALING FACTOR                                                   
C                                                                               
      WRITE(IOUT,2037)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=1,2),                   
     &(RNUM(I),RDEN(I),NUMBER(I),R(I),FMINS1(I),FMINS2(I),I=3,10)               
     &,(RNUM(I),RDEN(I),NUMBER(I),R(I),SQRTR1(I),SQRTR2(I),I=11,18)             
C                                                                               
      DO 2043 I=21,28                                                           
      FMINS1(I) = FOMIN/SS+(I-21)*FODELT                                        
 2043 FMINS2(I) = FOMIN/SS+(I-20)*FODELT                                        
      DO 2044 I=29,36                                                           
      SQRTR1(I) = SQRT(RHOMN+(I-29)*RODELT)                                     
      SQRTR2(I) = SQRT(RHOMN+(I-28)*RODELT)                                     
 2044 CONTINUE                                                                  
      WRITE(IOUT,30)                                                            
      WRITE(IOUT,2037)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=19,20),(RNUM(           
     &I),RDEN(I),NUMBER(I),R(I),FMINS1(I),FMINS2(I),I=21,28),                   
     &(RNUM(I),RDEN(I),NUMBER(I),R(I),SQRTR1(I),SQRTR2(I),I=29,36)              
      GOTO 2039                                                                 
C                                                                               
C---- MORE THAN ONE SCALING FACTOR.                                             
C                                                                               
 3035 DO 2045 I=11,18                                                           
      SQRTR1(I) = SQRT(RHOMN+(I-11)*RODELT)                                     
      SQRTR2(I) = SQRT(RHOMN+(I-10)*RODELT)                                     
 2045 CONTINUE                                                                  
      WRITE(IOUT,3037)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=1,10),                  
     &(RNUM(I),RDEN(I),NUMBER(I),R(I),SQRTR1(I),SQRTR2(I),I=11,18)              
      WRITE(IOUT,30)                                                            
      DO 2046 I=29,36                                                           
      SQRTR1(I) = SQRT(RHOMN+(I-29)*RODELT)                                     
      SQRTR2(I) = SQRT(RHOMN+(I-28)*RODELT)                                     
 2046 CONTINUE                                                                  
      WRITE(IOUT,3037)(RNUM(I),RDEN(I),NUMBER(I),R(I),I=19,28)                  
     &,(RNUM(I),RDEN(I),NUMBER(I),R(I),SQRTR1(I),SQRTR2(I),I=29,36)             
C                                                                               
C---- WRITE SUM OF FCALC AND GOODNESS OF FIT                                    
C                                                                               
 2039 IF(MREF.EQ.0)WRITE(IOUT,32)SUMFC,TEMP                                     
      IF(MREF.NE.0)WRITE(IOUT,32)SUMFC,GOF                                      
C                                                                               
C---- WRITE A WARNING, IF A REFLECTION WAS FOUND FOR WHICH THE                  
C     EXTINCTION TENSOR WAS NOT POSITIV DEFINITE.                               
C                                                                               
      IF(IWARN1.EQ.1) WRITE(IOUT,9999)                                          
C                                                                               
C---- STRUKTURFACTOR CALCULATION OR LEAST SQUARES FIT?                          
C                                                                               
      IF(MFSEL)2040,3000,2040                                                   
C                                                                               
C---- LS-FIT. UPDATE THE PARAMETERS.                                            
C                                                                               
 2040 CONTINUE                                                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C     CALL LLINK("R1OV2")                                                       
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C---- UPDATE AND PRINT RESULTS OF THE CYCLE                                     
C                                                                               
C---- RNUM(19)**2 TO FIT IT FOR ROUTINE INVERT                                  
C                                                                               
      RNUM(19)=RNUM(19)**2                                                      
C                                                                               
      CALL IINVER(MCORR,SIGB,BBETA,SIGXYZ,SIGO,EGGY,NSF,TEMP,                  
     & RMINUS,MODELL,SEMAX)
C                                                     
	WRITE(*,2519) KCYL+1,R(19),R(20),TEMP,SEMAX
2519	FORMAT(1X,I4,F17.4,F18.4,F16.4,F21.4)
C                                                                               
C---- CHECK TO SEE IF AUXILLARY FUNCTIONS TO BE DONE                            
C                                                                               
C---- BOND DISTANCES  & ELLIPSOIDS AND THERMAL CORRECTIONS TO BONDS.            
C                                                                               
      ILADE=0                                                                   
 3000 IF(MBODAN)3010,3020,3010                                                  
C                                                                               
 3010 CONTINUE                                                                  
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C     CALL LLINK("R1OV5")                                                       
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
      CALL BODAN1(MBODAN)                                                       
      ILADE=1                                                                   
 3020 IF(MELVIB)3030,3040,3030                                                  
 3030 CONTINUE                                                                  
C                                                                               
C <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<            
C     IF(ILADE.EQ.0) CALL LLINK("R1OV5")                                        
C <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<            
C                                                                               
      CALL ELVIB1(MELVIB,MBODAN)                                                
 3040 IF((MBODAN.EQ.0.AND.MELVIB.EQ.0).OR.NDEGN.EQ.0)GO TO 3042                 
C                                                                               
C---- RESTORE CONSTRAINTS.                                                      
      REWIND ISC5                                                               
      READ(ISC5)LDEGN,(KDEGN(I),I=1,LDEGN)                                      
C                                                                               
C---- NEW CYCLE  OR FINISHING?                                                  
C                                                                               
 3042 READ(IN,19)IEF,NFLAG,ITEM1,ITEM2                                          
      IF(ITEM1.NE.0.OR.ITEM2.NE.0)ISC1=10*ITEM1+ITEM2                           
C                                                                               
C---- CHECK FOR LEGAL RANGE OF 'NFLAG'                                          
C                                                                               
      IF(NFLAG.LT.0.OR.NFLAG.GT.3)GO TO 7086                                    
C---- NO CARDS IF NFLAG=0                                                       
      IF(NFLAG.EQ.0)GO TO 7084                                                  
C                                                                               
C---- CARDS TO BE PUNCHED. IN THE CURRENT VERSION PUNCHING IS INTER-            
C     PRETED BY PRINTING ON HARD DISK OR TAPE.                                  
C                                                                               
C      REWIND IPUN                                                               
C  
	OPEN(UNIT=IPUN,STATUS='NEW',CARRIAGECONTROL='LIST',IOSTAT=IDUMMY)
C
C---- PUNCH XRAY67 CARDS IF NFLAG=1 OR 3                                        
      IF(NFLAG.EQ.2)GO TO 7093                                                  
      DO 7091 I=1,NATOM                                                         
      DO 7090 J=1,6                                                             
 7090 TFB(J)=BETA(J,I)*EGGY(J)                                                  
 7091 WRITE(IPUN,7092)(TAG(J,I),J=1,2),(XYZ(J,I),J=1,3),(TAG(J,I),J=1,2)        
     &,TFB                                                                      
C                                                                               
 7093 IF(NFLAG.EQ.1)GO TO 7083                                                  
C                                                                               
C---- PUNCH 'PROMETHEUS' CARDS IF  NFLAG=2 OR 3
C                                                                               
C---- SCALE FACTOR CARD                                                         
      WRITE(IPUN,7097)(SCALE(I),I=1,NSF)                                        
C                                                                               
C---- EXTINCTION CARD                                                           
C                                                                               
      IF(IZACH.EQ.1) GOTO 3500                                                  
C---- BECKER AND COPPENS EXTINCTION                                             
C                                                                               
      IF(IBDF(1).NE.0) GOTO 3501                                                
C---- NO EXTINCTION                                                             
      R(1)=0.                                                                   
      GOTO 3502                                                                 
C---- IBDF(1) IS GREATER THAN ZERO                                              
 3501 DO 3503 I=1,IPAREX(IBDF(1)+1)                                             
 3503 R(I)= BDF(IBKC ( IBDF(1))+I )                                            
 3502 WRITE(IPUN,27)IBDF(1),IBDF(2),(R(I),I=1,IPAREX(IBDF(1)+1))                
      GOTO 3504                                                                 
 3500 I=8                                                                       
      WRITE(IPUN,27)I,IEXT,EXTIN                                                
C                                                                               
C---- PUNCH ATOM PARAMETER CARDS                                                
C                                                                               
 3504 DO 7096 I=1,NATOM
                                                         
C      K=0                                                                       
C      IF(ISOT(I).GT.1)K=1                                                       
C      WRITE(IPUN,16)(TAG(J,I),J=1,2),SITE(I),OCCUP(I),OCCA(I),(ISCAT(J,I        
C     &),J=1,2),(XYZ(J,I),J=1,3),(BETA(J,I),J=1,6),K                             
C---- DO HIGHER ORDERS EXIST?                                                   
C      IF(K.EQ.0) GO TO 7096                                                     
C---- PUNCH 3RD CUMULANT                                                        
C      K=ISOT(I)-2                                                               
C      WRITE(IPUN,7094)(CR(J,I),J=1,10),K                                        
C      IF(K.EQ.0)GO TO 7096                                                      
C---- PUNCH 4TH CUMULANT                                                        
C      K=ISOT(I)-3                                                               
C      WRITE(IPUN,7095)(DR(J,I),J=1,15),K                                        
C      IF(K.EQ.0)GO TO 7096                                                      
CC---- PUNCH 5TH CUMULANT                                                        
C      K=ISOT(I)-4                                                               
C      WRITE(IPUN,7195)(ER(J,I),J=1,21),K                                        
C      IF(K.EQ.0)GO TO 7096                                                      
C---- PUNCH 6TH CUMULANT                                                        
C      WRITE(IPUN,7295)(ER(J,I),J=1,28)                                          
	ISITE=NINT(SITE(I)*REAL(JCELL*NSYM*(2-ICENT)))
	IF(ISOT(I).EQ.0)THEN			! ISOTROPIC CASE
	   WRITE(IPUN,16)(TAG(J,I),J=1,2),ISITE,
     &        OCCUP(I),OCCA(I),(ISCAT(J,I),J=1,2),'B',(XYZ(J,I),J=1,3),
     &        BETA(1,I)
	ENDIF
	K=MIN0(1,ISOT(I)-1)
	IF(K.GE.0.AND.ITTYP(I).EQ.0)THEN	! ANISOTROPIC BIJ-CASE
	   WRITE(IPUN,16)(TAG(J,I),J=1,2),ISITE,
     &        OCCUP(I),OCCA(I),(ISCAT(J,I),J=1,2),'B',(XYZ(J,I),J=1,3),
     &        (BETA(J,I),J=1,6),K
        ELSEIF(K.GE.0.AND.ITTYP(I).NE.0)THEN	! ANISOTROPIC UIJ-CASE
	   WRITE(IPUN,16)(TAG(J,I),J=1,2),ISITE,
     &        OCCUP(I),OCCA(I),(ISCAT(J,I),J=1,2),'U',(XYZ(J,I),J=1,3),
     &        (1.2665*EGGY(J)*BETA(J,I),J=1,6),K
	ENDIF
	K=MIN0(1,ISOT(I)-2)
	IF(K.GE.0)WRITE(IPUN,7094)(CR(J,I),J=1,10),K	
	K=MIN0(1,ISOT(I)-3)
	IF(K.GE.0)WRITE(IPUN,7095)(DR(J,I),J=1,15),K
	K=MIN0(1,ISOT(I)-4)
	IF(K.GE.0)WRITE(IPUN,7195)(ER(J,I),J=1,21),K	
	K=MIN0(1,ISOT(I)-5)
	IF(K.GE.0)WRITE(IPUN,7295)(FR(J,I),J=1,28)	

 7096 CONTINUE                                                                  
C                                                                               
C---- WRITE *END OF LIST*                                                       
C                                                                               
      WRITE(IPUN,7296)                                                          
C                                                                               
      IF(NPAR.EQ.0)GO TO 7100                                                   
C                                                                               
C---- PUNCH THE SPECIAL PARAMETERS                                              
C                                                                               
      WRITE(IPUN,90)NPAR                                                        
C                                                                               
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>          
C     CALL LLINK("R2OV1")                                                       
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>          
C                                                                               
      CALL PUNPAR                                                               
C                                                                               
C                                                                               
C---- ALPHA PARAMETER CARD.                                                     
C                                                                               
 7100 IF(MODELL.LT.3) GOTO 7101                                                 
      WRITE(IPUN,1801)(ALF(I),I=1,NATOM)                                        
C                                                                               
C---- PUNCH TEMPERATURE FACTOR TYPE CARD                                        
C                                                                               
 7101 WRITE(IPUN,7395)(ITYP(ISOT(I)+1),I=1,NATOM)                               
      GO TO 7083                                                                
C                                                                               
C---- THERE WAS AN ILLEGAL VALUE OF NFLAG ON CARD. IT IS IGNORED.               
C                                                                               
 7086 WRITE(IOUT,7087)NFLAG                                                     
C                                                                               
 7083 CONTINUE					! END FILE IPUN
 7084 CONTINUE                                                                  
C                                                                               
C                                                                               
      IF(MSF.lt.2.or.msf.eq.4) goto 9980                                
C                                                                               
CF*F*F*F*F*F*F*F*F*F*F*F THIS SECTION ENDS THE FOURIER FILE *F*F*F*F*F*F        
C                                                                               
      WRITE(ISC4)NATOM,((TAG(J,I),J=1,2),ISOT(I),(ISCAT(J,I),J=1,2),            
     &OCCA(I),OCCUP(I),SITE(I),(XYZ(J,I),J=1,3),(BBETA(J,I),J=1,6),             
     &I=1,NATOM),(SIGO(I),(SIGXYZ(J,I),J=1,3),(SIGB(J,I),J=1,6),I=1,NATO        
     &M)                                                                        
      END FILE ISC4                                                             
C                                                                               
CF*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F*F        
C                                                                               
 9980 CONTINUE                                                                  
      IF(IEF)100,4000,100                                                       
C                                                                               
C                   ------------------------                                    
C                   I  END OF CALCULATION  I                                    
C                   ------------------------                                    
C                                                                               
 4000 REWIND ISC1                                                               
      IF(MOD(IFILE,2))4080,4010,4080                                            
C                                                                               
C---- WRITE SAVE UNIT                                                           
C                                                                               
 4010 LDEGN=2*NDEGN                                                             
      WRITE(ISC1)                                                               
     &KCYL,LABEL,RECELL,G,VOL,NSYM,NATOM,NSCAT,JCELL,MRANK,NPARA,NSF,DMI        
     &N,DMAX,DELMAX,ICENT,(((RMAT(I,J,K),I=1,3),J=1,3),K=1,NSYM),((TRANS        
     &(I,J),I=1,3),J=1,NSYM),((CELLP(I,J),I=1,3),J=1,JCELL),(IPARA(I),I=        
     &1,NPARA),((FCURVE(I,J),I=1,9),J=1,NSCAT),(SCALE(I),I=1,NSF),IREJ,F        
     &OMAX,FOMIN,RHOMN,RHOMX,(JSCRF(I),I=1,NSF),NRSF,WINKEL,AG,BG,CG            
     &,NPAR,(PAR(I),(PARNAM(J,I),J=1,2),IPAR(I),IRPAR(I),I=1,NPAR),FISGN        
     &,IFSGN,EGGY,KEXTRF,BDF,GAMMAP,WVLNTH,INTPOL,JUNK6,INEUT,NWT,IWT           
     &,(INTER(I),I=1,NATOM),((X(J,I),I=1,INTPOL),J=1,35),((Y(J,I),I=1,IN        
     &TPOL),J=1,35),IUB,EXTRAN,IZACH,IREJEC,UNTEN,OBEN,MODELL,(ALF(I),I=        
     &1,NATOM),(IALFA(I),I=1,NATOM),(RDAMP(I),IDAMP(I),I=1,MRANK),IEQPMT        
      WRITE(ISC1)                                                               
     &((ANOM(J,I),J=1,2),I=1,NSCAT),IEXT,EXTIN,((TAG(J,I),J=1,2),ISOT(I)        
     &,(ISCAT(J,I),J=1,2),OCCA(I),OCCUP(I),SITE(I),(XYZ(J,I),J=1,3),            
     &(BETA(J,I),J=1,6),(CR(J,I),J=1,10),(DR(J,I),J=1,15),I=1,NATOM),           
     &LDEGN,(KDEGN(I),I=1,LDEGN),HELPE,HELPF,IHIGH,((ER(J,I),J=1,21),(FR        
     &(J,I),J=1,28),I=1,IHIGH),IZAEHL                                           
C                                                                               
 4020 READ(ISC2)(IBUFF(I),I=1,LBUFF)                                            
C                                                                               
      WRITE(ISC1)(IBUFF(I),I=1,LBUFF)                                           
C                                                                               
      IF(IBUFF(1))4060,4020,4060                                                
 4060 REWIND ISC2                                                               
      IF(IFIRST.EQ.0.AND.MFSEL.EQ.0)GO TO 4062                                  
      IK=MDEGN+1                                                                
      IJ=MDEGN+(MRANK*(MRANK+1))/2                                              
      WRITE(ISC1)MDEGN,(A(J),J=1,MDEGN)                                         
      WRITE(ISC1)(A(J),J=IK,IJ)                                                 
      WRITE(ISC1)((BBETA(J,I),J=1,6),SIGO(I),(SIGXYZ(J,I),J=1,3),(SIGB(J        
     &,I),J=1,6),I=1,NATOM)                                                     
      write(isc1)(bffd(i),i=1,mrank),(jirl(i),i=1,84*natom)
 4062 END FILE ISC1                                                             
C                                                                               
      REWIND ISC1                                                               
C                                                                               
C---- END OF THIS ROUTINE IF NEW PARAMETERS ARE TO BE SAVED                     
C                                                                               
      RETURN                                                                    
C                                                                               
C---- END OF RUN FOR NEW PARAMETERS NOT SAVED                                   
C                                                                               
 4080 ISC1=0                                                                    
      RETURN                                                                    
C----------------------------------------------------------------               
C                                                                               
C---- AUXILLARY PART FOR PARTIAL STRUCTURE FACTOR CALCULATION                   
C                                                                               
 9000 ASAVE=ACALC                                                               
      BSAVE=BCALC                                                               
      IF(IPART.EQ.2) FOBS=SQRT(ACALC**2 + BCALC**2)                             
      DO 9001 I=1,NATOM                                                         
      HOLDP(I) = OCCUP(I)                                                       
      HOLDO(I) = OCCA(I)                                                        
      IF(IOCCUP(I).NE.0) GOTO 9001                                              
      OCCUP(I)=0.                                                               
      OCCA(I) =0.                                                               
 9001 CONTINUE                                                                  
      GOTO 871                                                                  
C                                                                               
C---- RESTORE POPULATION PARAMETERS.                                            
C                                                                               
 9002 DO 9003 I=1,NATOM                                                         
      OCCUP(I) = HOLDP(I)                                                       
 9003 OCCA(I)  = HOLDO(I)                                                       
      GOTO 8711                                                                 
C                                                                               
C----------------------------------------------------------------               
C                                                                               
C---- ERROR MESSAGE WITH PROGRAMME BREAK DOWN.                                  
C               NO DATA HAD BEEN FOUND ON MAINUNIT NO. ISC1.                    
  143 WRITE(IOUT,144)ISC1                                                       
      CALL EXIT                                                                 
C                                                                               
C---- ERROR IN RECORD TWO OF THE BIARY FILE ISC1                                
  145 WRITE(IOUT,146)ISC1                                                       
      CALL EXIT                                                                 
      RETURN                                                                    
C                                                                               
      END                                                                       
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
