      PROGRAM ORIENT
CCCCCCCCCCCCCCCCCCCCCCCCCC let op regel 226 ==> 19 Feb. 96 ==> SWITCH(1)
***************************  File: U625002 ORIENT FORTRAN N = ORIENT FOR
**** Note: the last part of  ***************** Last update: 11 Nov. 1999
**** this file is:  ORIENT2  **** Source: Nordman, Strumpel, G.Beurskens
**** Find: CSUBFILE ORIENT2  **** ORIENT2 is also used  in Program PATTY
 
*ORIENT LOG of recent modifications (last on top
C 11 Nov 99 : blank commons aangepast aan ITAB lengte
      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 (IMFUN, IFILE(13)), (IPDEK, IFILE(14))
      EQUIVALENCE (LIS2,   IFILE(8))
      LOGICAL XBIG
      EQUIVALENCE (XBIG, SWITCH(14))
      CALL KEPROG ('ORIENT')
      WRITE (LIS2, FMT = '('' Last ORIENT update: 11 Nov. 1999'')')
      SWITCH(1) = .FALSE.
      CALL ORVIN (MPARIN)
      CALL ORVEC
      CALL ORDEK
      CALL MORV
      CALL MAPSIG
      IF (MPARIN.GT.0) GOTO 200
      CALL REGION
      CALL MORV
      CALL MAPSIG
  200 CALL SIGSEL (DELC)
      IF (DELC .LT. 0.35) GOTO 222
      DO 220 I = 1,2
      CALL MORV
      CALL MAPSIG
      CALL SIGSEL (DELC)
      IF (DELC .LT. 0.35) GOTO 222
  220 CONTINUE
  222 CALL EULOUT
      CALL FILCLO (IMFUN, 'DELETE')
      CALL KEPROX
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE ORVIN (MPARIX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3)),  (ICON,  IFILE(4))
      EQUIVALENCE (LIS1,  IFILE(7)),  (LIS2,  IFILE(8))
      EQUIVALENCE (KLAUE, KEYS(6)) ,  (IPRPAT,  KEYS(8))
      EQUIVALENCE (IPRDEK,  KEYS(9)), (IPRSIG,  KEYS(10))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      LOGICAL XBIG
      EQUIVALENCE (XBIG, SWITCH(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)
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      CHARACTER *6 PRIMAP(3)
      PARAMETER (LITAM = 7)
      CHARACTER *6 LITA(LITAM)
      DATA LITA   /'ORIENT',  'VMAX',  'PARAMS',  'MIN',  'XBIG',
     *             'PRIMAP',  ' ' /
      DATA PRIMAP / 'PATIN', 'DEK', 'MAPSIG' /
      D2R = ATAN(1.0) / 45.0
      VMAXIN = -1.
      FVMIN = -1.
      KWVLEN = 0
      MPAR = 0
      DELC = 0.
      MININ = 0
      NCONIN = 0
      CALL KERNZI (0, MM, 3)
      CALL KERNZI (0, MINM, 3)
      CALL KERNZI (0, MIN4, 4)
      CALL RDCRYS (ICRYS)
      CALL FILCLO (ICRYS, 'KEEP')
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 177
  102 IF (IUNIQ .EQ. 1) GOTO 101
      IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = 2
      GOTO 177
  103 KLAUE = 3
      GOTO 177
  104 KLAUE = 4
  177 CALL RDCOND (ICON, LITA, LITAM, KEND)
      IF (KEND .EQ. -1) THEN
         WRITE (LIS1, FMT='('' No CONDA file: default run'')')
         GOTO 910
         ENDIF
      IF (KEND .EQ. 0) GOTO 900
      NCONIN = NCONIN + 1
      IF (NCONIN .EQ. 2) WRITE(LIS1, FMT='('' CONDA control data:'')')
      GOTO (177, 200, 300, 400, 500, 600, 177), KEND
  200 VMAXIN = FNUM(1)
      IF (VMAXIN.LE.0.0 .AND. NFNUM.GT.1) GOTO 202
      WRITE (LIS1, FMT ='( '' VMAX input ='', F7.2)' ) VMAXIN
      IF (VMAXIN .LT. 1.1) CALL KERROR (' Error: No value for VMAX ',
     * -1, ' ORVIN' )
  202 IF (NFNUM .GT. 1) THEN
         KWVLEN = NINT(FNUM(2))
         IF (KWVLEN .EQ. 1) WRITE (LIS1, FMT='(
     *      '' Sorting of vectors on Weight * SQRT(Vector-length)'')')
         IF (KWVLEN .GT. 1) WRITE (LIS1, FMT='(
     *      '' Sorting of vectors on Weight * Vector-length'')')
         ENDIF
      GOTO 177
  300 MPAR = MPAR + 1
      IF (MPAR .EQ. 1) WRITE (LIS1, FMT='('' Set nr.  '',
     *   ''   Abeg  Ainc Nr.     Bbeg  Binc Nr.     Cbeg  Cinc Nr.'')')
      I =0
      DO 310 J=1,3
      PAR1(J,MPAR) = FNUM(I+1)
      PAR2(J,MPAR) = FNUM(I+2)
      NPAR(J,MPAR) = NINT(FNUM(I+3))
      IF (NPAR(J,MPAR).LE.0) GOTO 800
  310 I = I + 3
      WRITE (LIS1,312) MPAR,
     *   (PAR1(J,MPAR), PAR2(J,MPAR), NPAR(J,MPAR), J=1,3)
  312 FORMAT (' Set', I3, 3(F10.1, F6.1, I3))
      IF (NFNUM .NE . 9) GOTO 800
      DO 314 J=1,3
      IF (NPAR(J,MPAR).LE.0) GOTO 800
      IF (NPAR(J,MPAR).GT.1 .AND. PAR2(J,MPAR).LT.0.01) GOTO 800
  314 CONTINUE
      DELC = DELC + PAR2(3,MPAR)
      GOTO 177
  400 IF (NFNUM .EQ. 4) GOTO 440
      IF (FNUM(1).GT.0.05 .AND. FNUM(1).LT.0.95) GOTO 460
      CALL KERF2I (FNUM, MINM, 3)
      WRITE (LIS1, FMT =
     * '('' MIN values: M = '' , 6I3)' ) (MINM(I), I =1,NFNUM)
      IF (NFNUM.GT.3 .OR. NFNUM.LT.1) GOTO 800
      IF (NFNUM.EQ.1 .AND. MINM(1).LE.0) GOTO 800
      IF (NFNUM.EQ.2 .AND. MINM(2).LE.MINM(1)) GOTO 800
      IF (NFNUM.EQ.3 .AND. MINM(3).LE.MINM(2)) GOTO 800
      MININ = NFNUM
      GOTO 177
  440 CALL KERF2I (FNUM, MIN4, 4)
      IF (MIN4(1).LE.0 .OR. MIN4(2).LT.MIN4(1) .OR.
     *    MIN4(3).LT.MIN4(2) .OR. MIN4(4).LT.MIN4(3) )
     *    CALL KERROR('Incorrect MIN - parameters...', 440, 'ORVIN')
      GOTO 177
  460 FVMIN = FNUM(1)
      GOTO 177
  500 CONTINUE
      XBIG = .TRUE.
      WRITE (LIS1, FMT ='('' XBIG parameter for eXtra BIG problem'')')
      GOTO 177
  600 CONTINUE
      DO 610 I = 2, NLIT
      CALL KEREQ6 (LIT(I), PRIMAP, 3, LEND)
      GOTO (601, 602, 603), LEND
      WRITE (CHOUT, FMT='('' Incorrect PRIMAP parameters '')')
      CALL SHOUT
      GOTO 800
  601 IPRPAT = LIS2
      GOTO 610
  602 IPRDEK = LIS2
      GOTO 610
  603 IPRSIG = LIS2
  610 CONTINUE
      WRITE (CHOUT, FMT='('' Print'', A66)') CHIN(7:72)
      CALL SHOUT2
      GOTO 177
  800 CALL KERROR (' Input for ORIENT not correct ', -6 ,'ORVIN')
  900 IF (MPAR .GT. 0) DELC = AMIN1 (10., DELC / FLOAT(MPAR))
  910 IF (DELC .LT. 0.1) DELC=10.
      IF (MPAR .GT. 0) WRITE (LIS1, FMT='(
     *   '' Starting value of DELC (aver. increment C):'',F6.2)') DELC
      CALL FILCLO (ICON, 'KEEP')
      MPARIN = MPAR
      MPARIX = MPAR
      CALL READAT
      RETURN
      END
      SUBROUTINE READAT
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IATMOD, IFILE(2))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (LIS1,   IFILE(7))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(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)
      PARAMETER (MAXAT = 1026)
      COMMON /ATODAT/  NAT, ATXYZ(10, MAXAT), IZAT(MAXAT)
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER *6   ATNAME
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('Error on file ATMOD', -1,'READAT')
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      IF (NAT .LE. 1) CALL KERROR ('Only one atom' , -1, 'READAT')
      CMAX = 360.
      ISM = 0
      IF (LIT(NLIT) .EQ. 'SYMX') ISM = NINT(FNUM(NFNUM))
      IF (ISM .GE. 2) CMAX = CMAX / FLOAT(ISM)
      CHOUT='Starting coords for rotation search (ABC=000) for compound'
      CHOUT(60:65) = CCODE
      WRITE (LIS1, 406)
  406 FORMAT (' Starting Cartesian coordinates for rotation search'/
     *        ' (model with angles A B C = 0 0 0  from file ATMOD)'/
     *        '   Nr  atomnm',5X,'x',7X,'y',7X,'z      Z(At.nr.)' )
      DO 420 I = 1,NAT
      ATXYZ(4,I) = FLOAT(IZAT(I))
      WRITE (LIS1, 410) I, ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I)
  410 FORMAT (I5, 2X, A6, 3F8.3, I5)
  420 CONTINUE
      RETURN
      END
      SUBROUTINE ORVEC
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LDPU,  IFILE(2)), (LIS1,  IFILE(7))
      EQUIVALENCE (LIS2,  IFILE(8)), (IDDL,  IFILE(9))
      EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28))
      LOGICAL NIJM, SWPRI
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(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)
      PARAMETER (MAXAT = 1026)
      COMMON /ATODAT/  NAT, ATXYZ(10, MAXAT), IZAT(MAXAT)
      PARAMETER (MAXVE = 2000)
      COMMON /XKLADX/  TAB(50),
     2             VEX(MAXVE), VEY(MAXVE), VEZ(MAXVE),   VLEN(MAXVE),
     2             WI(MAXVE),  W(MAXVE),   KFLAG(MAXVE), IW(MAXVE)
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION PATP(8)
      PARAMETER (VVMAX = 12.)
      DATA DEL /.01/
      DATA IMAX2, DELY, DEL2Y / 0, 0.0, 0.0 /
      WRITE (LIS2, 110)
  110 FORMAT (' Generate, weight and select vectors')
      CALL LOGRD (IDDL, 'SINGPK', KLOG)
      IF (KLOG.LT.0) CALL KERROR('DDLOG file not available',-1,'VEC')
      IF (KLOG.EQ.0 .OR. NFNUM.NE.3) CALL KERROR
     * ('DDLOG file not correct, SINGPK or ORIGIN missing',-1,'VEC')
      SINGPK = FNUM(2)
      ORIGIN = FNUM(3)
      CALL LOGRD (IDDL, 'PK', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      IF (KLOG.LE.0 .OR. NFNUM.NE.9) CALL KERROR
     *  ('DDLOG file: no peak shape (Rerun Patterson)',-1,'VEC')
      CALL KERNAB (FNUM(2), PATP, 8)
      IF (PATP(1) .LT. .5)
     *   CALL KERROR ('wrong PK SHAPE in DDLOG file', 0, 'VEC')
      DO 120 I = 2, 8
      IF (PATP(I) .LT. 0.) PATP(I) = 0.
      IF (PATP(I-1) .LT. 0.2) THEN
         PATP(I-1) = PATP(I-1) * 0.9
         PATP(I) = AMIN1 (0.99, PATP(I))
         ENDIF
  120 PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I)))
      IF (SWPRI) WRITE (LIS2, 123) PATP
  123 FORMAT ('0Peak profile:  ',
     * 'for x.a = 0.0   0.1   0.2   0.3   0.4   0.5   0.6   0.7   0.8'/
     * 16X, 'shape   = 1.000', 8F6.3 )
      TAB(1) = 1.
      IXL = 0
      I = 2
  136 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX.EQ.IXL) GOTO 137
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 138
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 138
  137 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
  138 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 136
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
      VMAX = VVMAX + 1.
      V2MAX = VMAX**2
      VMIN = 0.7
      IF (NAT.GT.40) VMIN=1.7
      V2MIN = VMIN**2
      NMAXVE = 0
      NVMAX = 0
      NVE = 0
      VMAXAT = 0.1
      DO 350  J = 1, NAT-1
      DO 350 K = J+1, NAT
      IF (NVE .EQ. MAXVE) THEN
         NMAXVE = NMAXVE + 1
         GOTO 350
         ENDIF
      VLEN2 = (ATXYZ(1,K) - ATXYZ(1,J))**2
     *     + (ATXYZ(2,K) - ATXYZ(2,J))**2
     *     + (ATXYZ(3,K) - ATXYZ(3,J))**2
      IF (VLEN2 .GT. VMAXAT) VMAXAT = VLEN2
      IF (VLEN2 .LT. V2MIN) GOTO 350
      IF (VLEN2 .GT. V2MAX) THEN
         NVMAX = NVMAX + 1
         GOTO 350
         ENDIF
          NVE=NVE+1
          VEX(NVE) = ATXYZ(1,K) - ATXYZ(1,J)
          VEY(NVE) = ATXYZ(2,K) - ATXYZ(2,J)
          VEZ(NVE) = ATXYZ(3,K) - ATXYZ(3,J)
          WI(NVE) = ATXYZ(4,J) * ATXYZ(4,K)
          W(NVE) = WI(NVE)
          VLEN(NVE) = SQRT(VLEN2)
      IF (NVE .EQ. 1) GOTO 350
      DO 340 I = 1, NVE-1
      IF (ABS (VLEN(NVE)-VLEN(I)) .GT. 0.1) GOTO 340
      IF (ABS (VEX(NVE)-VEX(I)) .GT. 0.1) GOTO 335
      IF (ABS (VEY(NVE)-VEY(I)) .GT. 0.1) GOTO 335
      IF (    (VEX(NVE)-VEX(I))**2 +
     *        (VEY(NVE)-VEY(I))**2 +
     *        (VEZ(NVE)-VEZ(I))**2 .LE. 0.01) GOTO 338
  335 IF (ABS (VEX(NVE)+VEX(I)) .GT. 0.1) GOTO 340
      IF (ABS (VEY(NVE)+VEY(I)) .GT. 0.1) GOTO 340
      IF (    (VEX(NVE)+VEX(I))**2 +
     *        (VEY(NVE)+VEY(I))**2 +
     *        (VEZ(NVE)+VEZ(I))**2 .GT. 0.01) GOTO 340
  338 WI(I) = WI(I) + WI(NVE)
      W(I) = WI(I)
      NVE = NVE-1
      GOTO 350
  340 CONTINUE
  350 CONTINUE
      IF (NMAXVE .GT. 0) WRITE (LIS1, '(
     * '' Storage problems: nr of vectors skipped:'', I6)') NMAXVE
      IF (NVMAX .GT. 0) WRITE (LIS1, '(
     * '' Number of very large vectors skipped:   '', I4)') NVMAX
      WRITE (LIS1, FMT = '(
     * '' Number of different vectors generated:  '', I4)') NVE
      VMAXAT = SQRT (VMAXAT)
      WRITE (LIS1, 354) VMAXAT
  354 FORMAT (' Longest vector in the model is:',16X, F8.2)
      MF = NVE - 1
      IF (MF.LE.0) GOTO 521
      RMAX1 = SQRT (RMAX2)
      DO 520 MVEC = 1,MF
      DO 520 NVEC = MVEC+1, NVE
      IF (ABS (VLEN(NVEC) - VLEN(MVEC)) .GT. 0.7) GOTO 520
      IF (ABS (VEX(NVEC) - VEX(MVEC)) .GT. RMAX1) GOTO 515
      IF (ABS (VEY(NVEC) - VEY(MVEC)) .GT. RMAX1) GOTO 515
      RR = (VEX(NVEC) - VEX(MVEC))**2
     *   + (VEY(NVEC) - VEY(MVEC))**2
     *   + (VEZ(NVEC) - VEZ(MVEC))**2
      IF (RR .LE. RMAX2) GOTO 518
  515 IF (ABS (VEX(NVEC) + VEX(MVEC)) .GT. RMAX1) GOTO 520
      IF (ABS (VEY(NVEC) + VEY(MVEC)) .GT. RMAX1) GOTO 520
      RR = (VEX(NVEC) + VEX(MVEC))**2
     *   + (VEY(NVEC) + VEY(MVEC))**2
     *   + (VEZ(NVEC) + VEZ(MVEC))**2
      IF (RR .GT. RMAX2) GOTO 520
  518 G = RR/DEL + 1.
      IG = G
      F = G - FLOAT(IG)
      OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
      W(MVEC) = W(MVEC) + OVRLAP * WI(NVEC)
      W(NVEC) = W(NVEC) + OVRLAP * WI(MVEC)
  520 CONTINUE
  521 WTCUT = 3.6
      VMAX = VMAX - 1.
      VMIN = 1.7
      IF (NAT.LT.7) VMIN=0.7
      JMAX = NVE
      NVE = 0
      DO 620 J=1,JMAX
      IF (W(J).LE.WTCUT) GOTO 620
      IF (VLEN(J).GT.VMAX) GOTO 620
      IF (VLEN(J).LT.VMIN) GOTO 620
      NVE = NVE + 1
      VEX(NVE) = VEX(J)
      VEY(NVE) = VEY(J)
      VEZ(NVE)  =VEZ(J)
      W(NVE)=W(J)
      WI(NVE)=WI(J)
      VLEN(NVE)=VLEN(J)
      IF(KWVLEN .GT. 1) W(J) = W(J) * VLEN(J)
      IF(KWVLEN .EQ. 1) W(J) = W(J) * SQRT(VLEN(J))
      IW(NVE) = W(J) * 30.
 620  CONTINUE
      IF (NIJM) WRITE (LIS1, FMT = '(
     * '' Number of independent vectors generated:'', I4)') NVE
      IF (NIJM) WRITE (LIS1, 622) VMIN, VMAX
  622 FORMAT (' Vector length program limitations:  ' , 7X,
     *   F6.2, '-', F5.2 )
      IF (NVE .LE. 0) CALL KERNER (992, 'VEC')
      CALL BSORT5 (IW, VEX, VEY, VEZ, VLEN, NVE)
      DO 630 J=1,NVE
      W(J) = FLOAT(IW(J)) / 30.
      IF(KWVLEN .GT. 1) W(J) = W(J) / VLEN(J)
      IF(KWVLEN .EQ. 1) W(J) = W(J) / SQRT(VLEN(J))
  630 CONTINUE
      IF (.NOT. SWPRI) GOTO 650
      WRITE (LIS2, 632)
  632 FORMAT (' List of VECTORS IN DESCENDING ORDER OF WEIGHTS')
      WRITE (LIS2, 670)
      DO 640 KDES=1,NVE
      K = NVE-KDES+1
  640 WRITE (LIS2, 710) KDES, VEX(K), VEY(K), VEZ(K), W(K), VLEN(K)
  650 SEPN = 0.4
      SEPN2 = 0.16
      IF (SWPRI) WRITE (LIS2, 660) SEPN
  660 FORMAT (' Minimum vector separation is:        ' ,F7.3)
      IF (SWPRI) WRITE (LIS2, 670)
  670 FORMAT (/15X, 4HVECX,4X,4HVECY,4X, 22HVECZ    WEIGHT  LENGTH )
      CALL KERNZI (0, KFLAG, NVE)
      VMAXAT = 0.1
      N = NVE
      MAXV2 = MAXV
      NV = 0
  700 IF (KFLAG(N) .NE. 0) GOTO 800
      NV = NV + 1
      VECTA(1, NV) = VEX(N)
      VECTA(2, NV) = VEY(N)
      VECTA(3, NV) = VEZ(N)
      VECTA(4, NV) = W(N)
      VECTA(5, NV) = VLEN(N)
      IF (VLEN(N).GT.VMAXAT) VMAXAT=VLEN(N)
      IF (SWPRI)
     *   WRITE (LIS2, 710) NV, VEX(N), VEY(N), VEZ(N), W(N), VLEN(N)
  710 FORMAT (' VECTOR', I4, 3F8.3, 2X, 2F8.3)
      IF (NV .EQ. MAXV2) GOTO 810
      J=N-1
      IF (J .EQ. 0) GOTO 810
  720 IF (KFLAG(J).NE.0) GOTO 770
      IF (ABS(VLEN(J) - VLEN(N)) .GE. SEPN) GOTO 770
      IF ( (VEX(J)-VEX(N))**2 + (VEY(J)-VEY(N))**2 + (VEZ(J)-VEZ(N))**2
     *   .LT. SEPN2) GOTO 750
      IF ( (VEX(J)+VEX(N))**2 + (VEY(J)+VEY(N))**2 + (VEZ(J)+VEZ(N))**2
     *   .GE. SEPN2) GOTO 770
  750 KFLAG(J)=1
  770 J=J-1
      IF (J .NE. 0) GOTO 720
  800 N=N-1
      IF (N .GT. 0) GOTO 700
  810 CONTINUE
      IF (NIJM) WRITE (LIS1, 953) NV
  953 FORMAT (' Number of accepted vectors is:' , I14)
      NVECA = NV
      WRITE (LIS1, 954) VMAXAT
  954 FORMAT (' Longest accepted vector is:', 20X, F8.2)
      VMAXAT = VMAXAT + 0.001
      RETURN
      END
      SUBROUTINE BSORT5 (A, B, C, D, E, N)
      DIMENSION A(N),B(N),C(N),D(N),E(N)
      INTEGER A
      INTEGER DEL, BE, DE
      IF (N.LE.1) RETURN
      NA=N-1
      DO 10 I=1,NA
      IF (A(I).LE.A(I+1)) GOTO 10
      T=A(I)
      A(I)=A(I+1)
      A(I+1)=T
      T=B(I)
      B(I)=B(I+1)
      B(I+1)=T
      T=C(I)
      C(I)=C(I+1)
      C(I+1)=T
      T=D(I)
      D(I)=D(I+1)
      D(I+1)=T
      T=E(I)
      E(I)=E(I+1)
      E(I+1)=T
 10   CONTINUE
      DEL=1
 20   IF (DEL.GE.A(N)) GOTO 30
      DEL=DEL+DEL
      GOTO 20
 30   DEL=DEL/2
      IF (DEL.EQ.0) RETURN
      BE=0
      I=1
      DE=DEL
 50   IF (I.GE.N) GOTO 60
      DO 70 L=I,N
      IF (A(L).GE.(DE+DEL)) GOTO 800
 70   CONTINUE
      L=N
      GOTO 800
 60   IF (BE.EQ.0) RETURN
      GOTO 30
 800  IF (L.LE.(I+1)) GOTO 90
      BE=1
      J=L-1
 85   IF (A(J)-DE) 100,110,110
 90   I=L
      DE=DE+2*DEL
      GOTO 50
 100  I=I+1
      IF (I.GT.J) GOTO 90
      IF (A(I-1).LT.DE) GOTO 100
      T=A(I-1)
      A(I-1)=A(J)
      A(J)=T
      T=B(I-1)
      B(I-1)=B(J)
      B(J)=T
      T=C(I-1)
      C(I-1)=C(J)
      C(J)=T
      T=D(I-1)
      D(I-1)=D(J)
      D(J)=T
      T=E(I-1)
      E(I-1)=E(J)
      E(J)=T
 110  J=J-1
      IF (I-J) 85,90,85
      END
      SUBROUTINE EULOUT
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS,IFILE(1)), (IATMOD, IFILE(2))
      EQUIVALENCE (IATOLD,IFILE(10))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (LMINCM, KEYS(17))
      LOGICAL XBIG
      EQUIVALENCE (XBIG, SWITCH(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)
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      PARAMETER (MAXAT = 1026)
      COMMON /ATODAT/  NAT, ATXYZ(10, MAXAT), IZAT(MAXAT)
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER *6   ATNAME
      PARAMETER (M25 = 98)
      DIMENSION RR(3,3), VL(M25), SIG(M25), XMIN(3), RSYMM(3,3,24)
      LOGICAL LARGE
      DATA KSET / 0 /
      IF (LMINCM .GT. 0) THEN
         FOMOR = FLOAT(LMINCM) / 1800.
         WRITE (LIS1, 133) FOMOR
  133    FORMAT (/' $$$ Fig. of Merit for best solution: FOMOR =', F7.4)
         LMINCH = KEYS(18)
         FOMOR = FLOAT(LMINCM) / 1800.
         WRITE (LIS1, 133) FOMOR
         ENDIF
      WRITE (LIS2, 140)
      WRITE (LIS1, 140)
  140 FORMAT (/' Final list of Eulerian angles       FOM=ISIG=100.pe',
     * 'ak/sigma'/ ' Set No.     A         B         C       ISIG '/)
      ISIGT = ISIG(1) * 5 / 10 - 1
      DO 144 I = 1,NPKS
      IF (.NOT. XBIG .AND. I .EQ. 3) ISIGT = ISIG(1) * 7 / 10 - 1
      IF ( XBIG .AND. I .EQ. 25) ISIGT = ISIG(1) * 7 / 10 - 1
      IF (ISIG(I) .GT. ISIGT) KSET = I
      WRITE (LIS2, 145) I, APIK(I), BPIK(I), CPIK(I), ISIG(I)
  144 WRITE (LIS1, 145) I, APIK(I), BPIK(I), CPIK(I), ISIG(I)
  145 FORMAT (I6, 3F10.2, I8)
      IF (KSET .EQ. 0) CALL KERROR(' No results', 0, 'ORIENT')
      REWIND IATMOD
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      WRITE (CHOUT, 148) CCODE
  148 FORMAT (' Output atomic parameters for ', A6, ' to file ATOMS')
      CALL SHOUT2
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3))
      NIP = 1
      WRITE (IATOMS, 149) CCODE, PROGNM, IT, KEYS(13), NIP, ISIG(NIP)
  149 FORMAT ('ATOMS ', A6, ' from pgm ',
     *            A8, ' date', I7, ' RUN', I4, ' OR=', I3, ' ISIG=', I5)
      WRITE (IATOMS,150) NIP, APIK(NIP), BPIK(NIP), CPIK(NIP), ISIG(NIP)
  150 FORMAT ('REMARK xxx atom set',I3,': ABC =',3F7.2,' ISIG =',I5)
      KSETM = 20
      IF (XBIG) KSETM = 37
      KSET = MIN0 (KSETM, KSET)
      WRITE (CHOUT, 160) KSET
  160 FORMAT (' Atom calculation will be called for the following',
     *  I3, ' ABC peaks')
      CALL SHOUT2
      LARGE = .FALSE.
      IF (NAT .GT. M25) LARGE = .TRUE.
      IF (LARGE) GOTO 200
      DO 180 I = 1, NAT
  180 VL(I) = SQRT (ATXYZ(1,I)**2 + ATXYZ(2,I)**2 + ATXYZ(3,I)**2)
      CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM)
  200 KAL = 0
      DO 500 IP = 1, KSET
      IF (NAT + KAL * NAT + NAT .GT. MAXAT) THEN
         WRITE (LIS1, 201)
  201    FORMAT (/' Remaining possible orientations rejected...'/)
         GOTO 501
         ENDIF
      CALL MATABC (APIK(IP), BPIK(IP), CPIK(IP), RR)
      DO 210 I = 1,NAT
      CALL MATXV3 (RR, ATXYZ(1,I), ATXYZ(5,I))
  210 CALL MAT6XV (CART2F, ATXYZ(5,I), ATXYZ(8,I))
      IF (LARGE) GOTO 400
      SIGT = 1.18 * ISIG(IP)
      IF (XBIG) SIGT = 1.05 * ISIG(IP)
      IF (KAL .EQ. 0) GOTO 400
      DO 350 ISYMM = 1, NSYMM
      L = NAT + KAL * NAT + 1
      DO 240 I = 1, NAT
      CALL MATXV3 (RSYMM(1,1,ISYMM), ATXYZ(8,I), ATXYZ(1,L))
  240 L = L + 1
      DO 300 KA = 1, KAL
      IF (SIG(KA) .GT. SIGT) GOTO 300
      L = NAT + KAL * NAT + 1
      ESD = 0.0001
      ESDM = 0.0001
      NESD = 0
      DO 270 I = 1, NAT
      K = KA * NAT + 1
      DO 260 J = 1, NAT
      IF (IZAT(I) .NE. IZAT(J)) GOTO 260
      IF (ABS (VL(I) - VL(J)) .GT. 0.3) GOTO 260
      DMAX = 0.3
      CALL DISTSQ (ATXYZ(1,K), ATXYZ(1,L), DMAX, XMIN, DIST2)
      IF (DIST2 .GT. 99.) GOTO 260
      ESDM = AMAX1 (ESDM, DIST2)
      NESD = NESD + 1
      ESD = ESD + DIST2
      GOTO 270
  260 K = K + 1
      GOTO 300
  270 L = L + 1
      ESD = SQRT (ESD / NAT)
      ESDM = SQRT (ESDM)
      IF (NESD .NE. NAT) CALL KERROR ('MOD 95 fout !', 0, 'EULOUT')
      WRITE (LIS1, 272) IP, KA, ESD, ESDM
      WRITE (LIS2, 272) IP, KA, ESD, ESDM
  272 FORMAT (/' Set No.',I3,' gives the same atoms as set No.', I3/
     * 11X, ' with esd of interatomic distances =' , F5.2, ' Angstrom'/
     * 11X, ' and largest interatomic deviation =' , F5.2, ' Angstrom')
      GOTO 500
  300 CONTINUE
  350 CONTINUE
  400 KAL = KAL + 1
      SIG(KAL) = ISIG(IP)
      WRITE (CHOUT, 402) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP)
  402 FORMAT ('0Set No.', I3,' (ABC =',3F7.2,') with ISIG=', I4)
      CALL SHOUT2
      IF (KAL .EQ. 1) THEN
         WRITE (LIS1, 417)
  417    FORMAT (/' Atomic coordinates (x,y,z)',
     *       ' written to ATOMS file:'/
     *       '   nr.   at.name', 9X, 'x', 8X, 'y', 8X, 'z' )
         DO 420 I = 1, NAT
         WRITE (LIS1, 422) I, ATNAME(I), (ATXYZ(J,I), J = 8,10)
  420    WRITE (IATOMS, 423)  ATNAME(I), (ATXYZ(J,I), J = 8,10)
  422    FORMAT (I6, 3X, A6, 2X, 3F9.5)
  423    FORMAT ('ATOM', 3X, A6, 2X, 3F9.5)
         WRITE (IATOMS, FMT='(''END'')')
         ENDIF
      L = KAL * NAT + 1
      WRITE (LIS2, 426)
  426 FORMAT (/ 8X, 'atom', 8X, 'Cartesian', 15X, 'fractional' /
     *  8X, 'name', 8X,'X',6X,'Y',6X,'Z',9X,'X',8X,'Y',8X,'Z')
      IF (KAL .GE. 2 .AND. .NOT. LARGE) THEN
         NIP = NIP + 1
         WRITE (IATOMS, 149) CCODE, PROGNM, IT, KEYS(13), NIP, ISIG(IP)
         WRITE (IATOMS, 150) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP)
         ENDIF
      DO 430 I = 1, NAT
      IF (.NOT. LARGE) CALL KERNAB (ATXYZ(8,I), ATXYZ(1,L), 3)
      WRITE (LIS2, 428) ATNAME(I), (ATXYZ(J,I), J = 5, 10)
  428 FORMAT (' ATOM', 2X, A6, 2X, 3F7.3, 4X, 3F9.5)
      IF (KAL .GE. 2 .AND. .NOT. LARGE)
     *   WRITE (IATOMS, 423)  ATNAME(I), (ATXYZ(J,I), J = 8,10)
  430 L = L + 1
      IF (KAL .GE. 2 .AND. .NOT. LARGE) WRITE (IATOMS, FMT='(''END'')')
  500 CONTINUE
  501 CONTINUE
      IF (KAL .EQ. 1) THEN
         WRITE (LIS1, 503)
         WRITE (LIS2, 503)
  503 FORMAT (/ ' Atom set 1 is the only acceptable result of ORIENT.'/
     * ' The  parameter set is transferred to TRACOR,' /
     * ' A copy of the parameter set is written to the ATOLD file.' )
      ELSE
         WRITE (LIS1, 510)
         WRITE (LIS2, 510)
  510    FORMAT (/
     * ' The first accepted parameter set is transferred to TRACOR.' /
     * ' All accepted parameter sets are written to the ATOLD file,' /
     * ' for use in case the first set does not lead to the correct'/
     * ' structure.' )
         WRITE (LIS2, 511)
  511    FORMAT (
     * ' Note:' /
     * ' All accepted parameter sets are written to the ATOMS file,' /
     * ' but  DDMAIN + TRACOR are going to use only the first set.')
         ENDIF
      WRITE (IATOMS, FMT= '(''FINISH'')')
      CALL FILCLO (IATMOD, 'KEEP')
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL FILCLO (IATOMS, 'KEEP')
      RETURN
      END
      SUBROUTINE MATABC (AE, BE, CE, R)
      DIMENSION  R(3,3)
      DATA D2R /0.01745329252/
      CA = COS (AE * D2R)
      CB = COS (BE * D2R)
      CC = COS (CE * D2R)
      SA = SIN (AE * D2R)
      SB = SIN (BE * D2R)
      SC = SIN (CE * D2R)
      CALL MATEUL (CA, CB, CC, SA, SB, SC, R)
      RETURN
      END
      SUBROUTINE MATEUL (CA, CB, CC, SA, SB, SC, R)
      DIMENSION  R(3,3)
      R(1,1) = CB
      R(1,2) = SB * SC
      R(1,3) = -SB * CC
      R(2,1) = SA * SB
      R(2,2) = CA * CC - SA * CB * SC
      R(2,3) = SA * CB * CC + CA * SC
      R(3,1) = CA * SB
      R(3,2) =-CA * CB * SC - SA * CC
      R(3,3) = CA * CB * CC - SA * SC
      RETURN
      END
      SUBROUTINE MORV
      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
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, 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 (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IMFUN, IFILE(13))
      EQUIVALENCE (NRUN,  KEYS(5)),   (ITPL,  KEYS(7))
      LOGICAL NIJM
      EQUIVALENCE (NIJM, SWITCH(1))
      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 (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      EQUIVALENCE (ALPH,COSA),(BET,COSB),(GAMM,COSC)
      DATA FACM / 1.0/
      NRUN = NRUN + 1
      WRITE (LIS1, FMT = '(65X,''Cycle'', I2)') NRUN
      WRITE (LIS2, FMT = '(65X,''Cycle'', I2)') NRUN
      CALL KERNZA (0., AAA, 3)
      CALL KERNZA (0., SSS, 3)
      NPOINT = 0
      IF (NRUN .EQ. 1) THEN
      CALL FILINQ (IMFUN, 'MFUN', 'UNFORMATTED', 'OUTPUT', KINQ)
         ITPL=1
         IF (MPAR.GT.0) ITPL=2
         ENDIF
      ITPL = MIN0 (8, ITPL * 2)
      IF (ITPL .NE. 2) THEN
         WRITE (CHOUT, FMT = '('' Patterson function retrieval:'',
     *       I2, ''-point interpolation'') ') ITPL
         CALL SHOUT
      ELSE
         WRITE (CHOUT, FMT = '('' Patterson function retrieval:'',
     *       '' max.  of 8 neighbours'') ')
         CALL SHOUT
         ENDIF
      VMAXXX = 0.
      YZMAX= 0.
      VECMAX = VMAXDE
      IF (VMAXIN .GT. 0.1) THEN
         VMAXIN = AMIN1 (VMAXIN, VMAXDE)
         VECMAX = AMIN1 (VMAXIN, VECMAX)
         ENDIF
      IF (MPARIN .LE. 0) THEN
         IF (NRUN .EQ. 1) VECMAX = AMIN1 (4.6, VECMAX)
         IF (NRUN .EQ. 2) VECMAX = AMIN1 (6.2, VECMAX)
         IF (NRUN .EQ. 3 .AND. VECMAX .GT. 7.5)
     *      VECMAX = AMAX1 (7.5, 0.5* (6.2 + VECMAX))
         ENDIF
      IF (VMAXAT .GT. VECMAX) WRITE (LIS2, FMT = '(
     * '' Max. vector length to be used:'', 9X, F5.2 ) ' ) VECMAX
      NVECB = 0
      DO 205 N = 1, NVECA
      IF (VECTA(5,N) .GT. VECMAX) GOTO 205
      IF (VECTA(5,N) .GT. VMAXXX) VMAXXX = VECTA(5,N)
      YZ = VECTA(2,N)**2 + VECTA(3,N)**2
      IF (YZ .GT. YZMAX) YZMAX = YZ
      NVECB = NVECB + 1
      CALL KERNAB (VECTA(1,N), VECTB(1,NVECB), 4)
  205 CONTINUE
      IF (NVECB .EQ. 0) CALL KERROR
     * ('All vectors too long; use larger VMAX', 205, 'MORV')
      WRITE (LIS1, FMT = '('' Nr of vectors and Max vector length:'',
     *  5X, I3, F11.2 ) ' ) NVECB, VMAXXX
      YZMAX = SQRT(YZMAX)
      IF (NVECB .LT. NVECA) WRITE (LIS2, FMT =
     *   '('' Selected number of vectors:'', I17 ) ') NVECB
      IF (VMAXXX .LT. VECMAX -0.001) THEN
         WRITE (LIS2, FMT =
     *      '('' Longest vector selected ='', 13X, F6.2) ') VMAXXX
         IF (YZMAX .GT. 0.00001) WRITE(LIS2, FMT = '(
     *        '' Longest yz-component ='', 16X, F6.2)' ) YZMAX
         ENDIF
      IF (NRUN .EQ. 1 .AND. MININ .GT. 0)
     *   FACM = AMIN1(1.8, FLOAT(MINM(MININ))/(0.5 * FLOAT(NVECB)) )
      IF (MININ .GT. 0) CALL KERNAI (MINM, MM, MININ)
      IF (NRUN .GT. 1 .AND. MININ .GT. 0) THEN
         MM(MININ) = NINT (FACM * 0.5 * FLOAT(NVECB) +1. )
         IF (MININ .GT. 1) MM(1) = NINT (FACM * 0.4 * FLOAT(NVECB) +1. )
         IF (MININ .EQ. 3) MM(2) = NINT (FACM * 0.45* FLOAT(NVECB) +1. )
         ENDIF
      IF (NRUN .EQ. 2 .AND. MININ .GT. 0) THEN
         MM(MININ) = MIN0 (MM(MININ), 2*MINM(MININ))
         IF (MININ .GT. 1) MM(1) = MIN0 (MM(1), 2*MINM(1))
         IF (MININ .EQ. 3) MM(2) = MIN0 (MM(2), 2*MINM(2))
         ENDIF
      IF (MM(1).GT.0 .AND. MININ.GT.0) GOTO 122
      IF (MIN4(1) .GT. 0) THEN
         MM(1) = MIN4(NRUN)
         GOTO 122
         ENDIF
      IF (FVMIN .GT. 0.) THEN
         MM(1) = FVMIN * FLOAT(NVECB) + 1.0
         GOTO 122
         ENDIF
      MM(1) = 1 + NVECB/4
      MM(2) = 2 + (NVECB-1)/3 + IABS(NVECB-6)/6
      MM(3) = 2 + (NVECB-1)/2
      IF (NVECB .EQ. 1) MM(2) = 0
      IF (NVECB .LE. 4) MM(3) = 0
      IF (NVECB .GT. 15) MM(2) = (MM(1) + MM(3)) / 2
  122 CONTINUE
      MMM = 0
      DO 158 J=1, 3
      IF (MM(J).LE.0) GOTO 159
      MMM = MMM + 1
      IF (MM(J) .LE. NVECB) GOTO 154
      WRITE (LIS2,153)
  153 FORMAT (' MIN(M): M GREATER THEN NUMBER OF VECTORS. RESET.' /)
      MM(J) = NVECB
  154 IF (MM(J) .EQ. NVECB) GOTO 159
  158 CONTINUE
  159 WRITE (LIS2,160) NRUN, (MM(J),J=1,MMM)
  160 FORMAT (' Cycle', I2, '.  Calculation of MIN(M), where M =', 3I4)
      IF (NIJM) WRITE (LIS1, 160) NRUN, (MM(J),J=1,MMM)
      IF (MPAR.EQ.0) CALL PARAMS
      WRITE (LIS2, 202) MPAR
  202 FORMAT (' Number of sets of parameters generated (MPAR):', I5)
      IF (NIJM) WRITE (LIS1,
     *   FMT='('' NIJM: Number of ABS-scans: MPAR='', I3)') MPAR
      IF (MPAR.GE.20) THEN
         WRITE (IPR1, FMT='('' Number of ABS-scans: MPAR='', I3)') MPAR
         ENDIF
      DO 300 IPAR = 1, MPAR
      I = MOD(IPAR, 20)
      IF (I .EQ. 0)
     *   WRITE (IPR1, FMT='('' ... next: ABS-scan number:'', I3)') IPAR
  300 CALL ORV (IPAR)
      TEMP = 0.
      DO 500 I=1, MMM
      AAA(I) = AAA(I) / FLOAT(NPOINT)
      TEMP = TEMP + AAA(I)
      SSS(I) = SSS(I) / FLOAT(NPOINT)
      SSS(I)= SQRT(SSS(I) - AAA(I)**2)
  500 IF (SSS(I) .LE. 1.0) SSS(I) = 1.0
         WRITE (LIS2, FMT ='('' Averages and sigmas for this cycle'' /
     * '' Min(m) average    sigma    for'', I6, '' points:'') ') NPOINT
         WRITE (LIS2, 504) (MM(J), AAA(J), SSS(J), J = 1,MMM)
  504    FORMAT (I6, 2F9.2)
      IF (TEMP.LE.0.001) CALL KERROR (' Min fun map all zeros',
     *  500, 'MORV')
      IF (MPARIN .EQ. 0 .AND. NRUN .LE. 2) RETURN
      DO 600 I = 1, MMM
      SSS(I) = AAA(I) / 3.
  600 AAA(I) = 0.
      RETURN
      END
      SUBROUTINE ORV (IPAR)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IMFUN, IFILE(13))
      EQUIVALENCE (NRUN,  KEYS(5))
      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 (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (IJK = 10 * MAXV + 1)
      DIMENSION CAX(IJK), CAY(IJK), CAZ(IJK), W(IJK),
     *          ABX(IJK), ABY(IJK), ABZ(IJK), WVEPAT(IJK), VEPAT(IJK)
      EQUIVALENCE (CAX(1),VECTB(1,1)), (CAY(1),CAX(2)), (CAZ(1),CAX(3)),
     *            (W(1),VECTB(4,1)),
     *            (ABX(1),VECTB(6,1)), (ABY(1),ABX(2)), (ABZ(1),ABX(3)),
     *            (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION ARG(3)
      DIMENSION RTM(3,3), XCRM(3,3), ABM(3,3), ROTM(3,3)
      LOGICAL BLOK
      DATA NVC  /0/
      BLOK = .FALSE.
      IF (NRUN .GE. 3) BLOK = .TRUE.
      IF (IPAR .EQ. 1) THEN
         REWIND IMFUN
         NVC = NVECB * 10 -9
         ENDIF
      AI = PAR1(1,IPAR)
      BI = PAR1(2,IPAR)
      CI = PAR1(3,IPAR)
      AD = PAR2(1,IPAR)
      BD = PAR2(2,IPAR)
      CD = PAR2(3,IPAR)
      NA = NPAR(1,IPAR)
      NB = NPAR(2,IPAR)
      NC = NPAR(3,IPAR)
      IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) BLOK = .FALSE.
      IF (NC .GT. 65) CALL KERROR ('Nr.points C rot > 65 ', 0, 'ORV')
      NPOINT = NPOINT + NA * NB * NC
      WRITE (IMFUN) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC
      AI = PAR1(1,IPAR) * D2R
      BI = PAR1(2,IPAR) * D2R
      CI = PAR1(3,IPAR) * D2R
      AD = PAR2(1,IPAR) * D2R
      BD = PAR2(2,IPAR) * D2R
      CD = PAR2(3,IPAR) * D2R
      A=AI
      N1 = 1
      GOTO 200
  190 A=A+AD
      N1 = N1 + 1
      IF (N1 .GT. NA) RETURN
  200 SINA=SIN(A)
      COSA=COS(A)
      B=BI
      N2 = 1
      GOTO 300
  290 B=B+BD
      N2 = N2 + 1
      IF (N2 .GT. NB) GOTO 190
  300 SINB=SIN(B)
      COSB=COS(B)
      N3C = 1
      C = CI
      SINC = SIN(C -CD)
      COSC = COS(C -CD)
      CALL MATEUL (COSA, COSB, COSC, SINA, SINB, SINC, ROTM)
      CALL MATMPY (CART2F, ROTM, ABM)
      DO 310 I = 1, NVECB
  310 CALL MATXV3 (ABM, VECTB(1,I), VECTB(6,I))
      CALL ROTMTX (CD, COSB, SINB*SINA, SINB*COSA, ROTM)
      CALL MATMPY (ROTM, FRAC2C, XCRM)
      CALL MATMPY (CART2F, XCRM, RTM)
      GOTO 400
  390 C=C+CD
      N3C = N3C + 1
      IF (N3C .GT. NC) GOTO 700
  400 IVEC = 0
      DO 480 IVE=1,NVC,10
      IVEC = IVEC + 1
      CALL MATXV3 (RTM, VECTB(6,IVEC), ARG)
      CALL KERNAB (ARG, VECTB(6,IVEC), 3)
      CALL RDOUT(ARG,PATF)
      WVEPAT (IVE)=PATF/W(IVE)
      VEPAT(IVE)=PATF
  480 CONTINUE
      CALL ISF (NVC, N3C)
      GOTO 390
  700 WRITE (IMFUN) NC, MMM, ((LMINC(K,N),K=1,NC), N=1,MMM)
      DO 795 J = 1, MMM
      ITOTAL = 0
      ISUMSQ = 0
      DO 792 K=1,NC
      ITOTAL = ITOTAL + LMINC(K,J)
  792 ISUMSQ = ISUMSQ + LMINC(K,J)**2
      AAA(J) = AAA(J) + FLOAT(ITOTAL)
  795 SSS(J) = SSS(J) + FLOAT(ISUMSQ)
      GOTO 290
      END
      SUBROUTINE ISF (NVEC, N3C)
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (IJK = 10 * MAXV + 1)
      DIMENSION W(IJK), WVEPAT(IJK), VEPAT(IJK)
      EQUIVALENCE (W(1),VECTB(4,1)),
     *            (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION LOW(MAXV), SAVP(MAXV)
      DATA  LO  /0/
      SUMP=0.
      SUMW=0.
      MLARGE = MM(MMM)
      DO 770 J=1,MLARGE
      WPLOW=999999.
      DO 760 K=1,NVEC,10
      IF (WVEPAT(K).GE.WPLOW) GOTO 760
      LO=K
      WPLOW=WVEPAT(K)
 760  CONTINUE
      SAVP(J)=WPLOW
      LOW(J)=LO
  770 WVEPAT(LO)=999999.
      K=1
      DO 800 J=1,MLARGE
      L=LOW(J)
      WVEPAT(L)=SAVP(J)
      SUMP=SUMP+VEPAT(L)
      SUMW=SUMW+W(L)
      IF (J .NE. MM(K)) GOTO 800
      LMINC(N3C,K) = 1800. * SUMP / SUMW
      K=K+1
 800  CONTINUE
      RETURN
      END
      SUBROUTINE PARAMS
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (KLAUE,  KEYS(6))
      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 (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      WRITE (LIS2, FMT = '('' Generate scan params. for ORV'' ) ')
      ISPAR = 0
      CI = 5.
      CD = 10.
      NC = CMAX / 9.9
      IF (NVECA .EQ. 1) NC = 1
      BI = 0.
      NB = 1
      IF (KLAUE.EQ.1) NB=2
      AI = 0.
      AD = 60.
      NA = 1
      I = 1
  100 BD = 180. - BI - BI
  111 ISPAR = ISPAR + 1
      MPAR = I
      PAR1(1,I) = AI
      PAR2(1,I) = AD
      NPAR(1,I) = NA
      PAR1(2,I) = BI
      PAR2(2,I) = BD
      NPAR(2,I) = NB
      PAR1(3,I) = CI
      PAR2(3,I) = CD
      NPAR(3,I) = NC
      I = I + 1
      GOTO (100 ,2, 3, 33, 4, 5, 6, 7, 8, 9), I
  2   BI = 9.
      AI = 30.
      NA = 6
      IF (KLAUE.EQ.3) NA = 3
      GOTO 100
  3   BI = 16.
      AI = 0.
      GOTO 100
  33  BI = 22.
      AI = 30.
      GOTO 100
  4   BI = 26.
      AI = 15.
      AD = 30.
      NA = NA * 2
      GOTO 100
  5   BI = 33.
      AI = 0.
      GOTO 100
  6   BI = 40.
      AI = 7.5
      AD = 15.
      NA = NA * 2
      GOTO 100
  7   BI = 50.
      AI = 0.
      GOTO 100
  8   AI = 5.
      AD = 10.
      NA = (NA * 3) / 2
      BI = 60
      NB = 4
      IF (KLAUE.EQ.1) NB=7
      BD = 10.
      GOTO 111
  9   RETURN
      END
      SUBROUTINE ROTMTX (ROT, DCOS1, DCOS2, DCOS3, ROTM)
      DIMENSION ROTM(3,3)
      COSR = COS(ROT)
      COS1 = COSR-1.
      SINR = SIN(ROT)
      T = DCOS1 * COS1
      ROTM(1,1) = COSR - DCOS1 * T
      T1 = DCOS2*SINR
      T2 = DCOS3*SINR
      T3 = -DCOS2*T
      ROTM(1,2) = T3 + T2
      ROTM(2,1) = T3 - T2
      T3 = -T * DCOS3
      ROTM(3,1) = T3 + T1
      ROTM(1,3) = T3 - T1
      ROTM(2,2) = COSR - DCOS2 * DCOS2 * COS1
      T1 = DCOS1 * SINR
      T3 = -DCOS2 * COS1 * DCOS3
      ROTM(2,3) = T3 + T1
      ROTM(3,2) = T3 - T1
      ROTM(3,3) = COSR - DCOS3 * DCOS3 * COS1
      RETURN
      END
      SUBROUTINE MATMPY (RM1,RM2,RM3)
      DIMENSION RM1(3,3),RM2(3,3),RM3(3,3)
      DO 150 J=1,3
      DO 150 K=1,3
      RM3(J,K)=0.
      DO 150 L=1,3
 150  RM3(J,K)=RM3(J,K)+RM1(J,L)*RM2(L,K)
      RETURN
      END
      SUBROUTINE MAPSIG
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1,   IFILE(7)),  (LIS2,   IFILE(8))
      EQUIVALENCE (IMFUN,  IFILE(13)), (IPRSIG, KEYS(10))
      EQUIVALENCE (LMINCM, KEYS(17))
      EQUIVALENCE (NRUN,  KEYS(5))
      LOGICAL NIJM, SWPRI
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION CLABL(65), LISIG(65,3)
      EQUIVALENCE (LISIG(1,1), LMINC(1,1))
      LOGICAL NIJA, BLOK
      BLOK = .FALSE.
      NIJA = NIJM .AND. NRUN.GE.4 .AND. .NOT.SWPRI .AND. IPRSIG.LE.0
      INIT65 = 0
      NREP = 0
      REWIND IMFUN
      IF (IPRSIG .GT. 0) THEN
        WRITE (CHOUT, FMT='('' Write MAPSIG min fun to printer LIS2'')')
         CALL SHOUT2
         WRITE (LIS2, 102) NRUN, TITLE
  102 FORMAT (' MAPSIG MIN. FUNCTIONS  cycle', I2, ' TITLE = ', A64 /)
         ENDIF
      IMIN = 0
      IF (NRUN.GT.1) GOTO 135
      IF (MPARIN.LE.0) THEN
         IMIN = 200
         ENDIF
      IF (NPOINT .LT. 1000) IMIN = NPOINT / 20
      SIGOUT = FLOAT (IMIN) / 100.
      WRITE (LIS2, 131) SIGOUT, IMIN
  131 FORMAT (' Output ABC points:' /
     * ' Function values of the minimun function are output' /
     * ' if SIGOUT (= function value / sigma)  is at least:', F6.2 /
     * ' ISIG (= 100 * SIGOUT) is used as a figure of merit'  /
     * ' The minimum value (=ISIGmin) for the first run is:', I6 )
      IF (IPRSIG .GT. 0) WRITE (CHOUT, 132)
  132 FORMAT (' Printing of min fun maps (skip insignificant lines)'/)
      CALL SHOUT2
  135 CONTINUE
      ISIGM = 0
      NPKS = 0
      DO 990 KPAR = 1, MPAR
      VMINCH = 0.
      READ (IMFUN, END=990) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC
      IPARAV(IPAR) = 0
      IF (KPAR .NE. IPAR) WRITE (LIS1, FMT='('' ??? KPAR/IPAR ???'')')
      MMM3 = MMM
      IF (IPAR .EQ. 1 .AND. SWPRI) THEN
         WRITE (LIS2, FMT = '(/'' Scan parameters'' /
     *                        '' Set No.    Ainit  Aincr     N'', 5X,
     *         ''Binit  Bincr     N'', 5X,''Cinit  Cincr     N'' /)')
         ENDIF
      IF (SWPRI) WRITE (LIS2, FMT = '(I5, 5X, 3(2F7.2, I6, 3X) )')
     *   IPAR, AI, AD, NA, BI, BD, NB, CI, CD, NC
      IF (IPRSIG .GT. 0) THEN
         CC = CI - CD
         DO 700 I=1, NC
         CC = CC + CD
  700    CLABL(I) = CC
         WRITE (LIS2, 748) IPAR, (CLABL(I), I=1,NC)
  748    FORMAT (' Parameter set no. ', I3 /
     *        '   A     B   MIN(M)  MAX    C=',1 9F5.0 / (30X, 19F5.0))
         ENDIF
      IF (NRUN .GE. 3) BLOK = .TRUE.
      IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) BLOK = .FALSE.
      IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) NIJA = .FALSE.
      IF (NIJA) THEN
         CC2 = CI + CD
         CC3 = CC2 + CD
         CC4 = CC3 + CD
         WRITE (LIS1, '(/'' parameter set no.'', I3, ''    C='',
     *      4F6.1 )') KPAR, CI, CC2, CC3, CC4
         ENDIF
      AA = AI - AD
      DO 980 IA=1,NA
      AA = AA + AD
      IF (NIJA) WRITE (LIS1, FMT='(/'' A='',F5.1,
     *   3(6X, ''MIN(M): M='',I3)  )') AA, (MM(J),J=1,MMM)
      BB = BI - BD
      DO 980 IB=1,NB
      BB = BB + BD
      READ (IMFUN) NC, MMM, ((LMINC(K,J), K=1,NC), J=1,MMM)
      IF (NIJA) WRITE (LIS1, FMT='(''  B='',F5.1, 3 (3X,4I4))')
     *   BB, ((LMINC(K,J), K=1,NC), J=1,MMM)
      IF (BLOK) THEN
         IPARAV(IPAR) = IPARAV(IPAR) +
     *       LMINC(1,1) + LMINC(2,1) + LMINC(3,1) + LMINC(4,1)
         IF (IA.EQ.4 .AND. IB.EQ.4) IPARAV(IPAR) = IPARAV(IPAR)/64
         IF (NIJM .AND. IA.EQ.4 .AND. IB.EQ.4) WRITE (LIS1, FMT='(
     *      '' TEMP NIJM average LMINC for IPAR:'', 2I6)')
     *       IPARAV(IPAR), IPAR
         ENDIF
      IMAXJ = 0
      DO 800 J=1, MMM
      DO 800 I=1, NC
      V = LMINC(I,J)
      IV = 100.1 * (V - AAA(J)) / SSS(J)
      LISIG(I,J) = MAX0 (0, IV)
      IF (J .EQ. 1) THEN
         VMINCH = AMAX1(VMINCH, V)
         KEYS(18) = NINT (VMINCH)
         IMAXJ = MAX0 (IMAXJ, IV)
         ENDIF
  800 CONTINUE
      IF (IMAXJ .LT. IMIN) GOTO 980
      IF (IMAXJ .LT. ISIGM) GOTO 862
      ISIGM = IMAXJ
      IMIN = MAX0 (IMIN, ISIGM / 2)
  862 IF (IPRSIG .LE. 0) GOTO 950
      DO 909 J=1,MMM
  907 FORMAT (2F6.1, 2I6, 6X, 19I5 / (30X, 19I5))
  909 WRITE (LIS2, 907) AA, BB, MM(J), IMAXJ, (LISIG(I,J), I=1,NC)
  950 CC = CI - CD
      DO 974 IC = 1, NC
      CC = CC + CD
      IF (LISIG(IC,1) .LT. IMIN) GOTO 974
      NPKS = NPKS + 1
      APIK(NPKS) = AA
      BPIK(NPKS) = BB
      CPIK(NPKS) = CC
      ISIG(NPKS) = LISIG(IC,1)
      DO 972 JSIG = 1, MMM
  972 ISIG3(NPKS,JSIG) = LISIG(IC,JSIG)
      NPIK(NPKS) = IPAR
      IF (NRUN .EQ. 4) THEN
         IJ = NINT ( AAA(MMM) + SSS(MMM) * FLOAT(LISIG(IC,MMM))/ 100.1 )
         IF (IJ .GT. LMINCM) LMINCM = IJ
         ENDIF
  974 CONTINUE
      IF (NPKS .LT. MAXPK-65) GOTO 980
      INIT65 = 0
      IF (NIJM) WRITE (LIS1, FMT=
     *  '('' $$$7 TEMP increase IMIN? Old value:'', I5)') IMIN
  975 INIT65 = INIT65 + 1
      IF (INIT65 .GE. 2) IMIN = 11*IMIN/10
      IF (INIT65 .GE. 2 .AND. NIJM) WRITE (LIS1, FMT=
     *  '('' $$$7 TEMP increase IMIN: new value='', I5)') IMIN
      N = 0
      DO 978 I = 1, NPKS
      IF (ISIG(I) .LT. IMIN) GOTO 978
      N = N + 1
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      ISIG(N) = ISIG(I)
      DO 977 JSIG = 1, MMM
  977 ISIG3(N,JSIG) = ISIG3(I,JSIG)
      NPIK(N) = NPIK(I)
  978 CONTINUE
      NPKS = N
      IF (NPKS .GE. MAXPK-65) GOTO 975
  980 CONTINUE
  990 CONTINUE
      WRITE (LIS2, 992) NPKS, NPOINT
  992 FORMAT (' $$$2 Nr of ABC min-fun points selected:', I4,
     *   ' (out of', I5, ' points)')
      IF (NIJM) WRITE (LIS1, 992) NPKS, NPOINT
      MPAR = 0
      IF (NIJA) WRITE (LIS1, '(
     *   /'' parameter sets to be printed will be reordered !'')')
      RETURN
      END
      SUBROUTINE REGION
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (KLAUE, KEYS(6))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      LOGICAL XBIG
      EQUIVALENCE (XBIG, SWITCH(14))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION LFL(MAXPK)
      EQUIVALENCE (LFL(1),NPIK(1))
      PARAMETER (MXPA = 100)
      DIMENSION
     *      AF(MXPA), BF(MXPA), CF(MXPA), AT(MXPA), BT(MXPA), CT(MXPA),
     *      NPT(MXPA), MAXSIG(MXPA), NUMA(MXPA), NUMB(MXPA), NUMC(MXPA)
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA DEA,DEB,DEC /10.,10.,10./
      DATA MSIGFR /4/
      DATA ISAVE /0/
      DELAB = 12.
      DELCA = 12.
      IF (XBIG) THEN
         DELAB = 9.
         DELCA = 9.
         DELC  = 7.
         ENDIF
      CALL RDMAPS (MSIGFR, NP)
      AMAX = 360.
      IF (KLAUE.EQ.3) AMAX = 180.
      NP2 = 0
      DO 10 I=1,NP
      IF (ABS(BPIK(I)).GT.23. .AND. ABS(180.-BPIK(I)).GT.23.) GOTO 10
      ISIG(I) = ISIG(I) - 9999
      NP2 = NP2 + 1
   10 CONTINUE
      IF (NP2.GT.0) CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      NP = NP - NP2
      CALL KERNZI (0, MAXSIG, MXPA)
      CALL KERNZI (0, NPT, MXPA)
      CALL KERNZI (0, LFL, MAXPK)
      IF (NP.EQ.0) GOTO 830
      NR=0
      NPTOT = 0
      CALL NEBOR (0, NP, DELAB, DELCA, IANSW)
      DO 800 IP=1,NP
      IF(LFL(IP).NE.0) GOTO 800
      IF (NR.GE.50) GOTO 805
      IF (NR.GE.20 .AND. NPTOT.GT.400) GOTO 805
      NR=NR+1
      LFL(IP)=NR
      NPT(NR)=1
      AF(NR)=APIK(IP)
      AT(NR)=APIK(IP)
      BF(NR)=BPIK(IP)
      BT(NR)=BPIK(IP)
      CF(NR)=CPIK(IP)
      CT(NR)=CPIK(IP)
      MAXSIG(NR)=ISIG(IP)
      IF(IP.EQ.NP) GOTO 800
      L=IP+1
      ISW = 1
      DO 700 I=IP,NP
      IF (LFL(I).NE.NR) GOTO 700
      DO 300 NB=L,NP
      IF (NB.EQ.I) GOTO 300
      IF (LFL(NB).NE.0) GOTO 300
      CALL NEBOR (I, NB, DELAB, DELCA, IANSW)
      IF(IANSW.EQ.0) GOTO 300
      LFL(NB) = ISW * NR
      IF (APIK(NB).GT.AT(NR)) AT(NR)=APIK(NB)
      IF (APIK(NB).LT.AF(NR)) AF(NR)=APIK(NB)
      IF (BPIK(NB).GT.BT(NR)) BT(NR)=BPIK(NB)
      IF (BPIK(NB).LT.BF(NR)) BF(NR)=BPIK(NB)
      IF (CPIK(NB).GT.CT(NR)) CT(NR)=CPIK(NB)
      IF (CPIK(NB).LT.CF(NR)) CF(NR)=CPIK(NB)
      NPT(NR) = NPT(NR)+1
      NPTOT = NPTOT + 1
 300  CONTINUE
 700  ISW = -1
      DO 740 I=L,NP
      IF (LFL(I).LT.0) LFL(I)=-LFL(I)
      IF (LFL(I).NE.0) GOTO 740
      IF (APIK(I).LT.AF(NR) .OR. APIK(I).GT.AT(NR)) GOTO 740
      IF (BPIK(I).LT.BF(NR) .OR. BPIK(I).GT.BT(NR)) GOTO 740
      IF (CPIK(I).LT.CF(NR) .OR. CPIK(I).GT.CT(NR)) GOTO 740
      LFL(I) = NR
      NPT(NR) = NPT(NR)+1
      NPTOT = NPTOT + 1
  740 CONTINUE
  800 CONTINUE
  805 CONTINUE
      DELA=DEA/2.
      DELB=DEB/2.
      DELC=DEC/2.
      WRITE (LIS2, 808) DELA,DELB,DELC
  808 FORMAT ('0Prepare new scan parameters for next cycle'/
     *        ' ABC-increments for regions:', 3F6.2)
      IF (SWPRI) WRITE (LIS2, FMT = '(''0Nr.  max.  Nr.points to be''/
     *   '' pts  ISIG  searched for in this region''/
     *   '' ---- ----  ---'')')
      DO 810 IR=1,NR
      AF(IR)=AF(IR)-DELA
      BF(IR)=BF(IR)-DELB
      CF(IR)=CF(IR)-DELC
      NUMA(IR)=ABS(AT(IR)-AF(IR))/DELA+2.1
      NUMB(IR)=ABS(BT(IR)-BF(IR))/DELB+2.1
      NUMC(IR)=ABS(CT(IR)-CF(IR))/DELC+2.1
      I = NUMA(IR) * NUMB(IR) * NUMC(IR)
      CALL STOPAR (AF(IR), BF(IR), CF(IR),
     *   NUMA(IR), NUMB(IR), NUMC(IR), MAXSIG(IR))
  810 IF (SWPRI) WRITE (LIS2, 820) NPT(IR), MAXSIG(IR), I
  820 FORMAT (3I5)
      WRITE (LIS2, 822) (MAXSIG(IR), IR = 1, NR)
  822 FORMAT (' Maximum ISIG found in regions: ', 10I4 / (32X, 10I4))
  830 IF (NP2.EQ.0) GOTO 950
      IF (NP .EQ. 0) THEN
         WRITE (LIS2, 822)
         WRITE (LIS2, FMT='('' ... only polar regions found:'')')
      ELSE
         WRITE (LIS2, FMT='('' ... and for polar regions... '')')
         ENDIF
      NPTOT = 0
      DELB = 2.
      DELC = 4.
      DO 849 I=1,NP2
      IF (NP .EQ. MAXPA) GOTO 920
      NP = NP + 1
      NPT(I) = 1
      MAXSIG(I) = ISIG(NP) + 9999
      IF (I.EQ.1) ISAVE = MAXSIG(I)
      NUMA(I) = 1
      NUMB(I) = 3
      NUMC(I) = 3
      IF (ABS(BPIK(NP)).GT.3. .AND. ABS(180.-BPIK(NP)).GT.3.) GOTO 842
      II = 6
      IF (KLAUE.EQ.3) II=3
      AF(I) = APIK(NP)
      DELA = 60.
      BF(I) = 1.
      IF (ABS(BPIK(NP)).GT.3.) BF(I)=175.
      CF(I) = CPIK(NP) - DELC
      GOTO 843
  842 II = 5
      DELA = 12.5
      AF(I) = APIK(NP) - 2. * DELA
      BF(I) = BPIK(NP) - DELB
      CF(I) = CPIK(NP) - DELC + 2. * DELA
      IF (ABS(BPIK(NP)).GT.12. .AND.ABS(180.-BPIK(NP)).GT.123.) GOTO 843
      BF(I) = BF(I) - 1.
      NUMB(I) = 4
  843 DO 844 J=1,II
      IF (MPAR .EQ. MAXPA) GOTO 920
      CALL STOPAR (AF(I), BF(I), CF(I),
     *   NUMA(I), NUMB(I), NUMC(I), MAXSIG(I))
      NPTOT = NPTOT + NUMA(I) * NUMB(I) * NUMC(I)
      AF(I) = AF(I) + DELA
      CF(I) = CF(I) - DELA
      IF (AF(I).GT.AMAX+5.) THEN
         AF(I) = AF(I) - AMAX
         CF(I) = CF(I) + AMAX
         IF (CF(I) .GT. CMAX+5.) CF(I) = CF(I) - CMAX
         ENDIF
      IF (CF(I) .LT. -5.) CF(I) = CF(I) + CMAX
  844 CONTINUE
  849 CONTINUE
  920 IF (SWPRI) WRITE (LIS2, 820) NP2, ISAVE, NPTOT
      WRITE (LIS2, 922) ISAVE
  922 FORMAT (' Largest value in polar region :', I4)
  950 DELC = DEC / 2.
      RETURN
      END
      SUBROUTINE SIGSEL (DELCX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8))
      LOGICAL XBIG
      EQUIVALENCE (XBIG, SWITCH(14))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA MSIGFR /4/
      DATA IRUN / 0 /
      DATA DELABC /0.0/
      IRUN = IRUN + 1
      IF (IRUN .GT. 1) GOTO 106
      DELABC = 2.
      DELAB  = 9.
      DELCA  = 10.
      IF (XBIG) THEN
         DELAB  = 7.
         DELCA  = 7.
         ENDIF
      IF (MPARIN.LE.0) GOTO 110
      DELABC = 0.4 * DELC
      DELAB = 1.5 * DELC
      DELCA = DELAB
      GOTO 110
  106 MSIGFR = MSIGFR + 1
      IF (XBIG) MSIGFR = MIN0 (MSIGFR, 5)
      DELABC = DELABC * 0.4
      DELAB = DELAB * .75
      DELCA = AMAX1(DELAB, DELCA * .65)
  110 CALL RDMAPS (MSIGFR, NP)
      IF (DELABC.GT.1.9) THEN
         CALL NEBOR  (0, NP, DELAB, DELCA, IANSW)
      ELSE
         CALL NEBORS (0, NP, DELAB, DELCA, CMAX, IANSW)
         ENDIF
      MP = 0
      DO 150 IP = 1,NP
      IF (ISIG(IP).EQ.0) GOTO 150
      MP = MP + 1
      N = IP + 1
      IF (N.GT.NP) GOTO 150
      DO 140 L = N,NP
      IF (ISIG(L).EQ.0) GOTO 140
      IF (DELABC.GT.1.9) THEN
         CALL NEBOR  (IP, L, DELAB, DELCA, IANSW)
      ELSE
         CALL NEBORS (IP, L, DELAB, DELCA, CMAX, IANSW)
         ENDIF
      IF (IANSW.EQ.0) GOTO 140
      ISIG(L) = 0
  140 CONTINUE
  150 CONTINUE
      IF (MP.EQ.NP) GOTO 170
      WRITE (LIS2, 160) MP
  160 FORMAT (' After rejecting neighbors', I4, ' points left')
      CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      NP = MP
      GOTO 180
  170 WRITE (LIS2, 172)
  172 FORMAT (/' No neighbors rejected')
  180 IF (NP .LE. 5)  GOTO 201
      NPMAX = 25
      IF (XBIG) NPMAX = 53
      NPLAST = NP
      IF (NP .GT. NPMAX) NP = NPMAX
      IRUNNP = 2*NP + 10*IRUN + 20
      ISMAX = (MIN0 (IRUNNP, 70) * ISIG(1)) / 100
      IF (XBIG) ISMAX = (MIN0 (IRUNNP, 55) * ISIG(1)) / 100
      DO 184 IP = 2,NP
      IF (ISIG(IP) .LT. ISMAX) GOTO 190
  184 CONTINUE
      GOTO 201
  190 NP = IP - 1
  201 WRITE (LIS2, FMT = '(I6,'' Highest points selected'')')  NP
      WRITE (LIS2, FMT = '(''0Set No.    A      B      C      ISIG'')')
      DO 213 IP = 1,NP
  213 WRITE (LIS2, 214) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP)
  214 FORMAT (I4, 5X, 3F7.2, I7)
      DELA = DELABC
      DELB = DELABC
      DELC = DELABC
      DELCX = DELC
      IF (DELC.LT.0.35 .OR. IRUN.GE.3) THEN
         NPKS = NP
         RETURN
         ENDIF
      WRITE (LIS2,32) NP, DELABC
 32   FORMAT ('0New ABC params,',
     * I4, ' sets, size 4*4*4, step-increments  ', F5.2 )
      NUMA = 4
      NUMB = 4
      NUMC = 4
      DO 900 I=1,NP
      AF = APIK(I) - 1.5 * DELA
      BF = BPIK(I) - 1.5 * DELB
      CF = CPIK(I) - 1.5 * DELC
  900 CALL STOPAR (AF, BF, CF, NUMA, NUMB, NUMC, ISIG(IP))
      RETURN
      END
      SUBROUTINE RDMAPS (MSIGFR, NP)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1,  IFILE(7)), (LIS2,   IFILE(8))
      EQUIVALENCE (NRUN,  KEYS(5))
      LOGICAL SWPRI, NIJM
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DIMENSION KARR(22)
      DATA MAXPKL / 501 /
      MFR = MAX0 (5, MSIGFR)
      MFR = MIN0 (8, MFR)
      WRITE (LIS2, 108) MFR
  108 FORMAT (' Subr. RDMAPS:  ISIG-minimum = maximum *',I2 , '/10')
      ISIGM = 0
      ISIGT = 0
      TSIG = 0.
      DO 150 II = 1, 2
      CALL VALDIS (-1, TSIG, 2000., KARR, 22, KEND)
      N = 0
      LSET = 0
      DO 125 I = 1, NPKS
      IF (ISIG3(I,1) .LT. IMIN) THEN
         IF (NRUN .LE. 2) ISIG(I) = 0
         GOTO 125
         ENDIF
      IF (MMM3 .EQ. 3) THEN
         ISIG(I) = (10*ISIG3(I,1) + 3*ISIG3(I,2) + ISIG3(I,3)) / 14
      ELSEIF (MMM3 .EQ. 2) THEN
         ISIG(I) = (2*ISIG3(I,1) + ISIG3(I,2)) / 3
      ELSE
         ISIG(I) =  ISIG3(I,1)
         ENDIF
      IF (ISIG(I).LT.ISIGT) GOTO 125
      IF (NRUN.LE.2) GOTO 24
      IF (NPIK(I).NE.LSET) GOTO 23
      IF (ISIG(I) .LT. ISIG(N)) GOTO 125
      IF (ISIG(I).GT.ISIG(I-1)) GOTO 22
      APIK(N) = (APIK(N) + APIK(I)) / 2.
      BPIK(N) = (BPIK(N) + BPIK(I)) / 2.
      CPIK(N) = (CPIK(N) + CPIK(I)) / 2.
      GOTO 125
   22 ISIG(N) = ISIG(I)
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      GOTO 125
   23 LSET = NPIK(I)
  24  N = N + 1
      ISIG(N) = ISIG(I)
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      TSIG = ISIG(I)
      CALL VALDIS (0, TSIG, DUMM, KARR, 22, KEND)
      IF (ISIG(I).LE.ISIGM) GOTO 125
      ISIGM = ISIG(I)
      ISIGT = MAX0 (ISIGT, (ISIGM*MFR)/10)
  125 CONTINUE
      NPTS = N
      IF (NPTS .LT. MAXPKL) GOTO 200
      WRITE (LIS2,35) NPTS
   35 FORMAT (' Number of ABC points sent by MAPSIG =', I5)
      IF (II .GT. 1) GOTO 200
      IF (NRUN.GE.3) THEN
         I = 7*ISIGM/10
         IF (I .LT. ISIGT) I = 8*ISIGM/10
         IF (I .GT. ISIGT) THEN
            ISIGT = I
            GOTO 30
            ENDIF
         ENDIF
      CALL VALDIS (MAXPKL-50, TSIG, DUMM, KARR, 22, KEND)
      I = TSIG
      ISIGT = MAX0 (I, ISIGT+1)
      IF (ISIGT.LE.ISIGM) GOTO 30
      ISIGT = ISIGM
   30 WRITE (LIS2,36) ISIGT
   36 FORMAT (' Reset min. value for ISIG to ', I5 )
  150 CONTINUE
  200 NP = N
      CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      ISIGTL = MIN0 (6* ISIG(1) / 10 + 1, ISIGT)
      IF (NIJM) WRITE(LIS1, FMT='('' NIJM result from RDMAPS:'',
     *   '' ISIGmax, ISIGlim: '', 2I4)') ISIG(1), ISIGTL
      DO 2 I = 1, NP
      IF (ISIG(I).LT.ISIGTL) GOTO 3
   2  CONTINUE
      GOTO 4
   3  NP = I - 1
   4  IF (NP .GT. MAXPKL) THEN
         ISIGT = ISIG(MAXPKL)
         NP = MAXPKL
         ENDIF
      NPKS = NP
      ISIGTL = ISIG(NP)
      IF (NIJM) WRITE(LIS1, FMT='('' NIJM result from RDMAPS:'',
     *   '' ISIGmax, ISIGmin: '', 2I4)') ISIG(1), ISIGTL
      IF (NIJM) WRITE (LIS1,37) NP, ISIGT
      WRITE (LIS2,37) NP, ISIGT
   37 FORMAT (I4, ' ABC points selected: new ISIGmin = ', I5)
      MPAR = 0
      IF (.NOT. SWPRI) RETURN
      WRITE (LIS2,37) NP, ISIGT
      DO 40 I=1,NP
   40 WRITE (LIS2,41) I,APIK(I),BPIK(I),CPIK(I), ISIG(I)
   41 FORMAT (I5, 7H  ABC = ,3F7.2, 8H  ISIG =, I5)
      RETURN
      END
      SUBROUTINE  NEBOR (IP, NB, DELAB, DELCA, 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 /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 (LIS2,   IFILE(8))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      IF (IP .GT. 0) GOTO 20
      NP = NB
      WRITE (LIS2, 5) DELAB, DELCA
    5 FORMAT (' Step size for neighbors:    delAB =', F6.2,
     *        '  delCA =', F6.2)
      DO 10 I = 1,NP
      B1 = BPIK(I) * 0.017453
      ASINB(I) = 0.5 * ABS(SIN(B1))
   10 CPLUSA(I) = CPIK(I) + APIK(I)
      GOTO 100
   20 ISW=0
      IF (ABS(BPIK(IP)-BPIK(NB)).GT.DELAB) GOTO 100
      T = ABS(CPLUSA(IP)-CPLUSA(NB))
      IF (T.GT.DELCA) GOTO 100
      T = ASINB(IP) + ASINB(NB)
      IF (ABS (APIK(IP)-APIK(NB))*T.GT.DELAB) GOTO 100
      ISW=1
 100  RETURN
      END
      SUBROUTINE NEBORS (IP, NB, DELAB, DELCA, CMAX, 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 /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 (LIS2,   IFILE(8))
      EQUIVALENCE (KLAUE, KEYS(6))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      DATA AMAX, CAMAX, AMAX2, CAMAX2 / 4 * 0.0/
      IF (IP .GT. 0) GOTO 20
      NP = NB
      WRITE (LIS2, 5) DELAB, DELCA
    5 FORMAT (' Step size for neighbors:    delAB =', F6.2,
     *                                   '  delCA =', F6.2)
      DO 10 I = 1,NP
      B1 = BPIK(I) * 0.017453
      ASINB(I) = 0.5 * ABS(SIN(B1))
   10 CPLUSA(I) = CPIK(I) + APIK(I)
      AMAX = 360.
      IF (KLAUE.EQ.3) AMAX = 180.
      CAMAX = AMIN1(CMAX, AMAX)
      CAMAX2 = CAMAX / 2.
      AMAX2 = AMAX / 2.
      GOTO 100
   20 ISW=0
      KSYM = 0
      IF (ABS(BPIK(IP)-BPIK(NB)).LE.DELAB) KSYM = 1
      IF (ABS(BPIK(IP)+BPIK(NB)).LE.DELAB .OR.
     *    ABS(BPIK(IP)+BPIK(NB) - 360.).LE.DELAB) KSYM = KSYM + 2
      IF (KSYM.EQ.0) GOTO 100
      T = AMOD (ABS(CPLUSA(IP)-CPLUSA(NB)), CAMAX)
      IF (T.GT.CAMAX2) T=ABS(CAMAX-T)
      IF (T.GT.DELCA) GOTO 100
      IF (KSYM.EQ.2) GOTO 50
      TT = ASINB(IP) + ASINB(NB)
      T = AMOD (ABS(APIK(IP)-APIK(NB)), AMAX)
      IF (T.GT.AMAX2) T=ABS(AMAX-T)
      IF (T * TT .LE.DELAB) GOTO 90
 50   IF (KSYM.EQ.1) GOTO 100
      TT = ABS(ASINB(IP) - ASINB(NB))
      T = AMOD (ABS(APIK(IP)-APIK(NB) + 180.), AMAX)
      IF (T.GT.AMAX2) T=ABS(AMAX-T)
      IF (T * TT .GT.DELAB) GOTO 100
  90  ISW=1
 100  RETURN
      END
      SUBROUTINE STOPAR (AI, BI, CI, NA, NB, NC, ISIG)
      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))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      MPAR = MPAR + 1
      PAR1(1,MPAR) = AI
      PAR1(2,MPAR) = BI
      PAR1(3,MPAR) = CI
      PAR2(1,MPAR) = DELA
      PAR2(2,MPAR) = DELB
      PAR2(3,MPAR) = DELC
      NPAR(1,MPAR) = NA
      NPAR(2,MPAR) = NB
      NPAR(3,MPAR) = NC
      IF (SWPRI .AND. MPAR.EQ.1)
     *   WRITE (LIS2, FMT='(16X, ''New ABC parameters''/ 16X,
     *  ''Set   Ast  Ainc NA    Bst  Binc NB    Cst  Cinc NC  ISIG'')')
      IF (SWPRI) WRITE (LIS2, 101)
     *  MPAR, AI, DELA, NA, BI, DELB, NB, CI, DELC, NC, ISIG
  101 FORMAT (I19, 3(F7.2, F6.2, I3), I5)
      RETURN
      END
      SUBROUTINE SORT4 (IX, A, B, C, N)
      DIMENSION IX(N), A(N), B(N), C(N)
      IF (N.LE.1)  RETURN
      K = 2
   10 K = K + K
      IF (K.LT.N) GOTO 10
      K = MIN0 (N, (3*K)/4 - 1)
   20 K = K/2
      L = N-K
      DO 200 II=1,L
      I = II
      J = I+K
      IF (IX(I).GE.IX(J)) GOTO 200
      IT = IX(J)
      AT = A(J)
      BT = B(J)
      CT = C(J)
   80 IX(J)= IX(I)
      A(J) = A(I)
      B(J) = B(I)
      C(J) = C(I)
      J = I
      I = I-K
      IF (I) 140,140,120
  120 IF (IX(I).LT.IT) GOTO 80
  140 IX(J)= IT
      A(J) = AT
      B(J) = BT
      C(J) = CT
  200 CONTINUE
      IF (K.NE.1) GOTO 20
      RETURN
      END
      SUBROUTINE ORDEK
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8)), (IFMAP, IFILE(17))
      EQUIVALENCE (KLAUE,  KEYS(6)),  (IPRPAT, KEYS(8))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(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)
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3))
      EQUIVALENCE (NUMX, NUM(1))
      INTEGER * 2 LPAT(198)
      DIMENSION NXYZM(3)
      EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3))
      DIMENSION ITLE(20)
      EQUIVALENCE (FFTSC, ITLE(18))
      DATA JXYZC, LXYZC / 0, 0 /
      DATA IZ, KXYZC, IXYZC / 0, 0, 0 /
      ILMAX = 49
      DO 111 I = 1, NUMTAB
 111  ITAB(I) = 0
      MAXFUN = 30254
      N254 = 0
      MIFUN = 0
      FUNSUM = 0.
      ILMA = ILMAX
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATIN')
      READ (IFMAP) ITLE, IMAP, IHALF
      IF (SWPRI) WRITE (LIS2, FMT='('' IMAP, IHALF, FFTSC ='',
     *   2I3, F10.5)') IMAP, IHALF, FFTSC
      IF (IMAP .NE. 2 .AND. IMAP .NE. 6) CALL KERROR
     *   ('No Patteron function (error on file FMAP)', 0 , 'PATIN' )
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (LIS2,6) NX, NY, NZ
   6  FORMAT (' Fourier grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = 0.2
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      IF (SWPRI) WRITE (LIS2, 138) FFTSC
  138 FORMAT ('0Input Patterson scale = ',12X, F10.5,' * volume ')
      IF (SWITCH(1)) WRITE (LIS2,1138) FFTSC
 1138 FORMAT (' PTB TEMP Input SCALE: SCALOR  = 3000 / sumF2 =' , F10.5)
      WRITE (LIS2, 152) SCAL, ABSCAL, SINGPK
  152 FORMAT (' Input function values will be multiplied by: ', F10.5 /
     *        ' To put the Patterson function on abs.scale *  ', F9.5 /
     *        ' Single-vector peak-height is approximately   ' ,F10.2 /)
      K = 0
   10 DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (L.GT.ILMAX) K=1
      LXYZ(I) = MIN0 (L, ILMAX)
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .LE. NUMTAB) GOTO 15
          ILMAX = ILMAX - 1
          GOTO 10
   15 IF (ILMA .NE. ILMAX) THEN
         WRITE (CHOUT,16) ILMAX
   16    FORMAT (' STORAGE PROBLEMS: ILMAX = ',I3, ' POINTS. ')
         CALL SHOUT2
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      VMAXDE = 9999.
      DO 18 I=1,3
      VV = (FLOAT(ILMAX) / FLOAT(NXYZ(I))) / RCELL(I)
   18 IF (VV .LT. VMAXDE) VMAXDE = VV
      IF (K .EQ. 1) WRITE (LIS2, 20) VMAXDE
   20    FORMAT (' DEK-storage limitations: max vector length:', F6.2)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (IPRPAT .GT. 0) THEN
         WRITE (CHOUT, FMT=
     *      '('' Print input Patterson map to printer LIS2'')')
         CALL SHOUT2
         WRITE (LIS2,24) (I, I=1, NUMX-1)
  24     FORMAT ('1Input Patterson map, file FMAP'//
     *      '  IY  IZ  IX = 0' , 24I4 / (12X, 25I4))
         WRITE (LIS2, FMT='('' '')')
         ENDIF
      IF (NYM .GT. NYHALF) CHOUT = ' Please tell PTB: NYM gt NYHALF '
      IF (NYM .GT. NYHALF) CALL SHOUT
      IF (NYM .GT. NYHALF) NYM=NYHALF
      DO 50 I1=1,NYM
      IY = I1 - 1
      KY = IY - NY
      IXY = NUM(1) * IY
      KXY = NUM(1) * KY
      K = 1
      IF (IS(2).EQ.0) GOTO 26
      IF (IY .GT. LXYZ(2)) K=3
      IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2
      IF (K.EQ.2 .AND. IY.GT.ILMAX) K=3
      IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1
      IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0
      IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0
      IF (K.EQ.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3
      IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1
      IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0
      IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN = 99. * ( FUN * SCAL + 25. )
      IFUN = NINT(FUN)
      IF (IFUN) 32, 32, 30
   30 IF (IFUN.GT.MIFUN) MIFUN=IFUN
      IF (IFUN .LE. MAXFUN) GOTO 36
      IFUN = MAXFUN
      N254 = N254 + 1
      GOTO 36
   32 IFUN = 0
   36 LPAT(I3) = IFUN
      FUNSUM = FUNSUM + FLOAT(IFUN)
      IX = I3 - 1
      IADR = IXYZC + IX
      ITAB(IADR) = IFUN
      IADR = JXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN
      IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      ITAB(IADR) = IFUN
      IADR = LXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN
   40 CONTINUE
      IF (IPRPAT .GT. 0) WRITE (LIS2,42) IY, IZ, (LPAT(I3), I3=1,NUMX)
   42 FORMAT (2I4, 4X, 25I4 / (12X, 25I4))
   48 CONTINUE
   50 CONTINUE
      IF (ILAUE .EQ.1 .AND. ICENT .EQ. 1) THEN
         CALL FILCLO (IFMAP, 'DELETE')
      ELSE
         CALL FILCLO (IFMAP, 'KEEP')
         ENDIF
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      IFUN = FUNSUM
      WRITE (LIS2,52) MIFUN, N254, MAXFUN, IFUN
   52 FORMAT (' Largest scaled Patterson value is: ', 15X, I5, /
     *         15X, I5,' values exceeded: '  , 13X, I5, /
     *         20X,    ' averaged value is: ', 11X, I5, /)
      CALL PATMOD
      RETURN
      END
      SUBROUTINE PATMOD
      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 SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (LIS2,   IFILE(8))
      EQUIVALENCE (KLAUE,  KEYS(6))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NUMX, NUM(1)), (NUMY,NUM(2)), (NUMZ,NUM(3))
      IF (KLAUE.EQ.1) RETURN
      IF (SWPRI) WRITE (LIS2, FMT = '(
     * ''0Reduce Patterson values of mirror faces'' )')
      GOTO (2,2,3,4), KLAUE
   2  CONTINUE
      DO 22 K = 1,2
      DO 22 L = 1,3
      FF = .85
      IF (K.EQ.1 .OR. L.EQ.2) FF = .75
      IF (K.EQ.1 .AND.L.EQ.2) FF = .5
      IX = K - 1
      IZ = L - 2
      IY = IS(2) - 1
      DO 22 I = 1, NUMY
      IY = IY + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  22  CONTINUE
      GOTO 3
   4  CONTINUE
      DO 440 K = 1,2
      DO 440 L = 1,3
      FF = .85
      IF (K.EQ.1 .OR. L.EQ.2) FF = .75
      IF (K.EQ.1 .AND.L.EQ.2) FF = .5
      IX = K - 1
      IY = L - 2
      IZ = IS(3) - 1
      DO 440 I = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  440 CONTINUE
  3   CONTINUE
      GOTO (20,20,30,40) , KLAUE
  30  DO 31 K=1,2
      IX = K - 1
      FF = .5
      IF (IX.EQ.1) FF=.75
      IY = IS(2) - 1
      DO 31 I = 1, NUMY
      IY = IY + 1
      IZ = IS(3) - 1
      DO 31 J = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  31  CONTINUE
  20  DO 21 K=1,2
      IY = K - 1
      FF = .5
      IF (IY.EQ.1) FF=.75
      IX = IS(1) - 1
      DO 21 I = 1, NUMX
      IX = IX+ 1
      IZ = IS(3) - 1
      DO 21 J = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  21  CONTINUE
      IF (KLAUE.EQ.2) RETURN
  40  DO 41 K=1,2
      IZ = K - 1
      FF = .5
      IF (IZ.EQ.1) FF=.75
      IX = IS(1) - 1
      DO 41 I = 1, NUMX
      IX = IX+ 1
      IY = IS(2) - 1
      DO 41 J = 1, NUMY
      IY = IY + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  41  CONTINUE
      RETURN
      END
      SUBROUTINE RDOUT (ARG, FUNF)
      DIMENSION ARG(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
      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 (ITPL,  KEYS(7))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /  /  NPIK(MAXPK), APIK(MAXPK),  BPIK(MAXPK), CPIK(MAXPK),
     *             ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *             ISIG3(MAXPK,3), MMM3, IMIN, ITAB(NUMTAB)
      INTEGER * 2 ITAB
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      IF (ITPL.EQ.2) GOTO 1000
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNNER * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      IF (ITPL .NE. 4) GOTO 610
      FUNF = AMAX1 (FUNF, 0.25 * (FUNNER + FUNX + FUNY + FUNZ) )
      RETURN
  610 I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      T1=FMYZ-FMXYZ
      T2=FMXZ-FMXYZ
      FUNF = FUNF + FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1 (FMXY-FMXYZ)*FUNXY + FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 - FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
 1000 DO 712 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      I = IFIX(T)
      IF (T.GE.0.) GOTO 711
      I = I - 1
      IF (I.LT.-LXYZ(IX)) I=I+1
      GOTO 712
  711 IF (I.EQ.LXYZ(IX)) I=I-1
  712 INEAR(IX) = I
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      K222 = K111 + 1 + NX + NXY
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + 1)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + NX)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + NXY)
      FUNZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - 1)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - NX)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - NXY)
      FUNXY = FLOAT( IJX ) / 99.
      FUNF= AMAX1(FUNNER, FUNX, FUNY, FUNZ, FUNFAR, FUNYZ, FUNXZ, FUNXY)
      RETURN
      END
      SUBROUTINE SYMM (X, Y, Z)
      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 /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)
      EQUIVALENCE (KLAUE,  KEYS(6))
      GOTO (5, 15, 25, 35), KLAUE
   5  IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      Z = -Z
      RETURN
   15 Y = ABS(Y)
      IF (X.GE.0.0) RETURN
      X = -X
      Z = -Z
      RETURN
   25 X = ABS(X)
      Y = ABS(Y)
      Z = ABS(Z)
      RETURN
   35 Z = ABS(Z)
      IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      RETURN
      END
