C                                                                               
                 SUBROUTINE DOINV(UB,UBINV,UBDET)                               
C                                                                               
C                  INVERSION OF A 3 X 3 MATRIX.                                 
C                                                                               
C           BY U. ZUCKER  USING A PART OF XRAY 80 SYSTEM                        
C                                                                               
C                                                                               
C    INPUT MATRIX IS UB, OUTPUT MATRIX UBINV. UBDET IS DETERMINANT              
C                         OF MATRIX UB.                                         
C    THE  MATRICES  ARE  FILLED  IN ONE DIMENSIONAL ARRAYS BY ROWS.             
C                                                                               
      DIMENSION UB(9),UBINV(9)                                                  
C                                                                               
      UBINV(1) = UB(5)*UB(9)-UB(8)*UB(6)                                        
      UBINV(4) =-UB(4)*UB(9)+UB(7)*UB(6)                                        
      UBINV(7) = UB(4)*UB(8)-UB(7)*UB(5)                                        
      UBDET    = UB(1)*UBINV(1)+UB(2)*UBINV(4)+UB(3)*UBINV(7)                   
      UBINV(1) = UBINV(1)/UBDET                                                 
      UBINV(4) = UBINV(4)/UBDET                                                 
      UBINV(7) = UBINV(7)/UBDET                                                 
      UBINV(2) = (-UB(2)*UB(9)+UB(8)*UB(3))/UBDET                               
      UBINV(5) = (UB(1)*UB(9)-UB(7)*UB(3))/UBDET                                
      UBINV(8) = (-UB(1)*UB(8)+UB(7)*UB(2))/UBDET                               
      UBINV(3) = (UB(2)*UB(6)-UB(5)*UB(3))/UBDET                                
      UBINV(6) = (-UB(1)*UB(6)+UB(4)*UB(3))/UBDET                               
      UBINV(9) = (UB(1)*UB(5)-UB(4)*UB(2))/UBDET                                
C                                                                               
      RETURN                                                                    
      END                                                                       
                     FUNCTION DCODE(ISOT)                                       
C                                                                               
C     FUNCTION   TO DECODE ISOT GIVEN IN A HEXADECIMAL SYSTEM                   
C     TO A DECIMAL SYSTEM.             (U. ZUCKER  FEB. 1980)                   
C                                                                               
C           ROUTINE IS OF COURSE SYSTEM INDEPENDENT.                            
C                                                                               
      DIMENSION IHEX(16)                                                        
C                                                                               
      DATA IHEX/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HA,                    
     &          1HB,1HC,1HD,1HE,1HF/                                            
      DATA IBNK/1H /                                                            
C                                                                               
      IF(ISOT.EQ.IBNK)ISOT=IHEX(1)                                              
C                                                                               
      DO 2 J=1,16                                                               
        JJ=J                                                                    
        IF(ISOT.EQ.IHEX(J)) GO TO  3                                            
   2    CONTINUE                                                                
   3    DCODE=JJ-1                                                              
C                                                                               
      RETURN                                                                    
      END                                                                       
C                                                                               
         SUBROUTINE CHECK(ISOT,NATOM,MODELL,J6LAST,LEGAL)                       
C                                                                               
C     THIS SUBROUTINE  CHECKS  FOR  A  LEGAL  RANGE  OF  ISOT.                  
C     REMEMBER  THAT  IN  THE CURRENT VERSION ONLY 6 ATOMS CAN                  
C     HAVE AN ANHARMONIC  THERMAL  DESCRIPTION TILL 6.  ORDER.                  
C     TO SAVE  CORE  THOSE  ATOMS  HAVE  TO  BE  GIVEN  FIRST.                  
C     IF  A  CUMULANT  FORM  OF FIFTH OR HIGHER ORDER   IS DE-                  
C     SIRED,,  ONLY 40 ATOM CAN HAVE THERMAL DESCRIPTION  TILL                  
C     FOURTH ORDER. THOSE ATOMS HAVE TO BE GIVEN AS THE SECOND                  
C     ONE. THERMAL VIBRATIONS IN THE HARMONIC CASE CAN BE USED                  
C     FOR THE COMPLETE NUMBER OF ATOMS.                                         
C                                                                               
C     EXAMPLE      ATOM NO.    THERMAL VIBRATIONS TILL N. ORDER                 
C     ---------------------------------------------------------                 
C              I      1     I             5. OR. 6.                             
C              I      .     I                 .                                 
C              I      .     I                 .                                 
C              I      6     I             5. OR. 6.                             
C              I      7     I                 4.                                
C              I      .     I                 .                                 
C              I      .     I                 .                                 
C              I     4 0    I                 4.                                
C              I     4 1    I                 2.                                
C              I      .     I                 .                                 
C              I     6 0    I                 2.                                
C                                                                               
C                                                                               
C     ROUTINE  WRITTEN  BY  U. ZUCKER   (FEB. 1980  , MPI-FKF )                 
C                                                                               
C                                                                               
      DIMENSION ISOT(60)                                                        
C                                                                               
      LEGAL = 1                                                                 
C                                                                               
      J4LAST = 0                                                                
      J6LAST = 0                                                                
C                                                                               
      DO 2000 I = 1,NATOM                                                       
      IF(ISOT(I).LT.4 ) GOTO 2000                                               
      IF(ISOT(I) - 9) 1000,1000,1010                                            
 1000 J4LAST=I                                                                  
      GOTO 2000                                                                 
 1010 J6LAST=I                                                                  
 2000 CONTINUE                                                                  
C                                                                               
                                                                                
      IF(J6LAST.NE.0 .AND. MODELL.NE.2) GOTO 3000                               
      IF(J4LAST .LE. 40 .AND. J6LAST .LE. 6 ) RETURN                            
      LEGAL=0                                                                   
      RETURN                                                                    
 3000 LEGAL=-1                                                                  
C                                                                               
      RETURN                                                                    
      END                                                                       
C                                                                               
C                                                                               
                          SUBROUTINE LOADNW(                                    
     &NEW,EGGY,IFIRST,NSF,NPARA,VOL,IOCCUP,MODELL, IZAEHL,IHIGH,IEQPMT)         
C                                                                               
C     ROUTINE TO LOAD PARAMETERS. IT WILL BE CALLED ONCE PER CYCLE.             
C                                                                               
C       THE ORIGINAL L.W. FINGER ROUTINE IS STRONGLY MODIFIED BY                
C                                                                               
C                     U. ZUCKER (OCT.78 - DEC.80)                               
C                                                                               
C     INPUT VARIABLES                                                           
C     ---------------                                                           
C                                                                               
C     NEW(1-8)   FLAGS OF CONTROL CARD FOR SELECTION OF INPUT VARIABLES         
C     EGGY(1-6)  OUTPUT ARRAY,FOR I=1,3 EGGY(I)=4/RECELL(I)**2                  
C                                       EGGY(4)=4/(RECELL(1)*RECELL(2))         
C                                       EGGY(5)=4/(RECELL(1)*RECELL(3))         
C                                       EGGY(6)=4/(RECELL(2)*RECELL(3))         
C                AT WHICH RECELL(I) IS AMOUNT OF  I-TH  RECIPROCAL AXIS         
C     IFIRST     NUMBER OF CYCLE OF CURRENT RUN                                 
C     NSF        NUMBER OF SCALE FACTORS                                        
C     NPARA      NUMBER OF PARAMETERS                                           
C     VOL        VOLUME OF REAL CELL                  (OUTPUT VARIABLE)         
C     IOCCUP     OUTPUT ARRAY   IOCCUP(I)  0/1 DO NOT/DO DELETE ATOM  I         
C                ONLY IN CASE OF A PARTIAL STRUCTURE FACTOR CALCULATION         
C     MODELL     NUMBER OF STRUCTURE FACTOR(SEE COMMENTS IN ROUT.RFINE)         
C     IZAEHL     NUMBER OF ATOMS WITH TEMPERATURE FACTORS  HIGHER  THAN         
C                SECOND ORDER. (IN CASE OF ALPHA FORMALISM ONLY - IT IS         
C                AN OUTPUT VARIABLE.)                                           
C     IEQPMT     GEOMETRY  OF   EULER   CRADLE   OF     DIFFRACTOMETER.         
C                                                                               
      INTEGER BUSLEV,DUMMY,SYNTEX
C                                                                               
      DIMENSION NEW(8),ITNS(8),JRMAT(10),TRS(8),JTNS(3),KRMAT(10),IBUFF(        
     &1023),IRMAT(2,3),EGGY(6),IBDF(2),IOCCUP(60),NP(6),ER(21,6),               
     &ICTYP(7),ICTRIC(4),VALUE(5),IVALUE(5),FR(28,6),ACS(3),BTY(5)              
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(2200)                                                                  
      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)                     
      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/FOUR/WINKEL(3),IUB,AG,BG,CG                                        
      COMMON/COPPEN/YEXT,BDF(16),JUNK6                                          
      COMMON/H/UB(9),CHI,PHI,TH,UBINV(9),TBAR,DIN(3),DOUT(3),IEQMPT             
C                                                                               
      EQUIVALENCE (IBUFF,BUFF),(KDEGN,AA,DADC(1,37))                            
      EQUIVALENCE (BDF(1),IBDF(1))                                              
      EQUIVALENCE (DR(1,41),ER),(DR(7,49),FR)                                   
C                                                                               
      DATA IVALUE,VALUE,NO/4H0.10,4H0.25,4H0.50,4H0.75,4H0.90,0.1,0.25,         
     & 0.50,0.75,0.90,4H    /                                                   
      DATA ITNS/3H   ,3H1/2,3H1/3,3H2/3,3H1/4,3H3/4,3H1/6,3H5/6/                
      DATA TRS/0.0,0.5,0.33333333,0.66666667,0.25,0.75,                         
     &  0.166666667,0.83333333/                                                 
      DATA JRMAT/3H   ,3H  X,3H +X,3H -X,3H  Y,3H +Y,3H -Y,3H  Z,3H +Z,         
     & 3H -Z/                                                                   
      DATA KRMAT /0,1,1,-1,2,2,-2,3,3,-3/                                       
      DATA BUSLEV,STOE,SYNTEX /4HBUSI,4HSTOE,4HSYNT/
      DATA ICTRIC,ICTYP/4HCENT,4HACEN,4HRIC ,4HTRIC,1HP,1HA,1HB,1HC,1HI         
     & ,1HF,1HR/                                                                
      DATA IEND,IBNK,IENDE,ITABLE,IEND3/4HEND ,1H ,1HE,4HTABL,3HEND/            
      DATA NP,BTY/5,10,20,35,56,84,2HB ,2HU ,2HUB,2HBU,2H  /                    
C                                                                               
C---- IHARMO IS THE NUMBER OF THAT LOGICAL UNIT TO WHICH THE PARAMETERS         
C     OF A HARMONIC REFINEMENT  CAN BE WRITTEN.  THESE PARAMETERS   ARE         
C     ONLY  NECESSARY   FOR    CALCULATION   OF   AN  EXTENDED PDF-MAP.         
C                                                                               
      DATA IHARMO/9/                                                            
C                                                                               
    1 FORMAT(A1,2A4,A4)                                                         
    5 FORMAT(//23H F BY INTERPOLATION FOR ,2X,2A4//18H SIN(THETA)/LAMBDA        
     &,5X,12HSCATT.-CURVE//)                                                    
    6 FORMAT(9F8.0)                                                             
    7 FORMAT(17H0SYMMETRY OF CELL/1X,16(1H-)//,1X,2A4,2X,12HCELL OF TYPE        
     &,3X,A1//1H )                                                              
    8 FORMAT(F10.5,13X,F10.5)                                                   
    9 FORMAT(/19H0LATTICE PARAMETERS/1X,18(1H-)//10H0REAL CELL,15X,3F10.        
     & 5,2X,5H( A ),5X,3F10.5,4X, 9H(DEGREES))                                  
   10 FORMAT(16H0RECIPROCAL CELL,9X,3F10.5,2X,5H(1/A),5X,3F10.5,4X,9H(DE        
     &GREES)/1H )                                                               
   11 FORMAT(/8H0SCALING /1X,7(1H-)/ 17H0SCALE FACTORS   ,10F9.4)               
   12 FORMAT(3(3A3,1X))                                                         
   13 FORMAT(5X,3(3A3,1X),4X,I4,6H. CARD)                                       
   14 FORMAT(3(1X,3F11.6,/),18H0INVERSE UB-MATRIX//3(1X,3F11.6,/),              
     & 25H0DETERMINANT OF UB-MATRIX//1X,F10.6///)                               
   15 FORMAT(1X,2A4,9F11.6)                                                     
   16 FORMAT(A1,2A3,I4,2X,2F6.4)                                                
   17 FORMAT(1H+,107X,2F9.3)                                                    
   18 FORMAT(65I1)                                                              
   19 FORMAT(/15H0ATOMPARAMETER  /1X,13(1H-)//                                  
     &        17H0ATOM LABEL     X,7X,1HY,7X,1HZ,7X,30HTEMPERATURE FACTO        
     &R DATA(BETAS)//(6X,2A3,2X,3F8.4,6F9.5))                                   
   20 FORMAT(20H0VOLUME OF REAL CELL,1X,F13.4,22X,6H(A**3) )                    
   21 FORMAT(43H0ATOM LABEL   TF  SCAT.  SITE   OCCUP  OCCA,10X,28H(TF =        
     & ORDER OF TEMP.-FACTOR)//(6X,2A3,1X,3I3,F7.3,2F8.3))                      
   22 FORMAT(/60H0UB-MATRIX OF PHILIPS DIFFRACTOMETER PW1100  (UNIT 1/LA        
     &MBDA)/1X,59(1H-)//)                                                       
   23 FORMAT(24X,2A3,2X,I1,1X,3I1,1X,6I1,2X,10I1,2X,15I1,2X,21I1,2X,28I1        
     & )                                                                        
   25 FORMAT(/14H0ATOMPARAMETER /1X,13(1H-)//                                   
     &        17H0ATOM LABEL     X,7X,1HY,7X,1HZ,7X,30HTEMPERATURE FACTO        
     &R DATA(BETAS) ,38X,5HALPHA //(6X,2A3,2X,3F8.4,6F9.5,7X,F8.4))             
   27 FORMAT(2I1,7F8.4)                                                         
   29 FORMAT(26H0NEW EXTINCTION PARAMETERS/1X,25(1H-)//)                        
   30 FORMAT(/20H0MODEL OF EXTINCTION /1X,19(1H-)/  )                           
   31 FORMAT(18X/8H LABEL  ,4(5X,2HA(,I1,1H),7X,2HB(,I1,1H),2X),5X,1HC,         
     & 10X,3HDFR,6X,3HDFI/)                                                     
   34 FORMAT(A4/2(3F8.0/),3F8.0)                                                
   35 FORMAT(32H0CORRECTION BY BECKER & COPPENS./)                              
   36 FORMAT(27H0CORRECTION BY ZACHARIASEN./)                                   
   58 FORMAT(I2)                                                                
   64 FORMAT(31H0ERROR IN SYMMETRY OPERATOR NO.,I3,1H.//16H JOB TERMINAT        
     &ED.)                                                                      
   67 FORMAT(/13H0ERRORMESSAGE/1X,12(1H-)//1H )                                 
   68 FORMAT(25H0TOO MANY SYMMETRY CARDS.//16H JOB TERMINATED.)                 
   70 FORMAT(38H0ERROR IN NUMBER OF SCATTERING CURVES.//16H0JOB TERMINAT        
     &ED.)                                                                      
   71 FORMAT(/8H0WARNING/1X,7(1H-)//32H NO SCALE FACTOR DIFFERENT FROM ,        
     & 12HONE READ IN./26H LET US TRY THE VALUE ONE.//1H )                      
   72 FORMAT(11H0TOO MANY (,I4,14H ) ATOMS READ.//16H0JOB TERMINATED.)          
   73 FORMAT(42H0END OF ATOM LIST WAS READ AS FIRST CARD. /                     
     & 58H0(EACH NON BLANK CHARACTER IN COLUMN 1 INDICATES THE END.)//          
     & 16H0JOB TERMINATED.)                                                     
   81 FORMAT(A1,6I1)                                                            
   84 FORMAT(10F7.0,I1)                                                         
   85 FORMAT(10F7.0/5F7.0,35X,I1)                                               
   86 FORMAT(2(10F7.0/),F7.0,63X,I1)                                            
   87 FORMAT(10F7.0)                                                            
   90 FORMAT(I4)                                                                
  159 FORMAT(//29H DETERMINANTE DER UB-MATRIX    ,F10.6///)                     
  161 FORMAT(2I2,1X,A2,1X,9F7.5,I2)                                             
  181 FORMAT(65A1)                                                              
  211 FORMAT(2A4,13X,2A1)                                                       
  214 FORMAT(/13H0ERRORMESSAGE/1X,12(1H-)//39H0ILLEGAL  CELL TYPE  INDIC        
     &ATOR READ IN./12H0INPUT WAS  ,2A1,2H .//16H0JOB TERMINATED.)              
  217 FORMAT(/13H0ERRORMESSAGE/1X,12(1H-)//39H0ILLEGAL   CENTRIC   INDIC        
     &ATOR READ IN./12H0INPUT WAS  ,2A4,2H .//16H0JOB TERMINATED.)              
  222 FORMAT(/73H0ORIENTATION MATRIX FOR 4-CIRCLE DIFFRACTOMETER IN BUSI        
     &NG & LEVY GEOMETRY/1X,72(1H-)//)                                          
  223 FORMAT(/54H0ORIENTATION MATRIX FOR   STOE-PICKER   DIFFRACTOMETER/        
     &1X,53(1H-)//)                                                             
  224 FORMAT(/54H0ORIENTATION MATRIX FOR   SYNTEX  P3    DIFFRACTOMETER/        
     &1X,53(1H-)//)                                                             
  255 FORMAT(/8H0WARNING/1X,7(1H-)// 32H NOTE THAT IF NEW CELL PARAMETER        
     &,49H WILL AFFECT SIN(THETA)/LAMBDA, AND THEREFORE THE/18H ATOMIC S        
     &CATTERING , 51H0FACTORS FOR VARIOUS REFLECTIONS, STRUCTURE FACTORS        
     &,22H  MUST   BE  READ  IN.// 46H0THIS WARNING LEADS TO TERMINATION        
     & OF THE JOB.//  41H0YOU CAN OVERWRITE THIS RULE BY NEW(1)=2.//1H )        
  291 FORMAT(17H0INPUT VALUES ARE,5X,6(F12.4,2X))                               
  421 FORMAT(/13H0ERRORMESSAGE/1X,12(1H-)//24H0NEW SCATTERING FACTORS ,         
     & 52HCURVES MUST BE READ ONLY IF NEW(8) IS NOT EQUAL ZERO/      41H        
     & OR THEY WOULD NEVER USED IN COMPUTATION.//16H0JOB TERMINATED.)           
  443 FORMAT(91H0ONLY INTERPOLATION OF THE FIRST FOUR SCATTERING CURVES         
     &IS IN THE CURRENT VERSION POSSIBLE.//16H0JOB TERMINATED.)                 
  457 FORMAT(54H0VIOLATION OF THE MONOTONY-RULE DURING PROCESSING  OF ,         
     & 30HTHE SCATTERING CURVE LABELED  ,2A4,2H .//16H JOB TERMINATED.)         
  459 FORMAT(25H0FOR THE SCATTERING CURVE,4X,2A4,54H THERE WERE TOO LESS        
     & OR TOO MANY INTERPOLATION POINTS.//16H0JOB TERMINATED.//)                
  461 FORMAT(/18H0SCATTERING CURVES/1X,17(1H-)//)                               
  503 FORMAT(/21H0ANOMALOUS DISPERSION,//7H DFR = ,F9.3,8H  DFI = ,F9.3)        
  551 FORMAT(/8H0WARNING/1X,7(1H-)//82H0CHANGING TEMPERATURE FACTOR TYPE        
     &S WITHOUT READING OF NEW PARAMETER SELECTION CARD//20H0CAN BE MEAN        
     &INGLESS./////1H )                                                         
  581 FORMAT(14H SCALE FACTORS,10X,10I1)                                        
  582 FORMAT(22H EXTINCTION PARAMETERS,2X,7I1)                                  
  583 FORMAT(19H SPECIAL PARAMETERS,5X,60I1)                                    
  918 FORMAT(14H ATOMPARAMETER,10X,2A3,2X,I1,1X,3I1,1X,6I1,2X,10I1,2X,          
     & 15I1,2X,21I1,2X,28I1)                                                    
 1025 FORMAT(17H ALPHA PARAMETERS,7X,60I1)                                      
 1907 FORMAT(/13H0ERRORMESSAGE/1X,12(1H-)//24H CHANGING OF EXTINCTION  ,        
     & 43HMODEL IS ONLY LEGAL IN AN * A PRIORI * RUN.//                         
     & 25HATTEMPT HAS BEEN IGNORED.//1H )                                       
 1988 FORMAT(/15H0ERROR-MESSAGE /32H0WRONG STRUCTURE FACTOR EQUATION,           
     &10H SELECTED./44H0ONLY THE GRAM-CHARLIER SERIES EXPANSION IS ,            
     &7H LEGAL./29H0YOU HAVE SELECTED  MODEL NO.,I7/16H0JOB TERMINATED.)        
 1995 FORMAT(/16H0JOB TERMINATED.)                                              
 1996 FORMAT(15H0ERROR-MESSAGE / 31H0TOO MANY OR ILLEGAL ATOMS WITH ,           
     &54H TEMPERATURE FACTORS OF FIFTH OR SIXTH ORDER HAVE BEEN  ,              
     &10H SELECTED. / 15H0YOUR INPUT WAS /(60I2))                               
 2003 FORMAT(9F8.0)                                                             
 4504 FORMAT(24H0THE SELECTED ATOMNUMBER,I5,13H IS TOO HIGH./32H0THE CUR        
     &RENT MAXIMUM OF ATOMS IS,I5,2H ./29H0IF YOU WANT TO INCREASE THE ,        
     &53HNUMBER OF ATOMS SELECT ATOMS WITH INCREASING NUMBER. /11H0START        
     & WITH, I5,2H ./33H0FOR NOW, JOB WILL BE TERMINATED.//1H )                 
 4700 FORMAT(/8H0WARNING/1X,7(1H-)//   30H VALUE OF NEW(5) IS NOT IN THE        
     &,37H LEGAL RANGE FOR AN  *A PRIORI*  RUN.//15H THE VALUE WAS ,I4,         
     & 19H  IT IS SET TO ONE. //1H )                                            
 9023 FORMAT(/32H0PARAMETER SELECTION INFORMATION /1X,31(1H-)/1H )              
C                                                                               
C                                                                               
C---- INITIALIZE                                                                
C     NEUEXT = 0 MEANS NO EXTINCTION CARD HAS BEEN READ.                        
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C     ILADE  = 0 MEANS OVERLAY R2OV1 IS NOT LOADED YET.                         
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C     IHARM  = 0 LOGICAL UNIT IHARMO NOT USED.                                  
C     JUNK   = 0 ONLY A SWITCH PARAMETER.                                       
C                                                                               
      NEUEXT = 0                                                                
      ILADE  = 0                                                                
      IHARM  = 0                                                                
      JUNK   = 0                                                                
C                                                                               
C---- INITIALIZE IPAREX (NUMBER OF PARAMETERS FOR EXTINCTION CORR.)             
C                                                                               
      IPAREX(1) = 0                                                             
      IPAREX(2) = 1                                                             
      IPAREX(3) = 1                                                             
      IPAREX(4) = 2                                                             
      IPAREX(5) = 6                                                             
      IPAREX(6) = 6                                                             
      IPAREX(7) = 7                                                             
C                                                                               
C                                                                               
C---- READ CELL PARAMETERS AND CALCULATE CELL.                                  
C                                                                               
      IF(NEW(1).EQ.0)  GOTO 180                                                 
C                                                                               
C---- NOTE THAT NORMALY CELL PARAMETERS AFFECT  SIN(THETA)/LAMBDA, AND          
C     THEREFORE THE ATOMIC SCATTERING FACTORS FOR VARIOUS REFLECTIONS,          
C     STRUCTURE FACTORS MUST BE READ IN AGAIN.                                  
C                                                                               
      IF(NEW(8)) 153,254,153                                                    
C---- ABOVE RULE CAN BE IGNORED BY NEW(1)=2                                     
  254 IF(NEW(1).EQ.2) GOTO 153                                                  
      WRITE(IOUT,255)                                                           
      CALL EXIT                                                                 
C                                                                               
  153 READ(IN,6)(A(I),I=1,6)                                                    
C---- STORE LATTICE PARAMETERS IN ANGSTROEMS AND ANGELS IN DEGEES               
C     FOR USING IN FOURIER-FILE.                                                
      DO 106 I=1,3                                                              
  106 WINKEL(I)=A(I+3)                                                          
      AG=A(1)                                                                   
      BG=A(2)                                                                   
      CG=A(3)                                                                   
C---- WRITE REAL CELL PARAMETERS.                                               
      WRITE(IOUT,9)(A(I),I=1,6)                                                 
C                                                                               
C---- CALCULATE METRIC MATRIX (G(3,3) AND B(I)=G(I,I) FOR I=1,3,                
C                              B(4)=G(1,2),B(5)=G(1,3),B(6)=G(2,3))             
C     VOL, EGGY DEFINED IN SECTION ABOUT INPUT VARIABLES.                       
C     RECIPROCAL CELL PARAMETERS (RECELL(1)=ASTAR,RECELL(2)=BSTAR,              
C     RECELL(3)=CSTAR, RECELL(4)=COS(ALPHASTAR),RECELL(5)......  )              
C                                                                               
                             DO 160 I=4,6                                       
      IF(ABS(A(I)-90.0)-0.001)154,155,155                                       
  154 A(I)=0.0                                                                  
      GO TO 160                                                                 
  155 A(I)=COS(A(I)*PI/180.0)                                                   
  160 CONTINUE                                                                  
      II=0                                                                      
                             DO 170 I=1,2                                       
      II=II+1                                                                   
      G(I,I)=A(I)**2                                                            
      B(II)=G(I,I)                                                              
      IJ=I+1                                                                    
                             DO 170 J=IJ,3                                      
      II=II+1                                                                   
      IK=9-I-J                                                                  
      G(I,J)=A(I)*A(J)*A(IK)                                                    
      G(J,I)=G(I,J)                                                             
  170 B(II)=G(J,I)                                                              
      G(3,3)=A(3)**2                                                            
      B(6)=G(3,3)                                                               
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                            LOAD OVERLAY                                       
                                ILADE=1                                         
C                         CALL LLINK("R2OV1")                                   
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
      CALL SYMINV(B,3,A,1,A,1.0E-10,VOL,JRANK,6)                            
      VOL=SQRT(VOL)                                                             
C                                                                               
      WRITE(IOUT,20)VOL                                                         
C                                                                               
      RECELL(1)=SQRT(B(1))                                                      
      RECELL(2)=SQRT(B(4))                                                      
      RECELL(3)=SQRT(B(6))                                                      
      RECELL(4)=B(5)/(RECELL(2)*RECELL(3))                                      
      RECELL(5)=B(3)/(RECELL(1)*RECELL(3))                                      
      RECELL(6)=B(2)/(RECELL(1)*RECELL(2))                                      
      EGGY(1)=4./RECELL(1)**2                                                   
      EGGY(2)=4./RECELL(2)**2                                                   
      EGGY(3)=4./RECELL(3)**2                                                   
      EGGY(4)=4./(RECELL(1)*RECELL(2))                                          
      EGGY(5)=4./(RECELL(1)*RECELL(3))                                          
      EGGY(6)=4./(RECELL(2)*RECELL(3))                                          
      DO 171 I=4,6                                                              
      II = I - 3
      ACS(II) = ACOS(RECELL(I))*57.29578                                       
  171 CONTINUE                                                                  
      WRITE (IOUT,10)(RECELL(I),I=1,3),(ACS(I),I=1,3)                           
C                                                                               
C---- EXTRAN(1-9) IS THE TRANSFORMATION MATRIX TO CALCULATE A REC-              
C     TANGULAR COORDINATE SYSTEM (IN REAL SPACE). THE MATRIX  WILL              
C     BE USED ONLY IN CASE OF ANISOTROPIC EXTINCTION. BUT THE CAL-              
C     CULATION IS ALWAYS DONE HERE, BECAUSE LATER CALCULATION WILL              
C     BE IMPOSSIBLE. THERE WOULD BE A LACK OF INFORMATION.                      
C                                                                               
C     THE TRANSFORMATION MATRIX IS THE TRANSPOSE OF THIS MATRIX=                
C                                                                               
C        1/(SIN(BETA)*SIN(GAMMA*)                     0        0                
C         COT(GAMMA*)/SIN(ALPHA)                 1/SIN(ALPHA)  0                
C -COT(BETA)/SIN(GAMMA*)-COT(ALPHA)*COT(GAMMA*)  -COT(ALPHA)   1                
C                                                                               
      EXTRAN(1)=1./(SQRT((1.-A(5)**2)*(1.-RECELL(6)**2)))                       
      EXTRAN(4)=0.0                                                             
      EXTRAN(7)=0.0                                                             
      EXTRAN(2)=RECELL(6)/(SQRT((1.-RECELL(6)**2)*(1.-A(4)**2)))                
      EXTRAN(5)=1./SQRT(1.-A(4))                                                
      EXTRAN(8)=0.0                                                             
      EXTRAN(3)=-A(5)/SQRT( (1.-A(5)**2)*(1.-RECELL(6)**2) )                    
     &   -A(4)*RECELL(6)/SQRT( (1.-A(4)**2)*(1.-RECELL(6)**2) )                 
      EXTRAN(6)=-RECELL(4)/SQRT(1.-RECELL(4)**2)                                
      EXTRAN(9)=1.0                                                             
C                                                                               
C---- EXTRAN(10 - 12) IS ONLY FOR CONVERSION FROM ISOTROPIC TO                  
C     ANISOTROPIC EXTINCTION PARAMETER.                                         
C                                                                               
C     EXTINKTION AUF DIE ANISOTROPE                                             
      EXTRAN(10)=A(4)                                                           
      EXTRAN(11)=A(5)                                                           
      EXTRAN(12)=A(6)                                                           
C                                                                               
C---- THE ROUTINE TRNFRM WILL ONLY BE CALLED IF SPECIAL PARAMETERS              
C     ARE SELECTED (AND THEN ONLY IN THE FIRST CYCLE OF RUN)                    
C     IN THE ROUTINE A TRANSFORMATION MATRIX LIKE EXTRAN(1-9) WILL              
C     BE CALCULATED. (SEE COMMENT IN TRNFRM)                                    
C                                                                               
  180 CONTINUE                                                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                        LOAD OVERLAY                                           
C           IF(NPAR.NE.0.AND.ILADE.EQ.0) CALL LLINK("R2OV1")                    
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
      IF(IFIRST.EQ.0.AND.NPAR.NE.0)CALL TRNFRM                                  
C                                                                               
C                                                                               
C---- ACCEPT NEW BOND DISTANCE LIMITS                                           
C                                                                               
      IF(NEW(2))190,200,190                                                     
  190 READ(IN,6)DMIN,DMAX                                                       
C                                                                               
C                                                                               
C---- READ NEW SYMMETRY OPERATORS, ACCEPT CENTRIC- AND CELL TYPE                
C     INDICATOR.                                                                
C                                                                               
  200 IF(NEW(3))210,420,210                                                     
C                                                                               
C---- IBUFF(3)=CENTRIC/ACENTRIC   IBUFF(4)=P,A,B,C,I,F AND R TYPE               
C     IBUFF(5) ALSO READ THIS INFO, BECAUSE OF  DIFFERENT  LENGTH               
C     OF SENTENCES *CENTRIC CELL OF TYPE X, ACENTRIC CELL OF... .               
C     IBUFF(6) ONLY FOR OUTPUT.                                                 
C                                                                               
  210 READ(IN,211)IBUFF(3),IBUFF(6),IBUFF(4),IBUFF(5)                           
C                                                                               
C---- CRACK OUT CELL TYPE                                                       
      ICELL = -1                                                                
      DO  212 I = 1,7                                                           
      IF(IBUFF(4).EQ.ICTYP(I)) ICELL = I - 1                                    
  212 IF(IBUFF(5).EQ.ICTYP(I)) ICELL = I - 1                                    
C                                                                               
C---- IS INPUT LEGAL.                                                           
      IF(ICELL) 213,215,215                                                     
  213 WRITE(IOUT,214)IBUFF(4),IBUFF(5)                                          
      CALL EXIT                                                                 
C                                                                               
C---- YES, IT IS. IS CELL CENTRIC OR ACENTRIC?                                  
  215 ICENT = -1                                                                
      IF(IBUFF(3).EQ.ICTRIC(1)) ICENT=0                                         
      IF(IBUFF(3).EQ.ICTRIC(2)) ICENT=1                                         
C---- LEGAL INPUT?                                                              
      IF(ICENT) 216,218,218                                                     
C---- NO, INPUT IS ILLEGAL.                                                     
  216 WRITE(IOUT,217)IBUFF(3),IBUFF(6)                                          
      CALL EXIT                                                                 
C                                                                               
C---- LEGAL INPUT OF CELL TYPE. PRINT IT OUT.                                   
C                                                                               
  218 WRITE(IOUT,7)ICTRIC(ICENT+1),ICTRIC(ICENT+3),ICTYP(ICELL+1)               
C                                                                               
C                                                                               
C---- READ SYMMETRY CARDS.                                                      
                             DO 220 I=1,3                                       
  220 CELLP(I,1)=0.0                                                            
      JCELL=1                                                                   
      IF(ICELL)230,320,230                                                      
  230 IF(ICELL-5)232,270,300                                                    
  232                        DO 240 I=1,3                                       
  240 CELLP(I,2)=0.5                                                            
      JCELL=2                                                                   
      IF(ICELL-4)250,320,250                                                    
  250 CELLP(ICELL,2)=0.0                                                        
      GO TO 320                                                                 
  270                        DO 290 I=2,4                                       
                             DO 280 J=1,3                                       
  280 CELLP(J,I)=0.5                                                            
  290 CELLP(I-1,I)=0.0                                                          
      JCELL=4                                                                   
      GO TO 320                                                                 
  300 JCELL=3                                                                   
                             DO 310 I=2,3                                       
      CELLP(1,I)=FLOAT(I-1)/3.0                                                 
      CELLP(2,I)=FLOAT(4-I)/3.0                                                 
  310 CELLP(3,I)=CELLP(2,I)                                                     
C---- READ AND WRITE NEW SYMMETRY CARDS                                         
  320 NSYM=0                                                                    
  330 READ(IN,12)(JTNS(I),(IRMAT(K,I),K=1,2),I=1,3)                             
      IF(JTNS(1).NE.IEND3) GOTO 331                                             
      GOTO 420                                                                  
  331 NSYM = NSYM + 1                                                           
      WRITE(IOUT,13)(JTNS(I),(IRMAT(K,I),K=1,2),I=1,3),NSYM                     
      IF(NSYM-24) 333,333,410                                                   
C                                                                               
  333                        DO 390 I=1,3                                       
                             DO 340 J=1,8                                       
      IF(JTNS(I)-ITNS(J))340,350,340                                            
  340 CONTINUE                                                                  
C---- ERROR IN LAST SYMMETRY CARD                                               
  342 WRITE(IOUT,67)                                                            
      WRITE(IOUT,64)NSYM                                                        
      CALL EXIT                                                                 
C---- CARD CAN BE INTERPRETED.                                                  
  350 TRANS(I,NSYM)=TRS(J)                                                      
                             DO 390 J=1,3                                       
      RMAT(J,I,NSYM)=0.0                                                        
                             DO 390 K=1,2                                       
      IJ=IRMAT(K,J)                                                             
                             DO 360 L=1,10                                      
      IF(JRMAT(L)-IJ)360,370,360                                                
  360 CONTINUE                                                                  
      GO TO 342                                                                 
  370 IF(I-IABS(KRMAT(L)))390,380,390                                           
  380 RMAT(J,I,NSYM)=ISIGN(1,KRMAT(L))                                          
  390 CONTINUE                                                                  
C---- GO TO READ NEXT CARD.                                                     
      GOTO 330                                                                  
C                                                                               
C---- TOO MANY SYMMETRY CARDS HAD BEEN READ.                                    
C                                                                               
  410 WRITE(IOUT,67)                                                            
      WRITE(IOUT,68)                                                            
      CALL EXIT                                                                 
C                                                                               
C                                                                               
C---- READ NEW SCATTERING FACTORS, NUMBER WILL BE COMPUTED.                     
C                                                                               
  420 IF(NEW(4))429,460,429                                                     
C                                                                               
C---- NEW SCATTERING FACTOR CURVES MUST BE  READ  ONLY  IN THE FIRST            
C     CYCLE OF A GIVEN COMPUTER RUN OR WHEN  NEW  STRUCTURE  FACTORS            
C     ARE BEING READ IN, OR THEY WOULD NEVER BE USED IN COMPUTATION.            
C                                                                               
  429 IF(NEW(8).NE.0) GOTO 430                                                  
C---- ERROR PART.                                                               
      WRITE(IOUT,421)                                                           
      CALL EXIT                                                                 
C                                                                               
  430 NSCAT = 0                                                                 
      INTPOL= 0                                                                 
C---- WRITE  *SCATTERING CURVES*                                                
      WRITE(IOUT,461)                                                           
C---- READ NAME OF SCATTERING CURVE AND ANOMALOUS DISPERSION                    
C                                                                               
  434 NSCAT = NSCAT + 1                                                         
      I = NSCAT                                                                 
      ANOM(1,I)=0.0                                                             
      ANOM(2,I)=0.0                                                             
C---- IFLAG=BLANK/A  DO NOT/DO READ ANOMALOUS DISPERSION                        
C     IFLAG=E MEANS  END OF LIST.                                               
C     L,K IS NAME OF SCATTERING CURVE.  L=END MEANS  *END OF LIST*              
C     INTER(I)= 0 / ANY NUMBER MEANS  SCATTERING  CURVE  GIVEN  BY              
C                              EXPONENTIAL FORM / TABULATION FORM.              
C                                                                               
      READ(IN,1)IFLAG,L,K,INTER(I)                                              
      IF(L.EQ.IEND.OR.IFLAG.EQ.IENDE) GOTO 4501                                 
      IBUFF(5) = 0                                                              
      IF(IFLAG.EQ.ICTYP(2)) IBUFF(5) = 1                                        
      IF(INTER(I).NE.ITABLE) GOTO 438                                           
C---- INPUT IS IN TABULATION FORM.                                              
      INTPOL=INTPOL+1                                                           
C---- MORE THAN 4 TABLES GIVEN?                                                 
      IF(INTPOL-4)441,441,442                                                   
C---- YES, PRINT ERROR AND TERMINATE JOB.                                       
  442 WRITE(IOUT,67)                                                            
      WRITE(IOUT,443)                                                           
      CALL EXIT                                                                 
C                                                                               
C---- LEGAL RANGE OF INTPOL. READ THE TABLE.                                    
  441 J = 1                                                                     
  436 READ(IN,6)R1,R2                                                           
C---- END OF LIST?                                                              
      IF(R1.LT.1.E-8 .AND. R2.LT.1.E-8) GOTO 4361                               
C---- NO.                                                                       
      X(J,INTPOL)=R1                                                            
      Y(J,INTPOL)=R2                                                            
      J = J + 1                                                                 
      GOTO 436                                                                  
C                                                                               
C---- END OF TABLE. COMPUTE FIELD POINTER.                                      
 4361 J = J - 1                                                                 
      INTER(I) = INTPOL*100 + J                                                 
C                                                                               
C---- WRITE THE LABEL OF THE ATOM AND THE LIST.                                 
      WRITE(IOUT,5)L,K                                                          
      DO 437 JJ=1,J                                                             
  437 WRITE(IOUT,8)X(JJ,INTPOL),Y(JJ,INTPOL)                                    
C                                                                               
C---- ANOMALOUS DISPERSION DESIRED?                                             
C                                                                               
      IF(IBUFF(5))501,502,501                                                   
C---- YES, READ AND WRITE IT.                                                   
  501 READ(IN,6)(ANOM(JJ,I),JJ=1,2)                                             
      WRITE(IOUT,503)(ANOM(JJ,I),JJ=1,2)                                        
C                                                                               
C---- CHECK TABLE OF LEGAL NUMBER OF INTERPOLATION POINTS AND OF                
C     VIOLATION OF MONOTONY RULE. (5% DEVIATION IS ALLOWED.)                    
C                                                                               
  502 IF(J.GT.35 .OR. J.LT.10 ) GOTO 449                                        
      DO 448 JJ=2,J                                                             
      IF(  X(JJ,INTPOL) -  X(JJ-1,INTPOL)) 447,447,451                          
  451 IF(0.95*Y(JJ,INTPOL)-Y(JJ-1,INTPOL)) 448,447,447                          
  448 CONTINUE                                                                  
      GO TO 450                                                                 
C                                                                               
C---- ERROR DETECTED IN TABLE. PRINT THE MESSAGE AND TERMINATE JOB.             
C                                                                               
C---- ERROR IN NUMBER.....                                                      
  449 WRITE(IOUT,67)                                                            
      WRITE(IOUT,459)L,K                                                        
      CALL EXIT                                                                 
C---- ERROR IN MONOTONY.....                                                    
  447 WRITE(IOUT,67)                                                            
      WRITE(IOUT,457)L,K                                                        
      CALL EXIT                                                                 
C                                                                               
C                                                                               
C---- EXPONENTIAL FORM OF SCATTERING CURVE IS DESIRED.                          
C                                                                               
  438 READ(IN,6)(FCURVE(J,I),J=1,9)                                             
      INTER(I)=0                                                                
      WRITE(IOUT,31)(IUH,IUH,IUH=1,4)                                           
      WRITE(IOUT,15)L,K,(FCURVE(J,I),J=1,9)                                     
C                                                                               
C---- ANOMALOUS DISPERSION DESIRED?                                             
C                                                                               
  439 IF(IBUFF(5))440,450,440                                                   
C---- YES, READ AND WRITE IT.                                                   
  440 READ(IN,6)(ANOM(J,I),J=1,2)                                               
      WRITE(IOUT,17)(ANOM(J,I),J=1,2)                                           
  450 GOTO 434                                                                  
C                                                                               
C---- ALL SCATTERING CURVES READ. ARE THERE TOO MANY CURVES READ IN?            
C                                                                               
 4501 NSCAT = NSCAT - 1                                                         
      IF(NSCAT-21) 460,432,432                                                  
C---- YES, TOO MANY CURVES  HAS BEEN READ.                                      
  432 WRITE(IOUT,67)                                                            
      WRITE(IOUT,70)                                                            
      CALL EXIT                                                                 
C                                                                               
C                                                                               
C                                                                               
  460 IF(NEW(5)) 470,540,470                                                    
C                                                                               
C----- NEW(5) CAN BE 0,1,2,3,4,5,6  BUT IN AN  A PRIORI RUN  ONLY 1.            
C                                                                               
C      NEW(5) = 0  DO NOT READ PARAMETERS                                       
C      NEW(5) = 1  READ THE FOLLOWING PARAMETER LIST.                           
C                  - SCALE FACTORS                                              
C                  - EXTINCTION PARAMETERS                                      
C                  - ATOM PARAMETERS (ENTIRE LIST)                              
C                  - SPECIAL PARAMETERS                                         
C                  - ALPHA PARAMETERS                                           
C                                                                               
C      NEW(5) = 2  READ SCALE FACTORS ONLY                                      
C      NEW(5) = 3  READ EXTINCTION PARAMETERS ONLY                              
C      NEW(5) = 4  READ ATOMPARAMETERS FOR SPECIAL ATOMS                        
C      NEW(5) = 5  READ SPECIAL PARAMETERS ONLY                                 
C      NEW(5) = 6  READ ALPHA PARAMETERS ONLY                                   
C                                                                               
C---- SPECIAL VALUE OF NEW(5) ?                                                 
C     IF THIS IS AN "A PRIORI" RUN, THEN NEW(5) CANNOT GREATER 1.               
C                                                                               
  470 IF(KCYL.NE.0 .OR. NEW(5).EQ.1) GOTO 4702                                  
      WRITE(IOUT,4700) NEW(5)                                                   
      NEW(5) = 1                                                                
C                                                                               
 4702 JUNK = 0                                                                  
      NEW(5) = MIN0(NEW(5),6)                                                   
C                                                                               
      GOTO (4704,4704,1002,476,479,1902), NEW(5)                                
C                                                                               
C---- READ NEW SCALE FACTORS..........                                          
C                                                                               
 4704 READ(IN,87)SCALE                                                          
      NSF = 0                                                                   
C                                                                               
C---- HOW MANY SCALE FACTORS ARE DIFFERENT FROM ZERO?                           
      DO 472 I = 1,10                                                           
      IF(SCALE(I).LT.1.E-8) GOTO 471                                            
  472 NSF = NSF + 1                                                             
C                                                                               
C---- LEGAL RANGE OF NUMBER OF SCALE FACTORS (NSF) ?                            
  471 IF(NSF) 4705,4705,4706                                                    
C---- NO SCALE FACTOR DIFFERENT FROM ZERO READ. TRY VALUE 1.                    
 4705 NSF = 1                                                                   
      SCALE(1) = 1.                                                             
C---- PRINT WARNING                                                             
      WRITE(IOUT,71)                                                            
C---- NOW PRINT SCALE FACTORS.                                                  
 4706 WRITE(IOUT,11)(SCALE(I),I=1,NSF)                                          
C                                                                               
C---- SHOULD SCALE BE READ ONLY?                                                
      IF(NEW(5)-2) 1002,539,539                                                 
C                                                                               
C                                                                               
C---- READ EXTINCTION MODEL AND PARAMETERS.                                     
C                                                                               
C                                                                               
 1002 READ(IN,27)NIEXT,NDISTR,RNEUEX                                            
      NEUEXT=1                                                                  
      IF(KCYL) 1903,1904,1903                                                   
C                                                                               
C---- ONLY IN AN *A PRIORI* RUN CHANGING OF MODEL IS LEGAL.                     
C                                                                               
 1904 IZACH=1                                                                   
      IF(NIEXT.LT.8) IZACH=0                                                    
      GOTO 1905                                                                 
C                                                                               
 1903 IF(NIEXT.GT.7 .AND. IZACH.EQ.1) GOTO 1905                                 
      IF(NIEXT.LT.8 .AND. IZACH.EQ.0) GOTO 1905                                 
C                                                                               
C---- ILLEGAL CHANGING OF MODEL                                                 
      WRITE(IOUT,1907)                                                          
C---- WRITE  *EXTINCTION MODEL*                                                 
 1905 WRITE(IOUT,30)                                                            
C---- OF BECKER AND COPPENS (IZACH=0) OR OF ZACHARIASEN.                        
      IF(IZACH.EQ.0)WRITE(IOUT,35)                                              
      IF(IZACH.EQ.1)WRITE(IOUT,36)                                              
C                                                                               
C---- BRANCH CORRESPONDING TO EXTINCTION MODEL                                  
C                                                                               
      IF(IZACH.EQ.0) GOTO 1003                                                  
C                                                                               
C---- PART OF CONVERSION OF EXTINCTION IN CASE OF ZACHARIASEN EXTINC.           
C                                                                               
      IF(NDISTR.NE.9)  IEXT=NDISTR                                              
      J=IEXT                                                                    
      IF(RNEUEX(1).LT.1.E-8.AND.KCYL.NE.1 .AND. NDISTR.NE.9) GOTO 1203          
      DO 1202 I=1,6                                                             
 1202 EXTIN(I)=RNEUEX(I)                                                        
 1203 IF(J.LE.2)GO TO 488                                                       
C---- CONVERT EXTINCTION TYPE                                                   
      IF(J.GT.4)GO TO 486                                                       
C---- CONVERT ISOTROPIC TO ANISOTROPIC                                          
      TEMP=EXTIN(1)**2                                                          
      IF(TEMP.GT.1.0E-20)TEMP=1.0/TEMP                                          
      DO 482 I=1,3                                                              
      EXTIN(I+3)=0.0                                                            
  482 EXTIN(I)=TEMP                                                             
      IEXT=J-2                                                                  
      GO TO 488                                                                 
  486 IF(J.GT.6)GO TO 487                                                       
C---- CONVERT ANISO TO ISO                                                      
      IEXT=0                                                                    
      EXTIN(1)=SQRT(1.0/(3.0*(EXTIN(1)+EXTIN(2)+EXTIN(3))))                     
      GO TO 488                                                                 
C---- SWITCH ANISO. TYPES                                                       
  487 IEXT=MAX0(9-J,2)                                                          
C---- RESET EXTINCTION TO ZERO.                                                 
  488 IF(NDISTR.EQ.9) WRITE(IOUT,29)                                            
      J = 6                                                                     
      IF(IEXT.EQ.0) J = 1                                                       
      WRITE(IOUT,291)(EXTIN(I),I=1,J)                                           
      GO TO 489                                                                 
C---- END OF ZACHARIASEN EXTINCTION PART                                        
C                                                                               
C                                                                               
C---- START PART OF BECKER AND COPPENS EXTINCTION.                              
C                                                                               
 1003 CONTINUE                                                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                        CALL OVERLAY                                           
C                     CALL LLINK("R2OV3")                                       
                            ILADE=0                                             
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL EXTINK(EXTRAN,RNEUEX,NIEXT,NDISTR,KCYL)                              
C                                                                               
C---- SHOULD ONLY EXTICTION READ IN?                                            
  489 IF(NEW(5)-3) 476,539,539                                                  
C                                                                               
C                                                                               
C---- READ ATOM PARAMETERS                                                      
C                                                                               
  476 I = 0                                                                     
C                                                                               
  473 I = I + 1                                                                 
C                                                                               
C---- SHOULD PARAMETERS READ ONLY FOR SPECIAL ATOMS?                            
C                                                                               
      IF(NEW(5)-4) 4731,4732,4731                                               
C                                                                               
C---- YES, ONLY FOR SELECTED ATOMS.                                             
 4732 READ(IN,58) I                                                             
      IF(I) 4751,4751,4745                                                      
C---- IS ATOM NUMBER HIGHER THAN CURRENT MAXIMUM?                               
 4745 IF(I-NATOM) 4731,4731,4511                                                
C---- YES. A STEP OF ONE IS LEGAL.                                              
 4511 IF(I.GT.NATOM+1) GOTO 4502                                                
C---- INCREASE NATOM BY ONE AND READ ATOM PARAMETERS FOR I. ATOM.               
      NATOM = NATOM + 1                                                         
      GOTO 4731                                                                 
C---- I AM SORRY, BUT I IS TO HIGH.                                             
 4502 WRITE(IOUT,67)                                                            
      NATOM1 = NATOM + 1                                                        
      WRITE(IOUT,4504) I,NATOM,NATOM1                                           
      CALL EXIT                                                                 
C                                                                               
C---- I  HAS A REASONABLE VALUE.                                                
C                                                                               
 4731 READ(IN,16)IFLAG,BUFF(1),BUFF(2),IBUFF(3),BUFF(4),BUFF(5)                 
C                                                                               
C---- IF THIS WAS THE LAST INFO, IFLAG IS NOT BLANK.                            
C                                                                               
C---- THE END OF THE LIST WILL BE MARKED BY IFLAG=E. ONE CAN THINK TO           
C     TAKE THE VARIABLE R1 FOR THIS REASON, BUT THEN  THE  COMPARSION           
C     WITH THE (THEN REAL) VARIABLE IBNK WOULD BE VERY DANGEROUS.   A           
C     CHANGING OF TAG TO A INTEGER VALUE IS VERY COMPLICATED, BECAUSE           
C     THIS VALUES ARE USED IN DIFFERENT PROGRAMMES IN VERY  DIFFERENT           
C     WAYS. (THE LIST WILL OF COURSE EVER STOPPED  BY  AN  INPUT  NOT           
C     EQUAL A BLANK CHARACTER.                                                  
C                                                                               
      IF(IFLAG.NE.IBNK) GOTO 4743                                               
C---- NOT END OF LIST. PROCESS PARAMETERS.                                      
      TAG(1,I) = BUFF(1)                                                        
      TAG(2,I) = BUFF(2)                                                        
      SITE(I)  = FLOAT(IBUFF(3))                                                
      OCCUP(I) = BUFF(4)                                                        
      OCCA(I)  = BUFF(5)                                                        
C---- READ REST OF PARAMETER LIST OF THIS ATOM.                                 
      READ(IN,161)(ISCAT(J,I),J=1,2),BTYP,(XYZ(J,I),J=1,3),(BETA(J,I),          
     & J=1,6), IEF                                                              
C                                                                               
C---- CONVERSION OF UIJ AND BETAIJ                                              
C                                                                               
      ITTYP(I) = 0                                                              
      IF(BTYP.EQ.BTY(2).OR.BTYP.EQ.BTY(4)) ITTYP(I) = 1                         
      IF(BTYP.NE.BTY(2)) GOTO 4739                                              
      DO 4733 J=1,6                                                             
 4733 BETA(J,I) = BETA(J,I)*0.78956835/EGGY(J)                                  
C                                                                               
C---- SITE IS MULTIPLICITY OF SITE. NOW CONVERT TO EQUIPOINT FRACTION.          
C                                                                               
 4739 SITE(I)=SITE(I)/FLOAT(JCELL*NSYM*(2-ICENT))                               
C                                                                               
      IF(IEF)474,475,474                                                        
C---- READ THIRD CUMULANT COEFFICIENTS                                          
  474 READ(IN,84)(CR(J,I),J=1,10),IEF                                           
      IF(IEF)4741,475,4741                                                      
C---- READ FOURTH CUMULANT COEF.                                                
 4741 READ(IN,85)(DR(J,I),J=1,15),IEF                                           
      IF(IEF)4742,475,4742                                                      
C---- READ FIFTH CUMULANT COEF.                                                 
 4742 READ(IN,86)(ER(J,I),J=1,21),IEF                                           
C---- READ SIXTH CUMULANT COEF.                                                 
      IF(IEF.NE.0) READ(IN,87)(FR(J,I),J=1,28)                                  
  475 GOTO 473                                                                  
C                                                                               
C---- END OF LIST. STORE NUMBER OF ATOMS, IF IN LEGAL RANGE.                    
C                                                                               
 4743 NATOM = I - 1                                                             
 4751 IF(NATOM.LT.61) GOTO 4744                                                 
 4744 IF(NATOM.GT.0) GOTO 4746                                                  
      WRITE(IOUT,67)                                                            
      IF(NATOM.GT.60)WRITE(IOUT,72)NATOM                                        
      IF(NATOM.EQ.0) WRITE(IOUT,73)                                             
      CALL EXIT                                                                 
C                                                                               
C---- SHOULD ONLY ATOMPARAMETERS READ?                                          
 4746 JUNK = 1                                                                  
      IF(NEW(5)-4) 479,539,539                                                  
C                                                                               
C                                                                               
C---- READ SPECIAL PARAMETERS                                                   
C                                                                               
  479 NPAR = 0                                                                  
      IF(IBUFF(31).EQ.0 .AND. NEW(5).NE.5)GO TO 480                             
      READ(IN,90)NPAR                                                           
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                         LOAD OVERLAY                                          
                   IF(ILADE.EQ.1) GOTO 9998                                     
C                     CALL LLINK("R2OV1")                                       
                            ILADE=1                                             
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
 9998 CALL PAREXT                                                               
      CALL TRNFRM                                                               
C                                                                               
C---- SHOULD ONLY SPECIAL PARAMETERS LOAD?                                      
  480 IF(NEW(5)-5) 1902,539,539                                                 
C                                                                               
C---- READ ALPHA VALUES.                                                        
C                                                                               
 1902 IF(MODELL.LT.3) GOTO 2015                                                 
      READ(IN,2003)(ALF(I),I=1,NATOM)                                           
 2015 JUNK = 1                                                                  
C                                                                               
C---- OUTPUT PART                                                               
C                                                                               
  539 IF(JUNK.NE.0 .AND. NEW(6).EQ.0) GOTO 5301                                 
C                                                                               
C                                                                               
C---- SHOULD TEMPERATURE FACTOR TYPES READ IN?                                  
C                                                                               
C                                                                               
  540 IF(NEW(6)) 481,550,481                                                    
C                                                                               
C---- YES.                                                                      
C                                                                               
  481 READ(IN,181) (ISOT(I),I=1,NATOM)                                          
C                                                                               
C---- DECODE THE VALUES ISOT.                                                   
C                                                                               
 1901 DO 1999 I=1,NATOM                                                         
 1999 ISOT(I)=DCODE(ISOT(I))                                                    
C                                                                               
C---- CHECK FOR LEGAL TEMPERATURE FACTOR SELECTION.                             
C                                                                               
      CALL CHECK(ISOT,NATOM,MODELL,IHIGH,LEGAL)                                 
      IF(LEGAL)1989,1998,1997                                                   
C                                                                               
C---- ILLEGAL SELECTION                                                         
C                                                                               
C---- WRONG NUMBER OR WRONG SELECTION OF ATOMS OF HIGHER ORDER.                 
 1998 WRITE(IOUT,1996)(ISOT(I),I=1,NATOM)                                       
      WRITE(IOUT,1995)                                                          
      CALL EXIT                                                                 
C---- WRONG MODEL, ONLY GRAM-CHARLIER IS LEGAL.                                 
 1989 WRITE(IOUT,1988)MODELL                                                    
      CALL EXIT                                                                 
C                                                                               
C---- CONVERT TEMPERATURE FACTOR TYPES.                                         
C                                                                               
 1997 CONTINUE                                                                  
      DO 530 I=1,NATOM                                                          
C                                                                               
      IF(ISOT(I)-1)530,530,490                                                  
C---- TEMPERATURE FACTOR TYPE TO BE CHANGED                                     
  490 IF(ISOT(I)-3)500,510,520                                                  
C---- ISOTROPIC TO ANISOTROPIC                                                  
  500 ISOT(I)=1                                                                 
      TEMP=BETA(1,I)                                                            
      BETA(6,I)=0.25*RECELL(2)*RECELL(3)*RECELL(4)*TEMP                         
      BETA(5,I)=0.25*RECELL(1)*RECELL(3)*RECELL(5)*TEMP                         
      BETA(4,I)=0.25*RECELL(1)*RECELL(2)*RECELL(6)*TEMP                         
      BETA(3,I)=0.25*RECELL(3)**2*TEMP                                          
      BETA(2,I)=0.25*RECELL(2)**2*TEMP                                          
      BETA(1,I)=0.25*RECELL(1)**2*TEMP                                          
      GO TO 530                                                                 
C---- ANISOTROPIC TO ISOTROPIC                                                  
  510 ISOT(I)=0                                                                 
      BETA(1,I)=4.0*(G(1,1)*BETA(1,I)+G(2,2)*BETA(2,I)+G(3,3)*BETA(3,I)+        
     &  2.0*(G(1,2)*BETA(4,I)+G(1,3)*BETA(5,I)+G(2,3)*BETA(6,I)))/3.0           
      GO TO 530                                                                 
  520 IF(ISOT(I)-6)521,522,525                                                  
  521 IF(ISOT(I)-5)524,522,524                                                  
C---- ISOT=5 OR 6, CHANGE TO THIRD CUM. FORM                                    
  522 DO 523 J=1,10                                                             
  523 CR(J,I)=0.0                                                               
      ISOT(I)=ISOT(I)-1                                                         
  524 ISOT(I)=6-ISOT(I)                                                         
      GO TO 530                                                                 
  525 IF(ISOT(I)-8)528,526,526                                                  
  526 IF(ISOT(I)-10)5261,5262,5263                                              
C---- CHANGE TO FOURTH CUMULANT FORM                                            
 5261 DO 527 J=1,15                                                             
  527 DR(J,I)=0.0                                                               
      ISOT(I)=ISOT(I)-1                                                         
  528 ISOT(I)=10-ISOT(I)                                                        
      GO TO 530                                                                 
 5263 IF(ISOT(I)-11)5262,5264,5266                                              
C---- CHANGE TO FIFTH CUMULANT FORM                                             
 5264 DO 5270 J=1,21                                                            
 5270 ER(J,I)=0.                                                                
      ISOT(I)=ISOT(I)-1                                                         
 5262 ISOT(I)=14-ISOT(I)                                                        
      GOTO 530                                                                  
 5266 IF(ISOT(I)-13) 5264,5265,5267                                             
C---- CHANGE TO SIXTH CUMULANT FORM                                             
 5267 DO 5271 J=1,28                                                            
 5271 FR(J,I)=0.0                                                               
      ISOT(I)=ISOT(I)-1                                                         
 5265 ISOT(I)=18-ISOT(I)                                                        
C                                                                               
  530 CONTINUE                                                                  
C                                                                               
C---- END OF CONVERSION PART - NOW PRINT MAIN ATOM PARAMETERS                   
C                                                                               
 5301 IF(MODELL.GT.2) GOTO 532                                                  
      WRITE(IOUT,19)((TAG(J,I),J=1,2),(XYZ(J,I),J=1,3),(BETA(J,I),J=1,6)        
     &,I=1,NATOM)                                                               
      GOTO 531                                                                  
  532 WRITE(IOUT,25)((TAG(J,I),J=1,2),(XYZ(J,I),J=1,3),(BETA(J,I),J=1,6)        
     &,ALF(I),I=1,NATOM)                                                        
  531 DO 533 I=1,NATOM                                                          
  533 ISOT(I) = ISOT(I) + 1                                                     
      WRITE(IOUT,21)((TAG(J,I),J=1,2),ISOT(I),(ISCAT(J,I),J=1,2),               
     & SITE(I),OCCUP(I),OCCA(I),I=1,NATOM)                                      
      DO 534 I=1,NATOM                                                          
  534 ISOT(I) = ISOT(I) - 1                                                     
      GO TO 550                                                                 
C                                                                               
C                                                                               
C                                                                               
C---- READ PARAMETER SELECTION, DAMPING AND RESET SWITCHES.                     
C     IF NEW(6) WAS NOT ZERO, NEW(7)=0 CAN BE  MEANINGLESS.                     
C     PRINT WARNING.                                                            
C                                                                               
  550 IF(NEW(6).NE.0 .AND. NEW(7).EQ.0 .AND. MFSEL.NE.0)WRITE(IOUT,551)         
C                                                                               
      IF(NEW(7))560,610,560                                                     
C                                                                               
C---- IF NEW(7)=2 HARMONIC PARAMETERS FOR EXTENDED PDF ON UNIT IHARMO.          
C     NEW(7) = 3  MEANS ONLY THE GENERATION OF THIS UNIT.                       
C                                                                               
  560 IF(NEW(7).EQ.2) IHARM=1                                                   
      IF(NEW(7).EQ.3) GOTO 603                                                  
      NPARA = 0                                                                 
      ND    = 0                                                                 
      MRANK = 0                                                                 
      NRSF  = 0                                                                 
      IBUFF(25) = 0                                                             
C                                                                               
C---- READ PARAMETER SELECTION SWITCHES FOR SCALE AND EXTINCTION.               
C                                                                               
      READ(IN,18)(IBUFF(I),I=15,14+NSF)                                         
      IF(IZACH.EQ.0 .AND. IBDF(1).NE.0) READ(IN,81)(IBUFF(I),I=25,31)           
      IF(IZACH.EQ.1) READ(IN,18)(IBUFF(I),I=25,31)                              
      IF(IZACH.EQ.1) GOTO 1009                                                  
C                                                                               
C---- IBUFF(25) CAN BE 0,1,5,6,7,8,9,R (BECKER & COPPENS EXTINCTION)            
C     0/1 = DO NOT/DO REFINE      5,6,7,8,9 = DO DAMPING OF PARAMETER           
C     R   = CALCULATE PARAMETERS TO REFINE AND SET SWITCHES.                    
C                                                                               
      IBUFF(32)=0                                                               
      IF(IBUFF(25).NE.ICTYP(7)) GOTO 1008                                       
      IBUFF(32)=1                                                               
      GOTO 1009                                                                 
 1008 IBUFF(25)=DCODE(IBUFF(25))                                                
      IF(IBUFF(25).EQ.15)IBUFF(32)=1                                            
C                                                                               
C---- IF AN ALPHA-FORMALISM USED AND AT LEAST ONE ATOM AHHARMONIC               
C     REFINED, READ ALPHA PARAMETER SELECTION SWITCHES.                         
C                                                                               
 1009 IF(MODELL.LT.3) GOTO 484                                                  
      IZAEHL = 0                                                                
      DO 483 I=1,NATOM                                                          
      IF(ISOT(I).LT.2) GOTO 483                                                 
      IZAEHL = IZAEHL + 1                                                       
  483 CONTINUE                                                                  
      IF(IZAEHL.EQ.0) GOTO 484                                                  
      READ(IN,18)(IBUFF(99+I),I=1,NATOM)                                        
C                                                                               
C---- CLEAR REFINEMENT SWITCHES FOR EXTINCTION.                                 
C                                                                               
  484 DO 1016 I=1,7                                                             
 1016 KEXTRF(I)=0                                                               
C                                                                               
C---- EXTINCTION SWITCHES FOR BECKER & COPPENS MODEL?                           
      IF(IZACH.EQ.1) GOTO 1004                                                  
C                                                                               
C---- YES. AUTOMATIC REFINEMENT?                                                
      IF(IBUFF(32))1007,1004,1007                                               
C---- NO. SPECIAL WISHES.                                                       
C     (IF PROGRAMME TERMINATES EXTINCTION REFINEMENT, SPECIAL WISHES            
C     ARE IGNORED.)                                                             
 1007 IF(IBDF(1).EQ.0) GOTO 1013                                                
C                                                                               
C---- YES, THERE IS A EXTINCTION MODEL SELECTED. GENERATE MATRIX                
C     POINTER.                                                                  
      DO 1006 I=1,IPAREX(IBDF(1)+1)                                             
      MRANK=MRANK+1                                                             
      KEXTRF(I)=MRANK                                                           
      IBUFF(I+24)=1                                                             
 1006 CONTINUE                                                                  
      GOTO 1013                                                                 
C                                                                               
C---- THERE ARE SPECIAL WISHES (DAMPING IS A SPEC. WISH TOO.)                   
 1004 JJ=6                                                                      
      IF(IEXT.EQ.0) JJ=1                                                        
      IF(IZACH.EQ.0) JJ=IPAREX(IBDF(1)+1)                                       
C                                                                               
      DO 565 I=1,JJ                                                             
      IF(IBUFF(I+24).LT.5)GO TO 1005                                            
C---- THERE IS DAMPING SELECTED. AUTOMATIC DAMPING CANCELED.                    
      JUNK6 = 1                                                                 
      MRANK=MRANK+1                                                             
      RDAMP(MRANK) = VALUE(IBUFF(I+24)-4)                                       
      IDAMP(MRANK) = IVALUE(IBUFF(I+24)-4)                                      
      ND = ND + 1                                                               
      KEXTRF(I)=MRANK                                                           
      GOTO 565                                                                  
 1005 IF(IBUFF(24+I).LE.0) GOTO 565                                             
      MRANK = MRANK + 1                                                         
      RDAMP(MRANK) = 1.0                                                        
      IDAMP(MRANK) = NO                                                         
      KEXTRF(I)=MRANK                                                           
  565 CONTINUE                                                                  
C                                                                               
C                                                                               
C---- ALPHA REFINEMENT SWITCHES.                                                
C                                                                               
 1013 IF(MODELL.LT.3) GOTO 1021                                                 
      IF(IZAEHL.EQ.0) GOTO 1021                                                 
      DO 1020 I=1,NATOM                                                         
      IF(IBUFF(99+I).LE.5) GOTO 1019                                            
      MRANK = MRANK + 1                                                         
      RDAMP(MRANK) = VALUE(IALFA(I)-4)                                          
      IDAMP(MRANK) = VALUE(IALFA(I)-4)                                          
      IALFA(I) = MRANK                                                          
      GOTO 1020                                                                 
C                                                                               
 1019 IF(IBUFF(99+I).LE.0) GOTO 1020                                            
      MRANK=MRANK+1                                                             
      RDAMP(MRANK) = 1.0                                                        
      IDAMP(MRANK) = NO                                                         
      IALFA(I)=MRANK                                                            
 1020 CONTINUE                                                                  
C                                                                               
C                                                                               
C---- GET SCALE FACTOR REFINEMENT SWITCHES                                      
C                                                                               
 1021 DO 575 I=1,NSF                                                            
      JSCRF(I)=0                                                                
      IF(IBUFF(I+14).LT.5) GO TO 1030                                           
      MRANK=MRANK+1                                                             
      RDAMP(MRANK) = VALUE(IBUFF(I+14)-4)                                       
      IDAMP(MRANK) = IVALUE(IBUFF(I+14)-4)                                      
      ND = ND + 1                                                               
      JSCRF(I)=MRANK                                                            
      NRSF=NRSF+1                                                               
      GOTO 575                                                                  
C                                                                               
 1030 IF(IBUFF(I+14).LE.0) GOTO 575                                             
      MRANK = MRANK + 1                                                         
      RDAMP(MRANK) = 1.0                                                        
      IDAMP(MRANK) = NO                                                         
      JSCRF(I) = MRANK                                                          
      NRSF = NRSF + 1                                                           
  575 CONTINUE                                                                  
C                                                                               
C                                                                               
      IF(NPAR.EQ.0)GO TO 579                                                    
C---- GET SPECIAL PARAMETER REFINEMENT SWITCHES                                 
      READ(IN,18)(IRPAR(I),I=1,NPAR)                                            
      DO 577 I=1,NPAR                                                           
      IF(IRPAR(I).LT.5)GO TO 5771                                               
      MRANK=MRANK+1                                                             
      RDAMP(MRANK) = VALUE(IRPAR(I)-4)                                          
      IDAMP(MRANK) = IVALUE(IRPAR(I)-4)                                         
      ND = ND + 1                                                               
      IRPAR(I)=MRANK                                                            
      GOTO 577                                                                  
 5771 IF(IRPAR(I).LT.1) GOTO 577                                                
  577 CONTINUE                                                                  
  579 CONTINUE                                                                  
C                                                                               
C---- READ ATOMPARAMETER SWITCHES.                                              
C                                                                               
      N0 = 1                                                                    
C                                                                               
      DO 580 I=1,NATOM                                                          
      NPARA = NPARA +5                                                          
      IF(ISOT(I))570,571,570                                                    
  570 NPARA = NPARA +5                                                          
  571 READ(IN,18)(IPARA(J),J=N0,NPARA)                                          
      N0=NPARA+1                                                                
      IF(ISOT(I)-2) 580,576,576                                                 
  576 NPARA = NPARA + 10                                                        
      READ(IN,18)(IPARA(J),J=N0,NPARA)                                          
      N0 = NPARA + 1                                                            
      IF(ISOT(I)-3) 580,5761,5761                                               
 5761 NPARA = NPARA + 15                                                        
      READ(IN,18)(IPARA(J),J=N0,NPARA)                                          
      N0 = NPARA + 1                                                            
      IF(ISOT(I)-4) 580,5762,5762                                               
 5762 NPARA = NPARA + 21                                                        
      READ(IN,18)(IPARA(J),J=N0,NPARA)                                          
      N0 = NPARA + 1                                                            
      IF(ISOT(I)-5) 580,5763,5763                                               
 5763 NPARA = NPARA + 28                                                        
      READ(IN,18)(IPARA(J),J=N0,NPARA)                                          
      N0 = NPARA + 1                                                            
  580 CONTINUE                                                                  
C                                                                               
C---- WRITE PARAMETER SELECTION CARDS.                                          
C                                                                               
      WRITE(IOUT,9023)                                                          
      WRITE(IOUT,581)(IBUFF(I),I=15,14+NSF)                                     
      IF(IZACH.EQ.0 .AND. IBDF(1).NE.0) WRITE(IOUT,582)(IBUFF(I),               
     & I=25,IPAREX(IBDF(1)+1)+24)                                               
      IF(IZACH.EQ.1) WRITE(IOUT,582)(IBUFF(I),I=25,24+JJ)                       
      IF(MODELL.GT.2 .AND.IZAEHL.NE.0) WRITE(IOUT,1025)(IBUFF(I),               
     & I=100,99+NATOM)                                                          
      IF(NPAR.NE.0)WRITE(IOUT,583)(IRPAR(I),I=1,NPAR)                           
C                                                                               
C---- WRITE  ATOMPARAMETER SWITCHES.                                            
C                                                                               
      NPARA = 0                                                                 
C                                                                               
      DO 980 I=1,NATOM                                                          
      N0 = NPARA + 1                                                            
      NPARA = NPARA + NP(ISOT(I)+1)                                             
      IF(I.EQ.1)WRITE(IOUT,918) (TAG(J,I),J=1,2),(IPARA(J),J=N0,NPARA)          
      IF(I.NE.1)WRITE(IOUT,23) (TAG(J,I),J=1,2),(IPARA(J),J=N0,NPARA)           
  980 CONTINUE                                                                  
C                                                                               
                                                                                
C                                                                               
C---- FOR ATOMPARAMETER SWITCHES A RESET AND REFRESHING ROUTINE IS              
C     AVAILABLE.                                                                
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                           LOAD OVERLAY                                        
C                         CALL LLINK("R2OV4")                                   
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL CRACK(NPARA,OCCUP,OCCA,IN,IOUT,VALUE,IVALUE,ND)                      
C                                                                               
C---- NOW WRITE IN THE MATRIX POINTER.                                          
C                                                                               
      DO 600 I=1,NPARA                                                          
      IF(IPARA(I))590,600,590                                                   
  590 MRANK=MRANK+1                                                             
      IPARA(I)=MRANK                                                            
  600 CONTINUE                                                                  
C                                                                               
C---- GENERATIOPN OF THE HARMONIC PARAMETER UNIT IHARMO.                        
C                                                                               
      IF(IHARM.NE.1)GOTO 601                                                    
  603 REWIND IHARMO                                                             
      WRITE(IHARMO)((XYZ(I,J),I=1,3),(BETA(L,J),L=1,6),J=1,NATOM)               
      IF(NEW(7).EQ.3)GOTO 610                                                   
C                                                                               
C---- READ DEPENDENT PARAMETER INFORMATION                                      
C                                                                               
  601 CONTINUE                                                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                            LOAD OVERLAY                                       
C                         CALL LLINK("R2OV1")                                   
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL RDEGN(KCYL,NEW(7))                                                   
      IF(NDEGN.EQ.0)GO TO 610                                                   
      KPARA=0                                                                   
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
C                             LOAD OVERLAY                                      
C                          CALL LLINK("R2OV2")                                  
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>         
C                                                                               
      CALL RESET(0,KPARA)                                                       
      DO 602 ID=1,NATOM                                                         
      I=ID                                                                      
      CALL RESET(I,KPARA)                                                       
  602 CONTINUE                                                                  
C                                                                               
C---- SHOULD STRUCTURE FACTORS BEING READ?                                      
C                                                                               
  610 IF(NEW(8)) 730,730,710                                                    
C                                                                               
C---- UB-MATRIX WILL BE READ IF NEW(8) GREATER 4. (AND NOT 9)                   
C                                                                               
  710 IUB=0                                                                     
      IEQPMT=2                                                                  
      IF(NEW(8).LT.6) GOTO 730                                                  
C                                                                               
C---- IF NEW(5)=5 THAT MEANS FOR STRUCTURE FACTOR CALCULATION A                 
C     READING OF HKL ONLY.                                                      
C                                                                               
      NEW(8)=NEW(8)-5                                                           
C                                                                               
C---- READ TYPE OF DIFFRACTOMETER USED AND UB-MATRIX.                           
      READ(IN,34)MACHIN,UB                                                      
C---- WHAT DIFFRACTOMETER ? 1=PW1100, 2=BUSING AND LEVY GEOMETRY                
C                           3=PICKER-STOE, 4=SYNTEX P3
C                           (DEFAULT IS B&L)                       
      IF(MACHIN.EQ.BUSLEV) IEQPMT=2                                             
      IF(MACHIN.EQ.DUMMY)  IEQPMT=3                                             
      IF(MACHIN.EQ.SYNTEX) IEQPMT=4                                             
C---- WRITE TYPE OF DIFFRACTOMETER.                                             
      IF(IEQPMT.EQ.1) WRITE(IOUT,22)                                            
      IF(IEQPMT.EQ.2) WRITE(IOUT,222)                                           
      IF(IEQPMT.EQ.3) WRITE(IOUT,223)                                           
      IF(IEQPMT.EQ.4) WRITE(IOUT,224)                                           
C---- INVERT UB-MATRIX                                                          
      CALL DOINV(UB,UBINV,UBDET)                                                
C---- NOW PRINT UB-MATRIX, INVERSE MATRIX AND DETERMINANT OF UB                 
      WRITE(IOUT,14)UB,UBINV,UBDET                                              
C---- IF NO PHILIPS DIFFRACTOMETER USED MULTIPLY MATRIX BY WAVELENGTH           
C     IN ROUTINE REFINE IF WHEN READING WAVELENGTH.                             
C                                                                               
C                                                                               
C---- SET FLAG THAT UB-MATRIX HAD BEEN READ.                                    
 1591 IUB = 1                                                                   
C                                                                               
  730 CONTINUE                                                                  
C                                                                               
      RETURN                                                                    
      END                                                                       
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
