*** werkversie x     NREJ2 = 0 hoeft niet           C30JUL print !!!
***** PROGRAM MISFIT ************ File: U625002 MISFIT FORTRAN N *******
*   ? 30 July 93: incl. tangent tests ??        origin:     17 dec. 1992
*   !!!!!  was  PADIM FORTRAN A !!!!!!!!        update:  do 29 July 1993
* LET OP: format XFO file                                              *
      PROGRAM MISFIT
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      CALL KEPROG ('MISFIT')
      CALL PADINI (0)   
      IF (NRX .EQ. 1) THEN  
         CALL PADINI (1)
         CALL LAYERI
      ELSEIF (NRX .EQ. 2) THEN  
         CALL PADINI (1)
         CALL LAYERX
         CALL PADINI (2)
         CALL LAYERI
      ELSEIF (NRX .EQ. 3) THEN  
         CALL PADINI (1)
         CALL PADINI (2)
         CALL LAYERX
         CALL PADINI (3)
         CALL SHIFL2
         CALL STORMS
         CALL SAYRMS
         ENDIF  
      CALL KEPROX   
      END   
CSUBROUTINE PADINI (LAY)
      SUBROUTINE PADINI (LAY)   
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IDDL, IFILE(1)), (IATOMS, IFILE(1))  
      EQUIVALENCE (IDDS, IFILE(2)), (IATOLD, IFILE(2)), (ICRYS,IFILE(3))
      EQUIVALENCE (ICON2, IFILE(3)) 
      EQUIVALENCE (ICON, IFILE(4)), (IPR2, IFILE(7)), (IPR3, IFILE(8))  
      EQUIVALENCE (KEYS(13), IRUN)  
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,  
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,  
     *               ILATT,    ISYST,       ILAUE,      IMULT,  
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,  
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4), 
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)  
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)  
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2   
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      PARAMETER (LCMAX = 13)
      DIMENSION LCONDA(LCMAX)   
      CHARACTER *6 LCONDA   
      DATA LCONDA / 'MISFIT','HKLMAT','CELL','CELLSD','SPGR','WAVE',
     *              'FORMUL', 'Z', 'X123', 'ATOM', 'X1234', 'SYMM4',
     *              'LAYER' /   
      IF (LAY .GT. 0) GOTO 115  
      CALL LOGRD (IDDL, 'LAYER', KLOG)  
      IF (KLOG .LE. 0 .OR. IRUN .NE. NINT(FNUM(2)))  THEN   
         NRX=1  
      ELSEIF (NINT(FNUM(3)) .EQ. 1) THEN
         NRX=2  
      ELSEIF (NINT(FNUM(3)) .EQ. 2) THEN
         NRX=3  
      ELSE  
         CALL KERROR ('Incorrect DDLOG-file', 103, 'LAYERI')
         ENDIF  
      IF (IRUN .EQ. 0) THEN 
         CHOUT =
     *   'Automatic solution of composite LAYER misfit structure'   
         CALL LOGWR (IDDL)  
         ENDIF  
      WRITE (CHOUT, 101) IRUN, NRX, CCODE   
  101 FORMAT (' Program MISFIT,  DIRDIF RUN ',I2,   
     *    ',   MISFIT call No.', I2, ' for compound ', A6)  
      CALL SHOUT2   
      IF (NRX .EQ. 1) THEN  
         CHOUT(33:72) = ' Initiate structure solution for LAYER 1'  
      ELSEIF (NRX .EQ. 3) THEN  
         CHOUT(14:72) = 
     *   ' Finish LAYER 2, combine LAYER 1+2 and start direct methods'  
      ELSE  
         CHOUT(14:72) = 
     *   ' Finish LAYER 1 and initiate structure solution for LAYER 2'  
         ENDIF  
      CALL SHOUT2   
      WRITE (CHOUT, 103) IRUN, NRX  
  103 FORMAT ('RUN', I4, '  LAYER', I2) 
      IF (NRX .EQ. 3) CHOUT(15:72) = ' 1+2 for DM ' 
      CALL LOGWR (IDDL) 
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (IPR3, FMT= 
     *  '(/ '' Start reading control data from the CONDA file''/)') 
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQ)  
      CALL FILINQ (ICON2, 'CONDA2', 'FORMATTED', 'OUTPUT', KINQ)
      IF (NRX .EQ. 1) THEN  
         ICIN = ICON
         ICOUT = ICON2  
      ELSE  
         ICIN = ICON2   
         ICOUT = ICON   
         ENDIF  
  107 READ (ICIN, 108, END = 110) CHIN  
  108 FORMAT (A80)  
      WRITE (ICOUT, 108) CHIN   
      GOTO 107  
  110 CALL FILCLO (ICON2, 'KEEP')   
      CALL RDCOND (ICON, LCONDA, LCMAX, KEND)   
      IF (KEND .LE. 0)  
     *   CALL KERROR ('Wrong data on CONDA file', 110, 'PADINI')
      CALL RDCOND (ICON, LCONDA, LCMAX, KEND)   
      IF (KEND .NE. 13) CALL KERROR 
     *  ('First control record = LAYER 1 ... ??', 111, 'PADINI')
      CALL KERNZA (0., X123, 3) 
      CALL KERNZA (0., X1234, 4)
      CALL KERNZA (0., HKLMAT, 12)  
      CALL KERNZA (0., HMATX, 12)   
      RETURN
  115 CALL KERNZI (0, ITEST, 12)
      CHRIN(10) = 'END' 
      ITEST(10) = 1 
      ITEST(1) = 1  
      NATOMS = 0
      IF (LAY .EQ. NRX) GOTO 120
  116 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)   
      IF (KEND .LE. 0)  
     *   CALL KERROR ('Wrong data on CONDA file', 116, 'PADINI')
      IF (LIT(1).EQ.'X123' .AND. LAY.EQ.1) CALL KERNAB (FNUM, X123, 3)  
      IF (LIT(1).EQ.'X123' .AND. LAY.EQ.2) X1234(4) = FNUM(1)   
      IF (LIT(1) .EQ. 'HKLMAT') CALL KERNAB (FNUM, HMATX, 12)   
      IF (KEND .EQ. 13) RETURN  
      GOTO 116  
  120 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)   
      GOTO (120, 2, 3, 3, 3, 3, 3, 3, 9, 10, 11, 12, 140), KEND 
      IF (KEND .EQ. 0) GOTO 140 
      CALL KERROR ('Wrong data keyword on CONDA file', 120, 'PADINI')   
  2   CALL KERNAB (FNUM, HKLMAT, 12)
      CHRIN(2) = CHIN   
      ITEST(2) = 1  
      IF (NFNUM .EQ. 12) GOTO 120   
      CALL KERROR ('Incorrect HKLMAT record on CONDA file', 1, 'PADINI')
  3   CHRIN(KEND) = CHIN
      ITEST(KEND) = 1   
      GOTO 120  
  9   CHRIN(KEND) = CHIN
      ITEST(KEND) = 1   
      IF (NFNUM .NE. 3) CALL KERROR 
     *   ('Incorrect X123 record on CONDA file', 9, 'PADINI')   
      IF (NRX .EQ. 1) CALL KERNAB (FNUM, X123, 3)   
      IF (NRX .GE. 2) THEN  
         ITEST(11) = 1  
         X1234(4) = FNUM(1) 
         IF (ABS(FNUM(2)) + ABS(FNUM(3)) .GT. 0.01) THEN
            WRITE (IPR2, 129) (FNUM(I), I=1,3)  
            WRITE (IPR3, 129) (FNUM(I), I=1,3)  
  129       FORMAT (' Shift X123 for LAYER 2:  S21 =', F7.4,
     *        ' is applied to X4 (in superspace)' / 
     *        ' but S22 =', F7.4, ' and S23 =', F7.4, ' are ignored!')  
            ENDIF   
         ENDIF  
      GOTO 120  
  10  IF (NATOMS. GT. 0) CALL KERROR
     *   ('ATOM and other CONDA data mixed up', 10, 'PADINI')   
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ.EQ.0 .AND. NRX.EQ.1) THEN
         CHOUT = ' Existing ATOMS file will be overwritten !'   
         CALL SHOUT2
         ENDIF  
      WRITE (IATOMS, 130) CCODE, NRX
  130 FORMAT ('ATOMS ' , A6,
     * ' Copied from CONDA, MISFIT, MISFIT for LAYER', I2)  
      NATOMS = 1
  131 WRITE (IATOMS, FMT='(A80)') CHIN  
      WRITE (IPR3, FMT='(1X,80A)') CHIN 
      CALL KERINA (ICON, LIT(32), 1, LEND)  
      IF (LEND .NE. 0) CALL KERROR  
     *   ('Incorrect CONDA file: data missing ?', 131, 'PADINI')
      IF (LIT(1) .EQ. 'ATOM') NATOMS = NATOMS + 1   
      IF (LIT(1) .EQ. 'REMARK' .OR. LIT(1) .EQ. 'ATOM' .OR. 
     *    LIT(1) .EQ. 'BIJ') GOTO 131   
      BACKSPACE ICON
      WRITE (IATOMS, FMT='(''END'')')   
      CALL FILCLO (IATOMS, 'KEEP')  
      GOTO 120  
  11  ITEST(KEND) = 1   
      CALL KERROR ('Incorrect X1234 record on CONDA file', 11, 'PADINI')
  12  ITEST(KEND) = 1   
      IF (NRX .NE. 3) CALL KERROR   
     *   ('SYMM4 on CONDA file allowed only for DM call', 12, 'PADINI') 
      IF (NFNUM .NE. 1) CALL KERROR 
     *   ('NSYM4 number on CONDA file?', 12, 'PADINI')  
      NSYM4 = NINT(FNUM(1)) 
      IF (NSYM4.LE.0 .OR. NSYM4.GT.24) CALL KERROR  
     *   ('NSYM4 impossible: bad control data!', 12, 'PADINI')  
  140 IF (ITEST(1).EQ.0) CALL KERROR
     *   ('No PROGRAM MISFIT record on CONDA file', 140, 'PADINI')  
      CHRIN(1) = 'TITLE'
      CHRIN(1)(8:72) = TITLE
      IF (NRX .EQ. 3 .AND. ITEST(12) .NE. 1) CALL KERROR
     *   ('SYMM4 record missing for DM', 140, 'PADINI') 
      RETURN
      END   
CSUBROUTINE LAYERI  
      SUBROUTINE LAYERI 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IDDL, IFILE(1)), (IDDS, IFILE(2))
      EQUIVALENCE (ICRYN, IFILE(2)), (ICRYS, IFILE(3))  
      EQUIVALENCE (ICON, IFILE(4))  
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IFREF, IFILE(10)), (IXFO , IFILE(12))
      EQUIVALENCE (IBIN, IFILE(13)) 
      EQUIVALENCE (IRUN, KEYS(13))  
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)  
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2   
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      DIMENSION IHKLM(4), IH(3) 
      WRITE (IPR3, 111) NRX 
  111 FORMAT (/' Prepare structure solution of LAYER', I2/) 
      CALL FILINQ (IFREF, 'FREFA', 'FORMATTED', 'TEST', KEND)   
      IF (KEND .EQ. 0) GOTO 123 
      CALL FILINQ (IFREF, 'FREFB', 'FORMATTED', 'TEST', KEND)   
      IF (KEND .EQ. 0) GOTO 123 
      CALL FILINQ (IFREF, 'FREFC', 'FORMATTED', 'TEST', KEND)   
      IF (KEND .NE. 0) GOTO 170 
  123 CHOUT = 'For the present MISFIT procedure the reflection data'
      CALL SHOUT2   
      CHOUT = ' files FREFA, FREFB or FREFC may not be present:'
      CALL SHOUT2   
      CALL KERROR ('Erase or rename 3D reflection files',123, 'LAYERI') 
  170 CALL FILINQ (IXFO, 'XFO', 'FORMATTED', 'INPUT', KEND) 
      IF (KEND .NE. 0) CALL KERROR ('XFO-file not present', 0, 'LAYERI')
      CALL FILINQ (IFREF, 'FREF', 'FORMATTED', 'OUTPUT', KEND)  
      WRITE (IFREF, FMT='(''FREF   '', A6)') CCODE  
      IF (NRX .EQ. 1) THEN  
         IZ1 = 1
         IZ4 = 4
      ELSE  
         IZ4 = 1
         IZ1 = 4
         ENDIF  
      WRITE (IPR2, 172) HKLMAT  
  172 FORMAT (' Transformation matrix to get hkl from 4D reflections:', 
     *      / 3 (4X, 4F5.2))
      NZZ = 0   
  173 READ (IXFO, 175, END=299) IHKLM, FOBS, SIG
  175 FORMAT (4I3, F9.3, 40X, F8.3) 
      JC = 0
      IF (IHKLM(IZ4) .NE. 0) GOTO 173   
      IF (IHKLM(IZ1) .EQ. 0)  THEN  
         FOBS = FOBS / 2.   
         SIG = SIG / 2. 
         NZZ = NZZ + 1  
         JC = 7 
         ENDIF  
      DO 200 I=1,3  
      HH = 0.   
      DO 197 J=1,4  
      HH = HH + FLOAT(IHKLM(J))*HKLMAT(J,I) 
  197 IH(I) = NINT(HH)  
  200 CONTINUE  
      WRITE (IFREF, 202) (IH(I), I=1,3), JC, FOBS, SIG  
  202 FORMAT (1X, 3I3, I2, F9.2, F7.2)  
      GOTO 173  
  299 WRITE (IFREF, FMT='(''E'')')  
      WRITE (IPR3, 300) NZZ 
  300 FORMAT(' Number of common projection reflections 0kl0 :', I4) 
      CALL FILCLO (IFREF, 'KEEP')   
      CALL FILCLO (IXFO, 'KEEP')
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'TEST', KEND)  
      IF (KEND .EQ. 0) CALL FILCLO (ICRYS, 'DELETE')
      IF (NRX.EQ.2 .AND. ITEST(6).EQ.0) THEN
         CHRIN(6) = 'WAVE'  
         CHRIN(6) (7:8) = WAVEAT
         ITEST(6) = 1   
         ENDIF  
      IF (ITEST(4).EQ.0) THEN   
         CHRIN(4) = 'CELLSD 0 0 0 0 0 0'
         ITEST(4) = 1   
         ENDIF  
      CALL FILINQ (ICRYN, 'CRYSIN', 'FORMATTED', 'OUTPUT', KEND)
      WRITE (ICRYN, 311) CCODE, NRX 
  311 FORMAT ('CRYSIN ', A6, ' LAYER', I2)  
      DO 333 I = 1, 10  
      IF (I.EQ.2 .OR. I.EQ.9) GOTO 333  
      IF (ITEST(I) .NE. 1) CALL KERROR  
     *  ('Incorrect CRYSIN - record on CONDA file', 333, 'LAYERI')  
      WRITE (ICRYN, FMT='(A72)') CHRIN(I)   
  333 CONTINUE  
      CALL FILCLO (ICRYN, 'KEEP')   
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) 
      IF (KINQ.EQ.-1) CALL KERROR ('DDSYST-file error ..', 0, 'LAYERI') 
      IF (NATOMS .EQ. 0) THEN   
         WRITE (IDDS, 537)  
  537    FORMAT ( 'CRYSDA'/'MERBIN'/'DDMAIN'/'FOUR'/'PATTY'/'DDMAIN'/   
     *            'PHASEX'/'DDMAIN'/'FOUR'/'STOP')  
         REWIND ICON
         WRITE (ICON, 571) CCODE, TITLE 
  571    FORMAT ('CONDA  ', A6, ' MISFIT'/ 'TITLE ', A64 /  
     *    'PROGRAM DDMAIN'/'OPTION 4 PATT 1 PATTY'/'PROGRAM FOUR'/  
     *    'PROGRAM PATTY'/ 'PROGRAM DDMAIN'/ 'OPTION 1 PHASEX'/ 
     *    'PROGRAM PHASEX'/ 'PROGRAM DDMAIN'/ 'OPTION 2 FOUR(PHASEX)'/  
     *    'PROGRAM FOUR'/ 'FINISH') 
         CALL FILCLO (ICON, 'KEEP') 
      ELSE  
         WRITE (IDDS, 637)  
  637    FORMAT ('CRYSDA'/'MERBIN'/'MISFIT'/'STOP') 
         CALL FILCLO (ICON, 'DELETE')   
         ENDIF  
      CALL FILCLO (IDDS, 'KEEP')
      CALL FILINQ (IBIN, 'BINFO', 'UNFORMATTED', 'TEST', KEND)  
      IF (KEND .EQ. 0) CALL FILCLO (IBIN, 'DELETE') 
      RETURN
      END   
CSUBROUTINE LAYERX  
      SUBROUTINE LAYERX 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IATOMS, IFILE(1)), (IDDL, IFILE(1))  
      EQUIVALENCE (ICRYN, IFILE(2)), (ICRYS, IFILE(3))  
      EQUIVALENCE (IATOLD, IFILE(2))
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IFREF, IFILE(10)), (IHKL, IFILE(11)) 
      EQUIVALENCE (IXFO, IFILE(12)), (IBIN, IFILE(13))  
      EQUIVALENCE (IRUN, KEYS(13))  
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,  
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,  
     *               ILATT,    ISYST,       ILAUE,      IMULT,  
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,  
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4), 
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)  
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)  
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2   
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,  
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24), 
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,  
     *                STL,      STL2,     ISS,      ENORM,  
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24) 
      PARAMETER (MAXAT = 513)   
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),   
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      COMMON /ATNAMA/ ATNAME(MAXAT) 
      CHARACTER * 6   ATNAME
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      CHARACTER *1 EEE  
      DIMENSION IHKLM(4), HKL(3), IH(3), ATXXX(3)   
      NRXX = NRX - 1
      WRITE (IPR2, 111) NRXX
      WRITE (IPR3, 111) NRXX
  111 FORMAT (/' Structure factors calculation for LAYER', I2/) 
      CALL LOGRD (IDDL, 'STLMAX', KLOG) 
      IF (KLOG .LT. 0 .OR. LIT(3) .NE. 'HKLMAX')
     *   CALL KERROR ('Incorrect DDLOG file', 114, 'LAYERX')
      STLMAX = FNUM(2)  
      CALL KERNAB (FNUM(3), HKLMAX, 3)  
      CALL LOGRD (IDDL, 'SCALE', KLOG)  
      IF (KLOG .LT. 0) CALL KERROR ('Incorrect DDLOG file',114,'LAYERX')
      SCALE = FNUM(2)   
      BP = 0.   
      BR = 0.   
      WRITE (IPR2, 116) NRX, SCALE, STLMAX  
      WRITE (IPR3, 116) NRX, SCALE, STLMAX  
  116 FORMAT (' TEMP NRX', I2, ' Fcalc: SCALE, STLMAX  =', F8.4, F8.4)  
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KEND) 
      IF (KEND .NE. 0) CALL KERROR ('CRYSDA file ???', 116, 'LAYERX')   
      CALL RDCRYS (ICRYS)   
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) 
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',  
     *   143, 'LAYERX') 
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)   
      NATQ = NAT
      N = 1 
  144 IF (ATNAME(N)(1:1) .EQ. 'Q') THEN 
         DO 146 N1 = N, NAT - 1 
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10)   
         ATNAME(N1) = ATNAME(N1+1)  
  146    IZAT(N1) = IZAT(N1+1)  
         NAT = NAT - 1  
         N = N - 1  
         ENDIF  
      N = N + 1 
      IF (N .LE. NAT) GOTO 144  
      IF (NAT .LT. NATQ) WRITE (IPR3, FMT=  
     *  '('' Nr of Q-atoms (= peaks) rejected:'', I3)') NATQ-NAT
      IF (NFNUM .GT. 0) THEN
         IF (LIT(NLIT). EQ. 'SC=' .AND. 
     *   FNUM(NFNUM) .GT. 0.0001) SCALE = FNUM(NFNUM)   
         WRITE (IPR2, 150) SCALE
         WRITE (IPR3, 150) SCALE
  150    FORMAT (' PTB TEMP: SCALE from ATOMS file =', F9.4)
         ENDIF  
      CALL FILCLO (IATOMS, 'KEEP')  
      CALL ATOMPR (IPR2, 7, ATXYZ, ATNAME, IZAT, NAT)   
      CALL ATOMPR (IPR3, 7, ATXYZ, ATNAME, IZAT, NAT)   
      IF (KEYT.EQ.1) CALL KERROR
     *   ('No temp.factors on ATOMS file!', 155, 'LAYERX')  
      WRITE (IPR2, FMT='('' SCALE factor:'',22X,''SC ='', F9.4)') SCALE 
      WRITE (IPR3, FMT='('' SCALE factor:'',22X,''SC ='', F9.4)') SCALE 
      CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
      WRITE (CHOUT,FMT='('' Scattering fraction, p**2 = '',F7.3)') PSQ  
      CALL SHOUT2   
      CALL FILCLO(ICRYS, 'DELETE')  
      CALL FILINQ (IFREF, 'FREF', 'FORMATTED', 'INPUT', KINQ)   
      IF (KINQ .LT. 0) CALL KERROR ('No FREF file ...!', 163, 'LAYERX') 
      READ (IFREF, 161) CHOUT(21:48)
  161 FORMAT (A28)  
      CHOUT(1:20) = ' Input FREF file: '
      CALL SHOUT2   
      CALL FILINQ (IHKL, 'HKL', 'FORMATTED', 'OUTPUT', KINQ)
      IF (NRXX .EQ. 2) THEN 
  163    READ (IHKL, FMT='(A1)') EEE
         IF (EEE .NE. 'E') GOTO 163 
         ENDIF  
      WRITE (IHKL, 165) CCODE, NRXX, VOLUM, ICENT, SCALE
  165 FORMAT ('HKL ', A6, ' MISFIT Fcalc LAYER', I2, ' VOLUM', F8.1,
     * ' ICENT', I2, ' SCALE', F9.4)
      CALL FILINQ (IXFO, 'XFO', 'FORMATTED', 'INPUT', KEND) 
      IF (NRXX .EQ. 1) THEN 
         IZ1 = 1
         IZ4 = 4
      ELSE  
         IZ4 = 1
         IZ1 = 4
         ENDIF  
      NZZ = 0   
      RNUM  = 0.
      RDEN  = 0.
      SUMFP = 0.
      NREFL = 0 
      CALL KERNZI (0, MHKLM, 4) 
  200 READ (IFREF, 201, END=219) EEE, HKL, JC, FOBS, SIG
  201 FORMAT (A1, 3F3.0, I2, F9.2, F7.2)
      IF (EEE .EQ. 'E') GOTO 220
      NREFL = NREFL + 1 
      CALL KERNAB (HKL, HKLX(1,1), 3)   
      CALL HKLSTL (HKLX, STL, STL2) 
      CALL FCALC1 (KEYT, ATXYZ, ITAT, NAT)  
      FOSC = FOBS * SCALE   
      FDEL = ABS (FOSC-FP)  
      CALL KERF2I (HKLX, IH, 3) 
  207 READ (IXFO, 209, END=218) IHKLM, FOBS, SIG
  209 FORMAT (4I3, F9.3, 40X, F8.3) 
      IF (IHKLM(IZ4) .EQ. 0 .OR. IHKLM(IZ1) .EQ. 0) GOTO 215
      DO 211 I = 1,4
      IF (IABS(IHKLM(I)) .GT. MHKLM(I)) MHKLM(I) = IABS(IHKLM(I))   
  211 CONTINUE  
  215 IF (IHKLM(IZ4) .NE. 0) GOTO 207   
      IF (IHKLM(IZ1).EQ.0 .AND. JC.NE.7) CALL KERROR
     *   (' Common proj. refl. 0kl0 out of order?', 217, 'LAYERX')  
      WRITE (IHKL, 217) IHKLM, JC, FOBS, SIG, FP, PHIP, STL 
  217 FORMAT (I4, 3I3, I2, F9.2, F7.2, F9.2, F7.2, F7.4)
      IF (JC .EQ. 7) GOTO 200   
      RNUM  = RNUM  + FDEL  
      RDEN  = RDEN  + FOSC  
      SUMFP = SUMFP + FP
      GOTO 200  
  218 CALL KERROR ('Premature end of input XFO file', 218, 'LAYERX')
  219 CALL KERROR ('Premature end of input FREF file', 219, 'LAYERX')   
  220 CONTINUE  
      WRITE (IHKL, FMT='(''E''/''END'')')   
      WRITE (IPR2, 240) NREFL   
      WRITE (IPR3, 240) NREFL   
  240 FORMAT (' Number of reflections read from file FREF:', I5)
      RNUM = RNUM  / RDEN   
      SCX2 = SUMFP / RDEN   
      SCALE2  = SCX2 * SCALE
      WRITE (IPR2, 250) RNUM, NRXX, SCX2, SCALE2
      WRITE (IPR3, 250) RNUM, NRXX, SCX2, SCALE2
  250    FORMAT (' Conventional R-factor =', F7.3, ' for LAYER', I2 /   
     *           ' Additional scale:     =', F7.3 / 
     *           ' New scale factor:     =', F7.3 ) 
      IF (NRX .EQ. 3) THEN  
         CALL FILINQ (ICRYN, 'CRYSIN', 'FORMATTED', 'TEST', KEND)   
         IF (KEND .EQ. 0) CALL FILCLO (ICRYN, 'DELETE') 
         CALL FILINQ (IBIN, 'BINFO', 'UNFORMATTED', 'TEST', KEND)   
         IF (KEND .EQ. 0) CALL FILCLO (IBIN, 'DELETE')  
         CALL FILINQ (IFREF, 'FREF', 'FORMATTED', 'TEST', KEND) 
         IF (KEND .EQ. 0) CALL FILCLO (IFREF, 'DELETE') 
         ENDIF  
      IF (ABS(X123(1)) + ABS(X123(2)) + ABS(X123(3)) .GT. 0.01) THEN
         WRITE (IPR2, 309) X123 
         WRITE (IPR3, 309) X123 
  309    FORMAT (' Atoms of LAYER 1 are back-transformed to 4D and' /   
     *     ' shifted by X123 = ', 3F7.3)
         ENDIF  
      DO 434 N = 1, NAT 
      DO 412 I = 1, 4   
      XAT4(I,N) = 0.
      DO 410 J = 1, 3   
  410 XAT4(I,N) = XAT4(I,N) + HMATX(I,J) * ATXYZ(J,N)   
  412 CONTINUE  
      XAT4(5,N) = ATXYZ(4,N)
      XAT4(6,N) = ATXYZ(5,N)
      NMAT4(N) = ATNAME(N)  
      IF (NRXX .EQ. 1) THEN 
         XAT4(1,N) = XAT4(1,N) + X123(1)
         XAT4(2,N) = XAT4(2,N) + X123(2)
         XAT4(3,N) = XAT4(3,N) + X123(3)
         ENDIF  
  434 CONTINUE  
      NAT4 = NAT
      IF (NRXX .EQ. 1) THEN 
         CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'OUTPUT', KEND) 
         IF (KEND .NE. 0) THEN  
            WRITE (IATOLD, 444) CCODE, (ITIME(I), I=1,3), IRUN  
  444       FORMAT ('ATOLD ', A6, ' file (= ATOMS OLD) created: DAY',   
     *         I5, 2I3, ' RUN', I4 / 'REMARK PGM MISFIT' / 'FINISH' )   
            ENDIF   
         CALL WRAT4 
         ENDIF  
      RETURN
      END   
CSUBROUTINE WRAT4   
      SUBROUTINE WRAT4  
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IATOLD, IFILE(2))
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IRUN, KEYS(13))  
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'OUTPUT', KEND)
      IF (KEND .NE. 0) CALL KERROR ('ATOLD file ???', 300, 'WRAT4') 
  301 READ (IATOLD, FMT='(A6)', END=313) CHIN(1:6)  
      IF (CHIN(1:6) .NE. 'FINISH') GOTO 301 
      GOTO 333  
  313 CALL KERROR ('Premature end of ATOLD file', 313, 'LAYERX')
  333 BACKSPACE IATOLD  
      NRXX = NRX - 1
      WRITE (IATOLD, 345) CCODE, IRUN, NRXX, HMATX  
  345 FORMAT (1X / 'ATOM4D ', A6, ' RUN', I4, ' LAYER', I2 /
     *   'REMARK MTX', 12F5.2 ) 
      WRITE (IPR2, 347) CCODE, IRUN, NRXX, HMATX
      WRITE (IPR3, 347) CCODE, IRUN, NRXX, HMATX
  347 FORMAT (' Write transformed atoms to the ATOLD file. Header:'/
     *   ' ATOM4D ', A6, ' RUN', I3 , ' LAYER', I2 /
     *   '        Matrix used to transform xyz to 4D atomic positions:'/
     *   ' HKLMAT ', 3(4F5.2 ,2X))  
      DO 434 N = 1, NAT4
      WRITE (CHOUT, 414) NMAT4(N), (XAT4(L,N), L=1,6)   
  414 FORMAT ('ATOM ', A6, 4F9.5, F7.4, F6.3)   
      WRITE (IATOLD, FMT='(A72)') CHOUT 
      WRITE (IPR2, FMT='(1X, A72)') CHOUT   
      WRITE (IPR3, FMT='(1X, A72)') CHOUT   
  434 CONTINUE  
      WRITE (IATOLD, FMT='(''END'' / ''FINISH'')')  
      CALL FILCLO (IATOLD, 'KEEP')  
      RETURN
      END   
CSUBROUTINE SHIFL2  
      SUBROUTINE SHIFL2 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IHKL, IFILE(11)) 
      PARAMETER (IIPAR = 2000)  
      COMMON /  / SICO(12500),  
     *            ST(100,100), STB(100,100),
     *            NREF, KL(2,IIPAR), FOBSX(IIPAR), SIGX(IIPAR), 
     *            F1(IIPAR), L1(IIPAR), F2(IIPAR), L2(IIPAR), SX(IIPAR) 
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      COMMON /COMC/ SICOD(450), ZKLZ(IIPAR), ITMMAX, ITAMAX, ITLMAX,
     *              KSPAN, LSPAN, MSPAN, ISPAN  
      DIMENSION IHKLM(4), SHIFT3(4) 
      CHARACTER *1 EEE  
      DATA I2MIN, I3MIN, I2MINB, I3MINB  / 0, 0, 0, 0 / 
      CALL KETIME (IPR3)
      CALL SICOT (SICOD, 450)   
      SUMFO = 0.
      SUMFP = 0.
      NREF = 0  
      SFOBS2 = 0.   
      CALL KERNZA (0., ST, 10000)   
      CALL KERNZA (0., STB, 10000)  
      TWOPI = 2. * 3.141594 
      D2R = TWOPI / 360.
      CALL FILINQ (IHKL, 'HKL', 'FORMATTED', 'INPUT', KINQ) 
      READ (IHKL, 113) NRXX, V1, ICENT1, SC1
  113 FORMAT (29X, I2, 6X, F8.1, 6X, I2, 6X, F9.4)  
  121 READ (IHKL, 123) EEE, IHKLM, JC, FOBS, SIG, FP, PHIP, STL 
  123 FORMAT (A1, 4I3, I2, F9.2, F7.2, F9.2, F7.2, F7.4)
      IF (EEE .EQ. 'E') GOTO 131
      IF (JC .NE. 7) THEN   
         SUMFO = SUMFO + FOBS   
         SUMFP = SUMFP + FP 
         GOTO 121   
         ENDIF  
      IF (NREF .EQ. IIPAR) GOTO 121 
      NREF = NREF + 1   
      KL(1,NREF) = IHKLM(2) 
      KL(2,NREF) = IHKLM(3) 
      FOBSX(NREF) = FOBS
      SIGX(NREF) = SIG  
      F1(NREF) = FP 
      L1(NREF) = NINT(PHIP) 
      IF (L1(NREF) .LE. 0) L1(NREF) = L1(NREF) + 360
      SX(NREF) = STL
      GOTO 121  
  131 SC1 = SUMFP / SUMFO   
      READ (IHKL, 113) NRXX, V2, ICENT2, SC2
      IF (NRXX .NE. 2) CALL KERROR ('File HKL error', 131, 'SHIFL2')
      SC2 = SCALE2  
      VAV = (V1 + V2) / 2.  
      W1 = V2 / VAV 
      W2 = V1 / VAV 
      SC = (W1 * SC1 + W2 * SC2) / 2.   
      WRITE (IPR2, 134) NREF
      WRITE (IPR3, 134) NREF
  134 FORMAT (/ 
     *  'SHIFT : Determination of the shift factor to bring LAYER 2' /  
     *  '        to the same origin as LAYER 1 .' / 
     *  '        Number of common projection reflection 0kl0 :', I5 )   
      WRITE (IPR2, 135) V1, V2, VAV, W1, W2, SC1, SC2, SC   
      WRITE (IPR3, 135) V1, V2, VAV, W1, W2, SC1, SC2, SC   
  135 FORMAT (/ 16X, 'LAYER 1       LAYER 2       Average'/ 
     + ' Volume (3D)', F11.1, 2F14.1 /  
     + ' Weight         W1=V2/V       W2=V1/V       V = (V1+V2)/2'/ 
     +   10X, 'Wi=', F10.4, F14.4 / 
     + ' Struct.fact.   F1            F2            F = W1.F1 + W2.F2'/ 
     + '    SC=F/Fobs:  SC1',11X, 'SC2',11X,'SC = (W1.SC1 + W2.SC2)/2'/ 
     + ' Scale SC', 3F14.5 / )  
      SCALE2 = SC   
      ICENT4 = ICENT1 * ICENT2  
      NREF1 = NREF  
      NREF = 0  
  221 READ (IHKL, 123) EEE, IHKLM, JC, FOBS, SIG, FP, PHIP, STL 
      IF (EEE .EQ. 'E') GOTO 231
      IF (JC .NE. 7) GOTO 221   
      IF (NREF .EQ. IIPAR) GOTO 221 
      NREF = NREF + 1   
      F1(NREF) = W1 * F1(NREF)  
      F2(NREF) = W2 * FP
      L2(NREF) = NINT(PHIP) 
      IF (L2(NREF) .LE. 0) L2(NREF) = L2(NREF) + 360
      FOBSX(NREF) = SC * FOBSX(NREF)
      GOTO 221  
  231 IF (NREF.NE.NREF1) CALL KERROR ('Error in HKL file',231,'SHIFL2') 
      DO 300 IREF = 1, NREF 
      FH2 = 360. * FLOAT(KL(1,IREF)) / 100. 
      FH3 = 360. * FLOAT(KL(2,IREF)) / 100. 
      LL1 = L1(IREF)
      FC1SIN = F1(IREF) * SICOD(LL1)
      FC1COS = F1(IREF) * SICOD(LL1+90) 
      PC2 = FLOAT (L2(IREF))
      FC2 = F2(IREF)
      FOBS = FOBSX(IREF)
      SFOBS2 = SFOBS2 + FOBS**2 
      X2 = 0.0  
      DO 250 I2 = 1,100 
      X2 = X2 + FH2 
      PC2X2 = PC2 + X2  
      PC2X2B = -PC2 + X2
      X3 = 0.0  
      DO 250 I3 = 1,100 
      X3 = X3 + FH3 
      IIIII = MOD (NINT (PC2X2 + X3), 360)  
      IF (IIIII .LE. 0) IIIII = IIIII + 360 
      FCSIN = FC1SIN + FC2 * SICOD (IIIII)  
      FCCOS = FC1COS + FC2 * SICOD (IIIII + 90) 
      ST(I2,I3) = ST(I2,I3) + (SQRT(FCSIN**2 + FCCOS**2) - FOBS) ** 2   
      IF (ICENT4 .NE. 1) GOTO 250   
      IIIII = MOD (NINT (PC2X2B + X3), 360) 
      IF (IIIII .LE. 0) IIIII = IIIII + 360 
      FCSIN = FC1SIN + FC2 * SICOD (IIIII)  
      STB(I2,I3) = STB(I2,I3) + (SQRT(FCSIN**2 + FCCOS**2) - FOBS) ** 2 
 250  CONTINUE  
 300  CONTINUE  
      RMIN = 999.   
      RMINB = 999.  
      DO 310 I2 = 1,100 
      DO 310 I3 = 1,100 
      ST(I2,I3) = SQRT(ST(I2,I3) / SFOBS2)  
      IF (ST(I2,I3) .LT . RMIN) THEN
         RMIN = ST(I2,I3)   
         I2MIN = I2 
         I3MIN = I3 
         ENDIF  
      IF (ICENT4 .NE. 1) GOTO 310   
      STB(I2,I3) = SQRT(STB(I2,I3) / SFOBS2)
      IF (STB(I2,I3) .LT . RMINB) THEN  
         RMINB = STB(I2,I3) 
         I2MINB = I2
         I3MINB = I3
         ENDIF  
  310 CONTINUE  
      CALL KETIME (IPR3)
      X2 = FLOAT(I2MIN) / 100.  
      X3 = FLOAT(I3MIN) / 100.  
      CALL SHIREF (0, X2, X3, X2NEW, X3NEW, RNEW)   
      SHIFT2(1) = 0.
      SHIFT2(2) = X2NEW 
      SHIFT2(3) = X3NEW 
      SHIFT2(4) = 0.
      WRITE (IPR2, 358) SHIFT2, RNEW
      WRITE (IPR3, 358) SHIFT2, RNEW
  358 FORMAT (' 4D shift vector for LAYER 2 = ', F4.1, 2F6.3, F4.1, 
     *        ' with R =', F7.4)
      IF (ICENT4 .NE. 1) GOTO 401   
      X2B = FLOAT(I2MINB) / 100.
      X3B = FLOAT(I3MINB) / 100.
      CALL SHIREF (1, X2B, X3B, X2NEWB, X3NEWB, RNEWB)  
      SHIFT3(1) = 0.
      SHIFT3(2) = X2NEWB
      SHIFT3(3) = X3NEWB
      SHIFT3(4) = 0.
      WRITE (IPR2, FMT='(/'' Using the enantiomer of LAYER 2:'')')  
      WRITE (IPR3, FMT='(/'' Using the enantiomer of LAYER 2:'')')  
      WRITE (IPR2, 358) SHIFT3, RNEWB   
      WRITE (IPR3, 358) SHIFT3, RNEWB   
      IF (RNEWB .GT. RNEW) THEN 
         CHOUT =
     * ' The enantiomer is rejected: the given coordinates are shifted:'
         CALL SHOUT 
         GOTO 401   
         ENDIF  
      CHOUT =   
     * ' Accept the enantiomer: the coordinates are inverted + shifted:'
      CALL SHOUT
      DO 390 N = 1, NAT4
      DO 389 J = 2,4
  389 XAT4(J,N) = 1.0 - XAT4(J,N)   
  390 WRITE (IPR3, 392) NMAT4(N), (XAT4(JJ, N), JJ=1,4) 
  392 FORMAT (4X, A6, 4F9.5)
      CALL KERNAB (SHIFT3, SHIFT2, 4)   
  401 WRITE (IPR2, FMT='(/'' Apply shift to atoms of LAYER 2 '')')  
      WRITE (IPR3, FMT='(/'' Apply shift to atoms of LAYER 2 '')')  
      DO 409 N = 1, NAT4
      DO 408 J = 1,4
  408 XAT4(J,N) = SHIFT2(J) + XAT4(J,N) 
      XAT4(2, N) = XAT4(2, N) + X123(2) 
      XAT4(3, N) = XAT4(3, N) + X123(3) 
      XAT4(4, N) = XAT4(4, N) + X1234(4)
  409 CONTINUE  
      CALL WRAT4
      SUMDEL = 0.   
      DO 444 IREF = 1, NREF 
      PC2 = FLOAT(L2(IREF)) + 360. * ( FLOAT(KL(1, IREF)) * SHIFT2(2)   
     *    + FLOAT(KL(2, IREF)) * SHIFT2(3)) 
      LL2 = MOD (NINT(PC2), 360)
      IF (LL2 .LE. 0) LL2 = LL2 + 360   
      LL1 = L1(IREF)
      FCSIN = F1(IREF) * SICOD(LL1)    + F2(IREF) * SICOD(LL2)  
      FCCOS = F1(IREF) * SICOD(LL1+90) + F2(IREF) * SICOD(LL2+90)   
      FC = SQRT (FCSIN**2 + FCCOS**2)   
      SUMDEL = SUMDEL + (FC - FOBSX(IREF))**2   
      PHIP = 0.0
      IF (FC .GT. 0.001) PHIP = ATAN2(FCSIN,FCCOS) / 0.0174532925   
      IF (PHIP .LT. 0.0) PHIP = PHIP + 360. 
      ZKLZ(IREF) = PHIP 
  444 CONTINUE  
      R = SQRT (SUMDEL / SFOBS2)
      WRITE (CHOUT, 446) R  
  446 FORMAT (' Final results for common',  
     *        ' projection refl. 0kl0:  R2 =', F7.4)
      CALL SHOUT2   
      CALL KETIME (IPR3)
      RETURN
      END   
CSUBROUTINE SHIREF (KCENT, X2, X3, X2NEW, X3NEW, RNEW)  
      SUBROUTINE SHIREF (KCENT, X2, X3, X2NEW, X3NEW, RNEW) 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IHKL, IFILE(11)) 
      PARAMETER (IIPAR = 2000)  
      COMMON /  / SICO(12500),  
     *            ST(100,100), STB(100,100),
     *            NREF, KL(2,IIPAR), FOBSX(IIPAR), SIGX(IIPAR), 
     *            F1(IIPAR), L1(IIPAR), F2(IIPAR), L2(IIPAR), SX(IIPAR) 
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      COMMON /COMB/ CHRIN(10), NMAT4(MAXAT2)
      CHARACTER     CHRIN *72, NMAT4 *6 
      COMMON /COMC/ SICOD(450), ZKLZ(IIPAR), ITMMAX, ITAMAX, ITLMAX,
     *              KSPAN, LSPAN, MSPAN, ISPAN  
      DIMENSION XX2(9), XX3(9), STX(9,9)
      DATA I2MIN, I3MIN / 0, 0 /
      DO 107 I=1,9  
      DX = FLOAT(I-5) / 500.
      XX2(I) = X2 + DX  
  107 XX3(I) = X3 + DX  
      SFOBS2 = 0.   
      CALL KERNZA (0., STX, 81) 
      TWOPI = 2. * 3.141594 
      D2R = TWOPI / 360.
      DO 300 IREF = 1, NREF 
      FH2 = 360. * FLOAT(KL(1,IREF))
      FH3 = 360. * FLOAT(KL(2,IREF))
      LL1 = L1(IREF)
      FC1SIN = F1(IREF) * SICOD(LL1)
      FC1COS = F1(IREF) * SICOD(LL1+90) 
      PC2 = FLOAT (L2(IREF))
      IF (KCENT .EQ. 1) PC2 = - PC2 
      FC2 = F2(IREF)
      FOBS = FOBSX(IREF)
      SFOBS2 = SFOBS2 + FOBS**2 
      DO 250 I2 = 1,9   
      PC2X2 = PC2 + FH2 * XX2(I2)   
      DO 250 I3 = 1,9   
      IIIII = MOD (NINT (PC2X2 + FH3 * XX3(I3)), 360)   
      IF (IIIII .LE. 0) IIIII = IIIII + 360 
      FCSIN = FC1SIN + FC2 * SICOD (IIIII)  
      FCCOS = FC1COS + FC2 * SICOD (IIIII+90)   
      ST(I2,I3) = ST(I2,I3) + (SQRT(FCSIN**2 + FCCOS**2) - FOBS) ** 2   
 250  CONTINUE  
 300  CONTINUE  
      RMIN = 999.   
      DO 310 I2 = 1,9   
      DO 310 I3 = 1,9   
      ST(I2,I3) = SQRT(ST(I2,I3) / SFOBS2)  
      IF (ST(I2,I3) .LT . RMIN) THEN
         RMIN = ST(I2,I3)   
         I2MIN = I2 
         I3MIN = I3 
         ENDIF  
  310 CONTINUE  
      X2NEW = XX2(I2MIN)
      X3NEW = XX3(I3MIN)
      RNEW = RMIN   
      RETURN
      END   
CSUBROUTINE STORMS  
      SUBROUTINE STORMS 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (ICON, IFILE(4)), (IHKL, IFILE(11)), (IXFO, IFILE(12))
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      PARAMETER (IIPAR = 2000)  
      COMMON /COMC/ SICOD(450), ZKLZ(IIPAR), ITMMAX, ITAMAX, ITLMAX,
     *              KSPAN, LSPAN, MSPAN, ISPAN  
      PARAMETER (ITMMX=3000, ITBMX=3000, ITAMX=33767, ITLMX=9000)   
      INTEGER*2 ITABM(3,ITMMX), KTABM(ITMMX), LTABM(ITMMX), 
     *          LTABB(ITBMX), ITABA(ITAMX), LTABA(ITAMX)
      COMMON / / ITABM, KTABM, LTABM, LTABB, ITABA, LTABA, ITABX(4,24), 
     *           LTABX(24), CTABL(ITLMX), STABL(ITLMX)  
      COMMON /TTTT/ MMMM(4,9000), MMMMP(9000), LLLL(4,9000) 
      DIMENSION MHOLD(4), MHMIN(4), IHKLM(4)
      CHARACTER *1 EEE  
      WRITE (IPR2, 103) 
      WRITE (IPR3, 103) 
  103 FORMAT (/' Application of direct methods in super space:'/
     *         ' Use known phases of main refl.  HKL0 and 0KLM'/
     *         ' in the tangent form. to phase satellites HKLM'/)   
      WRITE (IPR3, FMT= 
     *   '(/ '' Continue reading data from the CONDA file''/ )' )   
      CALL RDSYM4 (ICON)
      CALL FILCLO (ICON, 'DELETE')  
      DO 137 I = 1,4
      MHMIN(I) = MHKLM(I)   
      IF (MHMIN(I) .GT. 6) MHMIN(I) = 6 
  137 MHOLD(I) = MHKLM(I)   
      X = 1.00  
  145 MSPAN = 2 * MHKLM(4) + 1  
      LSPAN = MSPAN * (2 * MHKLM(3) + 1)
      KSPAN = LSPAN * (2 * MHKLM(2) + 1)
      KLMX = MHKLM(2) * LSPAN + MHKLM(3) * MSPAN + MHKLM(4) 
      ISPAN = 1 + KLMX - KSPAN  
      ITAMAX = MHKLM(1) * KSPAN + KLMX + ISPAN  
      IF (ITAMAX .LE. ITAMX) GOTO 176   
      X = 0.99 * X  
      DO 152 I = 1,4
      M = X * (FLOAT(MHOLD(I)) + FLOAT(I+5)/10.)
  152 MHKLM(I) = MAX0 (M, MHMIN(I)) 
      GOTO 145  
  176 IF (X .LT. .995) THEN 
         CHOUT='0Storage problems, reduce max indices for satellites:'  
         CALL SHOUT 
         ENDIF  
      WRITE (CHOUT, 179) MHKLM  
  179 FORMAT (' Max indices for satellites: ', 4I3) 
      CALL SHOUT
      WRITE (IPR3, 180) KSPAN, LSPAN, MSPAN, ISPAN  
  180 FORMAT (' Storage code IHKLMA = H *',I6, ' + K *', I4,
     *   ' + L *', I3, ' + M ', I6) 
      CALL FILINQ (IXFO, 'XFO', 'FORMATTED', 'INPUT', KEND) 
      DO 181 I=1,ITAMAX 
      ITABA(I) = 0  
  181 LTABA(I) = 0  
      ITLMAX = 0
      NREJ = 0  
  207 READ (IXFO, 209, END=418) IHKLM, FOBS, SIG
  209 FORMAT (4I3, F9.3, 40X, F8.3) 
      IF (IHKLM(1) .EQ. 0 .OR. IHKLM(4) .EQ. 0) GOTO 207
      DO 213 I = 1,4
      IF (IABS(IHKLM(I)) .GT. MHKLM(I)) THEN
         NREJ = NREJ + 1
         GOTO 207   
         ENDIF  
  213 CONTINUE  
      IF (ITLMAX .EQ. ITLMX) CALL KERROR
     *   ('Too many satellites: increase limit for Fobs...',
     *    213, 'STORMS')
      ITLMAX = ITLMAX + 1   
      CALL KERNAI (IHKLM, LLLL(1,ITLMAX), 4)
      IF (IHKLM(1) .GT. 0) GOTO 255 
      DO 253 I = 1,4
  253 IHKLM(I) = - IHKLM(I) 
  255 CALL HKLMEX(IHKLM, ITABX, LTABX)  
      CTABL(ITLMAX) = 0.
      STABL(ITLMAX) = 0.
      DO 324 ITX = 1, NSYM4 
      IF (LTABX(ITX) .LE. 0) LTABX(ITX) = LTABX(ITX) + 360  
      IF (ITABX(1,ITX) .GT. 0) GOTO 320 
      DO 311 I = 1,4
  311 ITABX(I,ITX) = - ITABX(I,ITX) 
      LTABX(ITX) = - LTABX(ITX) 
  320 IHKLMA = ITABX(1,ITX) * KSPAN + ITABX(2,ITX) * LSPAN +
     *         ITABX(3,ITX) * MSPAN + ITABX(4,ITX) + ISPAN  
      IF (IHKLMA.LE.1 .OR. IHKLMA.GT.ITAMAX) CALL KERNER (-4, 'STORMS') 
      ITABA(IHKLMA) = ITLMAX
      LTABA(IHKLMA) = LTABX(ITX)
  324 CONTINUE  
      GOTO 207  
  418 WRITE (CHOUT, 420) ITAMAX, ITLMAX 
  420 FORMAT (' Size of address-table:', I6, ', no. of satellites:', I5)
      CALL SHOUT
      CALL FILINQ (IHKL, 'HKL', 'FORMATTED', 'INPUT', KINQ) 
      READ (IHKL, 513) NRXX, V1, ICENT1, SC1
  513 FORMAT (29X, I2, 6X, F8.1, 6X, I2, 6X, F9.4)  
      ITMMAX = 0
  521 READ (IHKL, 527) EEE, IHKLM, JC, FOBS, SIG, FP, PHIP, STL 
  527 FORMAT (A1, 4I3, I2, F9.2, F7.2, F9.2, F7.2, F7.4)
      IF (EEE .EQ. 'E') GOTO 631
      IF (JC .EQ. 7) GOTO 521   
      IF (ITMMAX .EQ. ITMMX) GOTO 521   
      ITMMAX = ITMMAX + 1   
      PHIP = PHIP +             360. * ( FLOAT(IHKLM(1)) * X123(1) +
     *       FLOAT(IHKLM(2)) * X123(2) + FLOAT(IHKLM(3)) * X123(3) )
      PHIP = AMOD(PHIP, 360.)   
      IPHIP = NINT (PHIP)   
      IF (IPHIP .LE. 0) IPHIP = IPHIP + 360 
      CALL KERNAI (IHKLM, MMMM(1, ITMMAX), 4)   
      MMMMP(ITMMAX) = IPHIP 
      IF (IHKLM(1) .GT. 0) GOTO 555 
      DO 553 I = 1,4
  553 IHKLM(I) = - IHKLM(I) 
      IPHIP = - IPHIP   
  555 CONTINUE  
      IF (IHKLM(1) .GT. MHKLM(1)) THEN  
         ITABM(1,ITMMAX) = 0
      ELSE  
         ITABM(1,ITMMAX) = IHKLM(1) * KSPAN + ISPAN 
         ENDIF  
      ITABM(2,ITMMAX) = IHKLM(2) * LSPAN
      ITABM(3,ITMMAX) = IHKLM(3) * MSPAN
      KTABM(ITMMAX) = NINT (FOBS * SCALE2 * 10.)
      LTABM(ITMMAX) = IPHIP 
      GOTO 521  
  631 WRITE (IPR2, 640) X123, (SHIFT2(I), I=2,3), X1234(4)  
      WRITE (IPR3, 640) X123, (SHIFT2(I), I=2,3), X1234(4)  
  640 FORMAT (/ ' Phase modifications for reflections: ',   
     *          '  H.X1    K.X2    L.X3    M.X4'/   
     *   ' Shift vector X123 input for LAYER 1:', 3F8.4 /   
     *   ' Shift vector determined for LAYER 2:', 8X, 2F8.4 /   
     *   ' Shift vector X123 input for LAYER 2:', 24X, F8.4 )   
      RETURN
      END   
CSUBROUTINE SAYRMS  
      SUBROUTINE SAYRMS 
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IPR2, IFILE(7)), (IPR3, IFILE(8))
      EQUIVALENCE (IHKL, IFILE(11)), (IXFO, IFILE(12))  
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      PARAMETER (MAXAT2 = 97)   
      COMMON /COMA/ NRX, HKLMAT(4,3), ITEST(12), X123(3), HMATX(4,3),   
     +              SHIFT2(4), X1234(4), XAT4(6,MAXAT2), NAT4, MHKLM(4),
     +              NATOMS, SCALE2  
      PARAMETER (IIPAR = 2000)  
      COMMON /COMC/ SICOD(450), ZKLZ(IIPAR), ITMMAX, ITAMAX, ITLMAX,
     *              KSPAN, LSPAN, MSPAN, ISPAN  
      PARAMETER (ITMMX=3000, ITBMX=3000, ITAMX=33767, ITLMX=9000)   
      INTEGER*2 ITABM(3,ITMMX), KTABM(ITMMX), LTABM(ITMMX), 
     *          LTABB(ITBMX), ITABA(ITAMX), LTABA(ITAMX)
      COMMON / / ITABM, KTABM, LTABM, LTABB, ITABA, LTABA, ITABX(4,24), 
     *           LTABX(24), CTABL(ITLMX), STABL(ITLMX)  
      COMMON /TTTT/ MMMM(4,9000), MMMMP(9000), LLLL(4,9000) 
      INTEGER*2 ITABXX(4,24)
      DIMENSION IHKLM(4)
      CHARACTER *1 EEE  
      DIMENSION TTABL(9000), NTABL(9000)
      CALL KERNZA (0.0, TTABL, 9000)
      CALL KERNZI (0  , NTABL, 9000)
      NSIG2 = 0 
      READ (IHKL, 113) NRXX, V2, ICENT2, SC2
  113 FORMAT (29X, I2, 6X, F8.1, 6X, I2, 6X, F9.4)  
      ITBMAX = 0
      WRITE (IPR3, 117) MHKLM   
  117 FORMAT (' Max. values of hklm:    ', 4I7) 
      MHKLM(2) = MHKLM(2) * LSPAN   
      MHKLM(3) = MHKLM(3) * MSPAN   
      KEYITB = 0
  121 READ (IHKL, 127) EEE, IHKLM, JC, FOBS, SIG, FP, PHIP, STL 
  127 FORMAT (A1, 4I3, I2, F9.2, F7.2, F9.2, F7.2, F7.4)
      IF (EEE .EQ. 'E') GOTO 699
      IF (JC .EQ. 7) GOTO 121   
      IF (ITBMAX .EQ. ITBMX) GOTO 121   
      ITBMAX = ITBMAX + 1   
      PHIP = PHIP + 360. * ( FLOAT(IHKLM(2)) * (SHIFT2(2) + X123(2))
     *                     + FLOAT(IHKLM(3)) * (SHIFT2(3) + X123(3))
     *                     + FLOAT(IHKLM(4)) * (SHIFT2(4) + X1234(4)) ) 
      PHIP = AMOD(PHIP, 360.)   
      IPHIP = NINT (PHIP)   
      LTABB(ITBMAX) = IPHIP 
      IF (NSIG2 .LT. 39999) KEYITB = ITBMAX 
      IF (NSIG2 .GE. 39999) GOTO 121
      FOBS = FOBS * SCALE2 * 0.001  
      IF (IABS(IHKLM(4)) .GT. MHKLM(4)) GOTO 121
      CALL HKLMEX(IHKLM, ITABX, LTABX)  
      DO 133 I = 1, NSYM4   
      LTABX(I) = LTABX(I) + IPHIP   
      ITABXX(2,I) = ITABX(2,I) * LSPAN  
  133 ITABXX(3,I) = ITABX(3,I) * MSPAN  
      DO 599 ITX = 1, NSYM4 
      IF (ITX .EQ. 1) GOTO 205  
      DO 204 I = 1, ITX-1   
      IF    (ITABX(2,I).EQ.ITABX(2,ITX) .AND. ITABX(3,I).EQ.ITABX(3,ITX)
     * .AND. ITABX(4,I).EQ.ITABX(4,ITX) ) GOTO 599  
      IF   (-ITABX(2,I).EQ.ITABX(2,ITX) .AND.-ITABX(3,I).EQ.ITABX(3,ITX)
     * .AND.-ITABX(4,I).EQ.ITABX(4,ITX) ) GOTO 599  
  204 CONTINUE  
  205 DO 399 ITM = 1, ITMMAX
      IF (ITABM(1,ITM) .EQ. 0) GOTO 399 
      IFRIED = 1
      LPHASE = LTABX(ITX)   
      KK = ITABM(2,ITM) + ITABXX(2,ITX) 
      IF (IABS(KK) .GT. MHKLM(2)) GOTO 355  
      LL = ITABM(3,ITM) + ITABXX(3,ITX) 
      IF (IABS(LL) .GT. MHKLM(3)) GOTO 355  
      MM = ITABX(4,ITX) 
  220 IHKLMA = ITABM(1,ITM) 
      IHKLMA = IHKLMA + KK + LL + MM
      IF (ITABA(IHKLMA) .EQ. 0) GOTO 355
      ITL = ITABA(IHKLMA)   
      LSHI = LTABA(IHKLMA)  
      IPHASM = LTABM(ITM)   
      IF (LSHI .GT. 0) THEN 
         IPHASE = IPHASM + LPHASE - LSHI
      ELSE  
         IPHASE = LSHI - IPHASM - LPHASE
         ENDIF  
      NSIG2 = NSIG2 + 1 
      FOBS12 = KTABM(ITM)   
      FOBS12 = FOBS * FOBS12
      IPHL = MOD (IPHASE, 360)  
      IF (IPHL .LE. 0) IPHL = IPHL + 360
      TTABL(ITL) = TTABL(ITL) + FOBS12  
      NTABL(ITL) = NTABL(ITL) + 1   
      STABL(ITL) = STABL(ITL) + FOBS12 * SICOD(IPHL)
      CTABL(ITL) = CTABL(ITL) + FOBS12 * SICOD(IPHL + 90)   
  355 IFRIED = IFRIED + 1   
      IF (IFRIED .EQ. 3) GOTO 399   
      LPHASE = - LPHASE 
      KK = ITABM(2,ITM) - ITABXX(2,ITX) 
      IF (IABS(KK) .GT. MHKLM(2)) GOTO 399  
      LL = ITABM(3,ITM) - ITABXX(3,ITX) 
      IF (IABS(LL) .GT. MHKLM(3)) GOTO 399  
      MM = - ITABX(4,ITX)   
      GOTO 220  
  399 CONTINUE  
  599 CONTINUE  
      GOTO 121  
  699 CONTINUE  
      WRITE (IPR3, 701) KEYITB  
  701 FORMAT (' Generation stopped at ITBMAX =', I6)
      WRITE (CHOUT, 783) NSIG2  
  783 FORMAT (' Number of calculated Sigma-2 =', I6)
      CALL SHOUT
      MHKLM(2) = MHKLM(2) / LSPAN   
      MHKLM(3) = MHKLM(3) / MSPAN   
      REWIND IXFO   
      REWIND IHKL   
      ITM = 0   
      ITB = 0   
      IREF = 0  
      ITL = 0   
      NREFI = 0 
      NREJ = 0  
      NREJ2 = 0 
      SCSAN = 1.000 
      IF (CCODE .EQ. 'LANBS') SCSAN = 0.7275
      WRITE (IPR3, 787) SCSAN   
  787 FORMAT (//' ========= use SCSAN = ', F9.4 , ' =========') 
      WRITE (IPR3, 789) 
  789 FORMAT (//' TEMP ==== output reflecton data =====TEMP' // 
     *  ' H   K   L   M   Fobs  Phase    TEST: Fcalc PHcalc PHdiff'//)  
      SUMFO = 0.0   
      SUMFC = 0.0   
      SUMD1 = 0.0   
      SUMD2 = 0.0   
      SUMD3 = 0.0   
      SUMD4 = 0.0   
      NUMD1 = 0 
      NUMD2 = 0 
      NUMD3 = 0 
      NUMD4 = 0 
      SUMFD1 = 0.0  
      SUMFD2 = 0.0  
      SUMFD3 = 0.0  
      SUMFO1 = 0.0  
      SUMFO2 = 0.0  
      SUMFO3 = 0.0  
      ITLO = 0  
  807 READ (IXFO, 809, END=968) IHKLM, FOBS, FAAA, FBBB 
  809 FORMAT (4I3, F10.3, 10X, 2F10.4)  
      NREFI = NREFI + 1 
      PHASE = 0.0   
      PHCAL = -1.   
      PHDEL = -1.   
      ITYPR = 0 
      IF (IHKLM(1) .EQ. 0 .OR. IHKLM(4) .EQ. 0) GOTO 837
      ITYPR = 4 
      ITLO = ITL
      DO 813 I = 1,4
      IF (IABS(IHKLM(I)) .GT. MHKLM(I)) GOTO 901
  813 CONTINUE  
      ITL = ITL + 1 
      IF (ABS(STABL(ITL)).LT.0.01 .AND. ABS(CTABL(ITL)).LT.0.01) THEN   
         NREJ2 = NREJ2 + 1  
         GOTO 901   
         ENDIF  
      IF (NTABL(ITL) .EQ. 0) THEN   
         NREJ2 = NREJ2 + 1  
         GOTO 901   
         ENDIF  
      PHASE = ATAN2(STABL(ITL),CTABL(ITL)) / 0.0174532925   
      IF (IHKLM(1) .LT. 0) PHASE = - PHASE  
      NTABL(ITL) = - NTABL(ITL) 
      STABL(ITL) = PHASE
      GOTO 907  
  837 IF (IHKLM(1) .EQ. 0 .AND. IHKLM(4) .EQ. 0) GOTO 857   
      IF (IHKLM(1) .EQ. 0) GOTO 847 
      ITYPR = 1 
      ITM = ITM + 1 
      IF (ITM .GT. ITMMAX) GOTO 901 
      PHASE = LTABM(ITM)
      IF (IHKLM(1) .LT. 0) PHASE = -LTABM(ITM)  
      GOTO 907  
  847 ITB = ITB + 1 
      ITYPR = 2 
      IF (ITB .GT. ITBMAX) GOTO 901 
      PHASE = LTABB(ITB)
      GOTO 907  
  857 IREF = IREF + 1   
      ITYPR = 3 
      IF (IREF .GT. IIPAR) GOTO 901 
      PHASE = ZKLZ(IREF) + 360. * ( 
     *       FLOAT(IHKLM(2)) * X123(2) + FLOAT(IHKLM(3)) * X123(3) )
      PHASE = AMOD (PHASE, 360.)
      GOTO 907  
  901 NREJ = NREJ + 1   
      FOBS = 0.0
      GOTO 920  
  907 PHASE = AMOD (PHASE, 360.)
      IF (PHASE .LT. 0.0) PHASE = PHASE + 360.  
      IF (ABS(FAAA).LT.0.1 .AND. ABS(FBBB).LT.0.1) THEN 
         WRITE (IPR3, 908) IHKLM, FOBS, FAAA, FBBB  
  908    FORMAT (/' very weak calculated struc.fact.', 4I3, 3F7.2 /)
         GOTO 920   
         ENDIF  
      PHCAL = ATAN2(FBBB,FAAA) / 0.0174532925   
      PHDEL = AMOD (ABS (PHASE - PHCAL) , 360.) 
      IF (PHDEL .GT. 180.) PHDEL = 360. - PHDEL 
  920 CONTINUE  
      FCCC = SQRT ( FAAA**2 + FBBB**2)  
      WRITE (IPR3, 927) IHKLM, FOBS, PHASE, FCCC, PHCAL, PHDEL  
  927 FORMAT (1X, 4I3, F9.3, F6.1, 4X, F9.3, F6.1, F8.1)
      SUMFO = SUMFO + FOBS  
      SUMFC = SUMFC + FCCC  
      GOTO (931, 932, 933, 934), ITYPR  
  931 SUMD1 = SUMD1 + PHDEL 
      NUMD1 = NUMD1 + 1 
      SUMFD1 = SUMFD1 + ABS (FOBS*SCSAN - FCCC) 
      SUMFO1 = SUMFO1 + FOBS * SCSAN
      GOTO 940  
  932 SUMD2 = SUMD2 + PHDEL 
      NUMD2 = NUMD2 + 1 
      SUMFD2 = SUMFD2 + ABS (FOBS*SCSAN - FCCC) 
      SUMFO2 = SUMFO2 + FOBS * SCSAN
      GOTO 940  
  933 SUMD3 = SUMD3 + PHDEL 
      NUMD3 = NUMD3 + 1 
      SUMFD3 = SUMFD3 + ABS (FOBS*SCSAN - FCCC) 
      SUMFO3 = SUMFO3 + FOBS * SCSAN
      GOTO 940  
  934 CONTINUE  
      IF (ITLO .EQ. ITL) GOTO 940   
      IF (PHDEL .LT. -0.5) THEN 
         WRITE (IPR3, 1939) ITL, PHDEL, CTABL(ITL), NUMD4   
 1939 FORMAT(' PHDEL < -0.5   check label 1939  PHDEL=',  F7.2) 
         CTABL(ITL) = 200.  
         GOTO 940   
         ENDIF  
      SUMD4 = SUMD4 + PHDEL 
      NUMD4 = NUMD4 + 1 
      CTABL(ITL) = PHDEL
  940 CONTINUE  
      GOTO 807  
  968 CONTINUE  
      WRITE (IPR3, 1968) NREJ, NREJ2
 1968 FORMAT (/' Number of rejections,       NREJ  =', I3, ' refl.'/
     *        ' Included: no Sayre sums for NREJ2 =', I3, ' refl.') 
      D1 = SUMD1 / FLOAT (NUMD1)
      D2 = SUMD2 / FLOAT (NUMD2)
      D3 = SUMD3 / FLOAT (NUMD3)
      D4 = SUMD4 / FLOAT (NUMD4)
      R1 = SUMFD1 / SUMFO1  
      R2 = SUMFD2 / SUMFO2  
      R3 = SUMFD3 / SUMFO3  
      SCSAN = SUMFC / SUMFO 
      WRITE (IPR3, 970) D1, R1, D2, R2, D3, R3, D4, NUMD4, SCSAN
  970 FORMAT (/ ' Final test results:' //   
     *    ' LAYER 1:  av. phase dev.:', F7.2,'  R(Sander)=', F7.2/  
     *    ' LAYER 2:  av. phase dev.:', F7.2,'  R(Sander)=', F7.2/  
     *    ' 0kl0 ref. av. phase dev.:', F7.2,'  R(Sander)=', F7.2/  
     *    ' satellts. av. phase dev.:', F7.2,'  on', I4, ' refl.' / 
     *    ' New SCSAN = FC/FO =',  F9.4 /)  
      WRITE (IPR3, 973) ITL, ITLMAX 
  973 FORMAT (/ ' Final ITL, old ITLMAX ====', 2I4 //)  
      RETURN
      END   
CSUBROUTINE RDSYM4 (ICONDA) 
      SUBROUTINE RDSYM4 (ICONDA)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),   
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),  
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),   
     *               SWITCH(28) 
      LOGICAL        SWITCH 
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,  
     *               CHIN,      LIT(32),    CHOUT   
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,  
     *               CHIN *80,  LIT *6,     CHOUT *72   
      EQUIVALENCE (IPR3,  IFILE(8)) 
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      ISY=0 
  110 DO 222 I=1, 4 
  120 CALL KERINA (ICONDA, LIT(32), 1, LEND)
      IF (LEND .NE. 0) CALL KERROR  
     *   ('Incorrect CONDA file: data missing ?', 110, 'RDSYM4')
      WRITE (IPR3, FMT='(1X,80A)') CHIN 
      IF (LIT(1) .EQ. 'REMARK') GOTO 120
      IF (I .EQ. 1 .AND. LIT(1) .NE. 'MAT4') CALL KERROR
     *   ('Incorrect CONDA file: MAT4 missing ?', 110, 'RDSYM4')
      IF (I .EQ. 1) ISY = ISY+1 
      IF (I .EQ. 1 .AND. NLIT .NE. 1) CALL KERROR   
     *   ('Incorrect MAT4 record: unknown literals', -6, 'RDSYM4')  
      IF (I .NE. 1 .AND. NLIT .NE. 0) CALL KERROR   
     *   ('Incorrect MAT4 record: unknown literals ', -6, 'RDSYM4') 
      IF (NFNUM .NE. 5) CALL KERROR 
     *   ('Incorrect MAT4 record: not 5 numbers found', -6, 'RDSYM4')   
      TSYM4(I,ISY) = FNUM(5)
      DO 125 J=1, 4 
      IRSYM4(I,J,ISY) = NINT (FNUM(J))  
      IF (IRSYM4(I,J,ISY).LT.-1 .OR. IRSYM4(I,J,ISY).GT.1) CALL 
     *   KERROR ('Incorrect symm. operator elements', -6, 'RDSYM4') 
  125 CONTINUE  
  222 CONTINUE  
      IF (ISY .GT. 1) GOTO 333  
      DO 240 II=1, 4
      IF (ABS(TSYM4(II,1)).GT.0.0001) GOTO 250  
      IF (IRSYM4(II,II,1).NE.1) GOTO 250
      DO 240 JJ=1, 4
      IF (II.NE.JJ .AND. IRSYM4(II,JJ,1).NE.0) GOTO 250 
  240 CONTINUE  
      GOTO 333  
  250 CALL KERROR ('The first operator must be the identity', 0,
     *                   'RDSYM4')  
  333 IF (ISY .LT. NSYM4) GOTO 110  
      RETURN
      END   
CSUBROUTINE HKLMEX (IHKLM, IHKLMX, IHKLMP)  
      SUBROUTINE HKLMEX (IHKLM, IHKLMX, IHKLMP) 
      DIMENSION IHKLM(4), IHKLMX(4,24), IHKLMP(24)  
      COMMON /CRYSC/ IRSYM4(4,4,24), TSYM4(4,24), NSYM4, ICENT4,
     *               IPOL4(4)   
      DIMENSION IT360(4,24) 
      LOGICAL SW
      DATA SW / .FALSE. /   
      IF (SW) GOTO 110  
      SW = .TRUE.   
      DO 100 I=1,NSYM4  
      DO 100 J=1,4  
  100 IT360(J,I) = NINT (360. * TSYM4(J,I)) 
  110 CALL KERNAI (IHKLM, IHKLMX, 4)
      CALL KERNZI (0, IHKLMP, NSYM4)
      IF (NSYM4 .EQ. 1) RETURN  
      DO 320 J = 2, NSYM4   
      DO 120 K = 1, 4   
  120 IHKLMX(K,J) = IHKLM(1) * IRSYM4(1,K,J) + IHKLM(2) * IRSYM4(2,K,J) 
     *            + IHKLM(3) * IRSYM4(3,K,J) + IHKLM(4) * IRSYM4(4,K,J) 
      ITEST = 0 
      DO 140 K=1,4  
  140 ITEST  = ITEST - IHKLM(K) * IT360(K,J)
      IHKLMP(J) = MOD(ITEST, 360)   
  320 CONTINUE  
      RETURN
      END   
