      PROGRAM PHASEX
********************************** U625002 PHASEX FORTRAN N = PHASEX.FOR
*****    PHASEX                    ******  Last update:     11 Nov. 1999
*****                              ******  Source: Dirdif / CS 1988
 
*PHASEX LOG of recent modifications
C 25 sep     DDOKA : KEPROX returns!  11 Nov: STOP 99
C 24 Sep     Because of Linux: LINK, UNPACK replaced by XXLINK &  XUNPAK
C 7 Apr 99:  Corr in COMFOM: if no Quartets: clear quartet FOMS
      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
      EQUIVALENCE   (LIS1,   IFILE(7)), (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      CALL KEPROG ('PHASEX')
      WRITE (LIS2, FMT = '('' Last PHASEX update: 11 Nov. 1999'')')
      WRITE (LIS1, FMT='('' The program  PHASEX  performs the'',
     *    '' DIRDIF phase expansion and refinement''/
     *    '' procedure by application of direct metods to difference'',
     *    '' structure factors'')')
      CALL DIFTIN
      IPSQ = 0
      CALL DDOP
      IF (IDC .GT. 0) CALL DACOP
      IF (IDC .GT. 1) CALL DAMAIN
      IF (IDC .EQ. 1) CALL DCMAIN
      IF (IDC .GT. 0) CALL DACEND
      CALL DDTAN
      CALL KEPROX
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE DIFTIN
      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, SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      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)), (ICRYS,  IFILE( 3))
      EQUIVALENCE (ICON,   IFILE( 4)), (LIS1,   IFILE( 7))
      EQUIVALENCE (LIS2,   IFILE( 8)), (IE100,  IFILE(10))
      EQUIVALENCE (IBINDU, IFILE(14))
      EQUIVALENCE (NBINDU, KEYS (14))
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      PARAMETER (MAXBUF = 198)
      DIMENSION  BUFDUA(MAXBUF)
      DIMENSION    FITDUA(7)
      EQUIVALENCE (FITDUA(1), HCODE), (FITDUA(2), E1), (FITDUA(3), E2),
     *            (FITDUA(5), P1),    (FITDUA(6), P2), (FITDUA(7), W1)
      DIMENSION KARR(100), MAXHC(3), IHKL(3), HKL(3)
      PARAMETER (LCMAX = 8)
      CHARACTER LCONDA(LCMAX) *6
      DATA LCONDA / 'PHASEX', 'NCEST', 'ACCEPT', 'LOCCEN', 'STLMAX',
     *              'MAXHKL', 'DIRP1', 'PRINT' /
      DATA K, IBIG, NN / 0, 0, 0/
      EMIN  = 0.9
      STLMAX = 1.0
      MAXREF = 2047
      CALL KERNZI (0,  MAXHKL, 3)
      CALL KERNZA (0.,     TO, 3)
      CALL KERNZA (0., ESTART, 5)
      CALL KERNZA (0.,   E2AG, 7)
      CALL KERNZA (0.,   E2CG, 7)
      DO 190 I=1,ISIZ
  190 ITAB(I) = 0
      WRITE (LIS2, 200) ISIZ
  200 FORMAT (/' Available storage: ', I6)
      NC =  0
      E2AGE = 0.0
      E2CGE = 0.0
      NR  = 0
      IDC = 0
      QEET = 0.8
      MAXT = 60
      CALL KERNZI (0, MAXHKL, 3)
      CALL KERNZI (0, MAXHC,  3)
      CALL RDCRYS (ICRYS)
      KEYS(19) = ICENT
  210 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (210, 211, 212, 213, 214, 215, 216, 217) KEND
      IF (KEND .EQ. 0) GOTO 260
      CALL KERROR ('Error reading CONDA file', 0, 'DIFTIN')
  211 IF (NFNUM .NE. 6) CALL KERNER (211, 'DIFTIN')
      NC = IFIX(FNUM(1))
      IF (NC .GT. 5) NC = 5
      CALL KERNAB (FNUM(2), ESTART, 5)
      GOTO 210
  212 IF (NFNUM .NE. 2) CALL KERNER (212, 'DIFTIN')
      QEET = FNUM(1)
      IF (QEET .LT. 0.5) QEET = 0.5
      MAXT = IFIX(FNUM(2))
      IF (MAXT .LT. 10)  MAXT = 60
      GOTO 210
  213 IF (NFNUM .NE. 3) CALL KERNER (213, 'DIFTIN')
      CALL KERNAB (FNUM, TO, 3)
      IDC = 1
      GOTO 210
  214 IF (NFNUM .NE. 1) CALL KERNER (214, 'DIFTIN')
      STLMAX = FNUM(1)
      GOTO 210
  215 IF (NFNUM .NE. 3) CALL KERNER (215, 'DIFTIN')
      CALL KERF2I (FNUM, MAXHC, 3)
      GOTO 210
  216 EXPAND = .TRUE.
      GOTO 210
  217 SWIPRI = .TRUE.
      GOTO 210
  260 CALL FILINQ (IE100, 'E100', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('No E100 file found', 0, 'DIFTIN')
      CALL KERINA (IE100, LIT, 1, LEND)
      IF (LIT(1).NE.'E100' .OR. LIT(2).NE.CCODE) CALL KERROR
     *   ('Error reading E100 file', 0, 'DIFTIN')
      NGN = IFIX(FNUM(1))
      NSP = IFIX(FNUM(2))
      E2ALE = FNUM(3)
      E2CLE = FNUM(4)
      CALL LOGRD (IDDL, 'PHASEX', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      IF (KLOG.LE.0 .OR. LIT(5).NE.'MHKL' .OR. LIT(6).NE.'NREFL1')
     *    CALL KERROR ('Error reading DDLOG file', 0, 'DIFTIN')
      CALL KERF2I (FNUM(4), MAXHKL, 3)
      NR = IFIX(FNUM(7))
      IF (MAXHKL(1).EQ.0 .AND. MAXHKL(2).EQ.0 .AND. MAXHKL(3).EQ.0)
     *    CALL KERROR ('No MAXHKL given on DDLOG file', 0, 'DIFTIN')
      IF (NR .EQ. 0)
     *    CALL KERROR ('No NREFL1 given on DDLOG file', 0, 'DIFTIN')
      IF (NGN.EQ.0 .AND. NSP.EQ.0)
     *    CALL KERROR ('No NGN or NSP given on E100 file', 0, 'DIFTIN')
      IF (E2ALE.LT.0.01 .AND. E2CLE.LT.0.01) CALL KERROR
     *           ('No E2ACLE or E2CLE given on E100 file', 0, 'DIFTIN')
      DO 265 I=1,3
  265 IF (MAXHC(I) .GT. 0) MAXHKL(I) = MIN0(MAXHKL(I), MAXHC(I))
      KORIS = 0
      IICENT = ICENT
      IF (EXPAND) IICENT = 1
      IF (IDC .EQ. 0) CALL LOCCEN (IDC, TO)
      IF (IDC .GT. 0) THEN
         KORIS = 1
         IDC = 1
         ENDIF
      IF (IDC .EQ. 0) GOTO 310
      IF (IICENT .EQ. 1) GOTO 280
      WRITE (LIS2, 270)
  270 FORMAT ('0Input LOCCEN ignored' /)
      IDC = 0
      KORIS = 0
      GOTO 310
  280 WRITE (LIS1, 285)
      WRITE (LIS2, 285)
  285 FORMAT (/ ' ***** Enantiomorph fixation *****' /)
      IF (ABS(TO(1)).LT..001 .AND. ABS(TO(2)).LT..001 .AND.
     *   ABS(TO(3)).LT..001) THEN
         KORIS = 0
         GOTO 310
         ENDIF
      WRITE (LIS1, 290) TO
      WRITE (LIS2, 290) TO
  290 FORMAT (' The origin is shifted over a vector (',3(F6.3,','),')')
      WRITE (LIS2, 300)
  300 FORMAT(' All phases printed by PHASEX are in agreement with the',
     *       ' new origin', / ' phases on the final output file are',
     *       ' set back to the original origin')
      CALL PSEUDO (TO)
  310 CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      E000R = BUFDUA(5)
      PSQ   = BUFDUA(6)
      R2X   = BUFDUA(7)
      WRITE (LIS2, FMT='('' Input atoms resulted in R2 ='',F6.3)') R2X
      IF (PSQ .GT. 0.99) CALL KERROR ('PSQ too big...', 310, 'DIFTIN')
      IF (NC .GT. 0) GOTO 320
      IF (IDC .EQ. 1) NC = 2
      NC = 3
      IF (NR .LT. 200) NC = 2
  320 IDC3 = IDC + 1
      IF (ESTART(1) .GT. 0.1) GOTO 340
      XX = 1.3
      IF (IICENT .EQ. 2) XX = 1.5
      DO 330 I=1,NC
  330 ESTART(I) = XX - 0.1*(I/2)
  340 WRITE (LIS2, 350) EMIN, NC, (ESTART(I), I=1,NC)
  350 FORMAT (/ ' Start    E1min = ', F4.2, '       Tangent formula:' /
     *        29X, 'minimum Er for', I2, ' cycles :   ', 5F5.2)
      IF (IDC .NE. 1) GOTO 370
      ESTART(1) = ESTART(1) - 0.1
      ESTAR1 = ESTART(1)
      WRITE (LIS2, 360) ESTAR1
  360 FORMAT (26X, 'Min E1 for cycle zero (with symbols): ', F4.2)
  370 WRITE (LIS2, FMT='('' MAXHKL:'', 3I4)') MAXHKL
      MCTMAX = 32767
      I34 = 1
      I35 = 1
      MCTLAT = 1
      FR = 1.
      M = 0
      MS = 1
      CALL KERNAI (MAXHKL, IHKL, 3)
  380 GOTO (410, 400, 390), I35
  390 IF (MOD(MAXL,3) .GT. 0) MAXL = MAXL + 3 - MOD(MAXL,3)
      GOTO 410
  400 MAXL = MAXL + MOD(MAXL,2)
  410 MCK = 2*MAXL/I35 + 1
      IF (I34 .EQ. 2) MAXK = MAXK + MOD(MAXK,2)
      MCH = MCK * (2*MAXK/I34+1)
      MCT = MCH*MAXH + MCK*MAXK/I34 + MAXL/I35
      IF (MCT .LE. MCTMAX) GOTO 470
      GOTO (420, 430, 430, 460), MS
  420 MS = 2
      IF (MCT .LE. 5*MCTMAX/4) GOTO 430
      IF (ILATT.EQ.1) GOTO 430
      MCTLAT = ILATT
      IF (ILATT.EQ.6 .AND. MCT.LE.7*MCTMAX/3) MCTLAT = 3
      IF (MCTLAT.EQ.6 .OR. MCTLAT.EQ.4) I34 = 2
      IF (MCTLAT .NE. 4) I35 = 2
      IF (MCTLAT .EQ. 7) I35 = 3
      GOTO 380
  430 M = 1
      FR = FR * ( (FLOAT(MCT)/MCTMAX - 1.)/3. + 1. )
      DO 450 N=1,3
  450 MAXHKL(N) = IHKL(N)/FR + 1.
      IF (MS .LT. 4) MS = MS + 1
      GOTO 380
  460 FR = FR * 1.02
      GOTO 430
  470 IF (M .GT. 0) WRITE (LIS2, 480) MAXHKL
  480 FORMAT ('0Storage too small; new MAXHKL: ', 3I3)
      WRITE (LIS2, 500) MCH, MCK, I34, I35, MCT
  500 FORMAT (' Packed indices are', I14, '*H + ', I4, '*K/', I1,
     *   ' + L/', I1, /, ' Dimension of address table is', I22)
      I34 = MAXK / I34
      I35 = MAXL / I35
      KK = 0
      ICR = 9
      NTAL = ISIZ - ICR
      MAXRE = (ISIZ-MCT) / 10
      IF (MAXRE .GT. MAXREF-5) MAXRE = MAXREF - 5
      WRITE (LIS2, 503) MAXRE
  503 FORMAT (' Dimension of reflection table is', I19)
      EMINO = EMIN
      EMAX = EMIN + 0.9
      CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI)
      MMS = 1
      NCOUNT = 500
      NBINDU = 0
  510 CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      IF (KENDUA .LT. 0) GOTO 580
      NBINDU = NBINDU + 1
      CALL HKLC1U (HCODE, HKL)
      CALL HKLSTL (HKL, STL, STL2)
      IT = 1
      IF (.NOT. EXPAND) IT = IPHFIX (HKL)
      ITP = IT - 1
      EEX = E2EXP (ITP, E1, E2)
      CALL KERF2I (HKL, IHKL, 3)
      IF (MAXH.LT.IABS(IHKL(1)) .OR. MAXK.LT.IABS(IHKL(2)) .OR.
     *    MAXL.LT.IABS(IHKL(3)) .OR. E1.LT.EMIN .OR.
     *    STL.GT.STLMAX) GOTO 570
      ITAB(NCOUNT+1) = IHKL(1)
      ITAB(NCOUNT+2) = IHKL(2)
      ITAB(NCOUNT+3) = IHKL(3)
      ITAB(NCOUNT+4) = NINT (100.*E1)
      ITAB(NCOUNT+5) = NINT (100.*E2)
      IF (ABS(P1-P2) .LT. 5.) ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
      IF (KORIS .EQ. 1) CALL ORSHIF (HKL, TO, P1, P2, 0., KORIS)
      ITAB(NCOUNT+6) = NINT (P1)
      IF (ITAB(NCOUNT+6) .GE. 360) ITAB(NCOUNT+6) = ITAB(NCOUNT+6) - 360
      ITAB(NCOUNT+7) = NINT (1000.*W1)
      ITAB(NCOUNT+8) = IT
      ITAB(NCOUNT+9) = NINT (100.*EEX)
      CALL VALDIS (0, E1, 0., KARR, 100, NREFDI)
      NCOUNT = NCOUNT + ICR
      IF (NCOUNT .LT. NTAL-ICR) GOTO 510
      CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI)
      WRITE (LIS2, 520) EMIN
  520 FORMAT (' Too many refl.; new E1min =', F5.2)
      IF (EMIN .GT. EMAX) THEN
         WRITE (LIS1, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97,
     *      (KARR(I), I= 1,100)
         WRITE (LIS2, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97,
     *      (KARR(I), I= 1,100)
  522    FORMAT (' Expected scaling error: distribution of E1 values:'/
     *      3X, 4F5.2, '  ....'/ (5X, 12I5) )
         EMIN = EMAX
         WRITE (LIS2, 524) EMIN
  524    FORMAT (' Reset: ........ new E1min =', F5.2)
         IF (EMIN .GT. EMINO + 1.0) THEN
            CHOUT= ' Too many tryals: scaling error!: see what happens.'
            CALL SHOUT2
            ENDIF
         ENDIF
      EMAX = EMIN + 0.9
      CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI)
      KK = NCOUNT
      NCOUNT  = 500
      K  = 500
      MMS = 2
  530 E1 = ITAB(K+4) / 100.
      IF (E1 .GE. EMIN) GOTO 540
      EEX = ITAB(K+9) / 100.
      IT = ITAB(K+8)
      K = K + ICR
      GOTO 570
  540 DO 550 I=1,9
      K = K + 1
      NCOUNT = NCOUNT + 1
  550 ITAB(NCOUNT) = ITAB(K)
      CALL VALDIS (0, E1, 0., KARR, 100, NREFDI)
  560 IF (K .LT. KK) GOTO 530
      MMS = 1
      GOTO 510
  570 IF (IT .EQ. 1) E2ALE = E2ALE + EEX
      IF (IT .GT. 1) E2CLE = E2CLE + EEX
      GOTO (510, 560, 660), MMS
  580 CONTINUE
      WRITE (LIS2, 581) NBINDU
  581 FORMAT (' Number of reflections input from file BINDUA:', I6)
      IF (NREFDI .LT. MAXRE+5) GOTO 600
      CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI)
      WRITE (LIS2, 520) EMIN
      MAXRE = (ISIZ - NCOUNT) / 8   - 5
      MAXRE = MIN0 (MAXRE, MAXREF)
  600 KK = NCOUNT
      IF (MCT .GT. NCOUNT) NCOUNT = MCT
      IBIG = NCOUNT
      NN = NCOUNT + 8*(MAXRE+5)
      K = 500
      MMS = 3
  610 E1  = ITAB(K+4) / 100.
      EEX = ITAB(K+9) / 100.
      IT  = ITAB(K+8)
      IF (E1 .GE. EMIN) GOTO 620
      K = K + ICR
      GOTO 570
  620 IF (IT.GT.1) GOTO 630
      E2AGE = E2AGE + EEX
      E2AG(1) = E2AG(1) + E1*E1
      GOTO 640
  630 E2CGE = E2CGE + EEX
      E2CG(1) = E2CG(1) + E1*E1
  640 DO 650 I=1,8
      K = K + 1
      NCOUNT = NCOUNT + 1
  650 ITAB(NCOUNT) = ITAB(K)
      K = K + 1
  660 IF (K.LT.KK .AND. NCOUNT.LT.NN) GOTO 610
      IF (IBIG .EQ. MCT) GOTO 680
      KK = NCOUNT
      NCOUNT = MCT
      K = IBIG + 1
      DO 670 I=K,KK
      NCOUNT = NCOUNT + 1
  670 ITAB(NCOUNT) = ITAB(I)
  680 NCT = NCOUNT - 8
      ICR = 8
      RETURN
      END
      SUBROUTINE DDOP
      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, SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      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 (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINDO, IFILE(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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      COMMON / KLAD / ICODE(4,48), ISHIFT(48)
      DIMENSION IPG1(8), KARR(100), IHKL(3)
      PARAMETER (MAXBUF = 198)
      DIMENSION FITDOP(9), BUFDOP(MAXBUF)
      CHARACTER LITOUT *25
      CHARACTER LETT(5) *2
      DATA LETT / '. ', 'S ', 'R ', 'SR', 'C ' /
      NITDOP = 9
      CALL BINOFF (4, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      EWMIN = ESTART(1) * 0.16 - 0.01
      CALL VALDIS (-1, 0.03, 2. , KARR, 80, MST)
      MR = (NCT-MCT)/ICR + 1
      MSMAX = MIN0 (400, (ISIZ - NCT + MR) / 12)
      WRITE (LIS2, 200) MR
  200 FORMAT (' Number of reflections to be refined: ', I6)
      NR = MR
      NLINPR = 0
      IF (.NOT. SWIPRI) GOTO 240
      WRITE (LIS2, 210)
  210 FORMAT ('0Reflection table (max. 300 refl. printed)', /,
     *        ' R = restricted phase (Fp .gt. Fobs)')
      IF (IICENT .EQ. 1) WRITE (LIS2, 220)
  220 FORMAT (' S = special reflection (two possible phase values)')
      WRITE (LIS2, 230)
  230 FORMAT ( '0', 5('  H  K  L  E1   P1   W1  ') /)
      CHOUT = '(5A25)'
      CALL LINPRX (LIS2, LITOUT, 25, 5)
  240 MS = 0
      NWZ = 0
      DO 260 K=MCT,NCT,ICR
      IHKL(1) = ITAB(K+1)
      IHKL(2) = ITAB(K+2)
      IHKL(3) = ITAB(K+3)
      E1      = ITAB(K+4)/100.
      E2      = ABS(ITAB(K+5)/100.)
      P1      = ITAB(K+6)
      W1      = ITAB(K+7)/1000.
      IF (W1 .LT. 0.01) NWZ = NWZ + 1
      IT      = ITAB(K+8)
      PHREST  = 180.
      IF (ITAB(K+5) .LT. 0) PHREST = 57.296 *
     *                    ASIN ((E2-E1) / (E2+E1))
      EW = E1 * W1
      IF (EW .GE. 0.03) CALL VALDIS (0, EW, 0., KARR, 80, MST)
      IF (E1.LT.ESTART(1) .OR. W1.LT.0.16) GOTO 250
      EW = EW + 10.
      MS = MS + 1
  250 LET = 0
      IF (IICENT .NE. 1) LET = -1
      IF (IT .NE. 1) LET = LET + 2
      IF (ITAB(K+5) .LT. 0) LET = LET + 2
      CALL KERI2F (IHKL, FITDOP(1), 3)
      FITDOP(4) = E1
      FITDOP(5) = E2
      FITDOP(6) = P1
      FITDOP(7) = W1
      FITDOP(8) = FLOAT(IT)
      FITDOP(9) = PHREST
      CALL BINOFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         IP1 = NINT(P1)
         LET = MAX0 (1, LET)
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, E1, IP1, LETT(LET), W1
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      ITAB(K+5) = EW*1000. + .5
  260 CONTINUE
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      CALL BINOFF (-1,IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (MS.LE.MSMAX .AND. MS.GE.MSMAX/4) GOTO 280
      MSMAXT = MSMAX
      IF (MS .LE. MSMAX) MSMAXT = MSMAX / 4
      CALL VALDIS (MSMAXT, EW, 0., KARR, 80, MST)
      WRITE (LIS2, 270) EW
  270 FORMAT (/' New starting set limitations;' /
     *        '     minimum E1 * W1 is: ', F6.3)
      EWMIN = EW - 0.001
      MST = 0
  280 CONTINUE
      NCOUNT = MCT
      MS = 0
      DO 290 K=MCT,NCT,ICR
      ITAB(NCOUNT+1) = ITAB(K+1)
      ITAB(NCOUNT+2) = ITAB(K+2)
      ITAB(NCOUNT+3) = ITAB(K+3)
      ITAB(NCOUNT+4) = ITAB(K+4)
      EW = ITAB(K+5) / 1000.
      ITAB(NCOUNT+5) = ITAB(K+8)
      ITAB(NCOUNT+6) = ITAB(K+6)
      ITAB(NCOUNT+7) = ITAB(K+7)
      IF (MST.GT.0 .AND. EW.LT.10.) GOTO 290
      IF (MST.EQ.0 .AND. EW.GT.10.) EW = EW - 10.
      IF (EW .LT. EWMIN) GOTO 290
      ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
      MS = MS + 1
  290 NCOUNT = NCOUNT + 7
      ICR = 7
      NCT = NCOUNT - ICR
      INCA4 = 4
      MARKA4 = NCOUNT - INCA4
      MAXA4 = ISIZ - INCA4
      ISTO4 = MARKA4
      MSMAX = MIN0 (MS, MSMAX+10)
      WRITE (LIS2, 300) MSMAX
  300 FORMAT (' Number of reflections in starting set: ', I4)
      IF (.NOT. SWIPRI) GOTO 320
      WRITE (LIS2, FMT='(''0Starting set (max. 200 refl. printed)'')')
      NLINPR = 0
      WRITE (LIS2, 230)
  320 DO 330 I=1,MCT
  330 ITAB(I) = 0
      CALL KERNZI (0, IPG1, 8)
      CALL KERNZI (0, IPG2, 8)
      IILAUE = ILAUE
      IF (EXPAND) ILAUE = 1
      LET = 1
      MS = 0
      MR = 0
      MITAB = 0
      E1MIN = 0.9
      E1MAX = 3.0
      CALL VALDIS (-1, E1MIN, E1MAX, KARR, 100, NRE1)
      DO 370 NCOUNT=MCT,NCT,ICR
      MR = MR + 1
      IHKL(1) = ITAB(NCOUNT+1)
      IHKL(2) = ITAB(NCOUNT+2)
      IHKL(3) = ITAB(NCOUNT+3)
      W1      = ITAB(NCOUNT+7) / 1000.
      ITAB(NCOUNT+1) = INPACK(IHKL)
      ITAB(NCOUNT+2) = W1 * ITAB(NCOUNT+4) +.5
      ITAB(NCOUNT+3) = ITAB(NCOUNT+6)
      ITAB(NCOUNT+7) = ITAB(NCOUNT+4)
      E1 = ITAB(NCOUNT+4) / 100.
      CALL VALDIS (0, E1, 0., KARR, 100, NRE1)
      I = IGROUP (IHKL)
      IPG2(I) = IPG2(I) + 1
      IP1 = ITAB(NCOUNT+6)
      IF (ITAB(NCOUNT+5) .GT. 0) GOTO 340
      IF (MS .GE. MSMAX) GOTO 350
      IF (SWIPRI .AND. NLINPR.LT.200) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, E1, IP1, LETT(LET), W1
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      CALL IITAB4 (IHKL, NCOUNT)
      IPG1(I) = IPG1(I) + 1
      ITAB(NCOUNT+2) = -ITAB(NCOUNT+2)
      MS = MS + 1
      GOTO 350
  340 ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
  350 ITAB(NCOUNT+6) = I
      NE = 1
      CALL SYMEQ (IHKL, NE)
      ITAB(NCOUNT+4) = NE
      DO 360 I=1,NE
      IADR = ICODE(4,I)
      ISIG = ISIGN(1,IADR)
      IADR = IABS(IADR)
      JSI  = ISHIFT(I) - 1
      ITAB(IADR) = ISIG*(4096*JSI+MR)
      MITAB = MITAB + 1
  360 CONTINUE
  370 CONTINUE
      ILAUE = IILAUE
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      WRITE (LIS2, 400) IPG1, IPG2
  400 FORMAT(/' Distribution of reflections in parity groups or equiva',
     *       'lent.', /, ' Group 1 is the seminvariant group', /
     *        16X, '    1    2    3    4    5    6    7    8', /
     *        16X, '   ggg  ugg  gug  uug  ggu  ugu  guu  uuu', /
     *       ' in starting set ', 8I5, /, ' in entire table ', 8I5)
      NPG1 = 0
      NPG2 = 0
      ISIG = 1
      IF (MS .LT. 20) ISIG = 0
      DO 410 IPG=1,8
      IF (IPG2(IPG) .GT. ISIG) NPG2 = NPG2 + 1
      IPG2(IPG) = 0
      IF (IPG1(IPG).LE.ISIG) GOTO 410
      IPG2(IPG) = -1
      NPG1 = NPG1 + 1
  410 CONTINUE
      IF (FLOAT(NPG2)/NPG1 .GT. 1.65) IDC = IDC + 2*IICENT
      NWZ = 100 * NWZ / MR
      IF (IDC.LE.1 .AND. NWZ.GT.40) IDC = IDC + 2*IICENT
      PSQMAX = 0.15
      IF (IPSQ .LT. 0) PSQMAX = 0.0
      IF (IDC.EQ.0 .AND. PSQ.LT.PSQMAX) THEN
         IDC = IICENT*2
         IPSQ = 1
         MAXE1 = MIN0 (NRE1, 1000)
      ENDIF
      IF (IPSQ .EQ. 0) GOTO 470
      MAXE5 = MIN0 (500, NRE1)
      CALL VALDIS (MAXE5, E500, 0., KARR, 100, NRE1)
      MAXE1 = MIN0 (1000, NRE1)
      CALL VALDIS (MAXE1, E1000, 0., KARR, 100, NRE1)
      WRITE (LIS2, 420) NRE1, MAXE5, E500, MAXE1, E1000, E1MAX
  420 FORMAT (' Total number of refl.:           ', I5, /,
     *        ' E1min for', I5, ' strongest refl.:  ', F5.3, /
     *        ' E1min for', I5, ' strongest refl.:  ', F5.3, /
     *        ' E1max:                           ', F5.3)
      VINC = (E1MAX - E1MIN) / 98.
      VSUB = E1MIN - 2.*VINC
      WRITE (LIS2, FMT='(/'' Distribution of E1:'')')
      DO 425 I=1,100,25
      AS = FLOAT (I)
      WRITE (LIS2, FMT='('' E1 '', 25F5.2)') (VSUB+VINC*A, A=AS,AS+24.)
  425 WRITE (LIS2, FMT='('' NR'', 25I5)') (KARR(J), J=I,I+24)
      CALL VALDIS (MAXE1, E1MIN, 0., KARR, 100, NRE1)
      WRITE (LIS2, FMT='('' E1min for FOMs for '', I5,
     *                   '' strongest refl.: '', F5.3)') MAXE1, E1MIN
      I100 = MIN0 (MAXE1, 100)
      CALL VALDIS (I100, E1100, 0., KARR, 100, NRE1)
      WRITE (LIS2, FMT='('' E1min for FOMs for '', I5,
     *                   '' strongest refl.: '', F5.3)') I100, E1100
  470 CONTINUE
      IF (IDC .GT. 1) GOTO 490
      DO 480 NCOUNT=MCT,NCT,ICR
      ITAB(NCOUNT+4) = 0
      ITAB(NCOUNT+5) = 0
      ITAB(NCOUNT+6) = 0
  480 IF (ITAB(NCOUNT+2).LT.0) ITAB(NCOUNT+2) = -ITAB(NCOUNT+2)
  490 E2AGE   = (E2AGE   + E2ALE)/(MAX0(1,NGN))
      E2CGE   = (E2CGE   + E2CLE)/(MAX0(1,NSP))
      E2AG(1) = (E2AG(1) + E2ALE)/(MAX0(1,NGN))
      E2CG(1) = (E2CG(1) + E2CLE)/(MAX0(1,NSP))
      CALL DD38
      IF (IDC.LE.1 .OR. IPSQ.EQ.1) RETURN
      WRITE (LIS1, 500)
      WRITE (LIS2, 500)
  500 FORMAT (/, ' ***** Origin fixation *****', /)
      RETURN
      END
      SUBROUTINE DDTAN
      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, SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      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 (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINDI, IFILE(15)), (IBINDO, IFILE(13))
      EQUIVALENCE (NBINDU, KEYS(14))
      EQUIVALENCE (ICENT, KEYS(19))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      PARAMETER (MAXBUF = 198)
      DIMENSION  BUFDIF(MAXBUF), FITDIF(4)
      EQUIVALENCE (FITDIF(1), HCODE), (FITDIF(2), EL), (FITDIF(3), PL),
     *            (FITDIF(4), WL)
      DIMENSION IHKL(3), HKL(3), E2TOT(7)
      CHARACTER LITOUT *25
      CHARACTER LETT(5) *2
      DATA LETT / '. ', '* ', 'R ', '*R', 'C ' /
      DATA NLINPR / 0 /
      WRITE (LIS1, FMT='(/'' Tangent refinement:'')')
      WRITE (LIS2, FMT='(/'' Tangent refinement:'')')
      NC = NC + 1
      DO 200 ICYC=2,NC
      CALL GENER
      CALL STARTS (ICYC)
      E2AG(ICYC) = (E2AG(ICYC) + E2ALE) / (MAX0(1,NGN))
  200 E2CG(ICYC) = (E2CG(ICYC) + E2CLE) / (MAX0(1,NSP))
      CALL FILCLO (IBINDO, 'DELETE')
      NITDIF = 4
      CALL BINOFF (4, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      NBINDI = 0
      IF (KORIS .NE. 1) GOTO 220
      DO 210 I=1,3
  210 TO(I) = -TO(I)
      KORIS = 2
      CALL PSEUDO (TO)
  220 IF (SWIPRI) THEN
         WRITE (LIS2, 230)
  230 FORMAT (/ ' The following table gives the final result of the',
     *           ' program PHASEX.', /,
     *     ' The reflections are marked (max. 300 refl. printed):' /
     *     '  *  =  refl. with total phase shift of 90 degrees or more',
     *    /'  R  =  refl. with WS.lt.0.9 (unreliable)', /,
     *      ' ', 5('  H  K  L  EL   PL   WL  ') /)
         NLINPR = 0
         CHOUT = '(5A25)'
         CALL LINPRX (LIS2, LITOUT, 25, 5)
      ENDIF
      IPMIN = 0
      NPMIN = 0
      NCOUNT = MCT - ICR
  240 NCOUNT = NCOUNT + ICR
      IPACK = ITAB(NCOUNT+1)
      CALL XUNPAK (IPACK, IHKL)
      CALL KERI2F (IHKL, HKL, 3)
      LET = 1
      IP1 = ITAB(NCOUNT+4)
      IPS = ITAB(NCOUNT+3)
      EL  = ITAB(NCOUNT+7)/100.
      WS  = ABS (ITAB(NCOUNT+2) * 0.01/EL)
      IF (WS .GT. 1.0) WS = 1.0
      PL = IPS
      IF (IDC .NE. 1) GOTO 260
      PL  = PL / 57.29
      AEL = EL * COS(PL)
      BEL = EL * SIN(PL) * 2.00
      EL  = SQRT(AEL**2 + BEL**2)
      PL  = ATAN2(BEL,AEL) * 57.29
      IF (PL .LT. 0.) PL = PL + 360.
  260 WL = WS
      IF (KORIS .EQ. 2) CALL ORSHIF (HKL, TO, 0., 0., PL, KORIS)
      IF (WS .LT. 0.9) LET = 3
      IF (ITAB(NCOUNT+5) .GE. 0) GOTO 270
      LET = 5
      GOTO 280
  270 IDIF = IABS(IPS-IP1)
      IDIF = MIN0(IDIF, 360-IDIF)
      IF (IDIF .GT. 89) LET = LET + 1
  280 IPS = INT(PL)
      IPMIN = IPMIN + MIN0(IABS(IPS), IABS(IABS(IPS)-180))
      NPMIN = NPMIN + 1
      NBINDI = NBINDI + 1
      CALL HKLC1 (HKL, HCODE)
      CALL BINOFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (.NOT. SWIPRI) GOTO 290
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, EL, IPS, LETT(LET), WL
         CALL LINPRX (0, LITOUT, 25, 5)
         ENDIF
  290 IF (NCOUNT .LT. NCT) GOTO 240
      CALL BINOFF (-1, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      WRITE (LIS2, 291) NBINDI
  291 FORMAT (' Number of reflections output to  file BINDIF:', I6)
      IPMIN = IPMIN / NPMIN
      IF (ICENT .EQ. 1) WRITE(LIS2, FMT = '(/
     * '' Average deviation from 0 degrees (or 180 degrees)'' /
     * '' for phases used in PHASEX '', I3  , '' degrees '')')  IPMIN
      NBINDI = NBINDU - NBINDI
      IF (NBINDI .NE. 0) WRITE (LIS2, 292) NBINDI
  292 FORMAT (' Number of reflections skipped by PHASEX:     ', I6)
      IF (KORIS .EQ. 2) WRITE (LIS1, 310)
      IF (KORIS .EQ. 2) WRITE (LIS2, 310)
  310 FORMAT (' ***** Origin shifted back *****')
      NTOT  = NGN + NSP
      ANGN  = FLOAT (MAX0(1,NGN))
      ANSP  = FLOAT (MAX0(1,NSP))
      ANTOT = FLOAT (NTOT)
      E2TOTE = (E2AGE*ANGN + E2CGE*ANSP) / ANTOT
      DO 320 I=1,7
  320 E2TOT(I) = (E2AG(I)*ANGN + E2CG(I)*ANSP) / ANTOT
      IF (IDC .EQ. 0) THEN
          WRITE (LIS1, 330) E2TOTE, (I, E2TOT(I), I=1,NC-1)
  330 FORMAT(' Values for average E**2', /
     *       ' a priori expectation values   ', F7.3, /,
     *      (' calculated before cycle', I5, 6X, F13.3))
          WRITE (LIS2, 335) NTOT, E2TOTE, (I, E2TOT(I), I=1,NC-1)
  335 FORMAT(' Values for average E**2 for all (', I5, ') reflections'/
     *       ' a priori expectation values   ', F7.3, /,
     *      (' calculated before cycle', I5, 6X, F13.3))
          IF (IICENT .EQ. 1)
     *    WRITE (LIS2, 340) NGN, NSP, E2AGE, E2CGE,
     *                    (I, E2AG(I), E2CG(I), I=1,NC-1)
  340 FORMAT(' Values for average E**2 for', I5, ' general refl. and',
     *   I4, ' special refl.:' /
     *       ' a priori expectation values   ', F7.3, 19X, F5.3 /
     *      (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3))
        ELSE
          WRITE (LIS1, 350) E2TOTE, E2TOT(1), E2TOT(7),
     *                     (I, E2TOT(I), I=2,NC-1)
  350 FORMAT(' Values for average E**2' /
     *       ' a priori expectation values   ', F7.3 /
     *       ' calculated at start    ',    11X, F13.3 /
     *       ' calculated after symbols',   10X, F13.3 /
     *      (' calculated before cycle', I5, 6X, F13.3))
          WRITE (LIS2, 355) NTOT, E2TOTE, E2TOT(1), E2TOT(7),
     *                     (I, E2TOT(I), I=2,NC-1)
  355 FORMAT('0Values for average E**2 for all (', I5, ') reflections'/
     *       ' a priori expectation values   ', F7.3 /
     *       ' calculated at start    ',    11X, F13.3 /
     *       ' calculated after symbols',   10X, F13.3 /
     *      (' calculated before cycle', I5, 6X, F13.3))
          IF (IICENT .EQ. 1)
     *    WRITE (LIS2, 360) NGN, NSP, E2AGE, E2CGE, E2AG(1), E2CG(1),
     *           E2AG(7), E2CG(7), (I, E2AG(I), E2CG(I), I=2,NC-1)
  360 FORMAT(' Values for average E**2 for general refl. (', I5,
     *      ') and special refl. (', I4, ')'  /
     *       ' a priori expectation values   ', F7.3, 19X, F5.3 /
     *       ' calculated at start    ',    11X, F13.3, 12X, F12.3 /
     *       ' calculated after symbols',   10X, F13.3, 12X, F12.3 /
     *      (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3))
      ENDIF
      WRITE (LIS1, 370) NC-1, E2TOT(NC)
  370 FORMAT(' calculated after  cycle', I5, 6X, F13.3)
      WRITE (LIS2, 370) NC-1, E2TOT(NC)
      IF (IICENT .EQ. 1) WRITE (LIS2, 380) NC-1, E2AG(NC), E2CG(NC)
  380 FORMAT(' calculated after  cycle', I5, 6X, F13.3, 12X, F12.3)
      RETURN
      END
      SUBROUTINE GENER
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      COMMON / KLAD / ICODE(4,48), ISHIFT(48)
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DIMENSION  IHKL(3), IHKL3(3),  LHIT(48)
      EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3),
     *            (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      DATA K,KTEST / 0, 0/
      ISTR1 = MARKA4 + INCA4 + INCA4
      ISTR2 = MARKA4 + INCA4
      DO 280 I41=ISTR1,ISTO4,INCA4
      IR1 = ITAB(I41+4) + MCT
      IEW1 = ITAB(IR1+2)
      IPH1 = ITAB(IR1+3)
      DO 200 I=1,3
  200 IHKL(I) = ITAB(I41+I)
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      DO 210 I=1,NEQ
      IS2 = ISHIFT(I)
      ISHIFT(I) = IPH1 + IDEG(IS2)
  210 ISHIFT(I+NEQ) = -ISHIFT(I)
      ISTOP = I41 - INCA4
      NEQ2 = NEQ * 2
      DO 270 I42=ISTR2,ISTOP,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      IPH2 = ITAB(IR2+3)
      IWEE = IEW1 * ITAB(IR2+2)
      J = ITAB(IR2+1)
      NHIT = 0
      DO 260 I11=1,NEQ2
      IF (MCTLAT .GT. 1) GOTO 220
      I = ICODE (4, I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 260
      IF (K .GT. MCT) GOTO 260
      IF (ITAB(K) .EQ. 0) GOTO 260
  220 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 260
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 260
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 260
      IF (MCTLAT .EQ. 1) GOTO 230
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 260
      IF (ITAB(K) .EQ. 0) GOTO 260
  230 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 260
      IF (NHIT .EQ. 0) GOTO 250
      DO 240 IHIT=1,NHIT
      IF (IR3 .EQ. LHIT(IHIT)) GOTO 260
  240 CONTINUE
  250 NHIT = NHIT + 1
      LHIT(NHIT) = IR3
      L = L + 1
      IPH3 = ISIGN(1,K)*ISIGN(1,KTEST)*(ISHIFT(I11)+IPH2) - IDEG(L)
      IPH3 = MOD(IPH3,360)
      IF (IPH3 .LE. 0) IPH3 = IPH3 + 360
      IF (ITAB(IR3+6) .GT. 32000) GOTO 260
      ITAB(IR3+4) = ITAB(IR3+4) + IWEE*ISCT(450-IPH3)/1000000
      ITAB(IR3+5) = ITAB(IR3+5) + IWEE*ISCT(IPH3)/1000000
      ITAB(IR3+6) = ITAB(IR3+6) + IWEE/1000
  260 CONTINUE
  270 CONTINUE
  280 CONTINUE
      RETURN
      END
      SUBROUTINE STARTS (ICYC)
      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, SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      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 (LIS1,   IFILE( 7))
      EQUIVALENCE (LIS2,   IFILE( 8))
      EQUIVALENCE (IBINDO, IFILE(13))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      CHARACTER LITOUT *38
      DIMENSION  IHKL(3)
      COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      PARAMETER (MAXBUF = 198)
      DIMENSION  BUFDOP(MAXBUF), FITDOP(9)
      DATA NLINPR / 0 /
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      ISTO4 = MARKA4
      LLMAX = MAXA4 - INCA4
      NSPEC = 0
      NGEN = 0
      NFLIP = 0
      NSHIFT = 0
      XNUM = 0.0
      XDEN = 0.0
      IIASUM = 0
      IISSUM = 0
      IIASN = 0
      JCYC = ICYC - 1
      IF (.NOT. SWIPRI) GOTO 210
      WRITE (LIS2, 200) JCYC
  200 FORMAT (/, '0In cycle ', I2, ' the following reflections had',
     *           ' shifts of more than 45 degress',
     *           ' (max. 100 refl. printed):', /, '0',
     *        3 ('  H  K  L Eold Enew Pold Pnew  Wnew   '), /)
      NLINPR = 0
      CHOUT = '(3A38)'
      CALL LINPRX (LIS2, LITOUT, 38, 3)
  210 DO 310 NCOUNT=MCT,NCT,ICR
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 320
      CALL KERF2I (FITDOP(1), IHKL(1), 3)
      E1 = FITDOP(4)
      EL = E1
      E2 = FITDOP(5)
      IP1 = NINT(FITDOP(6))
      IPHS = IP1
      W1 = FITDOP(7)
      IT = NINT(FITDOP(8))
      IREST = NINT(FITDOP(9))
      EOLD = ITAB(NCOUNT+7) / 100.0
      EWOLD = ITAB(NCOUNT+2) / 100.0
      WOLD = EWOLD / EOLD
      IPHO = ITAB(NCOUNT+3)
      ICS4 = ITAB(NCOUNT+4)
      ICS5 = ITAB(NCOUNT+5)
      ICS6 = ITAB(NCOUNT+6)
      IF (ICS4.EQ.0 .AND. ICS5.EQ.0 .AND. ICS6.EQ.0) THEN
          IDABS = 0
          EL = EOLD
          WS = WOLD
          IPHS = IPHO
          GOTO 265
      ENDIF
      XEE = EOLD / 10.
      AEE = ITAB(NCOUNT+4) * XEE
      BEE = ITAB(NCOUNT+5) * XEE
      FEE = ITAB(NCOUNT+6) * XEE
      EEE = SQRT(AEE*AEE + BEE*BEE)
      XNUM = XNUM + EEE
      XDEN = XDEN + FEE
      WS = (TANH(EEE/E000R))**2
      IF (EEE.LT.0.01 .OR. WS.LT.0.01) GOTO 260
      PHS = 57.29 * ATAN2(BEE,AEE)
      IF (PHS .LT. 0.) PHS = PHS + 360.
      IPHS = PHS + 0.5
      IF (IT.GT.1 .OR. WOLD.LT.0.1) GOTO 250
      IF (IDC3.EQ.1 .OR. (180-IPHO)*(180-IPHS).GT.0)  GOTO 220
      IF (MIN0(IPHS, 360-IPHS, IABS(180-IPHS)).GT.30) GOTO 250
      IPHS = 180 * MOD((IPHS+90)/180, 2)
      IF (IPHS.EQ.0 .AND. IPHO.GT.180) IPHS = 358
  220 CALL PHDIF (IPHS, IPHO, II, IIA)
      IF (PSQ .LT. 0.20)
     * IPHS=MOD(360+IPHO+ISIGN(MIN0(IIA,MAX1(47.,80.-10.*WOLD)),II),360)
      IF (IDC3 .EQ. 1) GOTO 250
      IIS = MIN0 (IPHS, 360-IPHS)
      IF (IDC3 .EQ. 2) IIS = MIN0 (IIS, IABS(180-IPHS))
      IIA = MIN0 (IPHO, 360-IPHO)
      IF (IDC3 .EQ. 2) IIA = MIN0 (IIA, IABS(180-IPHO))
      IIASUM = IIASUM + IIA
      IISSUM = IISSUM + IIS
      IIASN = IIASN + 1
      IF (IIS.GE.IIA .OR. IIS.GE.45) GOTO 250
      IF (IISSUM/IIASN .LT. 35) IPHS = ((IPHS+IPHO)/180) * 90 + 45
      IF (IIA .GT. 45) GOTO 250
      IF (IIA .LT. 20) GOTO 240
      IPHS = (IPHO+IPHS) / 2
      GOTO 250
  240 IPHS = IPHO + ISIGN(15, 90 - MOD(IPHO,180))
  250 CALL EPW
  260 CALL PHDIF (IPHS, IPHO, IDIF, IDABS)
      IF (WOLD .LT. 0.1) IDABS = 0
  265 IF (IT .GT. 1) GOTO 270
      NGEN = NGEN + 1
      NSHIFT = NSHIFT + IDABS
      E2AG(ICYC) = E2AG(ICYC) + EL*EL
      GOTO 280
  270 IF (IDABS .GT. 90) NFLIP = NFLIP + 1
      NSPEC = NSPEC + 1
      E2CG(ICYC) = E2CG(ICYC) + EL*EL
  280 IF (IDABS.LT.45 .OR. .NOT.SWIPRI) GOTO 290
      IF (SWIPRI .AND. NLINPR.LT.100) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, 2F5.2, 2(I4,''.''), F6.3, 2X)')
     *                        IHKL, EOLD, EL, IPHO, IPHS, WS
         CALL LINPRX (0, LITOUT, 38, 3)
      ENDIF
  290 ITAB(NCOUNT+2) = 100.0*EL*AMAX1(W1,WS) + 0.5
      ITAB(NCOUNT+3) = IPHS
      ITAB(NCOUNT+4) = 0
      ITAB(NCOUNT+5) = 0
      ITAB(NCOUNT+6) = 0
      ITAB(NCOUNT+7) = 100.*EL + 0.5
      IF (ICYC .LT. NC) GOTO 300
      ITAB(NCOUNT+4) = IP1
      ITAB(NCOUNT+5) = IREST
  300 IF (EL .LT. ESTART(ICYC)) GOTO 310
      IF (ISTO4 .GT. LLMAX) GOTO 310
      CALL IITAB4 (IHKL, NCOUNT)
  310 CONTINUE
  320 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 38, 3)
      IF (ISTO4 .GT. LLMAX) WRITE (LIS1, 330) ICYC
  330 FORMAT(' **** WARNING: the basic set for cycle', I2,
     *       ' is not complete; table ITAB is too small')
      MS = (ISTO4-MARKA4) / INCA4
      IF (NGEN .GT. 0) NSHIFT = FLOAT(NSHIFT)/NGEN + .5
      IF (IICENT .EQ. 1) THEN
         WRITE (LIS2, 340) JCYC, NGEN, NSHIFT, NFLIP, NSPEC
  340    FORMAT (' Statistics for cycle ', I3, ':', /,
     *        I5, ' general reflections gave average phase shift of ',
     *        I4, ' degrees', /, I5, ' special reflections out of',
     *        ' a total of', I5, '  shifted by 180 degrees')
      ELSE
         WRITE (LIS2, 342) JCYC, NFLIP, NSPEC
  342    FORMAT (' Statistics for cycle ', I3, ':', /,
     *         I5, ' reflections out of a total of',
     *         I5, '  gave a phase shift of 180 degrees')
         ENDIF
      IF (XDEN .LT. 0.00001) GOTO 355
      XDEN = XNUM / XDEN
      WRITE (LIS1, FMT='('' Cycle'', I3, '': Sigma2 - consistency  '',
     *                   F6.3)') JCYC, XDEN
      WRITE (LIS2, FMT='('' Sigma2 - consistency: '', F6.3)') XDEN
  355 IF (IDC3 .EQ. 1) GOTO 370
      IIASN  = MAX0 (1, IIASN)
      IIASUM = IIASUM / IIASN
      IISSUM = IISSUM / IIASN
      WRITE (LIS2, 360) IIASUM, IISSUM
  360 FORMAT ('0Average deviation from 0 degrees (or 180 degrees)' /
     *        ' for phases used in the last cycle: ', I3  , ' degrees '/
     *        ' for new phases (before resetting): ', I3  , ' degrees ')
  370 CALL KETIME (LIS2)
      IF (ICYC .LT. NC) WRITE (LIS2, 380) MS, ICYC
  380 FORMAT('0There are', I5, ' reflections in the basic set',
     *             ' for cycle', I3)
      RETURN
      END
      SUBROUTINE ORSHIF (HKL, TO, P1, P2, PL, KORIS)
      DIMENSION HKL(3), TO(3)
      PHT = 0.0
      DO 110 I=1,3
  110 PHT = PHT + TO(I)*HKL(I)
      PHT = AMOD(PHT,1.) * 360.
      IF (PHT .LT. 0.0) PHT = PHT + 360.
      IF (KORIS .NE. 1) GOTO 120
      P1 = P1 - PHT
      P2 = P2 - PHT
      IF (P1 .LT. 0.0) P1 = P1 + 360.
      IF (P2 .LT. 0.0) P2 = P2 + 360.
      GOTO 130
  120 PL = PL - PHT
      IF (PL .LT. 0.0) PL = PL + 360.
  130 RETURN
      END
      SUBROUTINE PSEUDO (TO)
      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, EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      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)
      DIMENSION  TO(3), RSYMM(3,3,24)
      NNSYMM = NSYMM
      IF (EXPAND) NNSYMM = 1
      CALL KERI2F (IRSYMM, RSYMM, 9*NNSYMM)
      DO 130 K=1,NNSYMM
      DO 130 I=1,3
      TMA = 0.0
      DO 120 J=1,3
  120 TMA = TMA + RSYMM(I,J,K)*TO(J)
  130 TSYMM(I,K) = TMA + TSYMM(I,K) - TO(I)
      RETURN
      END
      SUBROUTINE IITAB4 (IHKL, K)
      DIMENSION IHKL(3)
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      ISTO4 = ISTO4 + INCA4
      ITAB(ISTO4+1) = IHKL(1)
      ITAB(ISTO4+2) = IHKL(2)
      ITAB(ISTO4+3) = IHKL(3)
      ITAB(ISTO4+4) = K - MCT
      RETURN
      END
      INTEGER FUNCTION INPACK (I)
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      DIMENSION I(3)
      IF (MCTLAT .GT. 1) GOTO 100
      INPACK = MCH*I(1) + MCK*I(2) + I(3)
      RETURN
  100 K2 = I(2)
      K3 = I(3)
      GOTO (1,  2,  2,  4,  2,  6,  7  ), MCTLAT
    2 IF (K3 .NE. 0) K3 = (K3 + ISIGN(1,K3))/2
      GOTO 1
    6 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2
      GOTO 2
    7 IF (K3 .NE. 0) K3 = (K3 + ISIGN(2,K3))/3
      GOTO 1
    4 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2
    1 INPACK = MCH*I(1) + MCK*K2 + K3
      RETURN
      END
      SUBROUTINE XUNPAK (IPACK, IHKL)
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      DIMENSION IHKL(3)
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      I1 = IPACK + MCT
      I2 = I1 / MCH
      IHKL(1) = I2 - MAXH
      I1 = I1 - I2*MCH
      I2 = I1 / MCK
      IHKL(2) = I2 - I34
      IHKL(3) = I1 - I2*MCK - I35
      GOTO (9,  2,  3,  4,  5,  7,  6  ), MCTLAT
    2 KH = IABS(IHKL(2))
      GOTO 110
    3 KH = IABS(IHKL(1))
      GOTO 110
    5 KH = IABS(IHKL(1)+IHKL(2))
  110 IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3))
      GOTO 9
    7 KH = IHKL(3)*3
      GOTO (120, 9, 130), KH
  120 IHKL(3) = KH + MOD(300+IHKL(1)-IHKL(2),3)
      GOTO 9
  130 IHKL(3) = KH - MOD(300-IHKL(1)+IHKL(2),3)
      GOTO 9
    6 KH = IABS(IHKL(1))
      IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3))
    4 KH = IABS(IHKL(1))
      IF (IHKL(2) .NE. 0) IHKL(2) = 2*IHKL(2) - ISIGN(MOD(KH,2),IHKL(2))
    9 RETURN
      END
      FUNCTION IGROUP (IHKL)
      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)
      DIMENSION IHKL(3), ICODE(24)
      DATA ICODE / 1,2,3,4,3,4,1,2,1,2,3,4,2,1,4,3,1,2,2,1,3,4,4,3 /
      IGROUP = 0
      DO 100 I=1,3
  100 IGROUP = IGROUP + IABS(MOD(IHKL(I),2))*2 **I
      IGROUP = IGROUP/2 +1
      GOTO (3, 3, 3, 2, 2, 5, 5, 4, 4, 4, 4, 4, 5, 5), ILAUE
    2 I = 8*(IUNIQ-1) + IGROUP
      IGROUP = ICODE(I)
    3 RETURN
    4 IGROUP = IABS(MOD(IHKL(IUNIQ),2)) +1
      RETURN
    5 IGROUP = 0
      DO 110 I=1,3
  110 IGROUP = IGROUP + IHKL(I)
      IGROUP = IABS(MOD(IGROUP,2)) + 1
      RETURN
      END
      SUBROUTINE SYMEQ (IHKL, N)
      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, EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      COMMON / KLAD / IC(4,48), IS(48)
      DIMENSION ICODE(13), IHKL(3), ITEMP(24)
      DATA ICODE / 1, 0, 2, 3, 4, 0, 5, 0, 6, 7, 8, 0, 1 /
      NNSYMM = NSYMM
      IF (EXPAND) NNSYMM = 1
      M = N
      N = 1
      CALL KERNZI (0, ITEMP, 24)
      DO 150 I=1,NNSYMM
      XTEST = 0.0
      DO 120 K=1,3
      IC(K,N) = 0
      DO 110 L=1,3
  110 IC(K,N) = IC(K,N) + IHKL(L)*IRSYMM(L,K,I)
  120 XTEST = XTEST - IHKL(K)*TSYMM(K,I)
      IC(4,N) = INPACK(IC(1,N))
      ITEMP(N) = IABS(IC(4,N))
      IF (N.EQ.1) GOTO 140
      K = N - 1
      DO 130 L=1,K
  130 IF (ITEMP(L) .EQ. ITEMP(N)) GOTO 150
  140 XTEST = XTEST - IFIX(XTEST)
      IF (XTEST .LT. -0.01) XTEST = XTEST + 1.0
      J = IFIX(12.*XTEST+0.01) + 1
      IS(N) = ICODE(J)
      N = N + 1
  150 CONTINUE
      N = N - 1
      IF (M .EQ. 1) GOTO 170
      DO 160 J=1,N
      DO 160 I=1,4
  160 IC(I,J+N) = -IC(I,J)
  170 RETURN
      END
      SUBROUTINE DD38
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      IDEG(1) = 0
      IDEG(2) = 60
      IDEG(3) = 90
      IDEG(4) = 120
      IDEG(5) = 180
      IDEG(6) = 240
      IDEG(7) = 270
      IDEG(8) = 300
      P = 0.0
      DO 100 I=1,90
      P = P + 0.0174532925
      IP = SIN(P)*1000. + 0.5
      ISCT(I) = IP
      ISCT(180-I) = IP
      ISCT(180+I) = -IP
      ISCT(360-I) = -IP
      ISCT(360+I) = IP
  100 CONTINUE
      ISCT(360) = 0
      ISCT(180) = 0
      RETURN
      END
      SUBROUTINE PHDIF (IPHS, IP, IDIF, IDABS)
      IDIF = IPHS-IP
      IF (IDIF .LT. -179) IDIF = IDIF + 360
      IF (IDIF .GT.  180) IDIF = IDIF - 360
      IDABS = IABS(IDIF)
      RETURN
      END
      SUBROUTINE EPW
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      CALL PHDIF (IPHS, IP1, IDIF, IDABS)
      IF (IREST .LT. 100) GOTO 220
      IF (IT .EQ. 1) GOTO 200
      EEE = ABS (EEE * COS(IDIF/57.29))
      WS = TANH (EEE/E000R)**2
      IDIF = 0
      IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 250
      IF (IDABS .LT. 90) GOTO 250
      IDIF = 180
      EL = E2
      GOTO 250
  200 IF (IDIF .EQ. 0) GOTO 250
      IF (W1 .LT. 0.1) GOTO 210
      IF (WS .LT. W1) IDIF = IDIF*WS/W1 + 0.5
  210 COSD = COS(IDIF/57.29) * (E2-E1)
      EL = 0.5 * ABS(COSD - SQRT(COSD**2+4.*E1*E2))
      GOTO 250
  220 IF (IT .NE. 1) GOTO 240
      IF (IDABS .LT. IREST) GOTO 230
      IDIF = ISIGN (IREST,IDIF)
      EEE = ABS (EEE * COS((IDABS-IREST)/57.29))
      WS = TANH (EEE/E000R)**2
      IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 240
      EL = SQRT (E1*E2)
      GOTO 250
  230 IF (IDIF .EQ. 0) GOTO 260
      IF (WS .LT. W1) GOTO 240
      COSD = COS (IDIF/57.29) * (E2+E1)
      EL = 0.5 * ABS (COSD - SQRT(COSD**2-4.*E1*E2))
      GOTO 250
  240 IDIF = 0
  250 IPHS = IP1 + IDIF
      IF (IPHS .GE. 360) IPHS = IPHS - 360
      IF (IPHS .LT. 0)   IPHS = IPHS + 360
  260 CONTINUE
      RETURN
      END
      SUBROUTINE LOCCEN (KEY, CENTER)
      DIMENSION CENTER(3)
      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, EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (LIS1,   IFILE(7))
      EQUIVALENCE (LIS2,   IFILE(8))
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      PARAMETER (NSLOT = 10, MAXAT = 993)
      COMMON /LOCPC1/
     *          ATXYZ(NSLOT, MAXAT), IZAT(MAXAT),
     *          XY(3,400), NIZ(400), NDEL(400), SYMXYZ(3),
     *          DLIM(6), CEN2(3)
      COMMON /LOCPC2/
     *          ATNAME
      CHARACTER *6 ATNAME(MAXAT)
      IF (KEY .GT. 0) RETURN
      IF (IICENT .EQ. 2) RETURN
      NSLOC = NSYMM
      IF (EXPAND) NSLOC = 1
      IF (NSLOC .NE. NSYMM) THEN
         WRITE (LIS2, 200)
  200    FORMAT (/' Search for LOCCEN in triclinic symmetry:' /
     *       ' Results correct only after execution of program EXPAND')
      ELSE
         WRITE (LIS2, 210)
  210    FORMAT ('0Search for LOCCEN (symm.center in model struct.?))')
         ENDIF
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('No ATOMS file found', 0, 'LOCCEN')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL FILCLO (IATOMS, 'KEEP')
      N = NAT * NSLOC * NLATT
      IF (N .LE. 400) GOTO 260
      WRITE (LIS1, 240) N
      WRITE (LIS2, 240) N
  240 FORMAT (' No search for LOCCEN: too many atoms in the unit cell'/
     *        ' Allowed: maximum 400 , input (symmetry inluded):', I5  /
     *        ' If enantiomorph problem: do supply a LOCCEN card')
      RETURN
  260 DO 270 I=1,3
      DLIM(I) = 0.20 / CELL(I)
  270 DLIM(I+3) = 1.0 - DLIM(I)
      K = 1
      DO 320 LA=1,NAT
      DO 320 LL=1,NLATT
      DO 320 LS=1,NSLOC
      DO 280  I=1,3
      XY(I,K) = TSYMM(I,LS) + TLATT(I,LL)
      DO 280  J=1,3
  280 XY(I,K) = XY(I,K) + ATXYZ(J,LA)*IRSYMM(I,J,LS)
      DO 310  I=1,3
  290 IF (XY(I,K) .GT. 0.5) GOTO 300
      IF (XY(I,K) .GT. -.5) GOTO 310
      XY(I,K) = XY(I,K) + 1.0
      GOTO 290
  300 XY(I,K) = XY(I,K) - 1.0
      GOTO 290
  310 CONTINUE
      NIZ(K) = IZAT(LA)
  320 K = K + 1
      DO 410 L=1,N
      IF (IABS(NIZ(1)-NIZ(L)) .GT. 2) GOTO 410
      DO 340 I=1,3
      CEN2(I) = XY(I,1) + XY(I,L)
      IF (CEN2(I) .GT. 0.7) CEN2(I) = CEN2(I) - 1.0
      IF (CEN2(I) .LE. -.3) CEN2(I) = CEN2(I) + 1.0
  340 CENTER(I) = CEN2(I)
      J = 2
      CALL KERNZI (0, NDEL, N)
      NDEL(1) = 1
      NDEL(L) = 1
      DO 390 LC=1,N
      IF (NDEL(LC) .EQ. 1) GOTO 390
      DO 350 I=1,3
  350 SYMXYZ(I) = CEN2(I) - XY(I,LC)
      DO 380 LR=1,N
      IF (NDEL(LR) .EQ. 1) GOTO 380
      IF (IABS(NIZ(LR)-NIZ(LC)) .GT. 2) GOTO 380
      DO 360 I=1,3
      DIST = ABS(SYMXYZ(I) - XY(I,LR))
      IF (DIST.GT.DLIM(I) .AND. DIST.LT.DLIM(I+3)) GOTO 380
  360 CONTINUE
      J = J + 2
      DO 370 I = 1,3
      DIST = XY(I,LC) + XY(I,LR)
      IF (DIST-CEN2(I) .LT. -.1) DIST = DIST + 1.0
      IF (DIST-CEN2(I) .GT. 0.1) DIST = DIST - 1.0
  370 CENTER(I) = CENTER(I) + DIST
      NDEL(LC) = 1
      NDEL(LR) = 1
      GOTO 390
  380 CONTINUE
      GOTO 410
  390 CONTINUE
      DO 400 I=1,3
  400 CENTER(I) = CENTER(I) / J
      GOTO 430
  410 CONTINUE
      WRITE (LIS2, 420)
  420 FORMAT (' No center of symmetry found')
      RETURN
  430 WRITE (LIS1, 440) (CENTER(I), I=1,3)
  440 FORMAT (' Center of symmetry found at ', 3F7.4)
      KEY = 1
      RETURN
      END
      SUBROUTINE LINPRX (KEY, LITOUT, LOUT, NIT)
      CHARACTER LITOUT *(*)
      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
      CHARACTER PRFORM *72
      PARAMETER (MAXLIN = 20, MAXCHA = 100)
      CHARACTER LITLIN(MAXLIN) *100
      DATA LITNIT, NITMAX, IPR / 0, 0, 0/
      IF (KEY) 230, 220, 200
  200 IPR = KEY
      PRFORM = CHOUT
      CHOUT = ' '
      NITMAX = NIT
      IF (NITMAX .GT. MAXLIN) CALL KERNER (4, 'LINPRX')
      IF (LOUT .GT. MAXCHA) CALL KERNER (4, 'LINPRX')
  210 CALL KERNZ1 (' ', LITLIN, NIT)
      LITNIT = 0
      RETURN
  220 IF (LITNIT+1 .GT. NITMAX) THEN
          WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT)
          CALL KERNZ1 (' ', LITLIN, NITMAX)
          LITNIT = 0
      ENDIF
      LITNIT = LITNIT + 1
      LITLIN(LITNIT) = LITOUT
      RETURN
  230 IF (LITNIT .GT. 0)
     *    WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT)
      GOTO 210
      END
      SUBROUTINE DACOP
      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
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ5 = 10000)
      INTEGER *2 ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLADC / CHAR(12)
      CHARACTER CHARR(12) *1, CHAR *1
      DATA CHARR / 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
     *             '-', ' '/
      DO 110 I=1,5*ISIZ5
  110 ITAB5(I) = 0
      INCA5 = 5
      DO 120 I=1,12
  120 CHAR(I) = CHARR(I)
      II = (MAXA4-ISTO4) / 50
      I = MS
      IF (IDC.EQ.1 .AND. I.GT.200) I = 100 + I/2
      MAXA4N = MARKA4 + I*INCA4
      I5 = I / 2
      I5 = MIN0(I5,II,MAXT) + 14
      MAXT = MIN0(I5,MAXT)
      IF (MS .LT. 500) I5 = 500 - MS
      MAXA4 = MAXA4N +  I5 * INCA4
      WRITE (LIS2, FMT='('' Limitations:'')')
      IF (IDC .EQ. 1) WRITE (LIS2, 140) I
  140 FORMAT (' New basic set with numeric phases: ', I5)
      WRITE (LIS2, 150) I5, II
  150 FORMAT (' in basic set with symbolic phases: ', I5/
     *        ' maximum number of symbolic phases: ', I5)
      RETURN
      END
      SUBROUTINE DAMAIN
      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
      EQUIVALENCE (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      DIMENSION KPGE(8), KPG(8)
      JSYMB = 0
      JOLD  = 0
      JSMAX = 10
      IF (IPSQ .EQ. 1) JSMAX = 15
      DO 210 K=MCT,NCT,ICR
      IF (ITAB(K+2) .GE. 0) GOTO 200
      ITAB(K+4) = -(1000.*ITAB(K+2)) / ITAB(K+7)
      GOTO 210
  200 WNE = ITAB(K+4)
      ITAB(K+4) = SQRT(WNE) * (ITAB(K+7)-ITAB(K+2))
  210 CONTINUE
      ISTA4 = ISTO4 + INCA4
      ISTO5 = 0
      WRITE (LIS2, 220)
  220 FORMAT (' Ambiguity choices', /, 5X, 'H   K   L    E1  Symbol')
      DO 270 KK=1,2
  230 CALL KERNZI (0, KPGE(1), 8)
      CALL KERNZI (0,  KPG(1), 8)
      KTEST = 0
      DO 240 K=MCT,NCT,ICR
      IF (IPSQ.EQ.1 .AND. IICENT.EQ.1 .AND. ITAB(K+5).NE.-1) GOTO 240
      IF (ITAB(K+2).LT.0 .OR. ITAB(K+6).LT.0) GOTO 240
      IF (IPSQ.EQ.0 .AND. ITAB(K+2).GT.2 .AND. KK.EQ.2) GOTO 240
      IPG = ITAB(K+6)
      IF (IPG2(IPG).LT.0 .AND. KK.EQ.1) GOTO 240
      IF (ITAB(K+4) .LE. KPGE(IPG)) GOTO 240
      KPGE(IPG) = ITAB(K+4)
      KPG(IPG)  = K
      KTEST = KTEST + 1
  240 CONTINUE
      DO 250 IPG=1,8
      IF (KPG(IPG) .LE. 0) GOTO 250
      K = KPG(IPG)
      IF (IICENT.EQ.2 .OR. ITAB(K+5).EQ.-1) CALL DACAS (K)
      IF (ITAB(K+7) .GT. 0) ITAB(K+6) = -1
      IF (JSYMB .EQ. JSMAX) GOTO 280
  250 CONTINUE
      IF (JOLD .EQ. JSYMB) GOTO 260
      JOLD = JSYMB
      GOTO 230
  260 IF (JSYMB .GT. 0) GOTO 280
      IF (KTEST.EQ.0 .AND. KK.EQ.2) GOTO 275
  270 CONTINUE
  275 IF (JSYMB .EQ. 0) GOTO 300
  280 IF (JSYMB .GT. 10) JSYMB = 10
      DO 290 K=MCT,NCT,ICR
      IF (ITAB(K+7) .GT. 0) ITAB(K+6) = 0
      IF (ITAB(K+2) .GT. 0) ITAB(K+4) = 0
  290 CONTINUE
  300 IF (JSYMB .EQ. 0) CALL KERROR ('No symbols', 0, 'DAMAIN')
      WRITE (LIS1, 310) JSYMB
      WRITE (LIS2, 310) JSYMB
  310 FORMAT (' Number of ambiguity symbolic choices (primary',
     *        ' set):', I6)
      RETURN
      END
      SUBROUTINE DACAS (K)
      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
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLADC / CHAR(12)
      CHARACTER CHAR *1
      DIMENSION IHKL(3), ISTOR(10)
      IPACK = ITAB(K+1)
      CALL XUNPAK (IPACK, IHKL)
      E1 = ITAB(K+7) / 100.
      IF (JSYMB .LT. 2) GOTO 200
      CALL GENERB (IHKL, K, ISW)
      IF (ISW .EQ. -1) RETURN
  200 IF (IPSQ .EQ. 0) GOTO 220
      EW = ITAB(K+2) / 100.
      W1 = EW / E1
      DO 210 I7=1,7
  210 ISTOR(I7) = ITAB(K+I7)
      ISTOR(4) = W1
      CALL KERNAI (IHKL, ISTOR(8), 3)
      CALL REDSYM (0, ISTOR, K)
  220 JSYMB = JSYMB + 1
      IF (JSYMB .GT .10) RETURN
      CALL IITAB4 (IHKL, K)
      ITAB(K+7) = -ITAB(K+7)
      ITAB(K+2) =  ITAB(K+7)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6)  = ISTO5 / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = JSYMB
      IF (IDC .EQ. 1) GOTO 240
      WRITE (LIS2, 230) IHKL, E1, CHAR(JSYMB)
  230 FORMAT (2X, 3I4, F7.2, 4X, A1, I8)
      RETURN
  240 WRITE (LIS2, 230) IHKL, E1, CHAR(JSYMB), ITAB(K+5)
      RETURN
      END
      SUBROUTINE GENERB (IHKL, IR1, ISW)
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLAD / ICODE(4,48), ISHIFT(48)
      DIMENSION IHKL(3), IHKL3(3)
      EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3)
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      DATA K / 0 /
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      NEQ2 = NEQ * 2
      DO 240 I42=ISTA4,ISTO4,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      J = ITAB(IR2+1)
      DO 230 I11=1,NEQ2
      IF (MCTLAT .GT. 1) GOTO 200
      I = ICODE(4,I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 230
      IF (K .GT. MCT) GOTO 230
      IF (ITAB(K) .EQ. 0) GOTO 230
  200 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 230
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 230
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 230
      IF (MCTLAT .EQ. 1) GOTO 210
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 230
      IF (ITAB(K) .EQ. 0) GOTO 230
  210 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3 .EQ. IR1) GOTO 250
      IR3 = IR3 - MCT
      DO 220 I=ISTA4,ISTO4,INCA4
      IRB = ITAB(I+4)
      IF(IR3 .EQ. IRB) GOTO 250
  220 CONTINUE
  230 CONTINUE
  240 CONTINUE
      ISW = 0
      RETURN
  250 ISW = -1
      RETURN
      END
      SUBROUTINE DCMAIN
      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, SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      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 (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINDO, IFILE(13))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      PARAMETER (MAXBUF = 198)
      DIMENSION FITDOP(9), BUFDOP(MAXBUF)
      DIMENSION IHKL(3), KARR(100)
      DIMENSION CC(25), ICC(25), IB(25)
      CHARACTER LITOUT *32
      CALL KERNZA (0., CC, 25)
      CALL KERNZI (0, ICC, 25)
      CALL GENER
      NAVG = 0
      CAVG = 0.0
      NAVG2 = 0
      CAVG2 = 0.0
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      DO 240 K=MCT,NCT,ICR
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 250
      E1     = FITDOP(4)
      W1     = FITDOP(7)
      IT     = FITDOP(8)
      PHREST = FITDOP(9)
      AEE = ITAB(K+4)
      BEE = ITAB(K+5)
      SEE = ITAB(K+6)
      ITAB(K+4) = W1 * 1000.
      ITAB(K+5) = 0
      ITAB(K+6) = 0
      IF (IT .GT. 1) GOTO 230
      IF (PHREST.LT.150. .OR. E1.GT.3.999) GOTO 240
      IF (W1 .LT. 0.16) GOTO 200
      IP1 = ITAB(K+3)
      IP1 = MOD(IP1,180)
      CALL PHDIF (IP1, 90, IDIF, IDABS)
      IF (IDABS .GT. 45) GOTO 200
      ITAB(K+4) = ITAB(K+4) + 1000
      GOTO 240
  200 EEE = SQRT(AEE*AEE+BEE*BEE)
      IF (EEE .LT. 1.) EEE = 1.
      QEE = SEE / EEE
      IF (QEE .GT. 5.) QEE = 5.
      C = QEE * E1 * (SEE-EEE)/10.
      NAVG = NAVG + 1
      IF (C .GT. 32767.) C = 32767.
      CAVG = CAVG + C
      IF (C .LT. 1.) GOTO 240
      ITAB(K+5) = C + 0.5
      IF (W1 .GT. 0.9) GOTO 240
      NAVG2 = NAVG2 + 1
      CAVG2 = CAVG2 + C
      C = C * E1
      IF (C .LE. CC(25)) GOTO 240
      II = 25
  210 JJ = II - 1
      IF (C .LE. CC(JJ)) GOTO 220
      CC(II)  = CC(JJ)
      ICC(II) = ICC(JJ)
      II = JJ
      IF (II .GT. 1) GOTO 210
  220 CC(II)  = C
      ICC(II) = K
      GOTO 240
  230 ITAB(K+5) = -IT
  240 CONTINUE
  250 CONTINUE
      CAVG = CAVG / NAVG
      IF (NAVG2 .GT. 0) CAVG2 = CAVG2 / NAVG2
      WRITE (LIS2, 260) CAVG, NAVG, CAVG2, NAVG2
  260 FORMAT(' The averaged value of the enantiomorph discriminator',
     *       ' (C): ', F7.2,/,3X, '(calculated on', I5, ' reflections)',
     *  /,   '                                                     ',
     *       ' (C): ', F7.2,/,3X, '(calculated on', I5,
     * ' unphased reflections)')
      NAVG = CAVG/2.0 + 0.5
      NAVG2 = CAVG2/2.0 + 0.5
      IF (NAVG2 .GT. 0) GOTO 280
      NAVG = 0
      WRITE (LIS2, 270)
  270 FORMAT ('0=== C-formula not valid === use: E1/W1**2 ===')
      IDC3 = 3
  280 NREFM = (NCT-MCT) / ICR / 5
      NREFM = MIN0(NREFM,80)
      NREFMA = (MAXA4N - MARKA4) / INCA4
      IW = 990
      IESTR = 80
      NN = 0
      NN2 = 0
      DO 290 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 290
      IF (ITAB(K+4) .GE. 990) NN2 = NN2 + 1
      NN = NN + 1
  290 CONTINUE
      IF (NN2 .GT. NREFMA) GOTO 310
      IF (NN2 .GE. NREFM)  GOTO 330
      IW = 500
      IF (NN .LE. NREFM) GOTO 330
      CALL VALDIS (-1, 500., 1000., KARR, 100, NUMA4)
      DO 300 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 300
      W1 = ITAB(K+4)
      CALL VALDIS (0, W1, 0., KARR, 100, NUMA4)
  300 CONTINUE
      CALL VALDIS (NREFM, W1, 0., KARR, 100, NUMA4)
      IW = W1 + .5
      GOTO 330
  310 CALL VALDIS (-1, 80., 400., KARR, 100, NUMA4)
      DO 320 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.990 .OR. ITAB(K+5).GT.NAVG) GOTO 320
      E1 = ITAB(K+7)
      CALL VALDIS (0, E1, 0., KARR, 100, NUMA4)
  320 CONTINUE
      CALL VALDIS (NREFMA, E1, 0., KARR, 100, NUMA4)
      IESTR = E1 + .5
  330 W1 = FLOAT(IW) / 1000.
      E1 = FLOAT(IESTR) / 100.
      WRITE (LIS2, 340) W1, E1
  340 FORMAT ('0Select new basic set, W1min = ', F6.3, ' E1min = ',F5.2)
      IF (SWIPRI) THEN
         WRITE (LIS2, 350)
  350    FORMAT ('0New basic set reflections with numeric phases', /
     *            ' ', 4 ('  H  K  L  E1   P1   W1    C    '), /)
         CHOUT = '(4A32)'
         CALL LINPRX (LIS2, LITOUT, 32, 4)
         ENDIF
      ISTO4 = MARKA4
      DO 360 K=MCT,NCT,ICR
      IF (ITAB(K+7).LT.IESTR .OR. ITAB(K+4).LT.IW
     *                       .OR. ITAB(K+5).GT.NAVG) GOTO 360
      IF (ISTO4 .GE. MAXA4N) GOTO 370
      IP = ITAB(K+1)
      CALL XUNPAK (IP, IHKL)
      CALL IITAB4 (IHKL, K)
      ITAB(K+2) = -ITAB(K+2)
      IF (SWIPRI) THEN
         E1  = ITAB(K+7) / 100.
         IP1 = ITAB(K+3)
         W   = ITAB(K+4) / 1000.
         IF (ITAB(K+4) .GT. 1000) W = W - 1.
         ICX = ITAB(K+5)
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, ''.'', F5.2, I4, 3X)')
     *                        IHKL, E1, IP1, W, ICX
         CALL LINPRX (0, LITOUT, 32, 4)
         ENDIF
  360 CONTINUE
  370 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4)
      NUMA4 = (ISTO4-MARKA4) / INCA4
      WRITE (LIS2, 380) NUMA4
  380 FORMAT ('0There are ', I5, ' reflections with numeric phases',
     *        ' in the new basic set')
      NIB = 25
      IF (NAVG .GT. 0) GOTO 430
      IE4 = 399
  383 CALL KERNZI (0, IB, 25)
      NIB = 0
      DO 420 K=MCT,NCT,ICR
      IF (ITAB(K+4).GT.IW .OR. ITAB(K+5).LT.0) GOTO 420
      IF (ITAB(K+7) .GT. IE4) GOTO 420
      I = ITAB(K+4)
      I = ITAB(K+7) * 100000 / MAX0(10,I)**2
      IF (I .LE. IB(25)) GOTO 420
      NIB = MIN0 (NIB +1, 25)
      JJ = 25
      DO 390 II=1,25
      IF (I-IB(II)) 390, 390, 410
  390 CONTINUE
  400 IB(JJ)  = IB(JJ-1)
      ICC(JJ) = ICC(JJ-1)
      JJ = JJ - 1
  410 IF (II .LT. JJ) GOTO 400
      IB(II)  = I
      ICC(II) = K
  420 CONTINUE
      IF (NIB .LT. 25) THEN
         WRITE (LIS2, 421) NIB
  421    FORMAT (' Only ', I3, ' enant.discr. refl. accepted:')
         IF (NIB .GT. 0) WRITE (LIS2, 422) IB(NIB)
  422    FORMAT (' the weakest having IE1 / IW1 =', I7)
         IF (NIB .GE. 15) GOTO 430
         IF (IE4 .LT. 500) THEN
            IE4 = IE4 + 200
            IW = IW * 2
            WRITE (LIS2, FMT='('' try again ... ??'')')
            GOTO 383
            ENDIF
         IF (NIB .GE. 1) GOTO 430
         CALL KERROR ('No enant.discr.refl. found', 422, 'DCMAIN')
         ENDIF
  430 DO 440 K=MCT,NCT,ICR
      IF (ITAB(K+4) .GT. 1000) ITAB(K+4) = ITAB(K+4) - 1000
  440 CONTINUE
      ISTA4 = ISTO4 + INCA4
      ISTO5 = 0
      WRITE (LIS2, 450)
  450 FORMAT ('0Enantiomorph discrimination reflections and',
     *        ' assignement of symbols', /, 5X,
     *        'H   K   L    E1  symbol    C')
      JSYMB = 0
      JSMAX = 10
      IF (IPSQ .EQ. 1) JSMAX = 15
      JSMAX = MIN0 (NIB, JSMAX)
      DO 460 I=1,NIB
      IF (JSYMB .EQ. JSMAX) GOTO 470
      K = ICC(I)
      CALL DACAS (K)
  460 CONTINUE
  470 WRITE (LIS1, 480) JSYMB
      WRITE (LIS2, 480) JSYMB
  480 FORMAT (' Number of ambiguity symbolic choices (primary',
     *        ' set):', I6)
      RETURN
      END
      SUBROUTINE DACEND
      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
      EQUIVALENCE (IRD,  IFILE(5))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      DIMENSION NLET(10), ISOL(10,2)
      CALL KETIME (LIS2)
      FAKWS = 1.
      REDUS = .FALSE.
      IF (IPSQ.EQ.1 .AND. JSYMB.GT.3) REDUS = .TRUE.
  200 ISTA42 = ISTA4
      CALL GENERC
      CALL REAR
      CALL KERNZI (0, NLET, 10)
      CALL KERNZI (1, NLET, JSYMB)
      CALL TACCEP (NLET, NTEMP)
      IF (NTEMP .LE. 0) GOTO 211
      CALL KETIME (LIS2)
      IF (REDUS) THEN
         KRED = 0
         CALL REDSYM (1, NLET, KRED)
         IF (KRED .EQ. 1) REDUS = .FALSE.
         GOTO 200
         ENDIF
      CALL REAR2
      CALL GENERC
      CALL REAR
  211 CALL SYMREL (ISOL)
      IF (IPSQ .EQ. 0) GOTO 320
      KBEST = ISOL(1,2)
      DO 260 J=1,JSYMB
      ISOL(J,1) = KB10X(J,KBEST)
  260 ISOL(J,2) = 0
  320 ILINK = 0
      CALL XXLINK (ISOL, ILINK)
      CALL KETIME (LIS2)
      RETURN
      END
      SUBROUTINE REDSYM (KEY, ISTOR, K)
      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
      EQUIVALENCE (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLADC / CHAR(12)
      CHARACTER CHAR *1
      DIMENSION ISTOR(10), ISTOR1(11,15), IHKL(3)
      LOGICAL   FIRST
      DATA FIRST / .FALSE. /
      DATA NSYMB, KTEST, ISMAX / 0, 0, 0 /
      IF (FIRST) GOTO 200
      ISMAX = 1
      KTEST = 0
      NSYMB = 0
      FIRST = .TRUE.
  200 IF (KEY .EQ. 1) GOTO 210
      NSYMB = NSYMB + 1
      CALL KERNAI (ISTOR(1), ISTOR1(1,NSYMB), 10)
      ISTOR1(11,NSYMB) = K
      RETURN
  210 CONTINUE
      WRITE (LIS2, FMT='('' Reduced ambiguity choices'', //,
     *       5X, ''H   K   L    E1  Symbol'')')
      KTEST = KTEST + 1
      MSYMB = 0
      ISTO4 = ISTA4 - INCA4
      ISTO5 = 0
      DO 250 I=MCT,NCT,ICR
  250 ITAB(I+6) = 0
      DO 270 I=1,JSYMB
      K = ISTOR1(11,I)
      IF (ISTOR(I) .LE. ISMAX) THEN
          ITAB(K+2) = ISTOR1(2,I)
          ITAB(K+3) = ISTOR1(3,I)
          ITAB(K+4) = ISTOR1(4,I)
          IF (ITAB(K+2) .GE. 0) ITAB(K+4) = 0
          ITAB(K+7) = ISTOR1(7,I)
          ISTOR1(11,I) = -1
          GOTO 270
      ENDIF
      MSYMB = MSYMB + 1
      CALL KERNAI (ISTOR1(8,I), IHKL, 3)
      CALL IITAB4 (IHKL,K)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6) = (ISTO5) / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = MSYMB
      E1 = FLOAT(ISTOR1(7,I)) / 100.
      WRITE (LIS2, 260) IHKL, E1, CHAR(MSYMB)
  260 FORMAT (2X, 3I4, F7.2, 4X, A1)
  270 CONTINUE
      K = 1
      IF (NSYMB .LE. JSYMB) GOTO 350
      DO 280 I=JSYMB+1,NSYMB
      K = ISTOR1(11,I)
      MSYMB = MSYMB + 1
      CALL KERNAI (ISTOR1(8,I), IHKL, 3)
      CALL IITAB4 (IHKL, K)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ITAB(K+7) = -ITAB(K+7)
      ITAB(K+2) =  ITAB(K+7)
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6) = ISTO5 / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = MSYMB
      E1 = FLOAT(ISTOR1(7,I)) / 100.
      WRITE (LIS2, 260) IHKL, E1, CHAR(MSYMB)
  280 IF (MSYMB .EQ. JSYMB) GOTO 290
  290 K = 0
      I = 0
  310 I = I + 1
  320 IF (ISTOR1(11,I) .GT. 0) GOTO 340
      NSYMB = NSYMB - 1
      DO 330 J=I,NSYMB
  330 CALL KERNAI (ISTOR1(1,J+1), ISTOR1(1,J), 11)
      GOTO 320
  340 IF (I .LE. JSYMB) GOTO 310
  350 JSYMB = MSYMB
      DO 360 I=ISTO4+INCA4+1,ISIZ
  360 ITAB(I) = 0
      DO 370 I=ISTO5+INCA5+1,5*ISIZ5
  370 ITAB5(I) = 0
      WRITE (LIS1, 380) JSYMB
      WRITE (LIS2, 380) JSYMB
  380 FORMAT (' Number of ambiguity symb. choices (reduced sec.',
     *         'set):', I5)
      IF (KTEST .EQ. 2) K = 1
      RETURN
      END
      SUBROUTINE SYMREL (ISOL)
      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
      EQUIVALENCE (IRD,  IFILE(5))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLAD / ICODE(4,48), ISHIFT(48)
      COMMON / KLADC/ CHAR(12)
      CHARACTER CHAR *1
      DIMENSION I2XI(2,10), IXI(10), ISOL(10,2), IXXI(40)
      EQUIVALENCE (IXXI(11), IXI(1)), (IXXI(21), I2XI(1,1))
      DIMENSION KSY(10), KA(1023), KAA(1024), KAAA(1025)
      EQUIVALENCE (KA(1), KAA(2), KAAA(3))
      DIMENSION KBB(110), LET1(4)
      DATA KBMAX1, KBMAX2 / 0, 0 /
      WRITE (LIS1, 200)
      WRITE (LIS2, 200)
  200 FORMAT (/' Analysis of the symbolic phases  A, B, ....')
      FAK = 2. / E000R
      CALL KERNZI (0,   IXXI,  40)
      CALL KERNZI (0,  KB10X, 15*25)
      CALL KERNZI (0, KB10XX, 15*25)
      IC123 = 0
      KAAA(1) = JSYMB
      KMAX = 2**JSYMB
      KSY(1) = KMAX / 2
      DO 210 I=2,JSYMB
  210 KSY(I) = KSY(I-1) / 2
      CALL KERNZI (0, KAA, KMAX)
      CALL KERNZI (0, KBB, 110)
      DO 370 K=MCT,NCT,ICR
      K51 = ITAB(K+6)
      IF (K51 .EQ. 0) GOTO 370
      IF (IDC .GT. 1) GOTO 220
      ITIP = ITAB(K+5)
      IF (ITIP.GE.0 .OR. ITAB(K+2).LT.0) GOTO 220
      IF (ITIP.GT.-4 .OR. ITIP.LT.-8) GOTO 370
  220 I51 = K51*INCA5
      IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 320
      GOTO 240
  230 K51 = IITAB5(I51,I51)
  240 IF (IITAB5(I51,I52) .EQ. 0) GOTO 370
      IF (ITAB5(I51+1) .NE. 32767) THEN
          IE1 = ALPS(I51)
          IF (IE1 .LE. 0) GOTO 230
          IP1 = ITAB5(I51+2)
          ELSE
          IP1 = ITAB(K+3)
          IE1 = 32767 * FAK
      ENDIF
      ICOL1 = ITAB5(I51+5)
      CALL DECOL2 (ICOL1, LET1)
      IC1 = IABS(LET1(1))
      IC3 = IABS(LET1(2))
      IADR1 = KSY(IC1)
      IF (IC1 .EQ. IC3) GOTO 230
      IF (IC3.NE.0 .AND. IDC.EQ.1) GOTO 230
      IF (IC3 .GT. 0) IADR1 = IADR1 + KSY(IC3)
      IF (IC3 .NE. 0) GOTO 280
      IP2 = ITAB(K+3)
      CALL PHDIF (IP2, IP1, IP12, IP2)
      I = MIN0(IP2,180-IP2)
      IF (I .LT. 5) GOTO 280
      I = ISIGN(I,IP12)
      Q = ITAB(K+2)
      IF (Q .LT. 2.5) GOTO 280
      I = FLOAT(I * IE1) * SQRT(Q) /100.
      IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * I
      GOTO 280
  270 IF (IITAB5(I52,I52) .EQ. 0) GOTO 230
  280 IE2 = ALPS(I52)
      IE2 = IALP(IE1,IE2)
      IF (IE2 .LE. 0) GOTO 270
      IP2 = ITAB5(I52+2)
      ICOL2 = ITAB5(I52+5)
      CALL DECOL2 (ICOL2, LET1)
      IC2 = IABS(LET1(1))
      IC4 = IABS(LET1(2))
      IADR2 = KSY(IC2)
      IF (IC3.NE.0 .AND. IC4.NE.0) GOTO 270
      IF (IC4 .GT. 0) IADR2 = IADR2 + KSY(IC4)
      IF (IC2 .EQ. IC4) GOTO 270
      CALL PHDIF (IP1, IP2, IP12, IP2)
      IE2 = IE2 * (90-IP2)
      IF (ICOL1+ICOL2 .EQ. 0) GOTO 310
      IADR = IADR1 + IADR2
      IF (IC3.EQ.0 .AND. IC4.EQ.0) GOTO 300
      IC123 = IC123 + 1
      IF (IC4 .EQ. 0) GOTO 290
      IF (IC2.EQ.IC1 .OR. IC4.EQ.IC1) IADR = IADR - 2*KSY(IC1)
      GOTO 300
  290 IF (IC1.EQ.IC2 .OR. IC3.EQ.IC2) IADR = IADR - 2*KSY(IC2)
  300 KA(IADR) = KA(IADR) + IE2
      IF (IDC .EQ. 4) GOTO 270
      IF (IC3.NE.0 .OR. IC4.NE.0) GOTO 270
      IF (ICOL1*ICOL2 .LT. 0) IE2 = -IE2
      I = 10*IC1 + IC2
      KBB(I) = KBB(I) + IE2
      GOTO 270
  310 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2)
      I2XI(1,IC1) = I2XI(1,IC1) + IE2
      GOTO 270
  320 IP1 = ITAB(K+3)
      GOTO 340
  330 IF (IITAB5(I51,I51) .EQ. 0) GOTO 370
  340 IP2 = ITAB5(I51+2)
      ICOL1 = ITAB5(I51+5)
      IC1 = IABS(ICOL1)
      EI2 = ALPS(I51) * 0.25
      IF (EI2 .LT. 0.) GOTO 330
      CALL PHDIF (IP1, IP2, IP12, IP2)
      IE2 = EI2 * (90.-FLOAT(IP2))
      IF (IC1 .GT. 10) GOTO 350
      IXI(IC1) = IXI(IC1) + IE2
      I = MIN0(IP2,180-IP2)
      IF (I .LT. 5) GOTO 330
      Q = ISIGN(I,IP12)
      IE2 = EI2 * Q
      IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * IE2
      GOTO 330
  350 CALL DECOL2 (ICOL1, LET1)
      IC1 = IABS(LET1(1))
      IC2 = IABS(LET1(2))
      IF (LET1(1) .EQ. LET1(2)) GOTO 360
      IADR = KSY(IC1) + KSY(IC2)
      KA(IADR) = KA(IADR) + IE2
      IF (IDC .EQ. 4) GOTO 330
      IF (LET1(1)* LET1(2).GT.0) IE2 = -IE2
      I = 10*IC1 + IC2
      KBB(I) = KBB(I) + IE2
      GOTO 330
  360 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2)
      I2XI(1,IC1) = I2XI(1,IC1) + IE2
      GOTO 330
  370 CONTINUE
      IF (IDC .EQ. 1) GOTO 400
      WRITE (LIS2, 380) IC123
  380 FORMAT (' ', I5, ' 3-letter-relations used')
      CALL SYMANA (0, IXI, KAAA, KSY, KB10X, KBMAX1)
      IF (IPSQ .EQ. 0) WRITE (LIS1, 390)
      IF (IPSQ .EQ. 0) WRITE (LIS2, 390)
  390 FORMAT (' ***** Origin fixed *****')
  400 IF (IDC .EQ. 4) GOTO 430
      CALL KERNZI (0, KAA, KMAX)
      DO 410 I=1,JSYMB
      DO 410 J=1,JSYMB
      IF (I .EQ. J) GOTO 410
      IC1 = 10*I + J
      IADR = KSY(I) + KSY(J)
      KA(IADR) = KA(IADR) + KBB(IC1)
  410 CONTINUE
      CALL SYMANA (90, IXXI, KAAA, KSY, KB10XX, KBMAX2)
      IF (IDC.EQ.2 .OR. IPSQ.EQ.0) GOTO 425
      WRITE (LIS2, 420)
  420 FORMAT (' ***** Enantiomorph fixed *****')
  425 IF (IDC .GT. 1)  ESTAR1 = ESTART(1) - 0.1
  430 IF (IPSQ .EQ. 0) GOTO 460
      KBMAX1 = MAX0 (KBMAX1, 1)
      KBMAX2 = MAX0 (KBMAX2, 1)
      KBMAX = KBMAX1 * KBMAX2
      KBMAX = MIN0 (KBMAX, 25)
      ILDUMP = 0
      CALL DAFOMS (KBMAX, E1100, NR, 0., 0., 0, ILDUMP)
      IF (IDC .NE. 1) GOTO 450
      DO 440 I=1,KBMAX2
  440 CALL KERNAI (KB10XX(1,I), KB10X(1,I), 12)
  450 CALL SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB)
      ILINK = 0
      ELDAF = 0.0
      IPHDAF = 0
      CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, ILINK)
      ILINK = MAX0 (ILINK, 1)
      ISOL(1,2) = ILINK
      DO 455 I=1,JSYMB
  455 ISOL(I,1) = KB10X(I,ILINK)
      GOTO 600
  460 DO 470 I=1,JSYMB
      IXI(I) = KB10X(I,1)
  470 IXXI(I) = KB10XX(I,1)
      IF (IDC .EQ. 1) CALL KERNAI (IXXI, IXI, 10)
      IF (IDC .EQ. 4) CALL KERNAI (IXI, IXXI, 10)
      J = IDC - 1
      DO 480 I=1,JSYMB
      IF (IXI(I).EQ.0 .AND. IXXI(I).EQ.270) IXI(I) = 360
  480 ISOL(I,1) = (IXI(I) + J * IXXI(I)) / IDC
  600 IF (IPSQ .EQ. 0) THEN
         WRITE (LIS1, 610)
         WRITE (LIS2, 610)
  610    FORMAT (' Results of the symbolic addition method for',
     *           ' the symbolic phases:')
      ELSE
         WRITE (LIS1, 620)
         WRITE (LIS2, 620)
  620    FORMAT(' Results of the PSI0 and negative quartet FOMs',
     *           ' for the symbolic phases:')
         ENDIF
      WRITE (LIS1, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB)
      WRITE (LIS2, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB)
  630 FORMAT (3X, 10(A1,'=',I3,2X))
      RETURN
      END
      SUBROUTINE SYMANA (KEY, KB, KAAA, KSY, KB10, KBMAXX)
      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
      EQUIVALENCE (LIS1, IFILE(7))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLAD /  ICODE(4,48), ISHIFT(48)
      DIMENSION KB(10), KAAA(1025), KSY(10), K10(2,200)
      DIMENSION KB10(15,25)
      DATA KADR / 0 /
      CALL KERNZI (0,    K10, 2*200)
      CALL KERNZI (0,   KB10, 15*25)
      K5 = 1
      IF (IPSQ .EQ. 1) K5 = 25
      KBMAXX = 0
      KX = 2**JSYMB + 1
      DO 200 I=1,JSYMB
      IADR = KSY(I) + 2
  200 KAAA(IADR) = KAAA(IADR) + KB(I)/10
      K = 0
      DO 210 I=2,KX
  210 K = K + IABS(KAAA(I))
      IF (K .GT. 0) GOTO 230
      WRITE (LIS1, 220)
  220 FORMAT ('0***** ERROR: no symbol relations; rerun PHASEX', /,
     *        ' *****        with lower E-min values   *********' /)
      GOTO 250
  230 Q = 32001. / FLOAT(K)
      DO 240 I=2,KX
  240 KAAA(I) = FLOAT(KAAA(I)) * Q
      CALL SYMAN (KAAA)
  250 KMAX = -32100
      DO 260 J=2,KX
      IF (KAAA(J) .LT. KMAX) GOTO 260
      KMAX = KAAA(J)
      KADR = J
  260 CONTINUE
      MAXR = KMAX * 100 / 32000
      MAXADR = KADR - 2
      KMIN = MIN0 (KMAX, 22400) * 7 / 10
      KBMAX1 = 1
      IF (IPSQ .EQ. 0) THEN
          K10(1,1) = KMAX
          K10(2,1) = KADR
          GOTO 305
      ENDIF
      DO 300 I=2,KX
      IF (KAAA(I) .LE. KMIN) GOTO 300
      DO 270 J=1,KBMAX1
      IF (KAAA(I) .LE. K10(1,J)) GOTO 270
      JJ = J
      GOTO 280
  270 CONTINUE
      GOTO 300
  280 DO 290 K=KBMAX1,JJ+1,-1
      K10(1,K) = K10(1,K-1)
  290 K10(2,K) = K10(2,K-1)
      K10(1,JJ) = KAAA(I)
      K10(2,JJ) = I
      KBMAX1 = KBMAX1 + 1
      IF (KBMAX1 .GT. 200) KBMAX1 = 200
  300 CONTINUE
      IF (KBMAX1 .NE. 200) KBMAX1 = KBMAX1 - 1
  305 DO 360 J=1,KBMAX1
      KADR = K10(2,J)
      MAXADR = KADR - 2
      K = K10(1,J)
      MAXR = K * 100 / 3200
      DO 320 I=1,JSYMB
      JJ = MAXADR / KSY(I)
      IF (JJ .EQ. 0) GOTO 310
      KB(I) = KEY + 180
      MAXADR = MAXADR - KSY(I)
      GOTO 320
  310 KB(I) = KEY
  320 CONTINUE
      JLINK = -J
      IF (IPSQ .EQ. 0) THEN
         JLINK = J
      ELSE
         CALL PHCOM1 (KB, JLINK)
         ENDIF
      IF (JLINK .EQ. J) THEN
         KBMAXX = KBMAXX + 1
         CALL KERNAI (KB, KB10(1,KBMAXX), 10)
         KB10(11,KBMAXX) = J
         KB10(12,KBMAXX) = MAXR
         IF (KBMAXX .EQ. K5) RETURN
         ENDIF
  360 CONTINUE
      RETURN
      END
      SUBROUTINE XXLINK (ISOL, ILINK)
      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
      LOGICAL        SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      EQUIVALENCE (LIS1,   IFILE(7)),  (LIS2,   IFILE(8))
      EQUIVALENCE (IBINDO, IFILE(13))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      PARAMETER (MAXBUF = 198)
      DIMENSION FITDOP(9), BUFDOP(MAXBUF)
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DIMENSION IHKL(3), ISOL(10,2)
      COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      DIMENSION ITYP(4)
      CHARACTER LETT(4) *2, LITOUT *25
      DATA LETT  / '. ', 'S ', '* ', '*S' /
      DATA NLINPR / 0 /
      EEESUM = 0.
      ABSUM = 0.
      AB1SUM = 0.
      CALL KERNZI (0, ITYP, 4)
      NUMK = 0
      MAXA4 = ISIZ
      ESTAR1 = ESTART(1) + 0.1
      ISTO4 = MARKA4
      IF (ILINK.EQ.0 .AND. MS.LT.700) MAXA4 = MAXA4 + (700-MS)*INCA4
      ISW = 0
      IF (ILINK .NE. 0) ISW = 1
      EB = 100. * E000R
      ISL = 0
      IF (SWIPRI) ISL = 1
      SWIPRI = .FALSE.
      NITDOP = 9
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (ISL .EQ. 1) SWIPRI = .TRUE.
      IF (.NOT.SWIPRI .OR. ILINK.NE.0) GOTO 230
      WRITE (LIS2, 200) ESTAR1
  200 FORMAT (' Results from DIRDIF.Special (end of PHASEX cycle 0),',
     *        ' max. 300 refl. printed' /
     *        '0* = accepted for basic set:  W1.gt.0.16, EL.gt.', F4.2)
      IF (IDC .NE. 4) WRITE (LIS2, 210)
  210 FORMAT (' S = special reflection (two possible phase values)')
      WRITE (LIS2, 220)
  220 FORMAT ('0', 5('  H  K  L  EL   PL   WS  ') /)
      NLINPR = 0
      CHOUT = '(5A25)'
      CALL LINPRX (LIS2, LITOUT, 25, 5)
  230 IREFL = 0
      DO 320 K=MCT,NCT,ICR
      LET = 1
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 330
      IREFL = IREFL + 1
      CALL KERF2I (FITDOP(1), IHKL(1), 3)
      E1     = FITDOP(4)
      IF (ILINK.GT.0 .AND. E1.LE.E1MIN) GOTO 320
      E2     = FITDOP(5)
      IP1    = NINT(FITDOP(6))
      W1     = FITDOP(7)
      IT     = FITDOP(8)
      IREST  = NINT(FITDOP(9))
      NUMK = NUMK + 1
      EL = E1
      WS = W1
      IF (IP1 .LE. 0) IP1 = IP1 + 360
      IPHS = IP1
      K51 = ITAB(K+6)
      KEY = 1
      IF (K51 .EQ. 0) GOTO 280
      LIBS = 0
      KEY = 2
      AEE = 0.0
      BEE = 0.0
      I51 = K51*INCA5
      GOTO 245
  240 I51 = K51*INCA5 + I51
  245 IP  = ITAB5(I51+2)
      EEE = ITAB5(I51+1)
      IF (EEE .LT. 32766.) GOTO 250
      EEE = EB
      IP = ITAB(K+3)
  250 ICOL = ITAB5(I51+5)
      I = IABS(ICOL)
      IF (I .GT. JSYMB) GOTO 260
      KEY = 3
      IP = IP + ISIGN(ISOL(I,1),ICOL)
      IP = MOD(IP,360)
      IF (IP .LE. 0) IP = IP + 360
      AEE = AEE + EEE*ISCT(450-IP)/1000.
      BEE = BEE + EEE*ISCT(IP)/1000.
      EEESUM = EEESUM + EEE
      LIBS = LIBS + 1
  260 K51 = ITAB5(I51+4)
      IF (K51 .NE. 0) GOTO 240
      IF (LIBS .EQ. 0) GOTO 280
      ITYP(4) = ITYP(4) + LIBS
      EEE = SQRT(AEE*AEE + BEE*BEE)
      ABSUM = ABSUM + EEE
      WW = W1 / 1000.
      IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 270
      IF (IT .NE. 1) GOTO 270
      WW = WW*2. / IDC3**2
  270 AEE = (AEE + EEE*ISCT(450-IP1)*WW)/10.
      BEE = (BEE + EEE*ISCT(IP1)*WW)/10.
      EEE = SQRT(AEE*AEE + BEE*BEE)
      IF (EEE .LT. 0.001) AEE = 0.1
      PHS = ATAN2(BEE,AEE) * 57.2958
      IF (PHS .LT. 0.) PHS = PHS + 360.
      IPHS = PHS + 0.5
      WS = TANH(EEE/E000R)**2
      CALL EPW
      AB1SUM = AB1SUM + EEE
      WS = AMAX1 (W1, WS)
  280 IF (IT .EQ. 1) THEN
         E2AG(7) = E2AG(7) + EL*EL
      ELSE
         E2CG(7) = E2CG(7) + EL*EL
         ENDIF
      IF (ILINK .EQ. 0) THEN
         ITAB(K+2) = 100.*EL*WS + 0.5
         ITAB(K+3) = IPHS
         ITAB(K+7) = 100.*EL + 0.5
      ELSE
         CALL PHCOM2 (IPHS, ILINK)
         ENDIF
      ITYP(KEY) = ITYP(KEY) + 1
      IF (EL.LT.ESTAR1 .OR. WS.LT.0.16) GOTO 290
      IF (ISW .EQ. 1) GOTO 290
      IF (ISTO4 .GT. MAXA4) GOTO 300
      IF (ILINK .EQ. 0) CALL IITAB4 (IHKL, K)
      LET = LET + 2
  290 ITAB1 = ITAB(K+1)
      IF (ILINK .EQ. 0) THEN
         ITAB(K+4) = 0
         ITAB(K+5) = 0
         ITAB(K+6) = 0
         IF (ITAB(K+7) .LT. 0) ITAB(K+7) = -ITAB(K+7)
      ELSE
         CALL DAFOMS (ITAB1, EL, IPHS, WS, E1, IREFL, ILINK)
         ENDIF
      IF (.NOT.SWIPRI .OR. ILINK.GT.0) GOTO 320
      IF (IT.NE.1 .AND. IDC.NE.4) LET = LET + 1
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, EL, IPHS, LETT(LET), WS
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      GOTO 320
  300 WRITE (LIS1, 310)
  310 FORMAT(' ******** WARNING: the basic set is not complete' )
      ISW = 1
      GOTO 290
  320 CONTINUE
  330 IF (SWIPRI .AND. ILINK.EQ.0) CALL LINPRX (-1, LITOUT, 25, 5)
      E2AG(7) = (E2AG(7) + E2ALE) / MAX0(1,NGN)
      E2CG(7) = (E2CG(7) + E2CLE) / MAX0(1,NSP)
      IF (EEESUM .LT. 0.0001) EEESUM = 1.
      C1EE = 10. * AB1SUM / EEESUM
      IF (ILINK .EQ. 0) GOTO 336
      ISOL(1,2) = NINT(C1EE*1000.)
      I2000 = -2000
      CALL PHCOM2 (IPHS, I2000)
      ILINK = I2000
      RETURN
  336 ITYP(3) = MAX0(1, ITYP(3))
      WW = FLOAT(ITYP(4)) / ITYP(3)
      WRITE (LIS2, 340) (ITYP(I),I=1,3), WW
  340 FORMAT ('0Number of refl. without symbolic phase: ', I11 /
     *        ' Number of refl. without single-letter phase: ', I6 /
     *        ' Number of refl. with N single-letter phases: ', I6 /
     *        ' (N = 1 or more,  average N =  ', F5.2, ' )')
      MAXA4 = ISIZ - INCA4
      MS = (ISTO4-MARKA4) / INCA4
      WRITE (LIS2, 350) MS
  350 FORMAT ('0Number of refl. in new basic set: ', I5 )
      RETURN
      END
      SUBROUTINE SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB)
      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
      EQUIVALENCE (IRD,  IFILE(5))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (LIS2, IFILE(8))
      PARAMETER (KBMAX = 25)
      DIMENSION KB10X(15,KBMAX), KB10XX(15,KBMAX), IXI(10), IXXI(10),
     *          IX(10,2), KBXX(15,KBMAX)
      COMMON /SOLCPC/ KBTEMP(12,KBMAX*KBMAX), KBORD(12,KBMAX*KBMAX)
      WRITE (LIS2, FMT='(I6, '' solutions for the symmetrical'',
     *                   '' part '')') KBMAX1
      CALL PHCOM2 (0, 0)
      ICONS2 = 0
      CALL KERNZI (0, KBXX, 15*KBMAX)
      IF (IDC.EQ.2 .OR. IDC.EQ.3) GOTO 240
      ICONS1 = KB10X (12,1)
      KBMAX1 = MAX0 (KBMAX1, KBMAX2)
      IACC = 0
      DO 230 I=1,KBMAX1
      DO 210 J=1,JSYMB
  210 IX(J,1) = KB10X(J,I)
      ILINK = I
      CALL XXLINK (IX, ILINK)
      IF (ILINK .NE. I) GOTO 230
      IACC = IACC + 1
      CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB)
      KBXX(11,IACC) = I
      CI = FLOAT(KB10X (12,I)) / FLOAT(ICONS1)
      KBXX(12,IACC) = NINT(CI * 1000.)
      KBXX(13,IACC) = IX(1,2)
      ICONS2 = MAX0 (ICONS2, IX(1,2))
  230 CONTINUE
      GOTO 330
  240 WRITE (LIS2, FMT='(I6, '' solutions for the'',
     *       '' antisymmetrical part '')')  KBMAX2
      WRITE (LIS2, FMT='(1X)')
      CALL KERNZI (0, KBTEMP, 12*KBMAX*KBMAX)
      CALL KERNZI (0, KBORD,  12*KBMAX*KBMAX)
      JDC = IDC - 1
      JALL = 0
      CONMAX = FLOAT (KB10X(12,1) + KB10XX(12,1)) / 1000.
      DO 252 I=1,KBMAX1
      CALL KERNAI (KB10X(1,I), IXI(1), JSYMB)
      DO 251 J=1,KBMAX2
      CALL KERNAI (KB10XX(1,J), IXXI(1), JSYMB)
      JALL = JALL + 1
      KBTEMP(11,JALL) = JALL
      CONS = FLOAT (KB10X(12,I) + KB10XX(12,J)) / CONMAX
      KBTEMP(12,JALL) = NINT (CONS)
      DO 250 IN=1,JSYMB
      IXI1 = IXI(IN)
      IF (IXI1.EQ.0 .AND. IXXI(IN).EQ.270) IXI1 = 360
      KBTEMP(IN,JALL) = (IXI1 + JDC*IXXI(IN)) / IDC
  250 CONTINUE
  251 CONTINUE
  252 CONTINUE
      JJ = 1
      DO 300 I=1,JALL
      IF (I .EQ. 1) GOTO 290
      DO 260 J=1,I-1
      IF (KBTEMP(12,I) .LT. KBORD(12,J)) GOTO 260
      JJ = J
      GOTO 270
  260 CONTINUE
      JJ = I
      GOTO 290
  270 DO 280 K=I,JJ+1,-1
  280 CALL KERNAI (KBORD(1,K-1), KBORD(1,K), 12)
  290 CALL KERNAI (KBTEMP(1,I), KBORD(1,JJ), 12)
  300 CONTINUE
      JSOL = 0
      IACC = 0
      DO 320 I=1,JALL
      CALL KERNAI (KBORD(1,I), IX(1,1), JSYMB)
      JSOL = JSOL + 1
      ISOL = JSOL
      CALL XXLINK (IX, ISOL)
      IF (JSOL .EQ. ISOL) THEN
         IACC = IACC + 1
         CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB)
         KBXX(11,IACC) = KBORD(11,I)
         KBXX(12,IACC) = KBORD(12,I)
         ELSE
         GOTO 320
         ENDIF
      KBXX(13,IACC) = IX(1,2)
      ICONS2 = MAX0 (ICONS2, IX(1,2))
      IF (IACC .EQ. KBMAX) GOTO 330
  320 CONTINUE
  330 CALL KERNZI (0, KB10X, 15*KBMAX)
      DO 340 I=1,IACC
      CALL KERNAI (KBXX(1,I), KB10X(1,I), 15)
      CI = FLOAT(KB10X(13,I)) / FLOAT(ICONS2)
  340 KB10X(13,I) = NINT(CI * 1000.)
      KBMAX1 = IACC
      IF (IDC.EQ.2 .OR. IDC.EQ.3) THEN
        WRITE (LIS2, FMT='(/I5, '' combined solutions'',
     *       '' (symmetrical and antisymmetrical part)'')') KBMAX1
      ELSE
         WRITE (LIS2, FMT='(1X)')
         ENDIF
      WRITE (LIS2, FMT='(5X, ''    A    B    C    D    E    F    G'',
     *                 ''    H    I    J   No CONS1 CONS2'',/,
     *                  (I3, '') '', 13I5))')
     *                  (I1, (KB10X(I13,I1), I13=1,13), I1=1,KBMAX1)
      RETURN
      END
      SUBROUTINE PHCOM1 (KB, ICOM)
      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, SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLADC / CHAR(12)
      CHARACTER CHAR *1
      PARAMETER (IACC = 25)
      DIMENSION KB(10), KLET(10), PLET(10), KACC(11,IACC), LET(4)
      LOGICAL FIRST
      DATA FIRST / .FALSE. /
      DATA JACC, PMAX / 0, 0.0 /
      IF (FIRST) GOTO 250
      FIRST = .TRUE.
      CALL KERNZI (0, KLET, JSYMB)
      NSYMB = 0
      DO 200 K=MCT,NCT,ICR
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 200
      NSYMB = NSYMB + 1
      I5 = K5 * INCA5
      GOTO 185
  180 I5 = K5*INCA5 + I5
  185 ICOL = ITAB5(I5+5)
      I = IABS(ICOL)
      IF (I .LE. JSYMB) GOTO 186
      CALL DECOL2 (I, LET)
      I = IABS(LET(1))
      KLET(I) = KLET(I) + 1
      I = IABS(LET(2))
      KLET(I) = KLET(I) + 1
      GOTO 190
  186 KLET(I) = KLET(I) + 1
  190 K5 = ITAB5(I5+4)
      IF (K5 .NE. 0) GOTO 180
  200 CONTINUE
      NSUM = 0
      DO 210 I=1,JSYMB
  210 NSUM = NSUM + KLET(I)
      PSUM = 100. / FLOAT(NSUM)
      PMAX = 0.
      DO 220 I=1,JSYMB
      PLET(I) = FLOAT(KLET(I)) * PSUM
  220 PMAX = MAX (PLET(I), PMAX)
      WRITE (LIS2, 230) NSYMB, (CHAR(I),I=1,JSYMB)
  230 FORMAT (' Symbol frequency for ', I5, ' reflections: ', /,
     *          10X, 10(4X,A1))
      WRITE (LIS2, FMT='(11X, 10I5)')   (KLET(I),I=1,JSYMB)
      WRITE (LIS2,FMT='(''   (in %) '', 1X, 10F5.1)')
     *                 (PLET(I), I=1,JSYMB)
      I = INT(PMAX)
      PMAX = FLOAT(I)
      IF (SWIPRI)
     *    WRITE (LIS2, FMT='('' Two solutions are equal, if the symbol''
     *                     ,'' changes'', /, ''    between them are'',
     *                      '' less than '', F5.1, '' %'')') PMAX
  250 IACOM = IABS(ICOM)
      IF (IACOM .EQ. 1) THEN
         CALL KERNZI (0, KACC, 11*IACC)
         JACC = 1
         ICOM = IACOM
         CALL KERNAI (KB(1), KACC(1,JACC), JSYMB)
         KACC(11, JACC) = IACOM
         RETURN
         ENDIF
      DO 280 I=1,JACC
      PSUM = 0.
      DO 260 J=1,JSYMB
      IDIF = IABS(KACC(J,I) - KB(J))
      DIF  = FLOAT (IDIF)
      MULT = MIN (1.0, DIF)
  260 PSUM = PSUM + MULT * PLET(J)
      IF (PSUM.LT.PMAX) RETURN
  280 CONTINUE
      ICOM = IACOM
      JACC = JACC + 1
      IF (JACC .GT. IACC) CALL KERROR ('Too many solutions',0, 'PHCOM1')
      CALL KERNAI (KB(1), KACC(1,JACC), JSYMB)
      KACC(11, JACC) = IACOM
      RETURN
      END
      SUBROUTINE PHCOM2 (IPHS, ILINK)
      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, EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      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)
      PARAMETER (NIPH = 1000, KBMAX = 25,
     *           MAXD1 = 10,  MAXD2 = 15)
      COMMON /PHC2PC/
     *          IPH(NIPH,KBMAX), IDIF(KBMAX), NDIF(KBMAX)
      DATA JSOL, NPH, JLINK, MAXDIF / 0, 0, 0, 0  /
      IF (ILINK .NE. 0) GOTO 200
      MAXDIF = MAXD2
      IF (ICENT.EQ.1 .OR. EXPAND) MAXDIF = MAXD1
      CALL KERNZI (0, IPH,  NIPH*KBMAX)
      CALL KERNZI (0, IDIF,      KBMAX)
      NPH  = 0
      JSOL = 1
      RETURN
  200 IF (ILINK .EQ. -2000) GOTO 220
      IF (JSOL .GT. KBMAX)
     *    CALL KERROR (' To much solutions stored', 0, 'PHCOM2')
      NPH = NPH + 1
      IF (NPH .GT. NIPH) THEN
          NPH = NIPH
          RETURN
      ENDIF
      JLINK = ILINK
      IPH(NPH,JSOL) = IPHS
      RETURN
  220 IF (JLINK .EQ. 1) GOTO 270
      DO 230 I=1,JSOL-1
      DO 230 J=1,NPH
      IPH12 = IABS (IPH(J,I) - IPH(J,JSOL))
      IF (IPH12 .GT. 180) IPH12 = 360 - IPH12
  230 IDIF(I) = IDIF(I) + IPH12
      ITEST = 0
      DO 260 I=1,JSOL-1
      MDIF = IDIF(I) / NPH
      IF (MDIF .LT. MAXDIF) ITEST = -1
      IF (ITEST .EQ. -1) GOTO 265
  260 CONTINUE
      GOTO 270
  265 ILINK = -ILINK
      ELDAF = 0.0
      IPHDAF = 0
      CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, -1)
      GOTO 280
  270 NDIF(JSOL) = JLINK
      JSOL = JSOL + 1
      ILINK = JLINK
  280 NPH = 0
      CALL KERNZI (0, IDIF, KBMAX)
      RETURN
      END
      SUBROUTINE GENERC
      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
      EQUIVALENCE (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / SINCOS / IDEG(8), ISCT
      COMMON / KLAD /   ICODE(4,48), ISHIFT(48)
      INTEGER*2 ISCT(450)
      DIMENSION IHKL(3), IHKL3(3),  LHIT(48)
      EQUIVALENCE (IHKL3(1),  JJH1), (IHKL3(2),  JJH2), (IHKL3(3),JJH3),
     *            (MAXHKL(1), MAXH), (MAXHKL(2), MAXK), (MAXHKL(3),MAXL)
      DIMENSION LET1(4), LET1R(4), LET2(4)
      DATA K, NUMB, KTEST / 0, 0, 0/
      MAXA5 = ISIZ5*INCA5 - INCA5
      IF (ISTA4 .EQ. ISTA42) NUMB = 0
      NUMBM = MAXA5 / INCA5
      IF (NUMBM .GT. ISIZ5+INCA5) NUMBM = ISIZ5 - INCA5
      ISTR1 = ISTA42
      ISTR2 = MARKA4 + INCA4
      MAX5  = MAXA5  - INCA5
      ICENTR = 2*IICENT - 3
      CALL KERNZI (0,  LET1, 4)
      CALL KERNZI (0, LET1R, 4)
      CALL KERNZI (0,  LET2, 4)
      DO 390 I41=ISTR1,ISTO4,INCA4
      DO 200 I=1,3
  200 IHKL(I) = ITAB(I41+I)
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      IR1  = ITAB(I41+4) + MCT
      IE1  = ITAB(IR1+2)
      IPH1 = ITAB(IR1+3)
      DO 210 I=1,NEQ
      IS2 = ISHIFT(I)
      ISHIFT(I) = IPH1 + IDEG(IS2)
      ISHIFT(I+NEQ) = -ISHIFT(I)
  210 CONTINUE
      K51S = ITAB(IR1+6)*INCA5 + INCA5
      ICOL1 = ITAB5(K51S)
      ICOL1R = ICENTR * ICOL1
      CALL DECOL2 (ICOL1, LET1)
      LET1R(1) = ICENTR * LET1(1)
      LET1R(2) = ICENTR * LET1(2)
      ISTOP = I41 - INCA4
      NEQ2  = NEQ * 2
      DO 380 I42=ISTR2,ISTOP,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      IF (I42 .LT. ISTA4) GOTO 220
      K52S = ITAB(IR2+6)*INCA5 + INCA5
      ICOL2 = ITAB5(K52S)
      CALL DECOL2 (ICOL2, LET2)
      CALL COLAD  (LET1,  LET2, ICOL,  IICENT)
      CALL COLAD  (LET1R, LET2, ICOLR, IICENT)
      IF (ICOL.EQ.0 .AND. ICOLR.EQ.0) GOTO 380
      GOTO 230
  220 ICOL  = ICOL1
      ICOLR = ICOL1R
  230 IPH2  = ITAB(IR2+3)
      IWEE  = IE1 * ITAB(IR2+2)
      J = ITAB(IR2+1)
      NHIT = 0
      NQQ1 = 1
      NQQ2 = NEQ
      IF (ICOL .EQ. 0) GOTO 370
  240 DO 360 I11 = NQQ1,NQQ2
      IF (MCTLAT .GT. 1) GOTO 250
      I = ICODE(4,I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 360
      IF (K .GT. MCT) GOTO 360
      IF (ITAB(K) .EQ. 0) GOTO 360
  250 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 360
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 360
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 360
      IF (MCTLAT .EQ. 1) GOTO 260
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 360
      IF (ITAB(K) .EQ. 0) GOTO 360
  260 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 360
      IF (NHIT .EQ. 0) GOTO 280
      DO 270 IHIT=1,NHIT
      IF (IR3 .EQ. LHIT(IHIT)) GOTO 360
  270 CONTINUE
  280 NHIT = NHIT + 1
      LHIT(NHIT) = IR3
      L = L + 1
      ISS  = ISIGN(1,K) * ISIGN(1,KTEST)
      IPH3 = ISS * (ISHIFT(I11)+IPH2)-IDEG(L)
      IF (ISS .EQ. 1) GOTO 290
      ICOL3 = ICENTR * ICOL
      GOTO 300
  290 ICOL3 = ICOL
  300 IPH3 = MOD(IPH3,360)
      IF (IPH3 .LE. 0) IPH3 = IPH3 + 360
      K53 = ITAB(IR3+6)
      IF (K53 .NE. 0) GOTO 310
      IF (NUMB+JSYMB .GE. NUMBM) GOTO 400
      ISTO5 = ISTO5 + INCA5
      ITAB(IR3+6) = ISTO5 / INCA5
      GOTO 340
  310 I53 = K53*INCA5
      IF (ITAB5(I53+5) .NE. ICOL3) GOTO 330
      IF (ITAB5(I53+1) .EQ. 32767) GOTO 360
      GOTO 350
  320 I53 = K53*INCA5 + I53
      IF (ITAB5(I53+5) .EQ. ICOL3) GOTO 350
  330 K53 = ITAB5(I53+4)
      IF (K53 .NE. 0) GOTO 320
      IF (ISTO5.GT.MAX5 .OR. (NUMB+JSYMB).GE.NUMBM) GOTO 400
      ISTO5 = ISTO5 + INCA5
      ITAB5(I53+4)   = (ISTO5 - I53) / 5
  340 ITAB5(ISTO5+1) = IWEE * ISCT(450-IPH3)/1000000
      ITAB5(ISTO5+2) = IWEE * ISCT(IPH3)/1000000
      ITAB5(ISTO5+3) = IWEE / 1000
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = ICOL3
      NUMB = NUMB + 1
      GOTO 360
  350 ITAB5(I53+1) = ITAB5(I53+1) + IWEE*ISCT(450-IPH3)/1000000
      ITAB5(I53+2) = ITAB5(I53+2) + IWEE*ISCT(IPH3)/1000000
      ITAB5(I53+3) = ITAB5(I53+3) + IWEE/1000
  360 CONTINUE
  370 IF (NQQ2.EQ.NEQ2 .OR. ICOLR.EQ.0) GOTO 380
      ICOL = ICOLR
      NQQ1 = NEQ+1
      NQQ2 = NEQ2
      GOTO 240
  380 CONTINUE
  390 CONTINUE
      GOTO 420
  400 WRITE (LIS2, 410) NUMB+JSYMB, NUMBM
  410 FORMAT ('0There is not enough storage (subr. GENERC):', /,
     *        ' Number of relations (', I5, ') .GE. max. number of',
     *        ' relations (', I5, ')')
      WRITE (LIS2, FMT='('' Generation is stopped at reflection : '',
     *       3I4, ''   (='', I4, ''. refl. in secondary set)'')')
     *      (ITAB(I41+I3), I3=1,3), (I41-ISTR1)/4
  420 WRITE (LIS1, 430) NUMB+JSYMB
      WRITE (LIS2, 430) NUMB+JSYMB
  430 FORMAT (' Total number of phases with symbols:', I21)
      RETURN
      END
      SUBROUTINE DECOL2 (ICOL, LET)
      DIMENSION LET(4)
      IF (IABS(ICOL) .LE. 10) GOTO 100
      LET(1) = (ICOL+220) / 21 - 10
      LET(2) = ICOL - LET(1)*21
      RETURN
  100 LET(2) = 0
      LET(1) = ICOL
      RETURN
      END
      SUBROUTINE COLAD (LET1, LET2, ICOL, ICENT)
      DIMENSION LET1(4), LET2(4)
      DATA N / 2 /
      ICOL = 0
      I1 = 1
      I2 = 1
      I = 0
  200 IF (IABS(LET1(I1)) - IABS(LET2(I2))) 210, 240, 230
  210 IF (I .EQ. N) GOTO 250
      ICOL = ICOL * 21 + LET2(I2)
      I2 = I2 + 1
  220 I = I + 1
      GOTO 200
  230 IF (I .EQ. N) GOTO 250
      ICOL = ICOL * 21 + LET1(I1)
      I1 = I1 + 1
      GOTO 220
  240 IF (LET1(I1) .EQ. 0) RETURN
      IF (ICENT.EQ.1 .AND. LET1(I1).EQ.LET2(I2)) GOTO 210
      I1 = I1 + 1
      I2 = I2 + 1
      GOTO 200
  250 ICOL = 0
      RETURN
      END
      SUBROUTINE REAR
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      FAK = 1.
      DO 260 K=MCT,NCT,ICR
      IF (ITAB(K+6) .EQ. 0) GOTO 260
      E1 = ITAB(K+7) / 100.
      IF (E1 .LT. 0.0) E1 = -E1
      J  = ITAB(K+6)*INCA5
      IMAX = J
      II = J
      IF (ITAB5(J+1) .NE. 32767) GOTO 200
      AX = 32767.
      GOTO 230
  200 AX = 0.0
  210 AEE = ITAB5(II+1)
      BEE = ITAB5(II+2)
      EEE = SQRT(AEE*AEE+BEE*BEE) * E1
      IF (EEE .LT. 0.001) AEE = 1.0
      PH3 = ATAN2(BEE,AEE)
      IEE = EEE + 1.0
      IWEE = ITAB5(II+3)*E1 + 0.5
      ITAB5(II+1) = MIN0(IEE,IWEE)
      ITAB5(II+3) = MAX0(1,IWEE)
      EEE = ALPS(II)
      IF (EEE .LE. AX) GOTO 220
      AX = EEE
      IMAX = II
  220 PH3 = PH3 * 57.2958
      IF (PH3 .LT. 0.0) PH3 = PH3 + 360.
      ITAB5(II+2) = PH3 + 0.5
  230 CONTINUE
      IJ = II
      II = ITAB5(II+4)
      IF (II .EQ. 0) GOTO 240
      II = II*INCA5 + IJ
      GOTO 210
  240 IF (J .EQ. IMAX) GOTO 260
      DO 250 I=1,5
      IF (I .EQ. 4) GOTO 250
      II = IMAX + I
      JJ = J + I
      MAX = ITAB5(II)
      ITAB5(II) = ITAB5(JJ)
      ITAB5(JJ) = MAX
  250 CONTINUE
  260 CONTINUE
      RETURN
      END
      FUNCTION ALPS (I51)
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ5 = 10000)
      INTEGER *2 ITAB5(5*ISIZ5)
      LOGICAL REDUS
      A = ITAB5(I51+1)
      B = ITAB5(I51+3)
      ALPS = (2.*A/B - 1.) * A * FAK
      RETURN
      END
      SUBROUTINE TACCEP (NLET, NTEMP)
      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, SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      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 (LIS1, IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / KLAD / ICODE(4,48), ISHIFT(48)
      COMMON / KLADC / CHAR(12)
      CHARACTER CHAR *1
      DIMENSION IHKL(3), NLET(10), ISYMB(4), LET1(4), KARR(100)
      CHARACTER LITOUT *32
      DATA AEMIN / 0.0 /
      QEETO = QEET
  111 CONTINUE
      CALL KERNZI (0, LET1, 4)
      MAXX = (MAXA4-ISTO4) / INCA4
      IF (MAXT .GT. MAXX) MAXT = MAXX
      ISTA42 = ISTO4 + INCA4
      ISW = 1
      AMIN = 0.1
      AMAX = 5.0
  200 CALL VALDIS (-1, AMIN, AMAX, KARR, 100, NTEMP)
      FAK  = 0.2 / E000R
      FAK1 = FAK / 2.
      FAKA = FAK / 100.
      IQEET = 100. * QEET
      AMINE = 1000.
      AMAXE = 0.
  210 NTEMP = 0
      IF (ISW .NE. 3) GOTO 240
      WRITE (LIS2, 220) AEMIN
  220 FORMAT (' For temporarily accepted reflections:',
     *        ' minimum  Alpha * E1 = ', F6.3)
      IF (.NOT. SWIPRI) GOTO 240
      WRITE (LIS2, 230)
  230 FORMAT ('0Temporarily accepted reflections = secondary set:' /
     *        ' ', 4('  H  K  L  E1  symb.phase  W    ') /)
      CHOUT = '(4A32)'
      CALL LINPRX (LIS2, LITOUT, 32, 4)
  240 DO 300 K=MCT,NCT,ICR
      IEW = ITAB(K+2)
      IF (IEW .LT. 0) GOTO 300
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 300
      I5 = K5*INCA5
      IEEE = ITAB5(I5+1)
      IE = ITAB(K+7)
      IF (IDC .GT. 1) GOTO 250
      ITIP = ITAB(K+5)
      IF (ITIP .GT. -1) GOTO 250
      IF (ITIP.GT.-5 .OR. ITIP.LT.-7) GOTO 300
  250 IF (IE .GT. 399) GOTO 300
      I = IQEET * ITAB5(I5+3)
      IF (I .GT. 100*IEEE) GOTO 300
      AE = IE * IEEE
      AE = AE * FAKA
      IF (ISW .GE. 2) GOTO 260
      CALL VALDIS (0, AE, 0., KARR, 100, NTEMP)
      AMINE = AMIN1 (AMINE, AE)
      AMAXE = AMAX1 (AMAXE, AE)
      GOTO 300
  260 IF (AE .LT. AEMIN) GOTO 300
      ICOL = ITAB5(I5+5)
      CALL DECOL2 (ICOL, LET1)
      LL1 = IABS(LET1(1))
      LL2 = IABS(LET1(2))
      IF (ISW .EQ. 3) GOTO 280
      NTEMP = NTEMP + 1
      NLET(LL1) = NLET(LL1) + 1
      IF (LL2 .NE. 0) NLET(LL2) = NLET(LL2) + 1
      GOTO 300
  280 IF (NLET(LL1) .LT. 1) GOTO 300
      IF (LL2 .EQ. 0) GOTO 290
      IF (NLET(LL2) .LT. 1) GOTO 300
  290 IF (NTEMP .GE. MAXT) GOTO 350
      NTEMP = NTEMP + 1
      NLET(LL1) = NLET(LL1) + 1
      IF (LL2 .GT. 0) NLET(LL2) = NLET(LL2) + 1
      ICHKL = ITAB(K+1)
      CALL XUNPAK (ICHKL, IHKL)
      CALL IITAB4 (IHKL, K)
      W = TANH(IEEE*FAK1)**2
      FAKWS = FAKWS + W
      E1 = IE / 100.
      IE = -IE
      IF (REDUS) GOTO 295
      ITAB(K+7) = IE
      ITAB(K+2) = IE*W - 0.5
      ITAB(K+4) = 1000. * W
      ITAB(K+3) = ITAB5(I5+2)
  295 IF (.NOT. SWIPRI) GOTO 300
      CALL KERNZI (12, ISYMB(1), 4)
      IF (LET1(1) .LT. 0) ISYMB(1) = 11
      ISYMB(2) = LL1
      IF (LET1(2) .LT. 0) ISYMB(3) = 11
      IF (LL2 .GT. 0)     ISYMB(4) = LL2
      IP = ITAB5(I5+2)
      WRITE (LITOUT, FMT='(1X,3I3,F5.2,1X,4A1,'' +'',I3,''.'',F5.2,1X)')
     *               IHKL, E1, CHAR(ISYMB(1)), CHAR(ISYMB(2)),
     *               CHAR(ISYMB(3)), CHAR(ISYMB(4)), IP, W
      CALL LINPRX (0, LITOUT, 32, 4)
  300 CONTINUE
      GOTO (310, 320, 350), ISW
  310 I = MAXT + 10
      IF (KARR(1).GT.I .OR. KARR(100).GT.I) THEN
         AMIN = AMINE - 0.1
         AMAX = AMAXE + 0.1
         GOTO 200
      ENDIF
      ISW = 2
      CALL VALDIS (I, AEMIN, 0., KARR, 100, NTEMP)
      GOTO 210
  320 ISW = 3
      NLETM = 4
      IF (MS .LE. 20) NLETM = 1
      DO 340 I=1,10
      IF (NLET(I) .GE. NLETM) GOTO 330
      IF (NLET(I) .EQ. 0) GOTO 340
      NLET(I) = -1
      GOTO 340
  330 NLET(I) = 1
  340 CONTINUE
      ITEST = 0
      DO 345 I=1,10
  345 IF (NLET(I) .LT. 1) ITEST = 1
      IF (ITEST .EQ. 0) REDUS = .FALSE.
      GOTO 210
  350 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4)
      WRITE (LIS1, 360) NTEMP
      WRITE (LIS2, 360) NTEMP
  360 FORMAT (' Number of temporarily accepted refl. (secondary set):',
     *          I4)
      IF (NTEMP .LE. 0) THEN
         CHOUT = ' No temp. acc. refl. found, decrease QEET and try.'
         CALL SHOUT2
         QEET = 0.5 * QEET -0.01
         IF (QEET .GT. 0.4 * QEETO) GOTO 111
         CHOUT = 'Again no temp. acc. refl. found ... scaling error???'
         CALL SHOUT2
         CHOUT = 'Continuation may be unreliable..... but we will try!'
         CALL SHOUT2
         ENDIF
      FAKWS = AMAX1 (2., 0.3 * NTEMP / FAKWS)
      DO 380 I=1,10
      IF (NLET(I) .LT. 0) NLET(I) = 1
  380 CONTINUE
      WRITE (LIS2, 390) (CHAR(I),I=1,JSYMB)
  390 FORMAT (' Symbol frequency in basic set', /, 1X, 10(3X, A1))
      WRITE (LIS2, FMT='(1X, 10I4)') (NLET(I), I=1,JSYMB)
      RETURN
      END
      SUBROUTINE REAR2
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ = 59876, ISIZ5 = 10000)
      INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5)
      LOGICAL REDUS
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DO 220 K=MCT,NCT,ICR
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 220
      E1 = ITAB(K+7) * 10.
      IF (E1 .LT. 0.0) E1 = -E1
      KK5 = K5 * INCA5
      IF (ITAB5(KK5+1) .EQ. 32767) GOTO 210
  200 EEE = ITAB5(KK5+1) / E1
      IPH = ITAB5(KK5+2)
      IF (IPH .LE. 0) IPH = IPH + 360
      ITAB5(KK5+1) = EEE * ISCT(450-IPH)
      ITAB5(KK5+2) = EEE * ISCT(IPH)
      ITAB5(KK5+3) = ITAB5(KK5+3) / E1*1000.
  210 K5 = ITAB5(KK5+4)
      IF (K5 .EQ. 0) GOTO 220
      KK5 = K5*INCA5 + KK5
      GOTO 200
  220 CONTINUE
      RETURN
      END
      SUBROUTINE SYMAN (A)
      INTEGER A(1025)
      NSY = A(1)
      M = 2**NSY
      KM = M * 2
      DO 100 I = 1, NSY
      KM = KM / 2
      LM = KM / 2
      DO 100 K=1,M,KM
      N = K + LM
      DO 100 L=1,LM
      IA = A(K+L)
      A(K+L) = IA + A(N+L)
  100 A(N+L) = IA - A(N+L)
      RETURN
      END
      INTEGER FUNCTION IITAB5 (I51, I52)
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ5 = 10000)
      INTEGER *2 ITAB5(5*ISIZ5)
      LOGICAL REDUS
      I52 = ITAB5(I51+4)*INCA5 + I51
      IITAB5 = ITAB5(I51+4)
      RETURN
      END
      FUNCTION IALP (IA, IB)
      DIMENSION IK(50)
      DATA IK / 10149, 9510, 8887, 8286, 7711, 7161, 6641, 6151, 5693,
     *           5266, 4871, 4505, 4169, 3863, 3581, 3324, 3090, 2878,
     *           2685, 2510, 2350, 2206, 2075, 1956, 1848, 1749, 1659,
     *           1577, 1502, 1433, 1388, 1332, 1296, 1243, 1190, 1139,
     *           1089, 1056, 1008,  961,  941,  920,  899,  879,  866,
     *            853,  840,  827,  814,  801 /
      IC = MAX0(IA,IB)
      IF (IC .LT. 51) GOTO 200
      IALP = MIN0 (IA, IB, (IA+IB)/4)
      GOTO 240
  200 M = MIN0 (IA, IB)
      IF (M .LT. 3) GOTO 220
      K = IK(IA) + IK(IB)
      IF (K .GT. 10149) GOTO 220
      N = M - 1
      DO 210 I=2,N
      II = M - I
      IF (IK(II) .GT. K) GOTO 230
  210 CONTINUE
  220 IALP = 0
      GOTO 240
  230 IALP = II
  240 RETURN
      END
      SUBROUTINE DAFOMS (INCODE, EL, IPH, WS, E1, IREFL, ILINK)
      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, SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      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 (LIS1,  IFILE( 7))
      EQUIVALENCE (LIS2,  IFILE( 8))
      EQUIVALENCE (IE100, IFILE(10))
      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 / KLAD  / ICODE(4,48), ISHIFT(48)
      COMMON / SINCOS / IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      PARAMETER (MAXNR = 1000, MAXADR = 4000, IBEMAX = 25)
      COMMON /DAFOPC/
     *          ITAB25(4,MAXNR,IBEMAX), IWEAK(4,100), DIF(4,IBEMAX),
     *          WEAKR(4,100,IBEMAX), ITAD(-1:MAXADR), QEST(3,IBEMAX),
     *          KARR(100),  IH(3), IK(3), IL(3), IHPK(3),
     *          IHKL(3), IHPL(3), IKPL(3), IHML(3), ICODEH(3,48),
     *          P1SOL(IBEMAX),  IP1SOL(IBEMAX), P2SOL(IBEMAX),
     *          IP2SOL(IBEMAX), Q1SOL(IBEMAX),  IQ1SOL(IBEMAX),
     *          Q2SOL(IBEMAX),  IQ2SOL(IBEMAX), IPQSOL(IBEMAX)
      LOGICAL FIRST, LAUEP, PSIZ
      DATA    FIRST, LAUEP, PSIZ / .FALSE., .FALSE., .TRUE. /
      DATA MINTRI / 10 /
      DATA IBEST, IKEND, IREF, IRED, IOLD, NNSYMM / 0, 0, 0, 0, 0, 0/
      DATA J12, IICENT, NREFL, E1100, KBMAX / 0, 0, 0, 0.0, 0/
      IF (FIRST) GOTO 210
      FIRST = .TRUE.
      KBMAX = MIN0 (INCODE, IBEMAX)
      IF (ILAUE.GT.3 .AND. .NOT.EXPAND) LAUEP = .TRUE.
      E1100 = EL
      NREFL = IPH
      IF (NREFL.GT.MAXADR) CALL KERROR
     *   ('Reduce number of reflections to MAXADR (= 4000)', 0,'DAFOMS')
      NNSYMM = NSYMM
      IICENT = ICENT
      IF (EXPAND) THEN
         NNSYMM = 1
         IICENT = 1
      ENDIF
      IBEST = 1
      IOLD = 1
      IKEND = 0
      ITAD(0)  = 0
      ITAD(-1) = 0
      IRED = 0
      CALL KERNZI (0, ITAB25, 4*MAXNR*IBEMAX)
      CALL KERNZA (0., WEAKR, 400*IBEMAX)
      CALL KERNZA (0.,  QEST, 3*IBEMAX)
      CALL KERNZI (0,  ITAD,  MAXADR)
      CALL KERNZI (0,  IWEAK,    400)
      CALL KERNZI (0,   IHKL,      3)
      RETURN
  210 IF (ILINK) 330, 340, 220
  220 IF (IOLD .NE. ILINK) GOTO 270
      IF (IKEND .GE. MAXNR) RETURN
      IF (IKEND .GE. NREFL) THEN
         CHOUT = ' too many symbols. Scaling error ?? Try to go on'
         CALL SHOUT2
         RETURN
         ENDIF
      IKEND = IKEND + 1
      ITAB25(1,IKEND,IBEST) = INCODE
      ITAB25(2,IKEND,IBEST) = NINT(EL*1000.)
      ITAB25(4,IKEND,IBEST) = NINT(WS*1000.)
      ITAB25(3,IKEND,IBEST) = IPH
      IF (IBEST .GT. 1) RETURN
      ITAB25(3,IKEND,1) = IPH + 370*IREFL
      IF (E1.LE.E1100 .OR. IRED.EQ.100) RETURN
      IRED = IRED + 1
      ITAB25(2,IKEND,1) = -ITAB25(2,IKEND,1)
      RETURN
  270 IF (IBEST .GT. 1) GOTO 320
      DO 310 I=1,IKEND
      IADR = ITAB25(3,I,1) / 370
      ITAB25(3,I,1) = ITAB25(3,I,1) - IADR*370
      ITAD(IADR) = I
  310 CONTINUE
      IREF = IKEND
  320 IBEST = IBEST + 1
      IF (IBEST .LE. KBMAX) THEN
          IKEND = 0
          IOLD  = ILINK
          GOTO 210
          ELSE
          CALL KERNER (-4, 'DAFOMS')
          ENDIF
  330 IOLD  = IOLD  + 1
      IKEND = 0
      RETURN
  340 IF (IKEND .EQ. 0) IBEST = IBEST - 1
      WRITE (LIS1, FMT='('' Psi0 FOM and negative quartet FOM:'')')
      WRITE (LIS2, FMT='(/'' Psi0 FOM and negative quartet FOM:'')')
      WRITE (LIS2, 345) IREF, IRED
  345 FORMAT (' Number of reflections stored in table:  ', I4, /,
     *        ' Number of reflections in reduced table: ', I4,
     *        '  (= strongest refl.)')
      IF (IBEST .EQ. 1) THEN
          ILINK = 1
          RETURN
          ENDIF
      READ (IE100, FMT='(A80)') CHIN
      IF (SWIPRI) WRITE (LIS2, FMT='(A80)') CHIN
      READ (CHIN, FMT='(5X, I3)') N100
      IF (N100 .LE. 10) CALL KERROR
     *   (' There are not enough weak reflections (< 10)', 0, 'DAFOMS')
      N100 = MIN0 (N100, 100)
      DO 380 I=1,N100
      READ (IE100, FMT='(3I4)') (IWEAK(J,I), J=1,3)
      CALL KERNAI (IWEAK(1,I), IHKL, 3)
  380 IWEAK(4,I) = IGROUP(IHKL) - 1
      IF (.NOT. SWIPRI) GOTO 395
      WRITE (LIS2, FMT='(''    (G = parity group)'')')
      WRITE (LIS2, 385) ((IWEAK(I4,I), I4=1,4), I=1,N100)
  385 FORMAT ('   H  K  L G', / (10(1X,3I3,I2)))
      WRITE (LIS2, 390) IREF, IRED, E1100
  390 FORMAT (' The table of ', I4, ' reflections is reduced to',
     *         I4, ' strongest reflections (min E1 = ', F5.3, ')')
      WRITE (LIS2, FMT='('' The '', I4, '' strongest reflections:'',
     *                     /, ''   No   H  K  L'')') IREF
      DO 394 I=0,IREF-1,12
      DO 391 J=1,12
      IF (I+J .GT. IREF) GOTO 392
      J12 = J
      CALL XUNPAK (ITAB25(1,I+J,1), IHKL)
  391 CALL KERNAI (IHKL, ICODEH(1,J), 3)
  392 WRITE (LIS2, 393) I+1, ((ICODEH(I3,I12), I3=1,3), I12=1,J12)
  393 FORMAT (I5, 12(1X,3I3))
  394 CONTINUE
  395 CALL KERNZI (0, ICODEH, 3*48)
      CALL KETIME (LIS2)
      NREL = 0
      CALL KERNZI (0, KARR, 100)
      DO 431 IJ=1,IREF
      IF (ITAB25(2,IJ,1) .GT. 0) GOTO 431
      ITAB25(2,IJ,1) = IABS (ITAB25(2,IJ,1))
      IF (NREL .GT. 5000) GOTO 435
      CALL XUNPAK (ITAB25(1,IJ,1), IK)
      NEQ = 2
      CALL SYMEQ (IK, NEQ)
      IF (NEQ .NE. NNSYMM) GOTO 431
      NEQ2 = NEQ * 2
      DO 400 INEQ=1,NEQ
      ISHIFT(INEQ) = IDEG(ISHIFT(INEQ))
  400 ISHIFT(INEQ+NEQ) = -ISHIFT(INEQ)
      DO 430 I=1,N100
      CALL KERNAI (IWEAK(1,I), IH, 3)
      IHIT = 0
      CALL KERNZA (0., DIF, 4*IBEMAX)
      DO 410 II=1,NEQ2
      ISK = 1
      IF (II .GT. NEQ) ISK = -1
      CALL KERNAI (ICODE(1,II), IK, 3)
      CALL GENERP (IH, IK, IADR, ISHMK)
      IADR = ITAD(IADR)
      IF (IADR .EQ. 0) GOTO 415
      ISS = ISIGN(1,ISHMK)
      ISHMK = IDEG(IABS(ISHMK))
      IHIT = IHIT + 1
      DO 405 J=1,IBEST
      IPK = ISK * (ITAB25(3,IJ,J) + ISHIFT(II))
      IPHMK = ISS * (ITAB25(3,IADR,J) + ISHMK)
      IPHK = IPHMK + IPK
      IPHK = MOD(IPHK, 360)
      IF (IPHK .LE. 0) IPHK = 360 + IPHK
      EH = FLOAT (ITAB25(2,IJ,J)) / 1000.
      EK = FLOAT (ITAB25(2,IADR,J)) / 1000.
      EHEK = EH * EK
      ICOSHK = ISCT(450-IPHK)
      COSHK = FLOAT(ICOSHK) / 1000.
      EHEKC = EHEK * COSHK
      DIF(1,J) = DIF(1,J) + EHEKC
      IF (IICENT .EQ. 1) THEN
          ISINHK = ISCT(IPHK)
          SINHK = FLOAT(ISINHK) / 1000.
          EHEKS = EHEK * SINHK
          EHEK2 = EHEKC**2 + EHEKS**2
          DIF(2,J) = DIF(2,J) + EHEKS
          DIF(3,J) = DIF(3,J) + SQRT(EHEK2)
          DIF(4,J) = DIF(4,J) + EHEK2
      ELSE
          DIF(3,J) = DIF(3,J) + ABS(EHEKC)
          DIF(4,J) = DIF(4,J) + EHEKC**2
          ENDIF
  405 CONTINUE
  410 CONTINUE
  415 CONTINUE
      IF (IHIT .GT. 0) THEN
          KARR(I) = KARR(I) + IHIT
          NREL = NREL + IHIT
          DO 420 J=1,IBEST
          WEAKR(1,I,J) = WEAKR(1,I,J) + DIF(1,J)
          WEAKR(2,I,J) = WEAKR(2,I,J) + DIF(2,J)
          WEAKR(3,I,J) = WEAKR(3,I,J) + DIF(3,J)
  420     WEAKR(4,I,J) = WEAKR(4,I,J) + SQRT(DIF(4,J))
          ENDIF
  430 CONTINUE
  431 CONTINUE
      GOTO 437
  435 WRITE (LIS2, FMT='('' PSI0 generation is stopped at refl. No.'',
     *                     I3, 2X, 3I4)') IJ, IK
      DO 436 I=IJ,IREF
  436 ITAB25(2,I,1) = IABS (ITAB25(2,I,1))
  437 WRITE (LIS1, 440) N100, NREL
      WRITE (LIS2, 440) N100, NREL
  440 FORMAT (' The ', I3, ' weakest reflections take part in', I5,
     *        ' triplet relationships.')
      IHIT = 0
      JREFL = 0
      CALL KERNZA (0.0001, DIF, 4*IBEMAX)
      DO 460 I=1,N100
      IF (KARR(I) .LT. MINTRI) GOTO 460
      JREFL = JREFL + 1
      IHIT = IHIT + KARR(I)
      DO 450 J=1,IBEST
      WEAKR(1,I,J) = SQRT(WEAKR(1,I,J)**2 + WEAKR(2,I,J)**2)
      DIF(1,J) = DIF(1,J) + WEAKR(1,I,J)
      DIF(2,J) = DIF(2,J) + WEAKR(3,I,J)
      DIF(3,J) = DIF(3,J) + WEAKR(4,I,J)
  450 CONTINUE
  460 CONTINUE
      IF (IHIT .EQ. 0) THEN
          WRITE (LIS2, 470)
  470     FORMAT (/' Sory, PSIzero FOM not possible, there are not ',
     *            'enough hits (10) per weak refl.')
          NREL = 0
          PSIZ = .FALSE.
          GOTO 530
          ENDIF
      HIT = FLOAT(IHIT) / FLOAT(JREFL)
      WRITE (LIS2, 480) IBEST, JREFL, HIT
  480 FORMAT (/' PSIzero FOM for the ', I2, ' best solutions',
     *        ' (with old solution numbers)', /,
     *        '    (for ',I3, ' weak reflections and number of hits',
     *        ' per reflection is ', F5.1, '):', /,
     *        '    PSIzero(1) = sum |sum(E(K) * E(H-K))| / sum(sum|',
     *        'E(K) * E(H-K)|)', /,
     *        '    PSIzero(2) = sum |sum(E(K) * E(H-K))| / sum(sum|',
     *        'E(K) * E(H-K)|**2)**1/2')
      WRITE (LIS2, FMT='(20X, ''PSI(1)'', 11X, ''PSI(2)'')')
      DO 490 J=1,IBEST
      DIF12    = DIF(1,J) / DIF(2,J)
      DIF13    = DIF(1,J) / DIF(3,J)
      DIF(1,J) = DIF12
      DIF(2,J) = DIF13
      P1SOL(J) = DIF12
  490 P2SOL(J) = DIF13
      CALL ORDTAB (P1SOL, IP1SOL, IBEST)
      CALL ORDTAB (P2SOL, IP2SOL, IBEST)
      P2MIN = P2SOL(1)
      DO 510 J=1,IBEST
      WRITE (LIS2, 500) J, P1SOL(J), IP1SOL(J), P2SOL(J), IP2SOL(J)
  500 FORMAT (1X, I2, '. solution: ', 2(F9.4, ' - ', I2, 3X))
      P1SOL(J) =  P2MIN / DIF(2,J)
  510 CONTINUE
  530 CALL KETIME (LIS2)
      E4MIN = 0.0
      NEGQ = 0
      DO 621 I=1,N100-2
      IF (NEGQ .GT. 500) GOTO 630
      CALL KERNAI (IWEAK(1,I), IHPK, 3)
      NEQI = 1
      CALL SYMEQ (IHPK, NEQI)
      IF (NEQI .NE. NNSYMM) GOTO 621
      DO 560 INEQ=1,NEQI
      DO 560 I3=1,3
  560 ICODEH(I3,INEQ) = ICODE(I3,INEQ)
      IPHPK = IWEAK(4,I)
      DO 622 II=I+1,N100-1
      CALL KERNAI (IWEAK(1,II), IHPL, 3)
      NEQII = 1
      CALL SYMEQ (IHPL, NEQII)
      IF (NEQII .NE. NNSYMM) GOTO 622
      IPHPL = IWEAK(4,II)
      IPKPL = IPHPK + IPHPL
      IPKPL = MIN0 (IPKPL, 14-IPKPL)
      IF (IPHPK-IPHPL .EQ. 0) IPKPL = 0
      DO 623 IIN=1,NEQII
      CALL KERNAI (ICODE(1,IIN), IHPL, 3)
      DO 624 III=II+1,N100
      IF (.NOT. LAUEP .AND. IWEAK(4,III).NE.IPKPL) GOTO 624
      CALL KERNAI (IWEAK(1,III), IKPL, 3)
      DO 620 IN=1,NEQI
      DO 570 I3=1,3
      IHPK(I3) = ICODEH(I3,IN)
      IHML(I3) = IHPK(I3) - IKPL(I3)
      IL(I3) = IHPL(I3) - IHML(I3)
      IF (.NOT. LAUEP) GOTO 570
      IF (MOD(IL(I3),2) .NE. 0) GOTO 620
  570 IL(I3) = IL(I3) / 2
      CALL GENERQ (IL, ISHL, IADL)
      IADL = ITAD(IADL)
      IF (IADL .EQ. 0) GOTO 620
      DO 580 I3=1,3
  580 IK(I3) = IKPL(I3) - IL(I3)
      CALL GENERQ (IK, ISHK, IADK)
      IADK = ITAD(IADK)
      IF (IADK .EQ. 0) GOTO 620
      DO 590 I3=1,3
  590 IH(I3) = IHPL(I3) - IL(I3)
      CALL GENERQ (IH, ISHH, IADH)
      IADH = ITAD(IADH)
      IF (IADH .EQ. 0) GOTO 620
      DO 600 I3=1,3
  600 IHKL(I3) = -IHPL(I3) - IK(I3)
      CALL GENERQ (IHKL, ISHHKL, IADHKL)
      IADHKL = ITAD(IADHKL)
      IF (IADHKL .EQ. 0) GOTO 620
      NEGQ = NEGQ + 1
      ISSH = ISIGN(1,ISHH)
      ISHH = IDEG(IABS(ISHH))
      ISSK = ISIGN(1,ISHK)
      ISHK = IDEG(IABS(ISHK))
      ISSL = ISIGN(1,ISHL)
      ISHL = IDEG(IABS(ISHL))
      ISSHKL = ISIGN(1,ISHHKL)
      ISHHKL = IDEG(IABS(ISHHKL))
      DO 610 J=1,IBEST
      EH = FLOAT (ITAB25(2,IADH,J)) / 1000.
      EK = FLOAT (ITAB25(2,IADK,J)) / 1000.
      EL = FLOAT (ITAB25(2,IADL,J)) / 1000.
      EHKL = FLOAT (ITAB25(2,IADHKL,J)) / 1000.
      E4  = EH * EK * EL * EHKL
      IF (E4 .LT. E4MIN) GOTO 610
      IPH = ISSH * (ITAB25(3,IADH,J) + ISHH)
      IPK = ISSK * (ITAB25(3,IADK,J) + ISHK)
      IPL = ISSL * (ITAB25(3,IADL,J) + ISHL)
      IPHKL = ISSHKL * (ITAB25(3,IADHKL,J) + ISHHKL)
      IPH4 = IPH + IPK + IPL + IPHKL
      IPH4 = MOD(IPH4, 360)
      IF (IPH4 .LE. 0) IPH4 = 360 + IPH4
      ICOS4 = ISCT(450-IPH4)
      COS4 = FLOAT(ICOS4) / 1000.
      ISIN4 = ISCT(IPH4)
      SIN4 = FLOAT(ISIN4) / 1000.
      E4 = SQRT((E4*COS4)**2 + (E4*SIN4)**2)
      QEST(1,J) = QEST(1,J) + E4*COS4
      QEST(2,J) = QEST(2,J) + E4
      QEST(3,J) = QEST(3,J) + E4*ABS(180.-FLOAT(IPH4))
  610 CONTINUE
  620 CONTINUE
  624 CONTINUE
  623 CONTINUE
  622 CONTINUE
  621 CONTINUE
      GOTO 631
  630 WRITE (LIS2, FMT='(/'' Negative quartet generation is stopped'',
     *  '' at weak refl. No.'', I3, 2X, 3I4)')  I, (IWEAK(I3,I), I3=1,3)
  631 IF (NEGQ .LT. 5) THEN
          WRITE (LIS2, 640) NEGQ
  640     FORMAT (/' Sorry, Negative Quartet FOM not possible, there',
     *            ' are only ', I1, ' hits ')
          IF (.NOT. PSIZ) RETURN
          CALL KERNZA (0.0, Q1SOL, IBEST)
          GOTO 690
          ENDIF
      WRITE (LIS1, 645) N100, NEGQ
  645 FORMAT (' The ', I3, ' weakest reflections take part in', I5,
     *        ' negative quartets.' )
      WRITE (LIS2, 650) N100, NEGQ
  650 FORMAT (/' The ', I3, ' weakest reflections take part in', I4,
     *        ' negative quartets.' /
     *        ' Negative quartet FOMs (with old solution numbers):', /,
     *        '  Hauptman: NQEST = sum (E4 * cos(PH4)) / sum E4 ',
     *        '   (here: NQEST + 1)', /,
     *        '  Schenk:   NQC   = sum (E4 * |180-PH4|)         ',
     *        '   (here: NQC / sum E4 * 180)', /,
     *        20X, 'NQEST', 11X, 'NQC')
      DO 660 J=1,IBEST
      QEST(1,J) = 1. + QEST(1,J) / QEST(2,J)
      QEST(2,J) = QEST(3,J) / (QEST(2,J) * 180.)
      Q1SOL(J) = QEST(1,J)
  660 Q2SOL(J) = QEST(2,J)
      CALL ORDTAB (Q1SOL, IQ1SOL, IBEST)
      CALL ORDTAB (Q2SOL, IQ2SOL, IBEST)
      Q1MIN = Q1SOL(1)
      Q2MIN = Q2SOL(1)
      DO 680 J=1,IBEST
      WRITE (LIS2, 670) J, Q1SOL(J), IQ1SOL(J), Q2SOL(J), IQ2SOL(J)
  670 FORMAT (I3, '. solution: ', 2(F9.4, ' - ', I2, 3X))
      Q1SOL(J) = (Q1MIN/QEST(1,J) + Q2MIN/QEST(2,J)) / 2.
  680 CONTINUE
  690 IPQSOL(1) = NREL
      IPQSOL(2) = NEGQ
      CALL COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST)
      ILINK = IPQSOL(1)
      WRITE (LIS2, FMT='( '' Combined FOM: best solution is solution'',
     *       '' No. '', I3)') ILINK
      FIRST = .FALSE.
      CALL KETIME (LIS2)
      RETURN
      END
      SUBROUTINE GENERP (IH, IK, IADR, ISHMK)
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      DIMENSION IH(3), IK(3), IHMK(3)
      IADR = -1
      DO 200 I=1,3
      IHMK(I) = IH(I) - IK(I)
  200 IF (IABS(IHMK(I)) .GT. MAXHKL(I)) GOTO 230
      ICOHMK = INPACK(IHMK)
      KC = IABS(ICOHMK)
      IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230
      K = ITAB(KC)
      IF (K .EQ. 0) GOTO 230
      L = IABS(K) / 4096
      ISHMK = (L + 1) * ISIGN(1,K) * ISIGN(1,ICOHMK)
      IADR = IABS(K) - 4096*L
  230 RETURN
      END
      SUBROUTINE GENERQ (IHKL, ISHIFT, IADR)
      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 / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4,
     *                  NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8),
     *                  E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS,
     *                  QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP,
     *                  E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7),
     *                  IDC3, PSQ, IPSQ, E1MIN, E1100
      PARAMETER (ISIZ = 59876)
      INTEGER *2 ITAB(ISIZ)
      DIMENSION IHKL(3)
      IADR = -1
      DO 210 I=1,3
  210 IF (IABS(IHKL(I)) .GT. MAXHKL(I)) GOTO 230
      ICODE = INPACK(IHKL)
      KC = IABS(ICODE)
      IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230
      K = ITAB(KC)
      IF (K .EQ. 0) GOTO 230
      L = IABS(K) / 4096
      ISHIFT = (L + 1) * ISIGN(1,K) * ISIGN(1,ICODE)
      IADR = IABS(K) - 4096*L
  230 RETURN
      END
      SUBROUTINE ORDTAB (URD, IORD, IOMAX)
      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
      PARAMETER (IMAX = 25)
      DIMENSION URD(IMAX), IORD(IMAX), ORD(IMAX)
      IOMAX = MIN0 (IOMAX, MIN0 (IOMAX,IMAX))
      CALL KERNZI (0, IORD, IOMAX)
      CALL KERNZA (0., ORD, IOMAX)
      JJ = 1
      DO 250 I=1,IOMAX
      IF (I .EQ. 1) GOTO 240
      DO 210 J=1,I-1
      IF (URD(I) .GT. ORD(J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = I
      GOTO 240
  220 DO 230 K=I,JJ+1,-1
      ORD(K)   = ORD(K-1)
  230 IORD(K)  = IORD(K-1)
  240 ORD(JJ)  = URD(I)
      IORD(JJ) = I
  250 CONTINUE
      CALL KERNAB (ORD(1), URD(1), IOMAX)
      RETURN
      END
      SUBROUTINE COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST)
      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
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N,
     *                  JSYMB, FAK, FAKWS, REDUS, KBMAX,
     *                  KB10X(15,25), KB10XX(15,25)
      PARAMETER (ISIZ5 = 10000)
      INTEGER *2 ITAB5(5*ISIZ5)
      LOGICAL REDUS
      PARAMETER (IBEMAX = 25)
      DIMENSION P1SOL(IBEMAX), Q1SOL(IBEMAX), IPQSOL(IBEMAX),
     *          C1SOL(IBEMAX), C2SOL(IBEMAX),  C3SOL(IBEMAX),
     *          CFSOL(IBEMAX)
      DATA WC1, WC2, WPSI, WNEQ / 2., 4., 4., 6. /
      IF (IPQSOL(1) .LT.  20) WPSI = 2.
      IF (IPQSOL(1) .EQ.   0) WPSI = 0.
      IF (IPQSOL(2) .GT. 290) WNEQ = 7.
      IF (IPQSOL(2) .LT.  20) WNEQ = 2.
      IF (IPQSOL(2) .LT.   5) WNEQ = 0.
      WSUM = WC1 + WC2 + WPSI + WNEQ
      WC1  = WC1  / WSUM
      WC2  = WC2  / WSUM
      WPSI = WPSI / WSUM
      WNEQ = WNEQ / WSUM
      CALL KERNZI (0, IPQSOL, IBEST)
      DO 200 I=1,IBEST
      C1SOL(I) = FLOAT(KB10X(12,I)) / 1000.
      C2SOL(I) = FLOAT(KB10X(13,I)) / 1000.
  200 CFSOL(I) = C1SOL(I) * WC1   +  C2SOL(I) * WC2  +
     *           P1SOL(I) * WPSI  +  Q1SOL(I) * WNEQ
      CALL KERNZA (0., C3SOL, IBEST)
      JJ = 1
      DO 250 I=1,IBEST
      IF (I .EQ. 1) GOTO 240
      DO 210 J=1,I-1
      IF (CFSOL(I) .LT. C3SOL(J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = I
      GOTO 240
  220 DO 230 K=I,JJ+1,-1
      C3SOL(K)  = C3SOL(K-1)
  230 IPQSOL(K) = IPQSOL(K-1)
  240 IPQSOL(JJ) = I
      C3SOL(JJ)  = CFSOL(I)
  250 CONTINUE
      CALL KERNZA (0., C3SOL, IBEST)
      DO 260 I=1,IBEST
  260 C3SOL(IPQSOL(I)) = FLOAT(I)
      CALL KERF2I (C3SOL, IPQSOL, IBEST)
      WRITE (LIS2, FMT = '('' Combined FOM:'', /,
     *  ''                 CONS1   CONS2    PSI0    NEQ ''/
     *  '' Rel.weights '', 4F8.3 /
     *  '' No  orig.No'' , 40X, ''CFOM  Range'')')
     *                      WC1, WC2, WPSI, WNEQ
      IPQMIN = IBEST
      DO 270 J=1,IBEST
      IF (IPQSOL(J) .LT. IPQSOL(IPQMIN)) IPQMIN = J
      N = KB10X(11,J)
  270 WRITE (LIS2, 280) J, N, C1SOL(J), C2SOL(J), P1SOL(J), Q1SOL(J),
     *                 CFSOL(J), IPQSOL(J)
  280 FORMAT (I3, I6, F13.3, 4F8.3, I4)
      IPQSOL(1) = IPQMIN
      RETURN
      END
