                           SUBROUTINE IINVER                                   
     & (MCORR,SIGB,BBETA,SIGXYZ,SIGO,EGGY,NSF,TEMM,RMINUS,MODELL,SEMAX)         
C                                                                               
C              POST-CYCLE MATRIX INVERSION AND PARAMETER CHANGES                
C                                                                               
C                 ORIGIN IS A SUBROUTINE WRITTEN BY L.W. FINGER                 
C                                                                               
C      MODIFIED FOR EXTINCTION CORRECTION OF BECKER AND COPPENS, ALPHA -        
C      REFINEMENT AND  THERMAL  VIBRATIONS  OF FIFTH AND SIXTH  ORDER AS        
C                           WELL AS FOR DAMPING                                 
C                                                                               
C                              BY UDO ZUCKER                                    
C             ERROR CORRECTION (DERIVATIVE OF SCALE FACTOR)                     
C                       MARCH 83 BY W.F.KUHS ILL                                
C                                                                               
C                                                                               
C    INPUT VARIABLES                                                            
C    ---------------                                                            
C                                                                               
C    MCORR = 0/1  DO NOT/DO   PRINT COMPLETE CORRELATION MATRIX                 
C    SIGB  = VARIANCE OF THE THERMAL PARAMETERS IN U(IJ)                        
C    BBETA = ARRAY CONSISTING OF U(IJ) OF EACH ATOM                             
C    SIGXYZ= ARRAY CONSISTING OF THE ERRORS OF THE COORDINATES.                 
C    SIGO  = ARRAY CONSISTING OF THE ERRORS OF OCCUPANCY.                       
C    EGGY  = ARRAY DEFINED IN HEAD OF SUBROUTINE LOADNW.                        
C    NSF   = NUMBER OF SCALE FACTORS READ IN.                                   
C    TEMM  = GOODNESS OF FIT.                                                   
C    RMINUS= WEIGHTED R VALUE FOR OPPOSITE DIRECTION BY CHANGING ORIEN-         
C            TATION (ENANTIOMORPHIC ORIENTATION)                                
C    MODELL= NUMBER OF STRUCTURE FACTOR FORMALISM USED.                         
C    SEMAX = MAXIMUM SHIFT/ERROR                                                
C                                                                               
      DOUBLE PRECISION HEAD5,HEAD6                                              
C                                                                               
      DIMENSION      IBDF(2), IQTQ(100), HEAD5(21), HEAD6(28), ER(21,6),        
     & FR(28,6), EGGY(6), BBETA(6,60), SIGB(6,60),SIGO(60),SIGXYZ(3,60),        
     & SAVE(120),HIB(20), KB(20), JB(20), KDEGN(2640),AA(2640),HEAD(36),        
     & ISTORE(7),IST(7),DELALF(60), ERRALF(60), IZ(60),IWORD(8),IREF(2),
     & jir(84,60)         
C                                                                               
C---- NEXT STATEMENTS FOR EMAS EDINBURGH TO TELL WHAT WE WANT EXPLICITLY        
C                                                                               
      DIMENSION BFFA(360,1),BFFB(240),BFFC(360),BFFD(360,1)                     
C                                                                               
C---- THATS IT, MORE DOWN IN EQUIVALENCE STATEMENTS                             
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(02200)                                                                 
      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/G/ BUFF(1023),FCURVE(9,20),IFMT(18),IWT,NSCAT,BETFAC,WVLNTH        
     &,WTFAC                                                                    
      COMMON/POL/ INTER(20),X(35,4),Y(35,4),INTPOL                              
      COMMON/COPPEN/YEXT,BDF(16),JUNK6                                          
      COMMON/EXTI/ITYP,IDISTR,QTQ(100)                                          
      COMMON/ILABEL/IDATA1(49)                                                  
C                                                                               
C                                                                               
C---- MORE STUFF FOR EMAS -------------------------------------------           
C                                                                               
      EQUIVALENCE (DBDB(1,1),BFFA(1,1)),(DBDO(1),BFFB(1)),                      
     &(DADB(1,1),BFFC(1),BFFD(1,1))                                             
C                                                                               
C---- THAT'S IT                                                                 
C                                                                               
      EQUIVALENCE (HIB,DADO),(KB(1),DADO(21)), (JB(1),DADO(41)),  (SAVE,        
     & DAALFA),(KDEGN,AA,DADC(1,37)),(IBDF,BDF),(BUFF,DELALF),(BUFF(61),        
     & ERRALF), (IQTQ,QTQ), (BUFF(121),IZ), (DR(1,41),ER),(DR(7,49),FR),
     & (jirl(1),jir(1,1))        
C                                                                               
      DATA IWORD,IREF /4H G  ,4H R  ,4H Z11,4H Z22,4H Z33,4H Z12,4H Z13,        
     &                 4H Z23,4HFOBS,4H F*F/                                    
      DATA HEAD/1HX,1HY,1HZ,1HB,2H11,2H22,2H33,2H12,2H13,2H23,3H111,3H22        
     &2,3H333,3H112,3H122,3H113,3H133,3H223,3H233,3H123, 4H1111, 4H2222,        
     &4H3333,4H1112,4H1113,4H1122,4H1123,4H1133,4H1222,4H1223,4H1233,4H1        
     &333,4H2223,4H2233,4H2333,1H /                                             
      DATA HEAD5/       5H11111,5H22222,5H33333,5H11112,5H11113,5H11122,        
     &  5H11123,5H11133,5H11222,5H11223,5H11233,5H11333,5H12222,5H12223,        
     &  5H12233,5H12333,5H13333,5H22223,5H22233,5H22333,5H23333/                
      DATA HEAD6/ 6H111111,6H222222,6H333333,6H111112,6H111113,6H111122,        
     &   6H111123,6H111133,6H111222,6H111223,6H111233,6H111333,6H112222,        
     &   6H112223,6H112233,6H112333,6H113333,6H122222,6H122223,6H122233,        
     &   6H122333,6H123333,6H133333,6H222223,6H222233,6H222333,6H223333,        
     &   6H233333/                                                              
C                                                                               
C                                                                               
    8 FORMAT(1H1,18A4,18X,9HCYCLE NO.,I4 ///1H )                                
   34 FORMAT(13H MATRIX RANK ,I3,12H INSTEAD OF ,I3/16H JOB TERMINATED.)        
   36 FORMAT(1H0,28X,9HPARAMETER,19X,3HOLD,10X,6HCHANGE,9X,                     
     &3HNEW, 9X,5HERROR,9X, 11HSHIFT/ERROR,1X,3HNP.,5HDAMP./1H )                
   38 FORMAT(7H0  ATOM,I3,4X,2A3,7X,21HEQUIPOINT FRACTION = ,F6.3/1H )          
   40 FORMAT(   27X,12HSCALE FACTOR,I3,6X,F12.4,F15.4,F13.4,F15.5,F16.2,        
     &I5,2X,A4//1H )                                                            
   44 FORMAT(27X,17HOCCUPANCY SPECIES,I3,F16.5,F15.5,F13.5,F14.5,F14.2,I        
     &5,2X,A4)                                                                  
   46 FORMAT(27X,17HOCCUPANCY SPECIES,I3,F16.5,15X,F13.5,F14.7)                 
   48 FORMAT(27X,25HTOTAL OCCUPANCY (FIXED) =,F11.5)                            
   50 FORMAT(27X,A1,20X,2F15.7,F13.7,F14.7,F14.2,I5,2X,A4)                      
   51 FORMAT(27X,4HBETA,A2,15X,2F15.7,F13.7,F14.7,F14.2,I5,2X,A4)               
  511 FORMAT(27X,1HU,A2,18X,2F15.7,F13.7,F14.7,F14.2,I5,2X,A4)                  
   52 FORMAT(27X,A1,20X,F15.7,15X,F13.7,F14.7)                                  
   53 FORMAT(27X,4HBETA,A2,15X,F15.7,15X,F13.7,F14.7)                           
  531 FORMAT(27X,1HU,A2,18X,F15.7,15X,F13.7,F14.7)                              
   54 FORMAT(1H1,18A4//10X,18HCORRELATION MATRIX/1H )                           
   56 FORMAT(5H0 ROW,I4/(10(I4,F8.4)))                                          
   57 FORMAT(1H1,18A4/48H0CORRELATION COEFICIENTS WITH LARGEST MAGNITUDE        
     &S//4(23H  PARAMETERS   VALUE   )/(/4(2I6,F9.4,2X)))                       
   59 FORMAT(3X,21HEXTINCTION CORRECTION)                                       
   60 FORMAT(/15X,9HISOTROPIC)                                                  
   63 FORMAT(/15X,20HANISOTROPIC - TYPE  ,I1)                                   
   65 FORMAT(/27X,7HR-STAR ,A2,17X,E10.4,18X,E10.4)                             
   67 FORMAT(/27X,7HR-STAR ,A2,13X,2(5X,E10.4),3X,E10.4,4X,E10.4,F13.2,I        
     &5,2X,A4)                                                                  
   74 FORMAT(///25X,22HMAXIMUM SHIFT/ERROR = ,F10.2//25X,22HAVERAGE SHIF        
     &T/ERROR = ,F10.2)                                                         
   75 FORMAT(/7H0REMARK/1X,6(1H-)//121H THERMAL PARAMETERS OF THIRD, FOU        
     &RTH, FIFTH AND SIXTH ORDER ARE MULTIPLIED BY 10**3, 10**4, 10**5 A        
     &ND 10**6 RESPECTIVELY.)                                                   
  751 FORMAT(/7H0REMARK/1X,6(1H-)//30H UIJ ARE MULTIPLIED BY 10**2. )           
   76 FORMAT(44H ESTIMATED STD. DEV. FOR OBS. OF UNIT WEIGHT,5X,F12.2,30        
     &X,29HSTRUCTUREFACTOR EQUATION NO. ,I3/91X,13HREFINEMENT ON,5X,A4//        
     & 1H )                                                                     
   78 FORMAT(   27X,12HSCALE FACTOR,I3,6X,F12.4,15X,F13.4//1H )                 
   80 FORMAT(27X,2HC(,A3,1H),16X,2(4X,E11.4),2X,E11.4,3X,E11.4,F13.2,I5,        
     & 2X,A4)                                                                   
   82 FORMAT(27X,2HC(,A3,1H),20X,E11.4,17X,E11.4,3X,E11.4)                      
   86 FORMAT(27X,2HD(,A4,1H),15X,2F15.9,F13.9,F14.9,F13.2,I5,2X,A4)             
   88 FORMAT(27X,2HD(,A4,1H),19X,E11.4,17X,E11.4,3X,E11.4)                      
   95 FORMAT(/3X,18HSPECIAL PARAMETERS)                                         
   96 FORMAT(27X,2A4,13X,2F15.8,F13.8,F14.8,F14.2,I5)                           
   97 FORMAT(27X,2A4,13X,F15.8,15X,F13.8,F14.8)                                 
   98 FORMAT(/9X,23HPRESENT ORIENTATION IS ,F4.0,39H  WTD R FOR THE OPPO        
     &SITE ORIENTATION IS ,F7.4,25H  THE NEW ORIENTATION IS ,F4.0)              
  586 FORMAT(27X,2HE(,A5,1H),14X,2F15.9,F13.9,F14.9,F13.2,I5,2X,A4)             
  588 FORMAT(27X,2HE(,A5,1H),18X,E11.4,17X,E11.4,3X,E11.4)                      
  781 FORMAT(///)                                                               
  886 FORMAT(27X,2HF(,A6,1H),14X,2F15.9,F13.9,F14.9,F13.2,I5,2X,A4)             
  888 FORMAT(27X,2HF(,A6,1H),18X,E11.4,17X,E11.4,3X,E11.4)                      
 2012 FORMAT(/27X,7HALPHA  ,11X,2(5X,F10.4),3X,F10.4,8X,F10.4,F                 
     & 14.2,I5,1H*,1X,A4)                                                       
 2014 FORMAT(/27X,7HALPHA  ,16X,F10.4,18X,F10.4//)                              
 2289 FORMAT(1H )                                                               
 3155 FORMAT(1H0,19A4)                                                          
 3172 FORMAT(1H0,8A4)                                                           
 3204 FORMAT(1H0,39X,A4, 5X,2(5X,E10.4),3X,E10.4,4X,E10.4,                      
     &F13.2,I5,2X,A4)                                                           
 3206 FORMAT(1H0,39X,A4,10X,E10.4,18X,E10.4)                                    
 4007 FORMAT(1H0,39X,A4,5X,2(5X,E10.4),3X,E10.4,4X,E10.4,F13.2,I5,F6.2)         
 4018 FORMAT(1H0,39X,A4,5X,2(5X,E10.4),3X,E10.4,4X,E10.4,F13.2,I5,2X,A4)        
C                                                                               
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                   ONLY A FLAG FOR OVERLAY ADMINISTRATION                      
                                  ILADE=0                                       
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      TEMPZZ=8.*PI*PI                                                           
C                                                                               
C                                                                               
C---- LEAST-SQUARES MATRIX INVERSION                                            
C                                                                               
      N=-MRANK                                                                  
      NJ=MRANK+1                                                                
C                                                                               
C---- CONDITION MATRICES                                                        
C                                                                               
          DO 2041 I=1,MRANK                                                     
          N=N+NJ                                                                
          NJ=NJ-1                                                               
 2041     BFFA(I,1)=1.0/SQRT(A(N+MDEGN))                                        
C                                                                               
      N=MDEGN                                                                   
C                                                                               
          DO 2042 I=1,MRANK                                                     
          BFFB(I)=B(I)                                                          
          B(I)=B(I)*BFFA(I,1)                                                   
               DO 2042 J=I,MRANK                                                
               N=N+1                                                            
 2042     A(N)=A(N)*BFFA(I,1)*BFFA(J,1)                                         
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                            LOAD OVERLAY                                       
C                         CALL LLINK("R2OV1")                                   
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C---- INVERSION                                                                 
      IASIZ = MAXIMA - MDEGN                                                     
      CALL SYMINV(A(MDEGN+1),MRANK,BFFC,1,B,1.0E-10,DET,JRANK,IASIZ)            
C                                                                               
C---- IS RANK OF MATRIX EQUAL NUMBER OF PARAMETERS?                             
C                                                                               
      IF(JRANK-MRANK)2050,2060,2050                                             
C---- NO.                                                                       
 2050 WRITE(IOUT,34)JRANK,MRANK                                                 
      CALL EXIT                                                                 
C                                                                               
C---- YES, WRITE TITLE OF CYCLE AND NO. OF CYCLE.                               
 2060 I = KCYL+1                                                                
      WRITE(IOUT,8)TITLE,KCYL                                                   
C                                                                               
C---- INITIALIZE, II IS FIRST MATRIX ELEMENT IN FIELD A (CONSTRAINTS ARE        
C     IN FRONT OF.)                                                             
      II=1+MDEGN                                                                
      SUM=0.0                                                                   
      TERM=TEMM**2                                                              
C                                                                               
C---- CONVERT MATRIX TO COVARIANCE MATRIX                                       
C                                                                               
            DO 2070 I=1,MRANK                                                   
            BFFD(I,1)=SQRT(A(II)*TERM)*BFFA(I,1)                                
            B(I)=B(I)*BFFA(I,1)                                                 
            SUM=SUM+B(I)*BFFB(I)                                                
                       DO 2070 J=I,MRANK                                        
                       A(II)=A(II)*TERM*BFFA(I,1)*BFFA(J,1)                     
 2070       II=II+1                                                             
C                                                                               
C---- WRITE ESTIMATED STANDARD DEVIATION FOR OBSERVATION OF UNIT WEIGHT         
C     AND USED STRUCTURE FACTOR EQUATION.                                       
C                                                                               
      SUM=SQRT((RNUM(19)-SUM)/FLOAT(NUMBER(19)-MRANK))                          
      WRITE(IOUT,76)SUM,MODELL,IREF(MREF+1)                                     
C                                                                               
C---- INITIALIZE PARAMETER UPDATE.                                              
C                                                                               
      IJ    = 1                                                                 
      SUM   = 0.0                                                               
      SEMAX = 0.0                                                               
C                                                                               
C---- COMPUTE AND PRINT NEW PARAMETERS                                          
C                                                                               
      IF(IZACH.EQ.0)GOTO 3100                                                   
C                                                                               
C---- EXTINCTION CORRECTION OF ZACHARIASEN. WRITE *EXTINCT.-CORRECTION*         
C                                                                               
      WRITE(IOUT,59)                                                            
C---- ISOTROPIC OR ANISOTROPIC?                                                 
      IF(IEXT)2074,2072,2074                                                    
C                                                                               
C---- ISOTROPIC EXTINCTION, SET POINTERS.                                       
 2072 WRITE(IOUT,60)                                                            
      J=1                                                                       
      K=35                                                                      
      GO TO 2076                                                                
C                                                                               
C---- ANISOTROPIC EXTINCTION, SET POINTER.                                      
 2074 WRITE(IOUT,63)IEXT                                                        
      J=6                                                                       
      K=4                                                                       
C                                                                               
 2076 WRITE(IOUT,36)                                                            
C                                                                               
C                                                                               
C---- EXPLANATION OF PARAMETER UPDATE IN THE EXAMPLE OF EXTINCTION.             
C                                                                               
C---- DO LOOP OVER THE J PARAMETERS OF EXTINCTION.                              
      DO 2090 I=1,J                                                             
C---- KEXTRF(I) = 0/MATRIXPOINTER MEANS  PARAMETER IS NOT/IS REFINED.           
      IF(KEXTRF(I))2080,2082,2080                                               
C---- EXTINCTION CORRECTION REFINED                                             
C     STORE OLD PARAMETER VALUE.                                                
 2080 TEMP=EXTIN(I)                                                             
C---- NEW=OLD+CHANGE*DAMPING                                                    
      EXTIN(I)=EXTIN(I)+B(IJ)*RDAMP(IJ)                                         
C---- TEMP1 IS SHIFT/ERROR                                                      
      TEMP1=B(IJ)/BFFD(IJ,1)                                                    
C---- FIND GREATEST SHIFT/ERROR.                                                
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
C---- SUMMATION OVER ALL SHIFT/ERROR TO COMPUTE LATER AVERAGED SHIFT/           
C     ERROR.                                                                    
      SUM=SUM+ABS(TEMP1)                                                        
C---- WRITE OUT, PARAMETERNAME, OLD VALUE, SHIFT, NEW VALUE, ERROR,             
C     SHIFT/ERROR, NUMBER OF REFINED PARAMETER, DAMPING FACTOR.                 
      WRITE(IOUT,67)HEAD(I+K),TEMP,B(IJ),EXTIN(I),BFFD(IJ,1),TEMP1              
     &,IJ,IDAMP(IJ)                                                             
C---- INCREASE NUMBER OF PARAMETERS BY ONE.                                     
      IJ=IJ+1                                                                   
      GO TO 2090                                                                
C                                                                               
C---- PARAMETER IS NOT REFINED (HERE ALWAYS FIXED ONE.)                         
C     WRITE NAME, OLD AND NEW VALUE OF PARAMETER.                               
 2082 WRITE(IOUT,65)HEAD(I+K),EXTIN(I),EXTIN(I)                                 
 2090 CONTINUE                                                                  
      GOTO 2092                                                                 
 3100 CONTINUE                                                                  
C                                                                               
C---- EXTINCTION CORRECTION OF BECKER AND COPPENS                               
C                                                                               
C---- NOW FILL IN THE OUTPUT ARRAY.                                             
C                                                                               
C---- CLEAR FIELD.                                                              
      DO 3105 I=1,19                                                            
 3105 IQTQ(I)=IDATA1(27)                                                        
C---- IF EXTINCTION GOTO 3110                                                   
      IF(IBDF(1).NE.0)GOTO 3110                                                 
C---- FILL IN * NO EXTINCTION CORRECTION *                                      
      DO 3107 I=1,7                                                             
 3107 IQTQ(I)=IDATA1(I)                                                         
      GOTO 3150                                                                 
C                                                                               
C---- THERE IS A EXTINCTION MODEL SELECTED.                                     
C                                                                               
 3110 CONTINUE                                                                  
C                                                                               
C---- FILL IN * ANISOTROPIC *                                                   
      DO 3112 I=1,3                                                             
 3112 IQTQ(I)=IDATA1(I+8)                                                       
C---- IF ISOTROPIC HAD BEEN CHOSEN, CHANGE *ANIS*  TO *  IS*                    
      IF(IBDF(1)+1.LE.4)IQTQ(1)=IDATA1(8)                                       
C---- WRITE *EXTINCTION CORRECTION*                                             
      DO 3118 I=1,6                                                             
 3118 IQTQ(I+3)=IDATA1(I+1)                                                     
C                                                                               
C---- BRANCH CORRESPONDING TO EXTINCTION MODEL.                                 
C                                                                               
      GOTO(3150,3120,3130,3140,3120,3130,3140),IBDF(1)+1                        
C                                                                               
C---- ISOTROPIC TYP I EXTINCTION.                                               
C                                                                               
C---- FILL IN   *TYPE 1   GAUSSIAN     DISTRIBUTION*                            
 3120 DO 3122 I=1,2                                                             
      IQTQ(I+9)=IDATA1(I+11)                                                    
      IQTQ(I+11)=IDATA1(I+14)                                                   
      IQTQ(I+13)=IDATA1(I+19)                                                   
 3122 IQTQ(I+15)=IDATA1(I+21)                                                   
C                                                                               
C---- IF IBDF=1 CHANGE *GAUSSIAN DISTRIBUTION* TO *LORENZIAN DIST..*            
      IF(IBDF(2))3150,3150,3124                                                 
 3124 DO 3126 I=1,7                                                             
 3126 IQTQ(I+11)=IDATA1(I+16)                                                   
      GOTO 3150                                                                 
C                                                                               
C---- ISOTROPIC TYPE 2 EXTINCTION.                                              
C                                                                               
C---- FILL IN *TYPE 2*                                                          
 3130 IQTQ(10)=IDATA1(12)                                                       
      IQTQ(11)=IDATA1(14)                                                       
      GOTO 3150                                                                 
C                                                                               
C---- ISOTROPIC GENERAL CASE.                                                   
C                                                                               
C---- FILL IN  *GENERAL CASE* AND IN IQTQ(13) ONLY A BLANK.                     
 3140 DO 3142 I=1,3                                                             
 3142 IQTQ(I+9)=IDATA1(I+23)                                                    
      IQTQ(13)=IDATA1(27)                                                       
C---- FILL IN *GAUSSIAN DISTRIBUTION*                                           
      DO 3144 I=1,2                                                             
      IQTQ(I+13)=IDATA1(I+14)                                                   
      IQTQ(I+15)=IDATA1(I+19)                                                   
 3144 IQTQ(I+17)=IDATA1(I+21)                                                   
C                                                                               
C---- IF IBDF=1 CHANGE *GAUSSIAN DISTR. * TO *LORENZIAN DISTR. *                
      IF(IBDF(2))3150,3150,3146                                                 
 3146 DO 3148 I=1,7                                                             
 3148 IQTQ(I+12)=IDATA1(I+16)                                                   
C                                                                               
C---- OKAY, NOW PRINT THE EXTINCTION TYPE USED.                                 
C                                                                               
 3150 CONTINUE                                                                  
      WRITE(IOUT,3155)(IQTQ(I),I=1,19)                                          
      WRITE(IOUT,36)                                                            
C                                                                               
C---- PRINT HEADER *PARAMETER  OLD CHANGE NEW ERROR SHIFT/ERROR DAMP.*          
C                                                                               
C                                                                               
C                                                                               
C---- IF *NO EXTINCTION* GOTO 3400 ELSE FILL IN *EXTINCTION PARAMETERS          
C                                            X 10**-4 *  AND WRITE IT.          
      IF(IBDF(1).EQ.0)GOTO 3400                                                 
      DO 3165 I=1,2                                                             
      IQTQ(I)=IDATA1(I+1)                                                       
      IQTQ(I+2)=IDATA1(I+27)                                                    
      IQTQ(I+4)=IDATA1(I+29)                                                    
 3165 IQTQ(I+6)=IDATA1(I+31)                                                    
      WRITE(IOUT,3172)(IQTQ(I),I=1,8)                                           
C                                                                               
C---- RESTORE THE OLD PARAMETER VALUES. FIELD NUMBER IS A FUNCTION              
C     OF THE USED EXTINCTION MODEL.                                             
C     IEND IS THE CURRENT DO TERMINAL PARAMETER.                                
C     ISTORE(I) IS THE NO. OF THE FIELD ELEMENT OF THE I TH EXTIN.              
C               PARAMETER.                                                      
C     IST(I)    IS  THE NO. OF THE FIELD ELEMENT OF THE ARRAY WORD              
C               CONTAINING THE NAMES OF THE CORRESPONDING PARAMET.              
C                                                                               
C     THIS STRANGE PROGRAMME PART IS A CONSEQUENCE OF THE ADAPTION              
C     OF THIS PROGRAMME FROM XRAY 80 SYSTEM.                                    
C                                                                               
      GOTO(3400,3301,3302,3303,3304,3305,3306),IBDF(1)+1                        
C---- ISOTROPIC TYPE 1                                                          
 3301 IEND=1                                                                    
      ISTORE(1)=3                                                               
      IST(1)=1                                                                  
      GOTO 3299                                                                 
C---- ISOTROPIC TYP 2                                                           
 3302 IEND=1                                                                    
      ISTORE(1)=4                                                               
      IST(1)=2                                                                  
      GOTO 3299                                                                 
C---- ISOTROPIC GENERAL CASE                                                    
 3303 IEND=2                                                                    
      ISTORE(1)=4                                                               
      ISTORE(2)=3                                                               
      IST(1)=2                                                                  
      IST(2)=1                                                                  
      GOTO 3299                                                                 
C---- ANISOTROPIC TYP 1                                                         
 3304 IEND=6                                                                    
      DO 3314 J=1,6                                                             
      ISTORE(J)=4+J                                                             
 3314 IST(J)=2+J                                                                
      GOTO 3299                                                                 
C---- ANISOTROPIC TYP 2                                                         
 3305 IEND=6                                                                    
      DO 3315 J=1,6                                                             
      ISTORE(J)=10+J                                                            
 3315 IST(J)=2+J                                                                
      GOTO 3299                                                                 
C---- ANISOTROPIC GENERAL CASE                                                  
 3306 IEND=7                                                                    
      DO 3316 J=1,6                                                             
      ISTORE(J)=4+J                                                             
 3316 IST(J)=2+J                                                                
      IST(7)=2                                                                  
      ISTORE(7)=4                                                               
 3299 CONTINUE                                                                  
C                                                                               
C---- NOW UPDATE REFINED PARAMETERS. THERE ARE DIFFERENT POSSI-                 
C     BILITIES  BECAUSE OF  THE  AUTOMATIC  DAMPING PROCEDURES.                 
C                                                                               
      DO 3201 I=1,IEND                                                          
C                                                                               
      IF(KEXTRF(I))3202,3203,3202                                               
C                                                                               
C---- PARAMETER HAS BEEN REFINED.                                               
 3202 TEMP=BDF(ISTORE(I))                                                       
C---- WHAT KIND OF PARAMETER DAMPING?   (PATHES GIVEN BY FLAGS)                 
C     JUNK6=2  NO DAMPING AT ALL.                                               
C     JUNK6=1  NO AUTOMATIC DAMPING, DAMPING FACTORS TO BE READ                 
C                                                                               
C     JUNK6=0  IN ISOTROPIC   CASE,         CONTROL THAT R,G>=0                 
C              IN ANISOT. CASE.  CHANGES  OF PARAMETERS MAY FOR                 
C              DIAGONALELEMENTS NOT GREATER THAN 1/2. FOR OFF -                 
C              DIAGONALELEMENTS NOT GREATER THAN 1.1.                           
C              IN GENERAL CASE            CONTROL THAT R,G >= 0                 
C                                                                               
C---- COMPUTE PATH-FLAGS.                                                       
      JUNK9=0                                                                   
C---- NO AUTOMATIC, BUT SELF HANDLE DAMPING, GOTO 4017                          
      IF(JUNK6) 4017,4015,4017                                                  
C                                                                               
C                                                                               
 4015 IF(IBDF(1).GT.3.AND.IST(I).GT.2) GOTO 4012                                
C---- DAMPING IN ISOTROPIC CASE AND FOR R IN GENERAL CASE.                      
C     IF R,G NEGATIVE - SET TO POSITIVE VALUE. USE INCREASING                   
C     DAMPING FACTORS   0.9, 0.8, 0.7, ......                                   
C                                                                               
      BDF(ISTORE(I))=TEMP + B(IJ)                                               
      DAEMPF = 0.0                                                              
      IF(BDF(ISTORE(I))) 4003,4006,4006                                         
 4003 JUNK9 = 1                                                                 
 4010 DAEMPF=DAEMPF+1.0                                                         
      BDF(ISTORE(I)) =BDF(ISTORE(I))-0.1*B(IJ)                                  
C---- AS LONG AS G,R ARE NEGATIVE DAMPING FACTOR INCREASES.                     
      IF(BDF(ISTORE(I))) 4010,4006,4006                                         
C                                                                               
C---- POSITIVITY IS REACHED.                                                    
C                                                                               
 4006 TEMP1 = B(IJ)/BFFD(IJ,1)                                                  
      IF(ABS(TEMP1).GT.ABS(SEMAX))SEMAX=TEMP1                                   
      SUM=SUM+ABS(TEMP1)                                                        
C---- PRINT PARAMETERS AND COMPUTED DAMPING FACTOR                              
      DAEMPF=1.-0.1*DAEMPF                                                      
      IF(JUNK9.EQ.1) WRITE(IOUT,4007)IWORD(IST(I)),TEMP,B(IJ),                  
     & BDF(ISTORE(I)),BFFD(IJ,1),TEMP1,IJ,DAEMPF                                
      IF(JUNK9.EQ.0) WRITE(IOUT,4007)IWORD(IST(I)),TEMP,B(IJ),                  
     & BDF(ISTORE(I)),BFFD(IJ,1),TEMP1,IJ                                       
      IJ = IJ+1                                                                 
      GOTO 3201                                                                 
C                                                                               
C---- ANISOTROPIC CASE (WITHOUT R IN GENERAL CASE)                              
C                                                                               
 4012 IF(IST(I).GT.5) GOTO 4024                                                 
C                                                                               
C---- DIAGONAL ELEMENTS                                                         
      IF(ABS(B(IJ))-0.5*TEMP) 4014,4014,4013                                    
C---- SHIFT IS TOO GREAT.                                                       
 4013 JUNK9 = 1                                                                 
      BDF(ISTORE(I)) = TEMP*(1.+SIGN(0.5,B(IJ)))                                
      DAEMPF=ABS(TEMP*0.5/B(IJ))                                                
      GOTO 4006                                                                 
C                                                                               
C---- SHIFT IS LEGAL                                                            
 4014 BDF(ISTORE(I)) = TEMP + B(IJ)                                             
      GOTO 4006                                                                 
C                                                                               
C---- OFF DIAGONAL ELEMENTS. HERE MAX. SHIFT MAY 1.1*VALUE(LAST),               
C     BECAUSE OFF DIAGONAL ELEMENTS CAN BE NEGATIVE.                            
C---- PARAMETER WAS NOT REFINED.                                                
C                                                                               
 4024 IF(ABS(B(IJ))-1.1*ABS(TEMP)) 4014,4014,4025                               
 4025 JUNK9=1                                                                   
      BDF(ISTORE(I))=TEMP*(1.+SIGN(1.1,B(IJ)))                                  
      DAEMPF = ABS(TEMP*1.1/B(IJ))                                              
      GOTO 4006                                                                 
C                                                                               
C---- NO AUTOMATIC DAMPING WAS REQUESTED.                                       
C                                                                               
 4017 IF(JUNK6.EQ.2) GOTO 4019                                                  
C---- BUT A DAMPING FACTOR WAS GIVEN.                                           
      BDF(ISTORE(I)) = TEMP + B(IJ)*RDAMP(IJ)                                   
      TEMP1 = B(IJ)/BFFD(IJ,1)                                                  
      IF(ABS(TEMP1).GT.ABS(SEMAX))SEMAX=TEMP1                                   
      SUM = SUM + ABS(TEMP1)                                                    
      WRITE(IOUT,4018)IWORD(IST(I)),TEMP,B(IJ),BDF(ISTORE(I)),BFFD              
     & (IJ,1),TEMP1,IJ,IDAMP(IJ)                                                
      IJ=IJ+1                                                                   
      GOTO 3201                                                                 
C                                                                               
C---- NO DAMPING AT ALL SELECTED.                                               
 4019 BDF(ISTORE(I)) = TEMP + B(IJ)                                             
      TEMP1 = B(IJ)/BFFD(IJ,1)                                                  
      IF(ABS(TEMP1).GT.ABS(SEMAX))SEMAX=TEMP1                                   
      SUM = SUM + ABS(TEMP1)                                                    
      WRITE(IOUT,4018)IWORD(IST(I)),TEMP,B(IJ),BDF(ISTORE(I)),BFFD              
     & (IJ,1),TEMP1,IJ                                                          
      IJ=IJ+1                                                                   
      GOTO 3201                                                                 
C---- PARAMETER IS FIXED.                                                       
C                                                                               
 3203 WRITE(IOUT,3206)IWORD(IST(I)),BDF(ISTORE(I)),                             
     &BDF(ISTORE(I))                                                            
C                                                                               
 3201 CONTINUE                                                                  
C                                                                               
C---- NO SAVE PARAMETERS IN ARRAY QTQ TO PRINT IT OUT BY ROUTINE                
C     EXTINK, ENTRY EXTRA.                                                      
      DO 3407 I=1,13                                                            
 3407 QTQ(39+I)=0.0                                                             
C                                                                               
      GOTO(3400,3401,3402,3403,3404,3405,3406),IBDF(1)+1                        
C---- ISOTROPIC TYP 1                                                           
 3401 QTQ(40)=BDF(3)                                                            
      GOTO 3410                                                                 
C---- ISOTROPIC TYP 2                                                           
 3402 QTQ(41)=BDF(4)                                                            
      GOTO 3410                                                                 
C---- ISOTROPIC GENERAL CASE                                                    
 3403 QTQ(40)=BDF(3)                                                            
      QTQ(41)=BDF(4)                                                            
      GOTO 3410                                                                 
C---- ANISOTROPIC TYP 1                                                         
 3404 DO 3411 I=1,6                                                             
 3411 QTQ(41+I)=BDF(4+I)                                                        
      GOTO 3410                                                                 
C---- ANISOTROPIC TYP 2                                                         
 3405 DO 3412 I=1,6                                                             
 3412 QTQ(47+I)=BDF(10+I)                                                       
      GOTO 3410                                                                 
C---- ANISOTROPIC GENERAL CASE                                                  
 3406 DO 3413 I=1,7                                                             
 3413 QTQ(40+I)=BDF(3+I)                                                        
      GOTO 3410                                                                 
C---- TYP OF EXTINCTION AND DISTRIBUTION (TYP 1 AND GENERAL CASE)               
 3410 ITYP=IBDF(1)+1                                                            
      IDISTR=IBDF(2)                                                            
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                             LOAD OVERLAY                                      
C                          CALL LLINK("R2OV3")                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C---- PRINT MOSAIKSPREAD, DOMAINSIZE AND ORTHOGONAL EXTINCTION TENSOR.          
C                                                                               
      CALL EXTRA(EXTRAN)                                                        
 3400 CONTINUE                                                                  
C                                                                               
C---- ABSOLUTE ORIENTATION                                                      
C                                                                               
 2092 IF(IFSGN.EQ.0)GO TO 2095                                                  
      TEMP=FISGN                                                                
      IF(0.99*RNUM(19).GT.RMINUS)FISGN=-FISGN                                   
      RMINUS=SQRT(RMINUS/RDEN(19))                                              
      WRITE(IOUT,98)TEMP,RMINUS,FISGN                                           
C                                                                               
C---- ALPHA PARAMETERS.                                                         
C                                                                               
C---- THE PARAMETRS AND THEIR SHIFTS ARE INTERMEDIATE STORED TO                 
C     GIVE A BETTER READABLE OUTPUT.                                            
C                                                                               
 2095 IF(MODELL.LT.3) GOTO 2001                                                 
      DO 2002 IY=1,NATOM                                                        
      IF(IALFA(IY).LE.0) GOTO 2002                                              
      DELALF(IY)=B(IJ)*RDAMP(IJ)                                                
      ERRALF(IY)=BFFD(IJ,1)                                                     
      TEMP1=DELALF(IY)/ERRALF(IY)                                               
      IF(ABS(TEMP1) .GT. ABS(SEMAX)) SEMAX=TEMP1                                
      SUM=SUM+ABS(TEMP1)                                                        
      IZ(IY)=IJ                                                                 
      IJ=IJ+1                                                                   
 2002 CONTINUE                                                                  
 2001 CONTINUE                                                                  
C                                                                               
C---- SCALE FACTORS.                                                            
C                                                                               
      DO 2100 I=1,NSF                                                           
      WRITE(IOUT,781)                                                           
      IF(JSCRF(I))2096,2097,2096                                                
 2096 TEMP=SCALE(I)                                                             
      B(IJ) = B(IJ)*TEMP                                                        
      SCALE(I) = TEMP + B(IJ)*RDAMP(IJ)                                         
      BFFD(IJ,1) = BFFD(IJ,1)*SCALE(I)                                          
      TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      WRITE(IOUT,40)I,TEMP,B(IJ),SCALE(I),BFFD(IJ,1),TEMP1,IJ,IDAMP(IJ)         
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      SUM=SUM+ABS(TEMP1)                                                        
      BFFD(IJ,1) = BFFD(IJ,1)/SCALE(I)
      IJ=IJ+1                                                                   
      GO TO 2100                                                                
 2097 WRITE(IOUT,78)I,SCALE(I),SCALE(I)                                         
 2100 CONTINUE                                                                  
C                                                                               
C---- THIS ENDS THE PART OF NOT CONSTRAINT PARAMETERS.                          
C                                                                               
C---- NO PARAMETERS SHOULD BE UPDATED, WHICH CAN BE CONSTRAINT.                 
      IF(NDEGN.EQ.0)GO TO 2109                                                  
C                                                                               
C---- RESTORE THE UNALTERED DEPENDENCY LIST                                     
      REWIND ISC5                                                               
      READ(ISC5)LDEGN,(KDEGN(L),L=1,LDEGN)                                      
C                                                                               
C---- SPECIAL PARAMETERS.                                                       
      IF(NPAR.EQ.0)GO TO 2109                                                   
C---- SAVE OLD SPECIAL PARAMETERS                                               
      DO 6020 I=1,NPAR                                                          
      SAVE(I)=PAR(I)                                                            
C---- UPDATE THE SPECIAL PARAMETERS                                             
      IJ=IRPAR(I)                                                               
      IF(IJ.GT.0)PAR(I)=PAR(I)+B(IJ)*RDAMP(IJ)                                  
 6020 CONTINUE                                                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                          LOAD OVERLAY                                         
                             ILADE=1                                            
C                       CALL LLINK("R2OV2")                                     
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C---- SET SPECIAL PARAMETERS CONSTRAINT BY SYMMETRY.                            
      CALL RESET(0,0)                                                           
C---- NOW PRINT OUT THE SPECIAL PARAMETERS                                      
      WRITE(IOUT,95)                                                            
      DO 2108 I=1,NPAR                                                          
      TEMP=SAVE(I)                                                              
      IJ=IRPAR(I)                                                               
      IF(IJ)6040,6040,6030                                                      
 6030 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      WRITE(IOUT,96)(PARNAM(J,I),J=1,2),TEMP,B(IJ),PAR(I),BFFD(IJ,1),           
     & TEMP1,IJ,IDAMP(IJ)                                                       
      IF(ABS(TEMP1).GT.ABS(SEMAX))SEMAX=TEMP1                                   
      SUM=SUM+ABS(TEMP1)                                                        
      GO TO 2108                                                                
 6040 WRITE(IOUT,97)(PARNAM(J,I),J=1,2),SAVE(I),PAR(I)                          
 2108 CONTINUE                                                                  
C                                                                               
C---- CONVENTIONAL PARAMETERS.                                                  
C                                                                               
 2109 IK=0                                                                      
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                 LOAD OVERLAY IF NOT DONE BEFORE                               
C                IF(ILADE.EQ.0)CALL LLINK("R2OV2")                              
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C---- LOOP OVER ATOMS                                                           
C                                                                               
      DO 2290 IYK=1,NATOM                                                       
C                                                                               
      I=IYK                                                                     
C---- SAVE THE OLD PARAMETERS FOR THIS ATOM                                     
      SAVE(1)=OCCUP(I)                                                          
      SAVE(2)=OCCA(I)                                                           
      DO 6060 J=1,3                                                             
 6060 SAVE(J+2)=XYZ(J,I)                                                        
      SAVE(6)=BETA(1,I)                                                         
      IF(ISOT(I).LT.1)GO TO 6070                                                
      DO 6062 J=2,6                                                             
 6062 SAVE(J+5)=BETA(J,I)                                                       
      IF(ISOT(I).LT.2)GO TO 6070                                                
      DO 6064 J=1,10                                                            
 6064 SAVE(J+11)=CR(J,I)                                                        
      IF(ISOT(I).LT.3)GO TO 6070                                                
      DO 6066 J=1,15                                                            
 6066 SAVE(J+21)=DR(J,I)                                                        
      IF(ISOT(I).LT.4) GOTO 6070                                                
      DO 6067 J=1,21                                                            
 6067 SAVE(J+36)=ER(J,I)                                                        
      IF(ISOT(I).LT.5) GOTO 6070                                                
      DO 6068 J=1,28                                                            
 6068 SAVE(J+57)=FR(J,I)                                                        
C                                                                               
C---- NOW UPDATE ALL REFINED PARAMETERS FOR THIS ATOM.                          
C                                                                               
 6070 J=1                                                                       
      IJ=IPARA(IK+J)                                                            
      IF(ISCAT(2,I))6090,6080,6090                                              
C                                                                               
C---- SINGLE OCCUPANCY                                                          
 6080 IF(IJ.GT.0)OCCUP(I)=OCCUP(I)+B(IJ)*RDAMP(IJ)                              
      GO TO 6100                                                                
C---- MULTIPLE OCCUPANCY                                                        
 6090 IF(IJ.GT.0)OCCA(I)=OCCA(I)+B(IJ)*RDAMP(IJ)                                
C---- POSITIONAL PARAMETERS                                                     
 6100 DO 6110 J=1,3                                                             
      IJ=IPARA(IK+J+1)                                                          
      IF(IJ.GT.0)XYZ(J,I)=XYZ(J,I)+B(IJ)*RDAMP(IJ)                              
 6110 CONTINUE                                                                  
C---- THERMAL PARAMETERS                                                        
      IJ=IPARA(IK+5)                                                            
      IF(IJ.GT.0)BETA(1,I)=BETA(1,I)+B(IJ)*RDAMP(IJ)                            
      IF(ISOT(I).LT.1)GO TO 6150                                                
      DO 6120 J=2,6                                                             
      IJ=IPARA(IK+J+4)                                                          
      IF(IJ.GT.0)BETA(J,I)=BETA(J,I)+B(IJ)*RDAMP(IJ)                            
 6120 CONTINUE                                                                  
      IF(ISOT(I).LT.2)GO TO 6150                                                
      DO 6130 J=1,10                                                            
      IJ=IPARA(IK+J+10)                                                         
      IF(IJ.GT.0)CR(J,I)=CR(J,I)+B(IJ)*RDAMP(IJ)                                
 6130 CONTINUE                                                                  
      IF(ISOT(I).LT.3)GO TO 6150                                                
      DO 6140 J=1,15                                                            
      IJ=IPARA(IK+J+20)                                                         
      IF(IJ.GT.0)DR(J,I)=DR(J,I)+B(IJ)*RDAMP(IJ)                                
 6140 CONTINUE                                                                  
      IF(ISOT(I).LT.4) GOTO 6150                                                
      DO 6141 J=1,21                                                            
      IJ=IPARA(IK+J+35)                                                         
      IF(IJ.GT.0) ER(J,I)=ER(J,I)+B(IJ)*RDAMP(IJ)                               
 6141 CONTINUE                                                                  
      IF(ISOT(I).LT.5) GOTO 6150                                                
      DO 6142 J=1,28                                                            
      IJ=IPARA(IK+J+56)                                                         
      IF(IJ.GT.0) FR(J,I)=FR(J,I)+B(IJ)*RDAMP(IJ)                               
 6142 CONTINUE                                                                  
C                                                                               
C---- UPDATE DEPENDENT PARAMETERS                                               
C                                                                               
 6150 KPARA=IK                                                                  
      CALL RESET(I,KPARA)                                                       
C                                                                               
C---- NOW PRINT OUT UPDATED PARAMETERS                                          
C                                                                               
C---- WRITE ATOM NUMBER, LABEL AND EQUIPOINT FRACTION OF ATOM                   
      WRITE(IOUT,38)I,(TAG(J,I),J=1,2),SITE(I)                                  
C                                                                               
      IF(ISCAT(2,I))2140,2110,2140                                              
C---- SINGLE OCCUPANCY                                                          
 2110 TEMP=SAVE(1)                                                              
      IJ=IPARA(IK+1)                                                            
      IF(IJ.LE.0)GO TO 2130                                                     
      TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      SUM=SUM+ABS(TEMP1)                                                        
      WRITE(IOUT,44)ISCAT(1,I),TEMP,B(IJ),OCCUP(I),BFFD(IJ,1),TEMP1             
     &,IJ,IDAMP(IJ)                                                             
      SIGO(I)=BFFD(IJ,1)
      jir(1,i) = ij                                                        
      GO TO 2180                                                                
 2130 WRITE(IOUT,46)ISCAT(1,I),TEMP,TEMP                                        
      GO TO 2180                                                                
C---- MULTIPLE OCCUPANCY                                                        
 2140 TEMP=SAVE(2)                                                              
      TEMP1=OCCUP(I)-TEMP                                                       
      IJ=IPARA(IK+1)                                                            
      IF(IJ.GT.0)GO TO 2160                                                     
      TEMP2=OCCUP(I)-OCCA(I)                                                    
      SIGMA=ERRCAL(I,1)                                                         
      IF(SIGMA.GT.0.0000001)GO TO 2150                                          
      WRITE(IOUT,46)ISCAT(1,I),TEMP,OCCA(I)                                     
 2145 WRITE(IOUT,46)ISCAT(2,I),TEMP1,TEMP2                                      
      GO TO 2170                                                                
 2150 WRITE(IOUT,46)ISCAT(1,I),TEMP,OCCA(I),SIGMA                               
      GO TO 2145                                                                
 2160 SIGO(I)=BFFD(IJ,1)                                                        
      TEMP2=OCCUP(I)-OCCA(I)                                                    
      TEMP3=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM+ABS(TEMP3)                                                        
      IF(ABS(TEMP3).GT.ABS(SEMAX)) SEMAX=TEMP3                                  
      WRITE(IOUT,44)ISCAT(1,I),TEMP,B(IJ),OCCA(I),BFFD(IJ,1),TEMP3              
     &,IJ,IDAMP(IJ)                                                             
      WRITE(IOUT,46)ISCAT(2,I),TEMP1,TEMP2
      jir(1,i) = ij                                      
 2170 WRITE(IOUT,48)OCCUP(I)                                                    
C                                                                               
C---- POSITIONAL PARAMETERS                                                     
C                                                                               
 2180 WRITE(IOUT,2289)                                                          
      DO 2210 J=1,3                                                             
      TEMP=SAVE(J+2)                                                            
      IJ=IPARA(IK+J+1)                                                          
      IF(IJ.GT.0)GO TO 2200                                                     
      SIGMA=ERRCAL(I,J+1)                                                       
      IF(SIGMA.GT.0.0000001)GO TO 2190                                          
      WRITE(IOUT,52)HEAD(J),TEMP,XYZ(J,I)                                       
      GO TO 2210                                                                
 2190 WRITE(IOUT,52)HEAD(J),TEMP,XYZ(J,I),SIGMA                                 
      GO TO 2210                                                                
 2200 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      SUM=SUM+ABS(TEMP1)                                                        
      WRITE(IOUT,50)HEAD(J),TEMP,B(IJ),XYZ(J,I),BFFD(IJ,1),TEMP1                
     &,IJ,IDAMP(IJ)                                                             
      SIGXYZ(J,I)=BFFD(IJ,1)
      jir(j+1,i) = ij                                                    
 2210 CONTINUE                                                                  
C                                                                               
C---- THERMAL PARAMETERS                                                        
C                                                                               
      WRITE(IOUT,2289)                                                          
      DO 2280 J=1,6                                                             
      UFAC = 1.2665148 * EGGY(J)                                                
      TEMP=SAVE(J+5)                                                            
      IJ=IPARA(IK+J+4)                                                          
      IF(ISOT(I))2250,2220,2250                                                 
C---- ISOTROPIC ATOM                                                            
 2220 IF(IJ)2240,2240,2230                                                      
 2230 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM+ABS(TEMP1)                                                        
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      WRITE(IOUT,50)HEAD(4),TEMP,B(IJ),BETA(1,I),BFFD(IJ,1),TEMP1               
     &,IJ,IDAMP(IJ)                                                             
      GO TO 2290                                                                
 2240 SIGMA=ERRCAL(I,5)                                                         
      IF(SIGMA.GT.0.0000001)GO TO 2245                                          
      WRITE(IOUT,52)HEAD(4),TEMP,BETA(1,I)                                      
      GOTO 2290                                                                 
 2245 WRITE(IOUT,52)HEAD(4),TEMP,BETA(1,I),SIGMA                                
      GO TO 2290                                                                
C---- ANISOTROPIC ATOM                                                          
 2250 IF(IJ)2270,2270,2260                                                      
 2260 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM+ABS(TEMP1)                                                        
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      IF(ITTYP(I).EQ.0) GOTO 2268                                               
      UTEMP = TEMP * UFAC                                                       
      USHI = B(IJ) * UFAC                                                       
      UBETA = BETA(J,I) * UFAC                                                  
      UERR = BFFD(IJ,1) * UFAC                                                  
      WRITE(IOUT,511) HEAD(J+4),UTEMP,USHI,UBETA,UERR,TEMP1,IJ,                 
     &IDAMP(IJ)                                                                 
      GOTO 2269                                                                 
 2268 WRITE(IOUT,51)HEAD(J+4),TEMP,B(IJ),BETA(J,I),BFFD(IJ,1),TEMP1             
     &,IJ,IDAMP(IJ)                                                             
C                                                                               
C---- THERMAL PARAMETERS IN U(I,J) FOR PRINTING XRAY ATOM-CARDS                 
C     AND FOR MAINFILE OUTPUT.                                                  
 2269 BBETA(J,I)=BETA(J,I)*EGGY(J)/TEMPZZ                                       
      SIGB(J,I)=BFFD(IJ,1)*EGGY(J)/TEMPZZ
      jir(j+4,i) = ij                                       
C                                                                               
      GO TO 2280                                                                
 2270 SIGMA=ERRCAL(I,J+4)                                                       
      IF(ITTYP(I).EQ.0) GOTO 2274                                               
      UTEMP = SAVE(J+5) * UFAC                                                  
      UBETA = BETA(J,I) * UFAC                                                  
      UERR = SIGMA * UFAC                                                       
      IF(SIGMA.GT.0.00000001) GOTO 2271                                         
      WRITE(IOUT,531)HEAD(J+4),UTEMP,UBETA                                      
      GOTO 2280                                                                 
 2271 WRITE(IOUT,531) HEAD(J+4),UTEMP,UBETA,UERR                                
      GOTO 2280                                                                 
 2274 IF(SIGMA.GT.0.0000001)GO TO 2275                                          
      WRITE(IOUT,53)HEAD(J+4),SAVE(J+5),BETA(J,I)                               
      GO TO 2280                                                                
 2275 WRITE(IOUT,53)HEAD(J+4),SAVE(J+5),BETA(J,I),SIGMA                         
 2280 CONTINUE                                                                  
C                                                                               
      IF(ISOT(I)-2)2290,2281,2281                                               
C                                                                               
C---- ALPHA PARAMETER.                                                          
C                                                                               
C---- PRINT NTERMEDIATE STORED PARAMETERS.                                      
 2281 WRITE(IOUT,2289)                                                          
      IF(MODELL.LT.3) GOTO 2006                                                 
      IF(IALFA(I)) 2010,2010,2011                                               
 2011 TEMP=ALF(I)                                                               
      ALF(I)=ALF(I)+DELALF(I)                                                   
      TEMP1=DELALF(I)/ERRALF(I)                                                 
      WRITE(IOUT,2012)TEMP,DELALF(I),ALF(I),ERRALF(I),TEMP1,IZ(I)               
     &,IDAMP(IZ(I))                                                             
      GOTO 2013                                                                 
 2010 WRITE(IOUT,2014)ALF(I),ALF(I)                                             
 2013 CONTINUE                                                                  
C                                                                               
C---- THIRD ORDER CUMULANT COEEF.                                               
C                                                                               
 2006 DO 2284 J=1,10                                                            
      TEMP=SAVE(J+11)                                                           
      IJ=IPARA(IK+J+10)                                                         
      IF(IJ)2283,2283,2282                                                      
 2282 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM+ABS(TEMP1)                                                        
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      WRITE(IOUT,80)HEAD(J+10),TEMP,B(IJ),CR(J,I),BFFD(IJ,1),TEMP1              
     &,IJ,IDAMP(IJ)
      jir(j+10,i) = ij                                                             
      GO TO 2284                                                                
 2283 SIGMA=ERRCAL(I,J+10)                                                      
      IF(SIGMA.GT.0.0000001)GO TO 6283                                          
      WRITE(IOUT,82)HEAD(J+10),SAVE(J+11),CR(J,I)                               
      GO TO 2284                                                                
 6283 WRITE(IOUT,82)HEAD(J+10),SAVE(J+11),CR(J,I),SIGMA                         
 2284 CONTINUE                                                                  
C                                                                               
      IF(ISOT(I)-3)2290,2285,2285                                               
C                                                                               
C---- FOURTH CUMULANT PARAMETRES                                                
C                                                                               
 2285 WRITE(IOUT,2289)                                                          
      DO 2288 J=1,15                                                            
      TEMP=SAVE(J+21)                                                           
      IJ=IPARA(IK+J+20)                                                         
      IF(IJ)2287,2287,2286                                                      
 2286 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM+ABS(TEMP1)                                                        
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      WRITE(IOUT,86)HEAD(J+20),TEMP,B(IJ),DR(J,I),BFFD(IJ,1),TEMP1              
     &,IJ,IDAMP(IJ)
      jir(j+20,i) = ij                                                             
      GO TO 2288                                                                
 2287 SIGMA=ERRCAL(I,J+20)                                                      
      IF(SIGMA.GT.0.0000001)GO TO 6287                                          
      WRITE(IOUT,88)HEAD(J+20),TEMP,DR(J,I)                                     
      GO TO 2288                                                                
 6287 WRITE(IOUT,88)HEAD(J+20),TEMP,DR(J,I),SIGMA                               
 2288 CONTINUE                                                                  
C                                                                               
      IF(ISOT(I)-4)2290,5285,5285                                               
C                                                                               
C---- FIFTH CUMULANT PATAMETERS                                                 
C                                                                               
 5285 WRITE(IOUT,2289)                                                          
      DO 5288 J=1,21                                                            
      TEMP=SAVE(J+36)                                                           
      IJ=IPARA(IK+J+35)                                                         
      IF(IJ)5287,5287,5286                                                      
 5286 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM=SUM + ABS(TEMP1)                                                      
      IF(ABS(TEMP1).GT.ABS(SEMAX))SEMAX=TEMP1                                   
      WRITE(IOUT,586)HEAD5(J),TEMP,B(IJ),ER(J,I),BFFD(IJ,1),                    
     & TEMP1,IJ,IDAMP(IJ)
      jir(j+35,i) = ij                                                       
      GOTO 5288                                                                 
 5287 SIGMA=ERRCAL(I,J+35)                                                      
      IF(SIGMA.GT.1.E-7) GOTO 7287                                              
      WRITE(IOUT,588)HEAD5(J),TEMP,ER(J,I)                                      
      GOTO 5288                                                                 
 7287 WRITE(IOUT,588)HEAD5(J),TEMP,ER(J,I),SIGMA                                
 5288 CONTINUE                                                                  
C                                                                               
      IF(ISOT(I)-5) 2290,8285,8285                                              
C                                                                               
C---- SIXTH CUMULANT PARAMETERS                                                 
C                                                                               
 8285 WRITE(IOUT,2289)                                                          
      DO 8288 J=1,28                                                            
      TEMP=SAVE(J+57)                                                           
      IJ=IPARA(IK+J+56)                                                         
      IF(IJ)8287,8287,8286                                                      
 8286 TEMP1=B(IJ)/BFFD(IJ,1)                                                    
      SUM= SUM+ ABS(TEMP1)                                                      
      IF(ABS(TEMP1).GT.ABS(SEMAX)) SEMAX=TEMP1                                  
      WRITE(IOUT,886)HEAD6(J),TEMP,B(IJ),FR(J,I),BFFD(IJ,1),                    
     & TEMP1,IJ,IDAMP(IJ)
      jir(j+56,i) = ij                                                       
      GOTO 8288                                                                 
 8287 SIGMA=ERRCAL(I,J+56)                                                      
      IF(SIGMA.GT.1.E-7)GOTO 9287                                               
      WRITE(IOUT,888)HEAD6(J),TEMP,FR(J,I)                                      
      GOTO 8288                                                                 
 9287 WRITE(IOUT,888)HEAD6(J),TEMP,FR(J,I),SIGMA                                
 8288 CONTINUE                                                                  
C                                                                               
C---- END OF PARAMETER LIST.                                                    
C                                                                               
 2290 IK=KPARA                                                                  
C                                                                               
C---- SUM = AVERAGE(SHIFT/ERROR) , SEMAX = MAXIMUM SHIFT/ERROR                  
C                                                                               
      SUM=SUM/FLOAT(MRANK)                                                      
      WRITE(IOUT,74)SEMAX,SUM                                                   
C                                                                               
C---- PRINT MESSAGE ABOUT EXXAGERATION FACTORS OF THERMAL PARAMETERS OF         
C     HIGHER THAN 2. ORDER  OR  IN CASE OF UIJ.                                 
C                                                                               
      DO 2296 I=1,NATOM                                                         
      IF(ITTYP(I).EQ.0) GOTO 2296                                               
      WRITE(IOUT,751)                                                           
      GOTO 2297                                                                 
 2296 CONTINUE                                                                  
 2297 DO 2298 I=1,NATOM                                                         
      IF(ISOT(I).LT.2) GOTO 2298                                                
      WRITE(IOUT,75)                                                            
      GOTO 2299                                                                 
 2298 CONTINUE                                                                  
C                                                                               
C---- CALCULATE CORRELATION MATRIX  (MCORR.NE.0 > PRINT ENTIRE M.)              
C                                                                               
 2299 IF(MCORR.NE.0)WRITE(IOUT,54)TITLE                                         
      IJ=MDEGN+1                                                                
      KNT=0                                                                     
      DO 2300 I=1,20                                                            
 2300 HIB(I)=0.0                                                                
      DO 2320 I=1,MRANK                                                         
      DO 2310 J=I,MRANK                                                         
      B(J)=A(IJ)/(BFFD(I,1)*BFFD(J,1))                                          
      IF(I.EQ.J)GO TO 2310                                                      
C---- GET OFF-DIAGONAL CORRELATIONS WITH LARGEST MAGNITUDES                     
      IF(KNT.LT.20)KNT=KNT+1                                                    
      DO 2301 K=1,KNT                                                           
C---- COMPARE CURRENT VALUE WITH LIST                                           
      IF(ABS(B(J)).GT.ABS(HIB(K)))GO TO 2303                                    
 2301 CONTINUE                                                                  
      GO TO 2310                                                                
 2303 L=KNT-K                                                                   
      IF(L.LT.1)GO TO 2305                                                      
C---- MOVE LAST ENTRIES UP IN THE LIST                                          
      DO 2304 M=1,L                                                             
      N=KNT-M                                                                   
      HIB(N+1)=HIB(N)                                                           
      KB(N+1)=KB(N)                                                             
 2304 JB(N+1)=JB(N)                                                             
C---- INSERT ENTRY                                                              
 2305 HIB(K)=B(J)                                                               
      KB(K)=I                                                                   
      JB(K)=J                                                                   
 2310 IJ=IJ+1                                                                   
      IF(MCORR.EQ.0)GO TO 2320                                                  
C---- PRINT ENTIRE CORRELATION MATRIX                                           
      WRITE(IOUT,56)I,(J,B(J),J=I,MRANK)                                        
 2320 CONTINUE                                                                  
C                                                                               
C---- PRINT THE LARGEST VALUES                                                  
      WRITE(IOUT,57)TITLE,(KB(J),JB(J),HIB(J),J=1,KNT)                          
C                                                                               
      RETURN                                                                    
      END                                                                       
C                                                                               
                        FUNCTION ERRCAL(NA,NP)                                  
C                                                                               
C     THIS FUNCTION SUBROUTINE DETERMINES  THE  STANDARD  DEVIATION OF A        
C     DEPENDENT PARAMETER ACCORDING TO THE FORMULA                              
C                                                                               
C                            D(P )     D(P )                                    
C                   N   N       K         K          1/2                        
C     SIGMA(P ) = (SUM SUM -------- * ------- COV   )                           
C            K     I=1 J=1   D(P )     D(P )     IJ                             
C                               I         J                                     
C                                                                               
C     WHERE N IS THE NUMBER OF REFINED PARAMETERS AND  COV   IS THE CO -        
C                                                        IJ                     
C     VARIANCE OF THE I-TH REFINED PARAMETER P  WITH THE    J-TH REFINED        
C                                             I                                 
C     PARAMETER P . D IS DIFFERENTIAL OPERATOR.                                 
C                J                                                              
C                                                                               
C     AUTOR              L. W. FINGER                                           
C     MODIFICATIONS      U.    ZUCKER                                           
C                                                                               
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(02200)                                                                 
      COMMON/TAPE/IN,INN,IOUT,ISC1,ISC2,ISC3,ISC4,ISC5,IPUN                     
C                                                                               
      DIMENSION LISPAR(30),DERI(30),KDEGN(200)                                  
C                                                                               
      EQUIVALENCE (KDEGN,A)                                                     
C                                                                               
      I1(K)=MOD(K/256**3,256)                                                   
      I2(K)=MOD(K/256**2,256)                                                   
      I3(K)=MOD(K/256,256)                                                      
      I4(K)=MOD(K,256)                                                          
      IP=0                                                                      
      IF(MDEGN.LE.0) GO TO 101                                                  
      DO 100 I=1,MDEGN,2                                                        
      IF(I3(KDEGN(I)).NE.NA.OR.I4(KDEGN(I)).NE.NP)GO TO 100                     
      IP=IP+1                                                                   
      IF(IP.GT.30)GO TO 101                                                     
      LISPAR(IP)=I2(KDEGN(I))                                                   
C                                                                               
C---- IF THERE ARE CONSTRAINTS TO A NOT REFINED ATOM, THEN LISPAR(IP)           
C     IS ZERO.                                                                  
C                                                                               
      IF(LISPAR(IP).EQ.0) GOTO 102                                              
      DERI(IP)=A(I+1)                                                           
 100  CONTINUE                                                                  
 101  IF(IP.NE.0)GO TO 150                                                      
 102  ERRCAL=0.                                                                 
      RETURN                                                                    
C                                                                               
 150  SUM=0.                                                                    
      DO 200 I=1,IP                                                             
      DO 200 J=I,IP                                                             
      II=LISPAR(I)                                                              
      JJ=LISPAR(J)                                                              
      KK=MDEGN+((II-1)*(2*MRANK-II+2))/2+JJ-II+1                                
      TERM=DERI(I)*DERI(J)*A(KK)                                                
      IF(I.NE.J)SUM=SUM+TERM                                                    
 200  SUM=SUM+TERM                                                              
      IF(SUM.GE.0.0)GO TO 210                                                   
      WRITE(IOUT,2)SUM                                                          
 2    FORMAT(41H0** WARNING **  VARIANCE IS NEGATIVE. V =,E12.4,                
     & 5X,23HCHECK YOUR CONSTRAINTS.)                                           
      SUM=0.0                                                                   
  210 ERRCAL=SQRT(SUM)                                                          
C                                                                               
      RETURN                                                                    
      END                                                                       
                                                                                
                                                                                
                                                                                
