PROGRAM POWDER
C POWDER DIAGRAMM INDEXING ROUTINE. MADE BY D.G.TAUPIN ACCORDING TO
C HIS PAPER IN J. APPL. CRYST. (1969) P.179.
C 
C       THE PURPOSE OF THE PRESENT PROGRAM IS TO FIND THE UNIT CELL OF
C A NEW SPECIES, KNOWING ITS ACCURATE X-RAY POWDER DIAGRAM. IT ALLOWS
C FOR POSSIBLE EXTRANEOUS LINES ALTHOUGH THIS RESULTS IN LESS RELIABI-
C LITY AND IN MORE COMPUTING TIME SPENT.
C       THIS ROUITNE IS NOT ADEQUATE FOR CHEMICAL ANALYSIS OF MIXTURES
C CONTAINING SEVERAL SPECIES WHOSE X-RAY PATTERNS ARE KNOWN; ONE SHOULD
C THEN USE POWDER-DATA-FILE SEARCHING ROUTINES LIKE THE JOHNSON-VAND
C PROGRAM DELIVERED BY A.S.T.M..
C 
C ......................................................................
C 
C HOW TO USE THIS PROGRAM
C FIRST CARD :
C=============
C COL 1-12 : OPTION LETTERS ( IN ANY ORDER ) :
C            'Q' MEANS THAT GIVEN LINE DATA ARE EXPRESSED AS 1/D**2
C            'A' MEANS THAT GIVEN LINE DATA ARE MEASURED 2-THETA ANGLES;
C            'A1' MEANS THAT THETA ANGLES ARE TO BE READ
C            'A4' MEANS THAT 4-THETA ANGLES ARE TO BE READ ;
C            'U' MEANS THAT 1/D VALUES ARE TO BE READ
C                DEFAULT FOR THESE OPTIONS IS D(HKL) DATA
C 
C            IN ALL THE ABOVE CASES, THE STATED ERROR IS AN ABSOLUTE
C            ERROR CORRESPONDING TO THE VALUE ACTUALLY READ.
C 
C            'V' MEANS THAT CELLS ARE ACCEPTED ONLY IF THEY CONTAIN AN A
C                PROXIMATELY INTEGER NUMBER OF ASYMETRICAL UNITS OR
C                MOLECULES ; IF THIS OPTION IS TAKEN, THE SECOND CARD
C                MUST CONTAIN ADDITIONAL VALUES FOR THE
C                       - MOLECULAR WEIGHT,
C                       - DENSITY,
C                       - ESTIMATED ERROR ON THAT DENSITY ;
C            'X' OVERRIDES THE NORMAL SELECTION CRITERIUM WHICH MOES
C                THE MINIMUM INFORMATION MERIT TO THE BEST ONE FOUND
C                MINUS 10 (2**-10 MEANS 1 0T00 relative probability).S
C            'C','T','H','O','M','3' MEAN THAT TRIALS MUST BE MADE FOR
C                CUBIC, TETRAGONAL, HEXAGONAL, ORTHORHOMBIC, MONOCLINIC,
C                OR TRICLINIC CELLS RESPECTIVELY ; THESE OPTIONS ARE
C                CUMULATIVE AND IF NONE OF THEM APPEARS THEY ARE ASSUMED
C                TO BE ALL PRESENT ;
C            'P' : store indexed lattices for further use
C            'L' means that only 'P'-lattices are to be sought.
C                otherwise, the programme will also try 'F', 'I', 'S'
C                lattices.
C            'Z' IS ESSENTIALLY A DEBUGGING OPTION WHICH PROVIDES ADDI
C                TIONAL LOGGING AND A PRINTOUT OF THE INDEX TABLES AT
C                THE BEGINNING.
C            'S' SUPPRESSES THE NORMAL REDUNDANCY TEST WHICH REJECTS LATTICES
C                WHOSE BASE LINES HAVE NOT THE SMALLEST ANGLES.
C 
C COL 13-72 : ANY ALPHANUMERIC TITLE WHICH WILL BE PRINTED AT THE TOP OF
C             EACH PAGE ;
C 
C SECOND CARD :
C==============
C ALL THESE VALUES ARE IN "FREE FORMAT", I.E. THEY MAY BE WRITTEN EITHER
C AS INTEGERS OR REAL VALUES SEPARATED BY SPACES OR COMMAS
C THESE VALUES ARE RESPECTIVELY :
C       - NUMBER OF GIVEN EXPERIMENTAL LINES
C       - MAXIMUM NUMBER OF EXTRANEOUS LINES
C       - MAXIMUM DEGENERESCENCE FACTOR : MAXIMUM NUMBER OF ADDITIONAL
C         LINES TO BE USED WHEN THE FIRST ONES LEAD TO A DEGENERATE EQUA
C         TION SYSTEM FOR CELL PARAMETER DETERMINATION (A GOOD VALUE IS
C         2 OR 3)
C       - UPPER LIMIT FOR H**2+K**2+L**2 FOR THE FIRST LINE ( THIS
C         VALUE IS USED TO COMPUTE THE UPPER LIMIT FOR H**2+K**2+L**2 OF
C         THE FOLLOWING LINES, ASSUMING THEY ARE PROPORTIONAL TO
C         Q=1/D**2  --  THIS IS OBVIOUSLY A ROUGHLY APPROXIMATE EXTRAPOLA
C         TION )
C       - MAXIMUM C.P.U. TIME ( MINUTES ); WHEN THIS LIMIT IS EXCEEDED
C         THE PROGRAM WILL SUSPEND ITSELF AND WRITE 2 OR MORE RESTART-
C         ING RECORDS; THIS LIMIT SHOULD BE SMALLER THAN THAT STATED IN
C         THE 'JOB' CARD TO PREVENT IT FROM BEING KILLED BY THE
C         OPERATING SYSTEM. IF NO RESTART FILE OPEN, BUT A PRINT FILE
C         IS ACTIVE, THE PRINT FILE WILL BE CLOSED, AND ANOTHER ONE
C         OF DERIVATED NAME WILL BE OPENED: THEN PERMITS SCRUTINY OF THE
C         PREVIOUS RESULTS AND DECISION TO CONTINUE OR NOT.
C       - MAXIMUM VOLUME OF THE UNIT CELL (ANGSTROEM**3)
C       - THE MINIMAL Information Merit (See D. Taupin's paper in Journal
C         of Applied Crystallography - 1988); USUAL VALUE = 40; HIGHER
C         VALUES MAY BE STATED IF EXPERIMENTAL MEASUREMENTS ARE GOOD.
C    WHEN OPTION 'V' IS PRESENT :
C       - MOLECULAR MASS ( OR MASS OF THE ASYMETRIC UNIT )
C       - DENSITY ( GRAMS/CM**3 )
C       - RELATIVE ESTIMATED ERROR ON THAT DENSITY
C 
C=============> NOTE THAT YOU MAY LEAVE ALL OR PART OF THESE TWO FIRST
C CARDS BLANK OR VOID; THEN THE PROGRAM WILL USE DEFAULT VALUES :
C - ALL SYSTEM TESTED;
C - LINES WILL BE COUNTED TO FIND THEIR EFFECTIVE NUMBER;
C - NO EXTRANEOUS LINES ALLOWED;
C - DEGENERESCENCE FACTOR EQUAL TO 2 ;
C - H**2+K**2+L**2 LIMITED TO 6 FOR THE FIRST LINE;
C - NO TIME LIMIT, THEN NO RESTART ;
C - MAXIMUM VOLUME = 1000 ANGSTROEM**3 ;
C - Minimum Information Merit equal to 40 ;
C 
C Note that blank values must be enclosed between commas since several
C spaces are considered as only one...
C 
C FOLLOWING CARDS :
C==================
C ONE CARD FOR EACH LINE; FREE FORMAT WITH COMMAS OR SPACES AS SEPARATORS
C VALUES ARE RESPECTIVELY AND SUCCESSIVELY
C       - d(hkl) in Angstroems or angle or 1/d or 1/D**2 according to
C         option letters in first card.
C       - ABSOLUTE ESTIMATED ERROR ON THE PREVIOUS VALUE ENTERED;
C         IF THIS VALUE IS BLANK, THEN EXTRAPOLATION IS MADE ASSUMING
C         THE ERROR ON 1/D IS CONSTANT ;
C         THIS ALLOWS THE PROGRAM TO CONTINUE A TRIAL
C         EVEN IF IT WAS NOT ABLE TO ASSIGN INDICES TO THAT LINE; IF
C         ALL LINES HAVE BLANK CHARACTER IN THIS POSITION, ALTHOUGH THE
C         MAXIMUM NUMBER OF EXTRANEOUS LINES IS NON-ZERO, THEN ALL
C         LINES ARE CONSIDERED AS POSSIBLY EXTRANEOUS.
C       -  VALUES OF H, K, L, FOR THAT LINE, IF THEY ARE KNOWN;
C          ONLY 10 LINES ARE ALLOWED TO HAVE H,K,L INDICATIONS.
C       - A 'P' OR A '?' MEANS THAT THIS LINE MAY BE EXTRANEOUS;
C 
C  THE FOLLOWING 8 STATEMENTS ARE COMPUTER DEPENDENT ;
C  'TINTVL'  IS THE COMPUTER TIME INTERVAL AS GIVEN BY BASIC TIMING
C            PROCEDURES ;
C  'KTNUM' IS THE TIME INTERVAL BETWEEN TWO TIME CHECKS ( FOR ANY
C            PATHOLOGICAL LOOPING DETECTION - IN 'CONTRL' SUBR..
C            IT IS SET TO 4 SECONDS ON THE IBM 360/195.
C  'INPUT' IS THE NORMAL STANDARD INPUT UNIT
C  'IRREST' is the unit on which save/restart data will be written/read;
C  'IPUNCH' IS THE UNIT ON WHICH RESULTS WILL BE PUNCHED (OR STORED)
C 
C ALLOWS FOR CONVERSATIONAL OR COMMAND DEFINITION OF DATA FILES
C 
C WORKING STORAGE FOR COMMAND DECODING
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      CHARACTER*1 DUMMY,DATTIM*30
C 
      IPRNT=6
      ISUMRY=99
      ITERM=6
      CMDBUF=' '
      CMDBUF=' '
      DO IXK=1,IARGC()
        FNAME=' '
        CALL GETARG(IXK,FNAME)
        CALL APPEND(CMDBUF,FNAME)
        CALL APPEND(CMDBUF,',')
      END DO
      IXK=0
      IPRNT=4
      IF(ITERM .NE. 0) WRITE(ITERM,11)
11    FORMAT('  '/' X-Ray Powder Diagram Indexing Routine, by Danie',
     $ 'l TAUPIN, C.N.R.S.')
      IF(ITERM .NE. 0) CALL VERSION(ITERM)
C TINTVL WILL BE GIVEN BY AN ASSEMBLER ROUTINE, CONNECTED TO "ELAPSE"
      CALL GETITV(TINTVL)
      KTNUM=NINT(10.0/TINTVL)
      INPUT=5
      IRREST=9
      IPUNCH=7
      ILOGF=8
C 
C OPENING FILES (MAY BE MACHINE DEPENDENT)
C 
C get the name of the input file, first field in command string
C require it if missing.
C 
      CALL CMDGET(CMDBUF,FNAME,1)
20    CONTINUE
      IF(FNAME .EQ. ' ') THEN
        IF(IXK .EQ. 0) THEN
          IF(ITERM .NE. 0) WRITE(ITERM,*)
     $   'Please give the name of the input file'
     $     ,', (DELETE to quit):_'
          READ 21,FNAME
21        FORMAT(A)
          CALL LJSTRG(FNAME)
          GO TO 20
        ELSE
          IF(ITERM .NE. 0) WRITE(ITERM,*) 'No input file given.'
          STOP
        END IF
      END IF
      IF(FNAME .NE. ' ') THEN
        CLOSE(INPUT)
        OPEN(INPUT,FILE=FNAME,STATUS='OLD',IOSTAT=IERR)
        IF(IERR .NE. 0) THEN
          IF(IXK .EQ. 0) THEN
            IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'open code',IERR,' for ',FNAME(:ITRIML(FNAME))
     $       ,', please give another name'
            FNAME=' '
            GO TO 20
          ELSE
            IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'open code',IERR,' for ',FNAME(:ITRIML(FNAME))
            STOP
          END IF
        END IF
      END IF
C 
C get the name of the save/restore file. If none continue
C without save/restore
C 
      CALL CMDGET(CMDBUF,RNAME,3)
      IF(RNAME .EQ. ' ') THEN
        IRREST=0
        IF(ITERM .NE. 0) WRITE(ITERM,*) 'No restore/save file'
      ELSE
        OPEN(IRREST,FILE=RNAME,STATUS='OLD',IOSTAT=IERR)
        IF(IERR .NE. 0) THEN
          IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'save/restore file does not exist, I create it'
          OPEN(IRREST,FILE=RNAME,STATUS='UNKNOWN',IOSTAT=IERR)
          IF(IERR .NE. 0) THEN
            IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'unable to create save/restore file:',IERR
            STOP
          END IF
          WRITE(IRREST,29)
29        FORMAT(' '/' '/' '/' '/' '/' '/' ')
        END IF
        CLOSE(IRREST)
      END IF
C 
C now get the name of the LOG/SUMMARY FILE
C if none, skip summarizing
C 
      CALL CMDGET(CMDBUF,LOGFIL,4)
      IF(LOGFIL .NE. ' ') THEN
        OPEN(ILOGF,FILE=LOGFIL,STATUS='UNKNOWN',IOSTAT=IERR)
        IF(IERR .NE. 0) THEN
          ILOGF=0
          IF(ITERM .NE. 0) WRITE(ITERM,*) 'Log file unavailable:',IERR
        ELSE
          IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'Summary on file ',LOGFIL(:ITRIML(LOGFIL))
          LOGCON=0
770       CONTINUE
          READ(ILOGF,'(A)',END=771,ERR=771) DUMMY
C$        PRINT *,DUMMY
          LOGCON=LOGCON+1
          GO TO 770
771       CONTINUE
          IF(LOGCON .EQ. 0) THEN
            WRITE(ILOGF,10)
            CALL VERSION(ILOGF)
            CALL FRTIMC(DATTIM)
            WRITE(ILOGF,*) 'Execution at ',DATTIM
          END IF
        END IF
      ELSE
        ILOGF=0
        IF(ITERM .NE. 0) WRITE(ITERM,*)
     $     'No log file stated, no log written'
      END IF
C 
C get the name of the print output file.
C if none, continue printing on standard device
C 
      CALL CMDGET(CMDBUF,PRTFIL,2)
      IF(PRTFIL .NE. ' ') THEN
        CLOSE(IPRNT)
        NUMSWP=0
        OPEN(IPRNT,FILE=PRTFIL,STATUS='NEW',IOSTAT=IERR)
        IF(IERR .NE. 0) CALL PRTSWP(IPRNT,PRTFIL,.FALSE.)
        IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'Output on file ',PRTFIL(:ITRIML(PRTFIL))
        IF (ITERM .NE. 0) CLOSE(ITERM)
        WRITE(IPRNT,10)
10    FORMAT('1 '//' X-Ray Powder Diagram Indexing Routine, by Danie',
     $ 'l TAUPIN, C.N.R.S.')
        CALL VERSION(IPRNT)
      ELSE IF(ITERM .NE. 0) THEN
        IPRNT=ITERM
      ELSE
        IPRNT=6
      END IF
C 
C  Open a 80 col. summary file to meet GGJ's needs
      CALL CMDGET(CMDBUF,LOGFIL,5)
      IF(LOGFIL .NE. ' ') THEN
        ISUMRY=99
        OPEN(ISUMRY,FILE=LOGFIL,STATUS='UNKNOWN',IOSTAT=IERR)
        IF(IERR .EQ. 0) THEN
          IF(ITERM .NE. 0) WRITE(ITERM,*)
     $    'Summary on file ',LOGFIL(:ITRIML(LOGFIL))
        ELSE
          ISUMRY=0
        END IF
      ELSE
        ISUMRY=0
      END IF
C 
C NOW CALL THE EFFECTIVE MAIN ROUTINE : 'PWMAIN'
C 
      CALL PWMAIN
      CALL GCLOSE(0)
      STOP
      END
      SUBROUTINE GCLOSE(IFLG)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      IF(ILOGF .NE. 0) THEN
        WRITE(ILOGF,*) TITLE
        IF(IFLG .EQ. 0) THEN
          WRITE(ILOGF,9983) FWMAXI
        ELSE
          WRITE(ILOGF,9984) FWMAXI
        END IF
9983    FORMAT(' ********** end of analysis ********** best merit: ',
     $         F8.3,' **********')
9984    FORMAT(' -------- Programme suspended -------- best merit: ',
     $         F8.3,' ----------')
        CALL HEURE(ILOGF)
        WRITE(ILOGF,*)
        CLOSE(ILOGF)
      END IF
      IF(IPRNT .NE. 6) CLOSE(IPRNT)
      STOP
      END
      SUBROUTINE PRTSWP(IUNIT,FILE,ISWFLG)
      IMPLICIT INTEGER(A-Z)
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      LOGICAL ISWFLG
      CHARACTER*(*) FILE
      CHARACTER*60 NFILE
C 
      IF(IUNIT .LE. 0) RETURN
      ZPT=INDEX(FILE,'.')
      ZBL=INDEX(FILE,' ')
      IF(ZPT .EQ. 0) ZPT=ZBL
      IF(ZPT .EQ. 1) RETURN
C 
      IF(NUMSWP .EQ. 0) THEN
        NFILE=FILE(:ZPT-1)//'_001'//FILE(ZPT:)
      ELSE
        NFILE=FILE
        WRITE(NFILE(ZPT-3:ZPT-1),'(I3.3)') NUMSWP+1
      END IF
      NUMSWP=NUMSWP+1
C 
      IF(ISWFLG) THEN
C prints elapsed c.p.u. times in MANAGE and CONTRL, and the total
      WRITE(IUNIT,*)
     $    'printout continued on file ',NFILE(:ITRIML(NFILE))
      CLOSE(IUNIT)
      END IF
777   OPEN(IUNIT,FILE=NFILE,STATUS='NEW',IOSTAT=IERR)
      IF(IERR .NE. 0) THEN
        IF(NUMSWP .LT. 999) THEN
          ZPT=INDEX(NFILE,'.')
          ZBL=INDEX(NFILE,' ')
          IF(ZPT .EQ. 0) ZPT=ZBL
          WRITE(NFILE(ZPT-3:ZPT-1),'(I3.3)') NUMSWP+1
          NUMSWP=NUMSWP+1
          GO TO 777
        END IF
        ZBL=ITRIML(NFILE)
        IF(ITERM .NE. 0)
     $      WRITE(ITERM,*) 'Unable to open ',NFILE(:ZBL),IERR
        STOP
      END IF
      IF(ISWFLG) WRITE(IUNIT,*)
     $     'printout continued from file ',FILE(:ITRIML(FILE))
      FILE=NFILE
      IF(ISWFLG) CALL HEURE(IPRNT)
      RETURN
      END
       SUBROUTINE PWMAIN
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      CALL PWRDA
C 
C APPEL DES SOUS PROGRAMMES POUR CHAQUE SYSTEME ESSAYE
C 
      SYMSYM='FIABCP'
      FAKOND(1)=4
      FAKOND(2)=2
      FAKOND(3)=2
      FAKOND(4)=2
      FAKOND(5)=2
      FAKOND(6)=1
      MASK(1)=1
      DO 50 I=2,6
      MASK(I)=2*MASK(I-1)
50    CONTINUE
C 
C TRY SUCCESSIVELY ALL 6 SYSTEMS
C 
      DO 9980 ISYSTM=1,6
C run hexagonal before tetragonal
      IF(ISYSTM .EQ. 2) THEN
        NUMSYS=3
      ELSE IF(ISYSTM .EQ. 3) THEN
        NUMSYS=2
      ELSE
        NUMSYS=ISYSTM
      END IF
      IF(.NOT. INDICN(NUMSYS)) GO TO 9980
C loop over Bravais lattices
      IF(INDICN(11)) THEN
        KLATS=6
      ELSE
        KLATS=1
      END IF
      DO 60 KLAT=KLATS,6
      IF(.NOT. TOMAKE(NUMSYS,KLAT)) GO TO 60
      NLAT=KLAT
      TROUVE=.TRUE.
      ISYS=' '
      IF(NUMSYS .EQ. 1) THEN
          CALL CUBIC(SYMSYM(KLAT:KLAT))
      ELSE IF(NUMSYS .EQ. 3) THEN
          CALL HEXAGO(SYMSYM(KLAT:KLAT))
      ELSE IF(NUMSYS .EQ. 2) THEN
          CALL TETRAG(SYMSYM(KLAT:KLAT))
      ELSE IF(NUMSYS .EQ. 4) THEN
          CALL ORTHOR(SYMSYM(KLAT:KLAT))
      ELSE IF(NUMSYS .EQ. 5) THEN
          CALL MONOCL(SYMSYM(KLAT:KLAT))
      ELSE IF(NUMSYS .EQ. 6) THEN
          CALL TRICLI(SYMSYM(KLAT:KLAT))
      END IF
C 
C neutralize for the case of a restart
C 
      TOMAKE(NUMSYS,KLAT)=.FALSE.
C 
      IF(ISYS .NE. ' ') THEN
        IF(.NOT. TROUVE) THEN
           WRITE(IPRNT,9989) TITLE,ISYS
           IF(ISUMRY .NE. 0) WRITE(ISUMRY,19989) TITLE,ISYS
        ELSE
           WRITE(IPRNT,9988) TITLE,ISYS,FWMAXI
           IF(ISUMRY .NE. 0) WRITE(ISUMRY,19988) TITLE,ISYS,FWMAXI
        END IF
      END IF
9989  FORMAT(///1X,A/1X,48('*'),' Not ',A,' system ',1X,48('*'))
19989 FORMAT(///1X,A/1X,4('*'),' Not ',A,' system ',1X,4('*'))
9988  FORMAT(///1X,A/1X,38('*'),' ',A,' system, best merit: ',
     $        F7.1,1X,38('*'))
19988 FORMAT(///1X,A/1X,3('*'),' ',A,' system, best merit: ',
     $        F7.1,1X,3('*'))
60    CONTINUE
9980  CONTINUE
C 
C FIN DU TRAITEMENT POUR CE RESEAU
C 
      CALL SAVERS(0)
      RETURN
      END
      SUBROUTINE PWRDA
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      LOGICAL UU,ERRORS
      REAL MMOL
      CHARACTER*1 ILET(NOPT),LLET(NOPT)
      CHARACTER*8 GFORMT
      CHARACTER*128 F3001
      CHARACTER*(KDIGIT) DALPHA,VALPHA,PALPHA,PALPHB
      CHARACTER*12 OTAB,CVALUE
      CHARACTER*144 INPLIN
      CHARACTER*1 CARD(72)
      EQUIVALENCE (INPLIN,CARD)
      LOGICAL ITOT
      REAL DONNEE(NGENDA)
      LOGICAL DESORD
      CHARACTER*30 DATTIM
      CHARACTER*4 DATKEY(NGENDA)
      CHARACTER*18 MHKLIB
C 
C DATA
C 
      DATA ILET/'C','T','H','O','M','3','Q','P','V','X','L','Z',
     $ 'A','1','4','S','U',3*'#'/
      DATA LLET/'c','t','h','o','m','3','q','p','v','x','l','z',
     $ 'a','1','4','s','u',3*'#'/
      DATA DONNEE/NGENDA*0.0/
      DATA DATKEY/'NLIN','NEXT','NDEG','INDX','CPUX','VMAX','INFM',
     $  'MOLM','DENS','DERR','WLTH','ERSC','CHIM','AMAX','AMIN','BMMX',
     $  'AOFF','XHIT' /
C 
C END DATA
C 
      CALL CHTABL
      ERRORS=.FALSE.
      ULOG2=-1.0/LOG(2.0)
      CALL RTIMER
      KSTART=0
C 
      CALL FRTIMC(DATTIM)
      CALL HEURE(IPRNT)
      WRITE(IPRNT,556) DATTIM
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,556) DATTIM
556   FORMAT(1X,'*** ',A,' ***' /' List of DATA records :')
C 
C LECTURE DE LA PREMIERE CARTE (OPTIONS, TITRE)
C 
      INPLIN=' '
      READ(INPUT,555,END=9999) INPLIN(1:72)
      DO 10 IZ=1,12
      IF(CARD(IZ) .NE. ' ') GO TO 11
      CARD(IZ)='@'
10    CONTINUE
11    CONTINUE
      IENDZ=INDEX(INPLIN,' ')
      IF(IENDZ .EQ. 0) IENDZ=LEN(INPLIN)
      IENDY=INDEX(INPLIN,',')
      IF(IENDY .EQ. 0) IENDY=LEN(INPLIN)
      IENDZ=MIN(IENDZ,IENDY)
      OTAB=INPLIN(:IENDZ)
      TITLE=INPLIN(IENDZ+1:)
      WRITE(IPRNT,*) OTAB,':',TITLE(:ITRIML(TITLE))
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,*) OTAB,':',TITLE(:ITRIML(TITLE))
       DO 2352 I=1,NOPT
       INDICN(I)=.FALSE.
2352  CONTINUE
      DO 2351 I=1,12
      DO 2351 J=1,NOPT
      IF(OTAB(I:I).EQ.ILET(J))    INDICN(J)=.TRUE.
      IF(OTAB(I:I).EQ.LLET(J))    INDICN(J)=.TRUE.
2351  CONTINUE
      ITOT=.FALSE.
      DO 3351 I=1,6
3351  ITOT=ITOT .OR. INDICN(I)
      IF(.NOT. ITOT) THEN
        DO 3352 I=1,6
3352    INDICN(I)=.TRUE.
      END IF
      DO 3355 I=1,6
      DO 3355 J=1,6
      TOMAKE(I,J)=INDICN(I)
3355  CONTINUE
C 
C LECTURE DE LA DEUXIEME CARTE EN FORMAT LIBRE :
C 
      INPLIN='  '
      KK=1
333   READ(INPUT,'(A)',END=9999) INPLIN(KK:MIN(KK+72,LEN(INPLIN)))
      KK=ITRIML(INPLIN)
      IF(INPLIN(KK:KK) .EQ. '-') GO TO 333
555   FORMAT(A72)
      CALL UPPERS(INPLIN)
      CALL BLKOMA(INPLIN)
C 
C   DONNEE(..).
C LES 15 'CHAMPS' DE LA DEUXIEME CARTE SONT STOCKES EN REEL DANS
C 
      WRITE(IPRNT,*) INPLIN(:ITRIML(INPLIN))
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,*) INPLIN(:ITRIML(INPLIN))
C 
C are data introduced by keywords ?
C 
      DO 334 IZ=1,NGENDA
      CALL KEYEXT(INPLIN,DATKEY(IZ)//'=',CVALUE,' ',',')
      CALL FREEFT(CVALUE,DONNEE(IZ),1)
334   CONTINUE
C 
      CALL FREEFT(INPLIN,GENDAT,NGENDA)
      DO 335 IZ=1,NGENDA
      IF(DONNEE(IZ) .NE. 0.0) GENDAT(IZ)=DONNEE(IZ)
335   CONTINUE
C 
      NQ=NINT(GENDAT(1))
      NQEFF=0
      NBMAX=NINT(GENDAT(2))
      NDEGEN=NINT(GENDAT(3))
      IF(NDEGEN .EQ. 0) NDEGEN=2
      INDMAX=NINT(GENDAT(4))
      IF(INDMAX .EQ. 0) INDMAX=-20
      TIMMAX=NINT(60.0*ABS(GENDAT(5)))
      TIMQTM=TIMMAX
      IF(TIMMAX .EQ. 0) TIMMAX=1.0E6
      IF(TIMQTM .EQ. 0) TIMQTM=60           ! dt 03-jan-1991
      TMINUT=GENDAT(5)
      VMAXI=GENDAT(6)
      IF(VMAXI .LT. 1.E-2) VMAXI=1000.0
      FWMINI=GENDAT(7)
      IF(FWMINI .EQ. 0) FWMINI=80
      MMOL=GENDAT(8)
      DENS=GENDAT(9)
      ETA=GENDAT(10)
      WL(0)=GENDAT(11)
      IF(INDICN(9)) THEN
        VMOL=MMOL/(0.6023*DENS)
      END IF
C 
      IF(GENDAT(12) .EQ. 0) THEN
        CHIORG=1
      ELSE
        CHIORG=GENDAT(12)
      END IF
C 
      IF(GENDAT(13) .EQ. 0) THEN
        CHIMIN=0.1
      ELSE
        CHIMIN=GENDAT(13)
      END IF
C 
      PARMAX=GENDAT(14)
      PARMIN=GENDAT(15)
      NBMMX=NINT(GENDAT(16))
C 
      MAXHIT=NINT(GENDAT(18))
      IF(MAXHIT .EQ. 0) MAXHIT=9999
      IF(NBMMX .EQ. 0) NBMMX=128
C 
      NDEGEN=MIN(JMAX,NDEGEN)
      ERRD=0
      DTWO(0)=0
      TWOT(0)=0
      NCON=0
C 
C LECTURE DES RAIES
C 
       INDICN(13)=INDICN(13) .AND. .NOT. INDICN(7)
       INDICN(15)=INDICN(15) .AND. INDICN(13)
       INDICN(14)=INDICN(14) .AND. INDICN(13)
       DO 2401 I=1,NQMAX
       ICON(I)=0
 2411 READ(INPUT,555,END=2404) INPLIN
      WRITE(IPRNT,557) I,(INPLIN(J:J),J=1,ITRIML(INPLIN))
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,557)
     $    I,(INPLIN(J:J),J=1,ITRIML(INPLIN))
557   FORMAT(1X,I4,': ',80A1)
      IF(INPLIN .EQ. '  ') GO TO 2411
      CERT(I)=.TRUE.
      K=INDEX(INPLIN,'P')
      IF(K .NE. 0) THEN
        CERT(I)=.FALSE.
C 
      IF(.NOT. INDICN(13) .AND. GENDAT(17) .NE. 0) THEN
        PRINT *,'angular offset not zero, ',
     $  'but input data are Q''s or d''s. Offset ignored.'
        GENDAT(17)=0
      END IF
        CARD(K)=' '
      END IF
      K=INDEX(INPLIN,'p')
      IF(K .NE. 0) THEN
        CERT(I)=.FALSE.
        CARD(K)=' '
      END IF
      K=INDEX(INPLIN,'?')
      IF(K .NE. 0) THEN
        CERT(I)=.FALSE.
        CARD(K)=' '
      END IF
      CALL BLKOMA(INPLIN)
      NQEFF=I
      CALL FREEFT(INPLIN,DONNEE,7)
      VAL=DONNEE(1)
      DVAL=DONNEE(2)
      RH=DONNEE(3)
      RK=DONNEE(4)
      RL=DONNEE(5)
      WL(I)=DONNEE(6)
      H=NINT(RH)
      K=NINT(RK)
      L=NINT(RL)
      IF(H .NE. RH) THEN
          H=0
          K=0
          L=0
          WL(I)=DONNEE(3)
      END IF
      IF(WL(I) .LE. 0) WL(I)=WL(I-1)
      IF(INDICN(13)) THEN
C LES DONNEES SONT LES ANGLES
        IF(INDICN(14)) THEN
           TWOT(I)=2*(VAL+GENDAT(17))
           DTWO(I)=2*DVAL
        ELSE IF(INDICN(15)) THEN
           TWOT(I)=0.5*(VAL+GENDAT(17))
           DTWO(I)=0.5*DVAL
        ELSE
           TWOT(I)=(VAL+GENDAT(17))
           DTWO(I)=DVAL
        END IF
        IF(WL(I) .LE. 0)  THEN
          WRITE(IPRNT,*) 'Angles given, but no wavelength.'
          IF(ISUMRY .NE. 0) WRITE(ISUMRY,*)
     $     'Angles given, but no wavelength.'
          STOP
       END IF
        IF(DTWO(I) .LE. 0) DTWO(I)=DTWO(I-1)
        SINTH=SIN((PI/360.0)*TWOT(I))
        COSTH=COS((PI/360.0)*TWOT(I))
        D(I)=0.5*WL(I)/SINTH
        Q(I)=1./D(I)**2
      ELSE
        IF(INDICN(7)) THEN
C LES DONNEES SONT LES Q
           Q(I)=VAL
           D(I)=SQRT(1./VAL)
        ELSE IF(INDICN(17)) THEN
C LES DONNEEES SONT LES 1/D
           D(I)=1./VAL
           Q(I)=VAL**2
        ELSE
C LES DONNEES SONT LES D
          D(I)=VAL
          Q(I)=1./VAL**2
        END IF
        IF(WL(I) .LE. 0) WL(I)=D(1)/2048.0
        SINTH=WL(I)*0.5/D(I)
        IF(SINTH .LE. 0 .OR. SINTH .GE. 1) THEN
          WRITE(IPRNT,2416) D(I),Q(I),WL(I)
          IF(ISUMRY .NE. 0) WRITE(ISUMRY,2416) D(I),Q(I),WL(I)
          ERRORS=.TRUE.
2416      FORMAT(' LINE D=',G14.6,' 1/D**2=',G14.6,' INCONSISTENT WITH',
     $      ' WAVELENGTH=',G14.6)
          SINTH=0.9999
        END IF
        COSTH=SQRT(1-SINTH**2)
        TWOT(I)=ATAN2(SINTH,COSTH)*(360.0/PI)
        ERRD=DVAL/VAL
        IF(INDICN(7)) ERRD=0.5*ERRD
        IF(ERRD .GT. 0) THEN
           DTWO(I)=(360./PI)*ERRD*SINTH/COSTH
        ELSE
          DTWO(I)=DTWO(I-1)
        END IF
C CALCUL DE EPS(I) DANS TOUS LES CAS
      END IF
      EPS(I)=2*Q(I)*COSTH*DTWO(I)*PI/(360.*SINTH)
      IF(H**2+K**2+L**2 .GT. 0) THEN
        CERT(I)=.TRUE.
        IF(MAX(IABS(H),IABS(K),IABS(L)) .GE. 10)
     $  WRITE(IPRNT, 2419) VAL,DVAL,H,K,L,WL(I)
        IF(MAX(IABS(H),IABS(K),IABS(L)) .GE. 10 .AND.
     $     ISUMRY .NE. 0) WRITE(ISUMRY, 2419) VAL,DVAL,H,K,L,WL(I)
2419    FORMAT(/' EXCESSIVE GIVEN H,K,L, PROBABLY MISTYPED'/
     $     2F10.5,1X,3I3,F10.5/1X)
        IF(NCON .LT. JMAX) THEN
          NCON=NCON+1
          HKLCON(1,NCON)=H
          HKLCON(2,NCON)=K
          HKLCON(3,NCON)=L
          ICON(I)=NCON
        END IF
      END IF
2401  CONTINUE
2404  CONTINUE
      CLOSE(INPUT)
C 
C FIN DE LA LECTURE DES RAIES
C 
       IF(NQ .EQ. NQEFF .OR. NQ .EQ. 0) GO TO 2405
       WRITE(IPRNT,2407 ) NQ,NQEFF
       IF(ISUMRY .NE. 0) WRITE(ISUMRY,2407 ) NQ,NQEFF
 2407  FORMAT(/' WARNING :',I4,' LINES STATED BUT ONLY',I4,' FOUND.'/)
       ERRORS=.TRUE.
 2405  NQ=NQEFF
       KNQ=(NQ+2)/3
       IF(NQ .EQ. 0) GO TO 2600
C SI NBMAX.NE.0.AND.TOUS LES CERT(I).TRUE.=METTRE TOUS LES CERT=.FALSE
       IF(NBMAX.EQ.0) GO TO 2451
       DO 2450 I=1,NQ
       IF(.NOT.CERT(I)) GO TO 2451
 2450  CONTINUE
       DO 2452 I=1,NQ
 2452  CERT(I)=.FALSE.
 2451  CONTINUE
C 
C CLASSEMENT DES RAIES PAR ANGLE CROISSANT
C 
 2402  CONTINUE
       IF(WL(0) .LE. 0) WL(0)=WL(1)
       DESORD=.FALSE.
       NQQ=NQ
       DO 2403 I=1,NQQ
      IF(Q(I) .LE. 0) GO TO 2409
      IF(EPS(I) .LE. 0) GO TO 2502
       IF(I .EQ. 1) GO TO 2403
      IF(Q(I)-Q(I-1))12,2409,2403
   12  CONTINUE
       U=Q(I)
       Q(I)=Q(I-1)
       Q(I-1)=U
       U=D(I)
       D(I)=D(I-1)
       D(I-1)=U
       U=EPS(I)
       EPS(I)=EPS(I-1)
       EPS(I-1)=U
       UU=CERT(I)
       CERT(I)=CERT(I-1)
       CERT(I-1)=UU
       KK=ICON(I)
       ICON(I)=ICON(I-1)
       ICON(I-1)=KK
       U=TWOT(I)
       TWOT(I)=TWOT(I-1)
       TWOT(I-1)=U
       U=DTWO(I)
       DTWO(I)=DTWO(I-1)
       DTWO(I-1)=U
       U=WL(I)
       WL(I)=WL(I-1)
       WL(I-1)=U
       DESORD=.TRUE.
       GO TO 2403
 2409  WRITE(IPRNT, 2510) D(I),Q(I)
       IF(ISUMRY .NE. 0) WRITE(ISUMRY, 2510) D(I),Q(I)
 2510  FORMAT(/' THE LINE D=',G14.6,', 1/D**2=',G14.6,' IS ZERO OR',
     $ 'DUPLICATE. DROPPED FOR FURTHER LISTING.')
       GO TO 2511
2502  WRITE(IPRNT, 2503) D(I),Q(I)
      IF(ISUMRY .NE. 0) WRITE(ISUMRY, 2503) D(I),Q(I)
 2503  FORMAT(/' THE LINE D=',G14.6,', 1/D**2=',G14.6,' HAS ZERO OR',
     $ 'INCONSISTENT MAXIMUM DEVIATION STATED. DROPPED')
 2511  ERRORS=.TRUE.
       IF(I .GE. NQ) GO TO 2507
       IP1=I+1
       DO 2506 J=IP1,NQ
       D(J-1)=D(J)
       Q(J-1)=Q(J)
       CERT(J-1)=CERT(J)
       EPS(J-1)=EPS(J)
       ICON(J-1)=ICON(J)
       WL(J-1)=WL(J)
       TWOT(J-1)=TWOT(J)
       DTWO(J-1)=DTWO(J)
 2506  CONTINUE
 2507  CONTINUE
       NQ=NQ-1
       IF(NQ) 2600,2600,2402
2403   CONTINUE
       IF(DESORD) GO TO 2402
2600   CONTINUE
C 
C FIN DU CLASSEMENT. MAINTENANT, LES VERIFICATIONS
C 
       DO 2500 I=1,NCON
       MCON(I)=0
       DO 2501 J=1,NQ
       IF(ICON(J) .EQ. I) THEN
         MCON(I)=J
         GO TO 2500
       END IF
 2501  CONTINUE
 2500  CONTINUE
C 
C before printing, build convenient formats for printing (without
C using G specifications which is often too wide for compact printouts.
C 
      DMAXI=D(1)
      QMAXI=Q(NQ)
      DFORMT=GFORMT(DMAXI)
      PFORMT=GFORMT(PARMAX)
      VFORMT=GFORMT(VMAXI)
      QFORMT=GFORMT(QMAXI)
C 
C IMPRESSION DES DONNEES DU PROBLEME
C 
       WRITE(IPRNT,30000) TITLE
30000  FORMAT('1 '//30X,A60//45X,'List of Experimental lines'   /
     $/' ',3('  2-theta   1/D**2      D    Er(1/D**2)   ')/)
       IF(NQ .GT. 2) GO TO 2520
       ERRORS=.TRUE.
       WRITE(IPRNT,2521)
2521   FORMAT(/' INSUFFICIENT NUMBER OF LINES'/)
       IF(N .EQ. 1) EPS(2)=EPS(1)
      IF(N .EQ. 1) Q(2)=Q(1)
2520  CONTINUE
      VDOTSF='   .....'
      F3001='(1X,2(F8.3,'//QFORMT//','//DFORMT//','//QFORMT//
     $   ',1X,L1,'' *''),F8.3,'//QFORMT//','//DFORMT//','//QFORMT//
     $   ',1X,L1)'
       DO 530 I=1,KNQ
530    WRITE(IPRNT,F3001)
     $    (TWOT(J),Q(J),D(J),CHIORG*EPS(J),CERT(J),J=I,NQ,KNQ)
C 
      WRITE(DALPHA,DFORMT) WL(0)
      WRITE(PALPHA,PFORMT) PARMAX
      WRITE(PALPHB,PFORMT) PARMIN
      WRITE(VALPHA,VFORMT) VMAXI
      IF(GENDAT(4) .GT. 0) THEN
        MHKLIB='for H**2+K**2+L**2'
      ELSE
        MHKLIB='missing lines   < '
      END IF
C 
      WRITE(IPRNT,30002) NQ,NBMAX,NDEGEN,MHKLIB,ABS(INDMAX),TMINUT,
     $   VALPHA,PALPHA,PALPHB,FWMINI,DALPHA,CHIORG,CHIMIN,NBMMX,MAXHIT
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,30002)
     $     NQ,NBMAX,NDEGEN,MHKLIB,ABS(INDMAX),TMINUT,
     $   VALPHA,PALPHA,PALPHB,FWMINI,DALPHA,CHIORG,CHIMIN,NBMMX,MAXHIT
30002  FORMAT(/' Number of experimental lines .......=',I10/
     $        ' Maximum number of extraneous lines .=',I10 /
     $        ' Degenerescence index ...............=',I10/
     $        ' Maximum ',A,'(1st line)=',I10/
     $        ' Maximum C.P.U. time (minutes) ......=',F10.2/
     $        ' Maximum given unit cell volume......=',A/
     $        ' Maximum lattice parameter...........=',A/
     $        ' Minimum lattice parameter...........=',A/
     $        ' Minimum ''Information Merit''.........=',F10.2/
     $        ' Default wavelength..................=',A/
     $        ' Error scale factor..................=',F10.4/
     $        ' Minimum error scale factor..........=',F10.4/
     $        ' Maximum bad merit lattices..........=',I10/
     $        ' Maximum possible lattices bef. quit.=',I10/
     $ )
       NBMAX=MAX(NBMAX,0)
       WRITE(VALPHA,VFORMT) VMOL
       IF(INDICN(9)) WRITE(IPRNT, 30003) VALPHA,MMOL,DENS,ETA
       IF(INDICN(9) .AND. ISUMRY .NE. 0) WRITE(ISUMRY, 30003)
     $     VALPHA,MMOL,DENS,ETA
30003 FORMAT(/' MOLECULAR VOLUME   (ANGSTROEM**3) ..=', F10.4 /
     $        ' MOLECULAR MASS .....................=',  F10.2/
     $        ' EXPERIMENTAL DENSITY  ..............=',  F10.4 /
     $        ' ESTIMATED ERROR ON DENSITY .........=',G10.3 /
     $ )
      VMMIN=MAX((CHIORG*EPS(NQ))**3,1/VMAXI**2)
      VMAXI=1./SQRT(VMMIN)
      WRITE(VALPHA,VFORMT) VMAXI
      WRITE(IPRNT,30004) VALPHA
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,30004) VALPHA
30004 FORMAT(/' Max. reasonable vol. for UNIT CELL..=', A)
      IF(ERRORS) GO TO 9998
C 
      Q(0)=0
      Q(NQ+1)=Q(NQ)+CHIORG*EPS(NQ)
C 
      NB=NBMAX+1
      DO 115 K=1,NB
      I=NQ-K-1
      IF(CERT(I)) GO TO 116
 115  CONTINUE
116   QMCERT=Q(I)
C 
      DO 68 I=1,JMAX
  68  JDEP(I)=1
      DO 681 J=1,JMAX
      DO 681 I=1,MAXCSE
 681  NCAUSE(I,J)=0
C 
C       LECTURE DES CARTES DE REPRISE SUR L'UNITE 'IRREST'
C       ELLES SERONT IGNOREES SI TOUS LES INDICATEURS SONT FAUX.
C 
      DOREST=.FALSE.
      CALL RESTRS
      NBHITS=0
C 
C PREPARATION DE LA TABLE DES PAIRES DE LIMITES POUR LE VOLUME RECIPROQU
C CORRESPONDANT EFFECTIVEMEMT A DES NOMBRES ENTIERS DE MOTIFS.
C 
      NMOMAX=0
      IF(INDICN(9)) THEN
        VMOL=VMOL
        NMOMAX=NINT(1+SQRT(1/VMMIN)/VMOL)
        NMOMAX=MIN(NMOMAX,NMOLIM)
        DO 122 NK=1,NMOMAX
        DV2R=2*ETA+3*CHIORG*EPS(2)/Q(2)
        VLIMI(NK)=(1./(NK*VMOL)**2)*(1-DV2R)
        VLIMS(NK)=(1./(NK*VMOL)**2)*(1+DV2R)
122     CONTINUE
      END IF
      RETURN
C 
9999  WRITE(IPRNT,*) 'Unexpected end of data'
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,*) 'Unexpected end of data'
9998  WRITE(IPRNT,  9997)
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,  9997)
9997  FORMAT(/'  DATA ERRORS, NO EXECUTION '/)
      STOP
      END
      SUBROUTINE FREEFT(LIGNE,ODATA,NDATA)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      CHARACTER*(*) LIGNE
      REAL ODATA(NDATA)
      CHARACTER*16 EDATA
C 
      DO 1 I=1,NDATA
      CALL CMDGET(LIGNE,EDATA,I)
      IF(EDATA .EQ. ' ') THEN
        ODATA(I)=0.0
      ELSE
        IF(INDEX(EDATA,'.') .EQ. 0) THEN
          IZL=ITRIML(EDATA)
          IF(IZL .LT. 16) EDATA(IZL+1:IZL+1)='.'
        END IF
        READ(EDATA,'(F16.0)',ERR=199) ODATA(I)
      END IF
1     CONTINUE
      RETURN
199   CONTINUE
      WRITE(IPRNT,*) 'Invalid free format real value: ',EDATA
      STOP
      END
      SUBROUTINE CMDGET(CMD,FLD,N)
      IMPLICIT NONE
C 
C PLACE DANS FLD LE N-IEME CHAMP DE LA COMMANDE CMD
C 
      CHARACTER*(*) CMD,FLD
      CHARACTER*1 CH
      INTEGER N,I,K,LC,LF,IVIRNO
C 
      FLD=' '
      LF=LEN(FLD)
      LC=LEN(CMD)
      IVIRNO=0
      K=0
      DO 1 I=1,LC
      CH=CMD(I:I)
      IF(CH .EQ. ',') THEN
          IVIRNO=IVIRNO+1
          IF(IVIRNO .GE. N) GO TO 900
      ELSE IF(CH .EQ. ' ') THEN
          GO TO 900
      ELSE IF(IVIRNO .EQ. N-1) THEN
          IF(K .LT. LF) THEN
            K=K+1
            FLD(K:K)=CH
          END IF
      END IF
1     CONTINUE
900   CONTINUE
      RETURN
      END
      FUNCTION FVDMER(FMERIT)
C compute the quantity chi_r*volume corresponding to the merit FMERIT
C 
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      REAL CHVTAB(3),MERTAB(3)
C 
C (1) is supposed to have the smallest merit and highest volume
C 
      CHVTAB(1)=1/SQRT(VMMIN)
      CHVTAB(2)=0.75*CHVTAB(1)
      CHVTAB(3)=0.5*CHVTAB(1)
      MERTAB(1)=0
      MERTAB(2)=0
      MERTAB(3)=0
      DO 1000 IZ=1,16
      DO 1001 I=1,3
      IF(MERTAB(I) .EQ. 0) MERTAB(I)=FMERVD(CHVTAB(I))
1001  CONTINUE
      IF(MERTAB(3) .LT. FMERIT) THEN
        MERTAB(1)=MERTAB(3)
        CHVTAB(1)=CHVTAB(3)
        MERTAB(3)=0
        CHVTAB(3)=0.5*CHVTAB(3)
        MERTAB(3)=FMERVD(CHVTAB(3))
      ELSE IF(MERTAB(1) .GT. FMERIT) THEN
        MERTAB(3)=MERTAB(1)
        CHVTAB(3)=CHVTAB(1)
        MERTAB(1)=0
        CHVTAB(1)=2*CHVTAB(1)
        MERTAB(1)=FMERVD(CHVTAB(1))
      ELSE
        CHVTAB(2)=0.5*(CHVTAB(1)+CHVTAB(3))
        MERTAB(2)=FMERVD(CHVTAB(2))
        IF(MERTAB(2) .LT. FMERIT) THEN
          CHVTAB(1)=CHVTAB(2)
          MERTAB(1)=MERTAB(2)
        ELSE
          CHVTAB(3)=CHVTAB(2)
          MERTAB(3)=MERTAB(2)
        END IF
      END IF
1000  CONTINUE
      FVDMER=CHVTAB(2)
      RETURN
      END
      FUNCTION FMERVD(VOLUME)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      FMU=FAKOND(NLAT)/FRACT
      PWINFO=0
      DO 536 I=1,NQ
      EXPONT=2*EPS(I)*2*PI*VOLUME/(FMU*D(I))
      IF(ABS(EXPONT) .LT. 0.00001) THEN
        PWINFO=PWINFO+LOG(EXPONT)
      ELSE IF(EXPONT .GT. 50) THEN
        PWINFO=PWINFO-EXP(-EXPONT)
      ELSE
        PWINFO=PWINFO+LOG(1-EXP(-EXPONT))
      END IF
536   CONTINUE
      FMERVD=PWINFO*ULOG2
      RETURN
      END
      SUBROUTINE MANAGE
C 
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      PARAMETER (MAMDIM=NINCMX+JMAX1)
      INTEGER CAUSE
      INTEGER JHMAX(JMAX1),MTMAX(JMAX1)
      COMMON/AACOMN/AM(MAMDIM,0:NINCMX),AASUPN(NINCMX),AAINFN(NINCMX),
     $   AW(MAMDIM,0:NINCMX)
      INTEGER NEQ(0:JMAX1)
      INTEGER MPIV(NINCMX),INEQ(JMAX1)
C 
C compute merit/volume correspondence table for max. devs.
C 
C!    WRITE(IPRNT,7744) NCMAX,IHKL
C! 7744  FORMAT(' ncmax:',I5,'  IHKL:',I5/(1X,20I5))
      NTSKIP=0
      VOLMER(0)=1E20
      FMU=FAKOND(NLAT)/FRACT
      VMAXIT=1/SQRT(VMMIN)
      DO 535 IV=1,NVOLMR
      VOL=(VMAXIT*IV)/NVOLMR
      VOLMER(IV)=FMERVD(VOL)
      VOLTAB(IV)=VOL
535   CONTINUE
      VOLTAB(0)=0
      VOLMER(0)=VOLMER(1)*2
C 
      CHIFAC=CHIORG
C 
      RIEN=CHIORG*EPS(1)/100
      ABRIEN=ABS(RIEN)
      NMAX=MIN(JMAX,NQ,NINC+NDEGEN)
      IF(.NOT. DOREST) THEN
        DO 1440 J=1,JMAX1
        DO 1440 I=1,MAXCSE
1440    NCAUSE(I,J)=0
      ELSE
        FWMINI=FWMINR
        FWMAXI=FWMAXR
        DO 1441 J=0,NR
        JDEP(J)=JDEPR(J)
1441    CONTINUE
      END IF
C 
      CHIVOX=FVDMER(FWMINI)
      VMAXI=CHIVOX/CHIMIN
      VMMIN=MAX(VMMIN,1/VMAXI**2)
      VMAXI=1/SQRT(VMMIN)
C 
C First, eliminate trials of given index combinations which
C have already been checked
C 
       DO 1141 I=1,NPERMU
       DO 1142 NN=1,NCON
       IF(JCON(NN) .NE. JNT(NN,I)) GO TO 1141
1142   CONTINUE
       RETURN
1141   CONTINUE
C 
C if not already, store it...
      NPERMU=NPERMU+1
      IF(NPERMU .LT. NPERMR .AND. DOREST) RETURN
      DOREST=.FALSE.
      NPERMR=0
C 
      DO 1139 NN=1,NCON
      JCONN=JCON(NN)
      JHMAX(NN)=JCONN
      MTMAX(NN)=MCON(NN)
      INDK(NN)=HKLT(1,JCONN)**2+HKLT(2,JCONN)**2+HKLT(3,JCONN)**2
1139  JNT(NN,NPERMU)=JCONN
C 
C compute maximum offset between N and actual line taken, due to possible
C uncertain lines interleaved within the base set.
C 
      INB=0
      DO 1138 NN=NCON+1,NMAX
1161  CONTINUE
      IF(.NOT. CERT(MIN(NQ,NN+INB)) .AND. INB .LT. NBMAX) THEN
        INB=INB+1
        GO TO 1161
      END IF
      MTMAX(NN)=MIN(NQ,NN+INB)
      IF(GENDAT(4) .GT. 0) THEN
        INDK(NN)=MIN(NCMAX,INT(ABS(INDMAX)*Q(MTMAX(NN))/Q(1)+1.0001))
        JHMAX(NN)=IHKL(INDK(NN))
      ELSE
        JHMAX(NN)=NINT(ABS(INDMAX)*EXP(1.5*LOG(Q(MTMAX(NN))/Q(1))))
        JHMAX(NN)=MIN(JHMAX(NN),NTMAXE)
        JHMXN=JHMAX(NN)
        INDK(NN)=HKLT(1,JHMXN)**2+HKLT(2,JHMXN)**2+HKLT(3,JHMXN)**2
      END IF
1138  CONTINUE
C 
      WRITE(IPRNT,5580) TITLE,ISYS
5580   FORMAT('1 '/' ',A/' Trying lattice ',A)
      IF(NCON .NE. 0) THEN
        WRITE(IPRNT,4999)
4999    FORMAT(/'  Some line(s) have KNOWN indices')
        DO 4997 N=1,NCON
        WRITE(IPRNT,4998)
     $    HKLCON(1,N),HKLCON(2,N),HKLCON(3,N),MCON(N),JCON(N)
4998    FORMAT(' ---------',3I4,' --> ',2I4)
4997    CONTINUE
      END IF
C 
      WRITE(IPRNT,30044) (I,INDK(I),JHMAX(I),
     $   HKLT(1,JHMAX(I)),HKLT(2,JHMAX(I)),HKLT(3,JHMAX(I)),I=1,NMAX)
30044 FORMAT(/' Upper limits for the INDICES of base lines:'/
     $     (' Line No.',I2,',  H**2+K**2+L**2 <=',I3,
     $     ', intern. ref. <=', I4,',  h k l : ',3I4))
C 
      IDK=(NVOLMR+4)/4
      IF(INDICN(12)) THEN
        WRITE(IPRNT,*)
     $    ' Unit cell volume <--> Information merit table'
        DO 538 K=0,IDK-1
        WRITE(IPRNT,539) (I,VOLTAB(I),VOLMER(I),I=K,NVOLMR,IDK)
538     CONTINUE
539     FORMAT(1X,4(I3,F10.3,F12.5,2X))
      END IF
C 
      WRITE(IPRNT,*)
      WRITE(IPRNT,*)
     $    'minimum merit:',FWMINI,'  -->  maximum chi_r*volume:',
     $      CHIVOX
      WRITE(IPRNT,*) 'computed error scale factor:',CHIFAC
      WRITE(IPRNT,*) 'maximum cell volume:',VMAXI
      WRITE(IPRNT,*)
C 
C N=NIVEAU DE VARIATION
C JN=JT(N)=INDEX DANS LA TABLE H2T ESSAYE AU NIVEAU N
C AM(X,NEQ)=ETAT DE LA MATRICE DE RESOLUTION AU NIVEAU N
C AM(NINC+J,NEQ)=ETAT DES SECONDS MEMBRES FORMES AU NIVEAU N
C 
      NEQ(0)=0
      VSUP2(0)=0
      CHIFCN(0)=CHIFAC
      DO 801 K=1,MAMDIM
      AM(K,0)=0
801   CONTINUE
C 
C!
C!
      ZFRACT=INDK(1)
      WRITE(IPRNT,*) 'ratio Q(1) / min(A,B,C) = ',ZFRACT
      DO 9 I=1,NINC
      IF(GENDAT(15) .EQ. 0) THEN
        IQREF=       MIN(NQ,NMAX+NBMAX)
        AASUP(I,0)=Q(IQREF)
      ELSE
        AASUP(I,0)=1.0/PARMIN**2
        IF(NINC .GT. 3) AASUP(I,0)=AASUP(I,0)*1.5
      END IF
      IF(I .LE. 3) THEN
        IF(GENDAT(14) .EQ. 0) THEN
          AAINF(I,0)=MAX(CHIFAC*EPS(1),Q(1)/ZFRACT)
        ELSE
          AAINF(I,0)=MAX(CHIFAC*EPS(1),1/PARMAX**2)
        END IF
      ELSE
        AAINF(I,0)=-CHIFAC*EPS(2)
      END IF
9     CONTINUE
C 
      PARMAX=1/SQRT(AAINF(1,0))
      PARMIN=1/SQRT(AASUP(1,0))
C!    WRITE(IPRNT,*) (AASUP(I,0),I=1,NINC)
C!    WRITE(IPRNT,*) (AAINF(I,0),I=1,NINC)
      WRITE(IPRNT,*)
      WRITE(IPRNT,*) 'Minimum value of 1/a*, 1/b*, 1/c*: ',PARMIN
      WRITE(IPRNT,*) 'Maximum value of 1/a*, 1/b*, 1/c*: ',PARMAX
      WRITE(IPRNT,*)
C 
      MT(0)=0
      JT(0)=0
      N=0
C 
C this is an important label where one comes back for a new value of N
C 
140   CONTINUE
      IF(N .GE. NMAX) THEN
        CAUSE=8
        NCAUSE(CAUSE,N)=NCAUSE(CAUSE,N)+1
        GO TO 190
      END IF
      NM1=N
      N=N+1
      NEQ(N)=NEQ(NM1)
      CHIFCN(N)=CHIFCN(NM1)
      NEQN=NEQ(N)
      INEQ(N)=0
C 
C if we are dealing with unknown lines, perform some preliminary
C controls to avoir wasting time in useless trials
C 
      IF(N .GT. NCON) THEN
        IF(N .LT. NCON+NINC) THEN
          DO 1442 KMOD=1,NINC
          MODIFS=0
          DO 1444 I=1,NINC
          AIN=AAINF(I,NM1)
          SUP=AASUP(I,NM1)
          CALL AAUPDT(AAINF(1,NM1),AASUP(1,NM1),AIN,SUP,I,MODIFS)
1444      CONTINUE
          IF(MODIFS .EQ. 0) GO TO 1443
          IF(MODIFS .LT. 0) THEN
            N=NM1
            GO TO 1803
          END IF
1442      CONTINUE
1443      CONTINUE
        END IF
C 
        GO TO (1401,1405,1403,1404,1405,1406),NSYS
1401    AAMIN=AAINF(1,NM1)
        AAMAX=AASUP(1,NM1)
        GO TO 1409
1405    AAMIN=MIN(AAINF(1,NM1),AAINF(2,NM1))
        AAMAX=MAX(AASUP(1,NM1),AASUP(2,NM1))
        GO TO 1409
1403    AAMIN=AAINF(3,NM1)
        AAMAX=AASUP(1,NM1)
        GO TO 1409
1404    AAMIN=MAX(AAINF(2,NM1)-AASUP(4,NM1),0.5*AAINF(2,NM1))
        AAMIN=MAX(CHIFAC*EPS(1),MIN(AAMIN,AAINF(3,NM1)))
        AAMAX=AASUP(1,NM1)+AASUP(4,NM1)
        AAMAX=MAX(AAMAX,AASUP(3,NM1))
        GO TO 1409
1406    AAMIN=AAINF(3,NM1)-MAX(AASUP(4,NM1),2*AASUP(5,NM1),
     $   2*AASUP(6,NM1))
        AAMAX=AASUP(1,NM1)+MAX(AASUP(4,NM1),2*AASUP(5,NM1),
     $   2*AASUP(6,NM1))
1409    CONTINUE
        AAMIN=MAX(AAMIN,CHIFAC*EPS(1))
        IF(QMCERT/AAMAX .GT. HPKPLX) THEN
          N=NM1
          GO TO 1803
        END IF
C 
C   now compute the range for JT(N)
C   accounting for a resuming value of JDEP(N)
C 
        MTNN=MTMAX(N)
        IHKMAX=MIN(INT((Q(MTNN)+2*CHIFAC*EPS(MTNN))/AAMIN)+1,
     $      HPKPLX,INDK(N))
        JHMAX(N)=IHKL(IHKMAX)
        IHKMIN=MAX(INT((Q(N-NCON)-2*CHIFAC*EPS(N-NCON))/AAMAX)-1,1)
        JT(N)=MAX(1,JDEP(N),IHKL(IHKMIN))
        JDEP(N)=1
        IF((N .LE. 2 .OR. NTSKIP .GT. 1000) .OR. INDICN(12)) THEN
           NTSKIP=0
           WRITE(IPRNT,1743) N,CHIFAC,IHKMIN,IHKMAX,NEQ(N),
     $      (JT(I),HKLT(1,JT(I)),HKLT(2,JT(I)),HKLT(3,JT(I)),I=1,N),
     $      -JHMAX(N),HKLT(1,JHMAX(N)),HKLT(2,JHMAX(N)),HKLT(3,JHMAX(N))
1743       FORMAT(' N=',I1,' chifac=',F5.3,' H^2+K^2+K^2=[',
     $   I3,',',I3,']  n.eqs=',I2,' JT:',    5(I4:'(',3I3,')':)
     $   :10(/(33X,3(I4:'(',3I3,')':))))
          CALL FINISH
        ELSE
          NTSKIP=NTSKIP+1
        END IF
      ELSE
        JT(N)=JCON(N)
        JHMAX(N)=JCON(N)
      END IF
C 
C This the place where one comes back with a new value of JT(N)
C 
100   CONTINUE
      NM1=N-1
      JN=JT(N)
      IF(SHKL(JN) .EQ. 2) GO TO 190
      NEQN=NEQ(N-1)
      NEQ(N)=NEQN
      INEQ(N)=0
C 
C another control: at least one of the indices of JT(N) must be
C greater than the same in JT(<N), because all AA(..)'s are positive
C But this does not apply to known lines, whose order is indefinite.
      DO 102 I=1,NM1
      JI=JT(I)
      IF(JI-JN)102,190,26
26    CONTINUE
      IF(I .LE. NCON) GO TO 102
C CONTROLE:  SI JT(I) .GT. JT(N) VERIFIER QU'IL N'Y A PAS D'INCOMPATIBIL
C (123) NE PEUT PRECEDER (012) PAR EXEMPLE
C ( EN EFFET PAR HYPOTHESE TOUS LES 'AA' SONT POSITIFS. )
      DO 109 J=1,NINC
      IF(H2T(J,JN) .GT. H2T(J,JI)) GO TO 102
109   CONTINUE
C bad...
       GO TO 190
C good...
102   CONTINUE
C 
C start new step in solving the system
C this deals only with the left part of equations, i.e. what
C is independent of the choice of the line MT(N)
C 
C tentative number of equations
      NEQT=NEQN+1
      IF(MAX(NEQT,NEQN,NEQ(N)) .GT. NINC) THEN
        DO 1648 KKK=1,NEQN
        WRITE(IPRNT,16489) KKK,(AM(I,KKK),I=1,NINC)
1648    CONTINUE
        WRITE(IPRNT,*)
     $    'N=',N,' NEQT=',NEQT,' NEQN=',NEQN,' NEQ(N)=',NEQ(N)
16489   FORMAT(' equation:',I4,' --> ',6F8.5)
        STOP
      END IF
      IF(INDICN(12))
     $   WRITE(IPRNT,*)
     $    'N=',N,' NEQT=',NEQT,' NEQN=',NEQN,' NEQ(N)=',NEQ(N)
C 
      DO 1103 I=1,MAMDIM
      AM(I,NEQT)=0
1103  CONTINUE
      AM(NINC+N,NEQT)=1
      DO 103 I=1,NINC
      AM(I,NEQT)=H2T(I,JN)
103   CONTINUE
C 
C substitute previous equations
C 
      DO 150 I=1,NEQN
        K=MPIV(I)
        AMKN=AM(K,NEQT)
        DO 151 J=1,NINC+N
        AM(J,NEQT)=AM(J,NEQT)-AM(J,I)*AMKN
151     CONTINUE
150   CONTINUE
C 
C try to find a pivot
C 
      MPIV(NEQT)=0
      PIVOTN=0
      DO 162 K=1,NINC
        IF(ABS(AM(K,NEQT)) .GT. 0.0001) THEN
          MPIV(NEQT)=K
          PIVOTN=AM(K,NEQT)
          DO 164 I=1,NINC+N
          AM(I,NEQT)=AM(I,NEQT)/PIVOTN
164       CONTINUE
          NEQ(N)=NEQT
          NEQN=NEQT
          INEQ(N)=NEQT
C 
C build the eliminated eq. set (as far as possible)
C 
          DO 1653 NP=1,NEQN
          DO 1653 I=1,NINC+N
          AW(I,NP)=AM(I,NP)
1653      CONTINUE
C 
          DO 1651 NP=1,NEQN
          KK=MPIV(NP)
          DO 1651 NN=1,NP-1
          AWK=AW(KK,NN)
          DO 1652 J=1,NINC+N
          AW(J,NN)=AW(J,NN)-AWK*AW(J,NP)
1652      CONTINUE
1651      CONTINUE
C 
          GO TO 163
        END IF
162   CONTINUE
C 
C this equation is not independent of the previous ones,
C this results in a necessary relationship between lines
C 
C9956   FORMAT(1X,2I4,' ---> ',8I5)
C9955   CONTINUE
163    CONTINUE
C 
C start line affectation at the preceeding item, unless N=NCON+1
C where affectation starts at 0 (+1 --> 1)
C 
       IF(N .EQ. NCON+1) THEN
         MT(N)=1
       ELSE IF(N .LE. NCON) THEN
         MT(N)=MCON(N)
       ELSE
         MT(N)=MT(N-1)+1
       END IF
C 
C choosing a new line to be associated with JT(N)
C 
3800   CONTINUE
       MN=MT(N)
       IF(MN .GT. MTMAX(N)) GO TO 190
       IF(ICON(MN) .NE. 0) THEN
         IF(N .GT. NCON) THEN
           MT(N)=MT(N)+1
           GO TO 3800
         END IF
       END IF
C 
C here starts a section which is common to both cases of known and
C unknown line label at level N
C 
       JN=JT(N)
       QMN=Q(MN)
       NEQN=NEQ(N)
C 
C use the equation:
C sum_k AM(NINC+k,N)*Q(k)= sum_j AT(j,N)*AA(j)
C when all AT(*,N) are zero
C 
       DO 1684 I=1,NINC
       AAINFN(I)=AAINF(I,N-1)
       AAINF(I,N)=AAINFN(I)
       AASUPN(I)=AASUP(I,N-1)
       AASUP(I,N)=AASUPN(I)
1684   CONTINUE
       VSUP2(N)=VSUP2(N-1)
       CHIFCN(N)=CHIFAC
C 
       IF(INEQ(N) .EQ. 0) THEN
         SUMSEC=0
         SUMMAX=0
         DO 1690 NN=1,N
         MTNN=MT(NN)
         SUMMAX=SUMMAX+ABS(AM(NINC+NN,NEQT))*CHIFAC*EPS(MTNN)
         SUMSEC=SUMSEC+AM(NINC+NN,NEQT)*Q(MTNN)
1690     CONTINUE
         IF(NMAX-N .LT. NINC-NEQ(N)) THEN
           CAUSE=8
           NCAUSE(CAUSE,N)=NCAUSE(CAUSE,N)+1
           GO TO 190
         END IF
         IF(ABS(SUMSEC) .GT. SUMMAX) GO TO 2804
         IF(NINC .GT. 2 .AND. NEQN .EQ. NINC-1 .AND. N .GT. NINC+1) THEN
         END IF
       ELSE
C do we have a sufficient number of indpt equations ?
         IF(NEQN .LT. NINC) THEN
C NO: then work only with inequalities
           QSUP=CHIFAC*EPS(MN)*2
           QINF=-QSUP
           DO 1685 I=1,NINC
           H2TIJN=H2T(I,JN)
           IF(H2TIJN) 1686,1685,1687
1686       QSUP=QSUP+H2TIJN*AAINFN(I)
           QINF=QINF+H2TIJN*AASUPN(I)
           GO TO 1685
1687       QINF=QINF+H2TIJN*AAINFN(I)
           QSUP=QSUP+H2TIJN*AASUPN(I)
1685       CONTINUE
           IF(QSUP .LT. QMN) GO TO 3801
           IF(QINF .GT. QMN) GO TO 3801
         END IF
C 
C now try to partially solve the system
C 
         DO 1642 KMOD=1,NINC
         MODIFS=0
         DO 1640 NN=1,NEQN
         SUMERR=0
         SUMREL=0
         DO 1641 J=1,N
         MTJ=MT(J)
         SUMREL=SUMREL+AW(NINC+J,NN)*Q(MTJ)
         SUMERR=SUMERR+ABS(AW(NINC+J,NN)*CHIFAC*EPS(MTJ))
1641     CONTINUE
C 
         IF(NEQN .LT. NINC) THEN
           DO 166 I=1,NINC
           ATIN=AW(I,NN)
           IF(ABS(ATIN) .GT. 0.0001) THEN
             Z=SUMREL+SUMERR
             Y=SUMREL-SUMERR
             DO 168 J=1,NINC
               IF(J .EQ. I) GO TO  168
               ATJN=AW(J,NN)
               IF(ATJN) 1681,168,1682
1681           Y=Y-ATJN*AAINFN(J)
               Z=Z-ATJN*AASUPN(J)
               GO TO 168
1682           Z=Z-ATJN*AAINFN(J)
               Y=Y-ATJN*AASUPN(J)
168          CONTINUE
             Y=Y/ATIN
             Z=Z/ATIN
             SUP=MAX(Y,Z)
             AIN=MIN(Y,Z)
           ELSE
             SUP=AASUPN(I)
             AIN=AAINFN(I)
           END IF
C 
C NOW COMPUTE VOLUME CONSTRAINTS
C 
          CALL AAUPDT(AAINFN,AASUPN,AIN,SUP,I,MODIFS)
          IF(MODIFS .LT. 0) THEN
            GO TO 1803
          END IF
C   GENERAL
166       CONTINUE
        ELSE
          K=MPIV(NN)
          AA(K)=SUMREL
          AE(K)=SUMERR
        END IF
1640    CONTINUE
        IF(MODIFS .EQ. 0) GO TO 1643
1642    CONTINUE
1643    CONTINUE
        DO 1649 I=1,NINC
        AAINF(I,N)=AAINFN(I)
        AASUP(I,N)=AASUPN(I)
1649    CONTINUE
C 
        IF(NEQN .EQ. NINC) GO TO 200
C 
        DO 1188 I=1,NINC
        IF(AAINFN(I) .GT. AASUPN(I)) GO TO 1802
1188    CONTINUE
        GO TO (1151,1152,1153,1154,1155,1156),NSYS
1151    CONTINUE
        VSUP2(N)=AASUPN(1)**3
        GO TO 1159
1152    CONTINUE
        VSUP2(N)=AASUPN(1)**2*AASUPN(2)
        GO TO 1159
1156    CONTINUE
1153    CONTINUE
        VSUP2(N)=AASUPN(1)*AASUPN(2)*AASUPN(3)
        GO TO 1159
1154    CONTINUE
        VSUP2(N)=AASUPN(3)*(AASUPN(1)*AASUPN(2)-
     $    MAX(0.0,AAINFN(4))**2)
        GO TO 1159
1155    CONTINUE
        VSUP2(N)=AASUPN(1)**2*AASUPN(2)*0.75
        GO TO 1159
1159    CONTINUE
      END IF
      IF(VSUP2(N) .LE. VMMIN)  GO TO 1804
C 
C update CHIFAC
C 
      CHIFAC=MIN(CHIORG,2.0*CHIVOX*SQRT(VSUP2(N)))
      CHIFCN(N)=CHIFAC
      GO TO 140
C 
C SYSTEME RESOLU. QUELQUES CONTROLES
C 
200   CONTINUE
      DO 209 II=1,NINC
      IF(AA(II) .LT. AAINFN(II)) GO TO 1806
      IF(AA(II) .GT. AASUPN(II)) GO TO 1806
209   CONTINUE
      GO TO (1301,1302,1303,1304,1302,1306),NSYS
1306  IF(AA(3) .LT. AA(6)) GO TO 1806
      IF(AA(3) .LT. AA(5)) GO TO 1806
      IF(AA(2) .LT. 2*AA(4)) GO TO 1806
      IF(AA(4) .LT. RIEN) GO TO 1806
      IF(AA(5) .LT. RIEN) GO TO 1806
      IF(AA(6) .LT. RIEN) GO TO 1806
1303  IF(AA(2) .LT. AA(3)) GO TO 1806
      GO TO 1305
1304  IF(AA(2) .LT. 2*AA(4)) GO TO 1806
      IF(AA(4) .LT. RIEN) GO TO 1806
1305  IF(AA(1) .LT. AA(2)) GO TO 1806
      GO TO 1214
1302  CONTINUE
1301  CONTINUE
1214  CONTINUE
      DO 1215 II=1,MIN(NINC,3)
      IF(AA(II) .LT. ABRIEN) GO TO 1806
1215  CONTINUE
CSPECIAL PAR SYSTEME, CALCUL DU VOLUME RECIPROQUE**2
      CALL VOLCAL
      IF(VRECI2 .LT. VMMIN) GO TO 1807
      CALL CONTRL(IBCODE)
      GO TO (1811,1810,1809,1807,1806),IBCODE
1811  TROUVE=.TRUE.
      CAUSE=11
      NCAUSE(CAUSE,N)=NCAUSE(CAUSE,N)+1
      DO 1843 NN=0,N-1
        DO 1842 KMOD=1,NINC
        MODIFS=0
        DO 1844 I=1,NINC
        AIN=AAINF(I,NN)
        SUP=AASUP(I,NN)
        CALL AAUPDT(AAINF(1,NN),AASUP(1,NN),AIN,SUP,I,MODIFS)
1844    CONTINUE
        IF(MODIFS .LE. 0) GO TO 1843
        DO 1846 I=1,NINC
        AAINF(I,NN+1)=MAX(AAINF(I,NN+1),AAINF(I,NN))
        AASUP(I,NN+1)=MIN(AASUP(I,NN+1),AASUP(I,NN))
1846    CONTINUE
1842    CONTINUE
1843  CONTINUE
      GO TO 180
C 
C The selected line does not fit, if not a known line, then try
C another one, else...
C 
3801  IF(N .LE. NCON) THEN
         WRITE(IPRNT,3701) N,Q(MN),QINF,QSUP
3701     FORMAT(' Line No.',I3,' 1/D**2 (given):',F9.5,
     $    ' (computed MIN.):',F9.5,' (computed MAX.):',F9.5)
      END IF
      CAUSE=1
      GO TO 1800
C 
2804  CONTINUE
      IF(N .LE. NCON) THEN
C DIAGNOSTIC PLUS EXPLICITE POUR INDICES INCOMPATIBLES
         WRITE(IPRNT,1701) N,Q(MN),99999.0,SUMSEC,SUMMAX
1701     FORMAT(' Given line No.',I3,' 1/D**2 (Given):',F9.5,
     $ ' (computed):',F9.5,' (diff.):',F9.5,' (max.diff.):',F9.5)
      END IF
      CAUSE=5
      GO TO 1800
1802  CAUSE=2
      GO TO 1800
1803  CAUSE=3
      GO TO 1800
1804  CAUSE=4
      GO TO 1800
1806  CAUSE=6
      IF(INDICN(12)) THEN
        WRITE(IPRNT, 1797)  (AA(I),I=1,6)
        CALL VOLCAL
        CALL MAILLE
        WRITE(IPRNT, 1796) A,B,C,ALPHA,BETA,GAMMA
1797    FORMAT(' Recip.',6G12.5)
1796    FORMAT(' Cell: ',6G12.5)
      END IF
      GO TO 1800
1807  CAUSE=7
      GO TO 1800
1809  CAUSE=9
      GO TO 1800
1810  CAUSE=10
      NBMMX=NBMMX-1
C 
C the difference between 1800 and 180 is that 1800 records
C statistics while 180 does not
1800  CONTINUE
      IF(N .LE. 0) GO TO 199
      NCAUSE(CAUSE,N)=NCAUSE(CAUSE,N)+1
      IF(N .LE. NCON .AND. CAUSE .LT. 6) WRITE(IPRNT, 1798) N,CAUSE
1798  FORMAT(/' WARNING : GIVEN INDICES LEAD TO DISAGREEMENT WITH'
     $ ,' STATED OR COMPUTED CONDITIONS. N=',I3,' ELIM.CODE=',I2)
      IF(.NOT. INDICN(12)) GO TO 180
      WRITE(IPRNT,1799) (AAINF(I,N),AASUP(I,N),I=1,6),CAUSE,
     $ (JT(K),MT(K),K=1,N)
1799  FORMAT(1X,12F8.5,I2,(T100,I3,I2,I3,I2,I3,I2,I3,I2,I3,I2,I3,I2))
C 
C common meeting point to try another line with current index set
C 
180   JN=JT(N)
      MN=MT(N)
      NM1=N-1
      IF(CERT(MN)) GO TO 190
C 
C increment MT(N) to try a new line at this stage
C 
       MT(N)=MT(N)+1
       GO TO 3800
C 
C increment JT(N) for a new test
C 
190   CONTINUE
      JT(N)=JT(N)+1
      IF(JT(N) .LE. JHMAX(N)) GO TO 100
      N=N-1
      CHIFAC=CHIFCN(N)
      IF(N .NE. 0) GO TO 180
      CALL PCAUSE
      RETURN
C 
199   CONTINUE
      NCAUSE(CAUSE,1)=NCAUSE(CAUSE,1)+1
      CALL PCAUSE
      RETURN
      END
      SUBROUTINE AAUPDT(AAINFN,AASUPN,AIN,SUP,INX,MODIFS)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
      REAL AAINFN(6),AASUPN(6)
C 
           I=INX
           AINV=AIN-1
           GO TO (261,262,263,264,265,266),NSYS
261        CONTINUE
           AINV=EXP(LOG(VMMIN)/3.0)
           GO TO 260
C 
262        CONTINUE
           GO TO (2621,2622),I
2621       AINV=SQRT(VMMIN/AASUPN(2))
           GO TO 260
2622       AINV=VMMIN/AASUPN(1)**2
           GO TO 260
C 
263        CONTINUE
           AINV=VMMIN*AASUPN(I)/(AASUPN(1)*AASUPN(2)*AASUPN(3))
           GO TO 260
C 
264        CONTINUE
           GO TO (2641,2642,2643,2644),I
2641       AINV=(AAINFN(4)**2+VMMIN/AASUPN(3))/AASUPN(2)
           GO TO 260
2642       AINV=(AAINFN(4)**2+VMMIN/AASUPN(3))/AASUPN(1)
           GO TO 260
2643       AINV=VMMIN/(AASUPN(1)*AASUPN(2)-AAINFN(4)**2)
           GO TO 260
2644       CONTINUE
           AINV=AIN-1
           GO TO 260
C 
265        CONTINUE
           GO TO (2651,2652),I
2651       AINV=SQRT(1.33333*VMMIN/AASUPN(2))
           GO TO 260
2652       AINV=1.33333*VMMIN/AASUPN(1)**2
           GO TO 260
C 
266        CONTINUE
           J=MOD(I,3)+1
           K=MOD(J,3)+1
           AINV=(VMMIN-2*AASUPN(4)*AASUPN(5)*AASUPN(6)
     $          +AAINFN(J)*AAINFN(K+3)**2+AAINFN(K)*AAINFN(J+3)**2)
     $          /(AASUPN(J)*AASUPN(K)-AAINFN(J+3)**2)
           GO TO 260
260        CONTINUE
C 
           AINV=MAX(AINV,AIN)
C 
           IF(SUP .LT. AASUPN(I)) THEN
             MODIFS=1
             IF(SUP .LT. AAINFN(I)) THEN
               MODIFS=-1
               RETURN
             END IF
             AASUPN(I)=SUP
             GO TO (270,270,273,274,270,276),NSYS
C   SPECIAL ORTHORHOMBIQUE
273          GO TO (2731,2732,2733),I
2731         AASUPN(2)=MIN(AASUPN(2),AASUPN(1))
2732         AASUPN(3)=MIN(AASUPN(3),AASUPN(2))
2733         GO TO 270
C   SPECIAL MONOCLINIQUE
274          GO TO (2741,2742,2743,2744),I
2741         AASUPN(2)=MIN(AASUPN(2),AASUPN(1))
2742         AASUPN(4)=MIN(AASUPN(4),0.5*AASUPN(2))
2743         CONTINUE
2744         GO TO 270
C   SPECIAL TRICLINIQUE
276          GO TO (2771,2772,2773,2776,2776,2776),I
2771         AASUPN(2)=MIN(AASUPN(2),AASUPN(1))
2772         AASUPN(3)=MIN(AASUPN(3),AASUPN(2))
             AASUPN(4)=MIN(AASUPN(4),0.5*AASUPN(2))
2773         AASUPN(5)=MIN(AASUPN(5),AASUPN(3))
             AASUPN(6)=MIN(AASUPN(6),AASUPN(3))
2776         GO TO 270
270          CONTINUE
           END IF
C 
           IF(AINV .GT. AAINFN(I)) THEN
             MODIFS=1
             IF(AINV .GT. AASUPN(I)) THEN
               MODIFS=-1
               RETURN
             END IF
             AAINFN(I)=AINV
             GO TO (280,280,283,284,280,286),NSYS
C   SPECIAL ORTHORHOMBIQUE
283          GO TO (2831,2832,2833),I
2833         AAINFN(2)=MAX(AAINFN(2),AAINFN(3))
2832         AAINFN(1)=MAX(AAINFN(1),AAINFN(2))
2831         GO TO 280
C   SPECIAL MONOCLINIQUE
284          GO TO (2841,2842,2843,2844),I
2844         AAINFN(2)=MAX(AAINFN(2),2*AAINFN(4))
2842         AAINFN(1)=MAX(AAINFN(1),AAINFN(2))
2843         CONTINUE
2841         GO TO 280
C  SPECIAL TRICLINIQUE
286          GO TO (2861,2862,2863,2864,2865,2866),I
2866         AAINFN(3)=MAX(AAINFN(3),AAINFN(6))
2865         AAINFN(3)=MAX(AAINFN(3),AAINFN(5))
2864         AAINFN(2)=MAX(AAINFN(2),2*AAINFN(4))
2863         AAINFN(2)=MAX(AAINFN(2),AAINFN(3))
2862         AAINFN(1)=MAX(AAINFN(1),AAINFN(2))
2861         GO TO 280
280          CONTINUE
           END IF
      IF(AAINFN(I) .GT. AASUPN(I)) MODIFS=-1
      RETURN
      END
      SUBROUTINE PCAUSE
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      CALL KTIMCL
      WRITE(IPRNT,1442)
     $    (NN,(NCAUSE(L,NN),L=1,MAXCSE),NN=1,MIN(NMAX+1,JMAX))
1442  FORMAT(/' Statistics for Unit Cell trials'//10X,
     $'  ------------------------NOT TRIED BECAUSE---------------',
     $'-------  unsucc. bad'
     $/7X,'     imposs.  SYM(1) VOL(1a) VOL(1b) incomp.',
     $   '  SYM(2)  VOL(2)  degen.  trial  merit  SUCCESS.' /
     $/(' N=',I2,4X ,11I8))
      RETURN
      END
       SUBROUTINE CONTRL(IBCODE)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      CHARACTER*16 HMSEC1,HMSEC2
      INTEGER*4 LASTT,LASTS,KTMAX,TEMPTT
C 
      COMMON/TWSECN/TSECN(NINCMX,0:NQMAX),WSECN(NINCMX,0:NQMAX)
      CHARACTER*196 F2710
C 
C DATA
C 
      DATA LASTT,LASTS/0,0/
C 
C these are the selection BITs to select the BRAVAIS lattice tested
C this also defines the order in which they are tested
C 
C END DATA
C 
      KTMAX=32000
      IBCODE=4
C IBCODE=4 FOR BAD VOLUME, IBCODE=3 FOR BAD LINES, IBCODE=2 FOR BAD
C MERIT, IBCODE=1 WHEN O.K., IBCODE=5 FOR REDUNDANCY
      CALL ATIMER(TEMPTT,1)
C 
      KCYCLE=-1
      KTOLER=1
1000  CONTINUE
C 
C ESSAI DE LA MAILLE CALCULEE
C 
      GO TO (331,332,333,334,332,336),NSYS
331   AAMIN=AA(1)
      AAMAX=AA(1)
      GO TO 339
332   AAMAX=MAX(AA(1),AA(2))
      IF(QMCERT/AAMAX .GT. HPKPLX) GO TO 601
      AAMIN=MIN(AA(1),AA(2))
      GO TO 339
333   AAMAX=AA(1)
      IF(QMCERT/AAMAX .GT. HPKPLX) GO TO 601
      AAMIN=AA(3)
      GO TO 339
334   AAMAX=MAX(AA(1)+AA(4),AA(3))
      IF(QMCERT/AAMAX .GT. HPKPLX) GO TO 601
      AAMIN=MIN(AA(2)-AA(4),AA(3))
      AAMIN=MAX(AAMIN,0.001*Q(NQ))
      GO TO 339
336   AAMAX=AA(1)+MAX(AA(4),AA(5),AA(6))
      IF(QMCERT/AAMAX .GT. HPKPLX) GO TO 601
      AAMIN=AA(3)-MAX(AA(4),AA(5),AA(6))
      AAMIN=MAX(AAMIN,0.001*Q(NQ))
339   CONTINUE
C 
C CONTROLE DU NOMBRE APPROXIMATIVEMENT ENTIER DE MOTIFS SI OPTION 'V'
      IF(INDICN(9)) THEN
         DO 298 I=1,NMOMAX
         IF(VRECI2 .GT. VLIMS(I)) GO TO 601
         IF(VRECI2 .GT. VLIMI(I)) GO TO 299
298      CONTINUE
299      CONTINUE
      END IF
      IBCODE=3
      IF(NQ .LE. NINC) GO TO 601
C 
      X=0
      M=0
      NBON=0
      DO 3010 J=1,NINC
      TSECN(J,0)=0
      WSECN(J,0)=0
      DO 3010 I=1,NINC
      TMAT(I,J)=0
      WMAT(I,J)=0
3010  CONTINUE
      NBAD=0
      IHKMAX=MIN(INT((Q(NQ)+2*CHIFAC*EPS(NQ))/AAMIN+1.),HPKPLX)
      IMAXX=IHKL(IHKMAX)
      DO 301 I=1,IMAXX
      IF(SHKL(I) .LT. 2) SHKL(I)=0
      DGEN(I)=0
301   QGEN(I)=0
C 
C base lines build a possible cell, now make general check
C 
      DO 341 I=1,NQ
341   MBASE(I)=0
      DO  340 NN=1,N
      M=MT(NN)
      MBASE(M)=NN
340   CONTINUE
C 
C Trying to index all expermental lines
C 
      DO 310 M=1,NQ
      QM=Q(M)
C additional tolerance at first cycle (KCYCLE=-1)
      EPSM=CHIFAC*EPS(M)*(1-0.6*KCYCLE)
      NREF(M)=0
      NN=MBASE(M)
      IF(NN .NE. 0) THEN
         IB=JT(NN)
         SHKL(IB)=1
         X=MIN(X+1,NCMAX-1)
         IBON(M)=IB
         IREF(X)=IB
         MREF(X)=M
         NREF(M)=1
C by definition, a base line is better than the others
         ECMAX=0.0
      ELSE
         IB=0
         IBON(M)=0
         ECMAX=1.E30
        IHKMAX=MIN(INT((QM+2*EPSM)/AAMIN+1.),HPKPLX)
        IHKMIN=MAX(INT((QM-2*EPSM)/AAMAX-1.),1)
        IF(IHKMIN .LE. IHKMAX) THEN
          IMIN=MIN(IMAXX,IHKL(IHKMIN))
          IMAX=MIN(IMAXX,IHKL(IHKMAX))
C 
          DO 305 I=IMIN,IMAX
          IF(SHKL(I) .NE. 0) GO TO 305
          IF(QGEN(I) .EQ. 0) THEN
             II=I
             DO 307 K=1,NINC
             DGEN(II)=DGEN(II)+AE(K)*IABS(H2T(K,II))
307          QGEN(II)=QGEN(II)+AA(K)*H2T(K,II)
          END IF
          ABSDIF=ABS(QGEN(I)-QM)
          IF(ABSDIF .GT. EPSM+DGEN(I)) GO TO 305
          IF(INDICN(16)) GO TO 304
          IF(N .LE. NCON) GO TO 304
          IF(M .GE. MT(N)) GO TO 304
C this line is indexed. It it is not in the base list, this means that
C this base list does not contain exclusively the N first true lines.
C thus, the system has to be rejected because of redundancy.
          IF(IB .EQ. 0) THEN
             IBCODE=5
             GO TO 2555
          END IF
304       CONTINUE
          X=MIN(X+1,NCMAX-1)
          IREF(X)=I
          MREF(X)=M
          NREF(M)=NREF(M)+1
          IF(ABSDIF .LT. ECMAX) THEN
            ECMAX=ABSDIF
            IBON(M)=I
          END IF
305       CONTINUE
        END IF
      END IF
C 
      I=IBON(M)
      IF(I .GT. 0) THEN
        IF(CERT(M)) SHKL(I)=1
        NBON=NBON+1
        WEPSM=1./EPSM**2
        IF(.NOT. CERT(M)) THEN
          IF(KCYCLE .LT. 0) THEN
            WEPSM=WEPSM*0.0625
          ELSE
            WEPSM=WEPSM*0.25
          END IF
        END IF
        DO 3050 J=1,NINC
        UU=H2T(J,I)*WEPSM
        TSECN(J,0)=TSECN(J,0)+QM*UU
        TSECN(J,NBON)=EPSM*UU
        DO 3049 K=0,NBON
3049    WSECN(J,K)=TSECN(J,K)
        DO 3050 K=1,NINC
        TMAT(K,J)=TMAT(K,J)+H2T(K,I)*UU
        WMAT(K,J)=TMAT(K,J)
3050    CONTINUE
        IF(M .LT. MT(N)) GO TO 310
        IF(NBON .LE. NINC) GO TO 310
        IF(KCYCLE .EQ. 0) GO TO 310
C 
C RESOLUTION DU SYSTEME
C 
        DO 100 L=1,NINC
        PIV=WMAT(L,L)
        IF(PIV .EQ. 0) GO TO 310
        DO 103 I=0,NBON
103     WSECN(L,I)=WSECN(L,I)/PIV
        IF(L .EQ. NINC) GO TO 110
        LP1=L+1
        WMAT(L,L)=1
        DO 102 I=LP1,NINC
102     WMAT(I,L)=WMAT(I,L)/PIV
        DO 104 K=LP1,NINC
        R=WMAT(L,K)
        WMAT(L,K)=0
        DO 105 I=LP1,NINC
105     WMAT(I,K)=WMAT(I,K)-R*WMAT(I,L)
        DO 106 I=0,NBON
106     WSECN(K,I)=WSECN(K,I)-R*WSECN(L,I)
104     CONTINUE
100     CONTINUE
110     CONTINUE
        L=NINC-1
        LP1=NINC
111     CONTINUE
        IF(L .GT. 0) THEN
          DO 112 K=LP1,NINC
          DO 113 I=0,NBON
          WSECN(L,I)=WSECN(L,I)-WMAT(K,L)*WSECN(K,I)
113       CONTINUE
112       CONTINUE
          LP1=L
          L=L-1
          GO TO 111
        END IF
        DO 3051 I=1,IMAXX
        DGEN(I)=0
3051    QGEN(I)=0
        DO 3052 J=1,NINC
        AE(J)=0
        DO 3053 I=1,NBON
        AE(J)=AE(J)+WSECN(J,I)**2
3053    CONTINUE
        AE(J)=SQRT(AE(J))
3052    AA(J)=WSECN(J,0)
      ELSE
        NBAD=NBAD+1
        IF(CERT(M)) GO TO 250
        IF(NBAD .GT. NBMAX+(KTOLER*(NBON+1))/8) GO TO 250
        IF(IB .NE. 0) GO TO 250
      END IF
310   CONTINUE
C 
C CALCUL DU VOLUME RECIPROQUE**2
C 
      CALL VOLCAL
      IF(VRECI2 .LT. VMMIN) THEN
C if the volume is bad, it is useless to loop over BRAVAIS lattices
         IBCODE=4
         GO TO 601
      END IF
C 
CE RESEAU SEMBLE BON, IL FAUT VERIFIER QUE PLUSIEURS RAIES NE SONT PAS
C INDEXEES PAR LES MEMES INDICES
C 
      CALL QRECAL(X)
      DO 260 K=1,X
      MK=MREF(K)
      IF(MK .EQ. 0) GO TO 260
      IK=IREF(K)
      VTABK=VTAB(K)
      EPSMK=CHIFAC*EPS(MK)*(1-0.6*KCYCLE)
      IF(SHKL(IK).EQ.0 .AND. ABS(VTABK).GT.EPSMK) GO TO 275
      KM1=K-1
      DO 261 L=1,KM1
      IL=IREF(L)
      IF(IK .NE. IL) GO TO 261
C there is a conflict, try to solve it
      ML=MREF(L)
      IF(SHKL(IL) .NE. 0) GO TO 275
      IF(SHKL(IK) .NE. 0) GO TO 271
      IF(IBON(MK) .NE. IK) THEN
        IF(IBON(ML) .EQ. IK) GO TO 275
        IF(ABS(VTABK) .GT. ABS(VTAB(L))) GO TO 275
        GO TO 271
      END IF
      IF(IBON(ML) .NE. IK) GO TO 271
C this is a serious conflict, IK=IL is the best for 2 lines
      IF(NREF(MK) .GT. NREF(ML)) GO TO 275
      IF(NREF(ML) .GT. NREF(MK)) GO TO 271
      IF(CERT(ML) .AND..NOT. CERT(MK)) GO TO 275
      IF(CERT(MK) .AND..NOT. CERT(ML)) GO TO 271
      IF(ABS(VTABK) .GT. ABS(VTAB(L))) GO TO 275
C remove the L-th line
271   CONTINUE
      IREF(L)=0
      MREF(L)=0
      NREF(ML)=NREF(ML)-1
      IF(IBON(ML) .EQ. IK) IBON(ML)=0
261   CONTINUE
      GO TO 260
C remove the K-th line
275   CONTINUE
      IREF(K)=0
      MREF(K)=0
      NREF(MK)=NREF(MK)-1
      IF(IBON(MK) .EQ. IK) IBON(MK)=0
260   CONTINUE
C 
C Duplications are now eliminated, so we compress the table
C In the same time, the chi**2 of the lattice is computed
C 
      NBON=0
      DO 277 K=1,NQ
277   IBON(K)=0
      MPREV=0
      ECMIN=0
      L=0
      DO 276 K=1,X
      I=IREF(K)
      IF(I .EQ. 0) GO TO 276
      L=L+1
      IREF(L)=IREF(K)
      MREF(L)=MREF(K)
      VTAB(L)=VTAB(K)
      QTH(L)=QTH(K)
      M=MREF(K)
      ECART=(VTAB(K)/(CHIFAC*EPS(M)))**2
      IF(M .NE. MPREV) THEN
        NBON=NBON+1
        ECMIN=ECART
        IBON(M)=IREF(K)
      ELSE IF(ECART .LT. ECMIN) THEN
        ECMIN=ECART
        IBON(M)=IREF(K)
      END IF
      MPREV=M
276   CONTINUE
      X=L
C 
      NBAD=NQ-NBON
      IF(NBAD .GT. NBMAX+(KTOLER*(NBON+1))/8) GO TO 250
      IF(NBON .LE. NINC) GO TO 250
C 
      CALL REFINE
      CALL QRECAL(X)
C 
      CHITWO=0
      DO 2761 K=1,X
      I=IREF(K)
      M=MREF(K)
      IF(IBON(M) .NE. I) GO TO 2761
      CHITWO=CHITWO+(VTAB(K)/(CHIFAC*EPS(M)))**2
2761  CONTINUE
      CHI2R=CHITWO/(NBON-NINC)
      CHI1R=SQRT(CHI2R)
C 
C computing the information conveyed by this fortunate trial (merit)
C 
      FMU=FAKOND(NLAT)/FRACT
      VC=1/SQRT(VRECI2)
      PWINFO=0
      DO 510 M=1,NQ
      IF(IBON(M) .EQ. 0) GO TO 510
      DELTAI=(CHIFAC*EPS(M))*CHI1R
      IF(M .EQ. 1) THEN
        DELTAM=DELTAI
      ELSE
        DELTAM=MIN(DELTAI,ABS(Q(M)-Q(M-1))*0.5)
      END IF
      IF(M .EQ. NQ) THEN
        DELTAP=DELTAI
      ELSE
        DELTAP=MIN(DELTAI,ABS(Q(M)-Q(M+1))*0.5)
      END IF
      PWINFO=PWINFO+LOG(1-EXP(-(DELTAP+DELTAM)*2*PI*VC/(FMU*D(M))))
510   CONTINUE
      WW=PWINFO*ULOG2
      IF(WW .LT. FWMINI+4*KCYCLE) GO TO 2707
C 
C give another chance to index new lines after refinement
C 
      IF(KCYCLE .LT. 0) THEN
        IF(NBAD .NE. 0) THEN
          KCYCLE=0
          KTOLER=0
          GO TO 1000
        END IF
      END IF
C 
      IF(WW .LT. FWMINI) GO TO 2707
C 
C Reconstruction of multiple labels (cubic, hexa, and tetrag. lattices)
C 
      IBCODE=1
      L=1
      KL=0
401   I=IREF(L)
      DO 47 K=1,NINC
      IF(H2T(K,I) .NE. H2T(K,I+1)) THEN
        L=L+1+KL
        KL=0
        IF(L .LE. X) GO TO 401
        GO TO 405
      END IF
47    CONTINUE
C the table contains two lines of same H2T
C insert it in the list
      IF(X .GE. NCMAX) GO TO 405
      K=X
1402  CONTINUE
      IREF(K+1)=IREF(K)
      MREF(K+1)=MREF(K)
      VTAB(K+1)=VTAB(K)
      QTH(K+1)=QTH(K)
      K=K-1
      IF(K .GE. L) GO TO 1402
      KL=KL+1
      IREF(L)=IREF(L)+1
      I=IREF(L)
      X=X+1
      GO TO 401
405   CONTINUE
C 
C LE RESEAU ESSAYE MARCHE, IL FAUT L'IMPRIMER
C 
       CALL MAILLE
       CALL EDITIO
      NBHITS=NBHITS+1
       GO TO 2555
C 
C SORTIE ANORMALE ' MAUVAIS FACTEUR DE MERITE
C 
2707  CONTINUE
      IBCODE=2
      MAXFND=MAX(NBON,MAXFND)
      IF(WW .LT. MIN(0.8*FWMAXI,0.5*FWMINI)) GO TO 2555
       WRITE(IPRNT,2503) NBON,I,SYMSYM(NLAT:NLAT),
     $   ('; ',HKLT(1,JT(K)),HKLT(2,JT(K)),HKLT(3,JT(K)),MT(K),K=1,N)
2503   FORMAT(1X,I3,' indexed, *Merit too BAD*(',I4,1X,A1,')',A2,
     $  'BASIC LIST:',(T51,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2))
       CALL MAILLE
       F2710='('' Lattice rejected, MERIT='',F7.2,''(min:'',F6.2'//
     $   ','')GR '',A1,'',A='','
     $   //DFORMT//','',B='','//DFORMT//','',C='','//DFORMT//
     $   ','' Alpha='',F7.2,'' Beta='',F7.2,'' Gamma='',F7.2)'
       WRITE(IPRNT,F2710)
     $    WW,FWMINI,SYMSYM(NLAT:NLAT),A,B,C,ALPHA,BETA,GAMMA
       GO TO 2555
C 
250    CONTINUE
       IF(NBON .LE. N+1 .AND. .NOT. INDICN(12)) GO TO 2555
       IF(NBON .LT. MAXFND .AND. .NOT. INDICN(12)) GO TO 2555
       IF(NBON .GT. MAXFND) WRITE(IPRNT, '(1X)')
       MAXFND=MAX(NBON,MAXFND)
       WRITE(IPRNT,2501) NBON,M,SYMSYM(NLAT:NLAT),
     $     ('; ',HKLT(1,JT(K)),HKLT(2,JT(K)),HKLT(3,JT(K)),MT(K),K=1,N)
2501   FORMAT(1X,I3,' INDEXED,',I3,'-TH REJECTED (',A1,')',A2,
     $  'BASIC LIST:',(T46,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2
     $    ,'(',3I3,  ')-LINE',I2,A2))
C Useless to try higher Bravais lattices, if this one fails
2555   CONTINUE
C 
601    CONTINUE
      CALL ATIMER(TEMPTT,2)
      IF(TEMPTT-LASTT .GE. KTNUM) THEN
         LASTT=TEMPTT
         CALL GHMSEC(KTIM1(1),HMSEC1)
         CALL GHMSEC(KTIM1(2),HMSEC2)
         WRITE(IPRNT,2557) HMSEC1,HMSEC2
2557     FORMAT(' ***** Time elapsed in ''MANAGE'':',A,
     $   'sec.; time elapsed in ''CONTRL'' :',A,'sec.')
         IF(TEMPTT-LASTS .GE. 5*KTNUM) THEN
           CALL SAVERS(0)
           LASTS=TEMPTT
           IF(TEMPTT .GT. 50.0*KTNUM) KTNUM=MIN(KTMAX,2*KTNUM)
         END IF
         CALL HEURE(IPRNT)
      END IF
      CALL FINISH
      RETURN
C 
      ENTRY KTIMCL
      CALL ATIMER(TEMPTT,1)
      CALL GHMSEC(KTIM1(1),HMSEC1)
      CALL GHMSEC(KTIM1(2),HMSEC2)
      WRITE(IPRNT,2557) HMSEC1,HMSEC2
      CALL HEURE(IPRNT)
      RETURN
      END
      SUBROUTINE QRECAL(NX)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
      INTEGER NX
C 
      DO 260 K=1,NX
      M=MREF(K)
      IF(M .EQ. 0) GO TO 260
      I=IREF(K)
      QTHK=0
      DO 3100 J=1,NINC
      QTHK=QTHK+AA(J)*H2T(J,I)
3100  CONTINUE
      QTH(K)=QTHK
      VTAB(K)=QTHK-Q(M)
260   CONTINUE
      RETURN
      END
      SUBROUTINE REFINE
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      REAL TSECN(NINCMX)
C 
C!    WRITE(IPRNT, '(6F12.6)') (AA(I),I=1,NINC)
      DO 3010 J=1,NINC
      TSECN(J)=0
      DO 3010 I=1,NINC
      TMAT(I,J)=0
3010  CONTINUE
C 
      DO 310 M=1,NQ
      I=IBON(M)
      IF(I .GT. 0) THEN
        WEPSM=1./(CHIFAC*EPS(M))**2
        DO 3050 J=1,NINC
        TSECN(J)=TSECN(J)+Q(M)*(H2T(J,I)*WEPSM)
        DO 3050 K=1,NINC
        TMAT(K,J)=TMAT(K,J)+H2T(K,I)*(H2T(J,I)*WEPSM)
3050    CONTINUE
      END IF
310   CONTINUE
C 
C RESOLUTION DU SYSTEME
C 
      DO 100 L=1,NINC
      PIV=TMAT(L,L)
      TSECN(L)=TSECN(L)/PIV
      IF(L .EQ. NINC) GO TO 110
      LP1=L+1
      TMAT(L,L)=1
      DO 102 I=LP1,NINC
102   TMAT(I,L)=TMAT(I,L)/PIV
      DO 104 K=LP1,NINC
      R=TMAT(L,K)
      TMAT(L,K)=0
      DO 105 I=LP1,NINC
105   TMAT(I,K)=TMAT(I,K)-R*TMAT(I,L)
      TSECN(K)=TSECN(K)-R*TSECN(L)
104   CONTINUE
100   CONTINUE
110   CONTINUE
      L=NINC-1
      LP1=NINC
111   CONTINUE
      IF(L .GT. 0) THEN
        DO 112 K=LP1,NINC
        TSECN(L)=TSECN(L)-TMAT(K,L)*TSECN(K)
112     CONTINUE
        LP1=L
        L=L-1
        GO TO 111
      END IF
      DO 3052 J=1,NINC
3052  AA(J)=TSECN(J)
C 
C CALCUL DU VOLUME RECIPROQUE**2
C 
      CALL VOLCAL
      RETURN
      END
      SUBROUTINE VOLCAL
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      GO TO  (231,232,233,234,235,236),NSYS
231   VRECI2=AA(1)**3
      GO TO 239
232   VRECI2=AA(1)**2*AA(2)
      GO TO 239
233   VRECI2=AA(1)*AA(2)*AA(3)
      GO TO 239
234   VRECI2=AA(3)*(AA(1)*AA(2)-AA(4)**2)
      GO TO 239
235   VRECI2=AA(1)**2*AA(2)*0.75
      GO TO 239
236   CONTINUE
      VRECI2=AA(1)*AA(2)*AA(3)+2*AA(4)*AA(5)*AA(6)
     $ -AA(3)*AA(4)**2-AA(1)*AA(5)**2-AA(2)*AA(6)**2
239   CONTINUE
C 
C!    WRITE(IPRNT, '(6F12.6)') (AA(I),I=1,NINC)
      RETURN
      END
      SUBROUTINE EDITIO
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
      LOGICAL OVERFL
      CHARACTER*30 DATTIM
      CHARACTER*128 F2012,F1001,F1002,F1005,LOGFMT
      CHARACTER*160 F0102
C 
      CHARACTER*132 OUTLNE
      LOGICAL OUTFUL
C 
      COMMON/OPUFLG/OUTFUL
      COMMON/OUTLNE/OUTLNE
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
C 
      CHARACTER*4 IAST,ICAR,ICAB,IHTRI,KYSYS
C 
C DATA
C 
      DATA IAST/'BASE'/
      DATA IHTRI/'TRIC'/
C 
C END DATA
C 
      F0102='(/'' A= '','//DFORMT//',4X,''B= '','//DFORMT//
     $   ',4X,''C= '','//DFORMT//
     $   ',3X,''ALPHA= '',F8.4,3X,''BETA= '',F8.4,3X,''GAMMA= '',F8.4/'
     $   //'/'' VOLUME OF THE UNIT CELL : '','//VFORMT//')'
      LOGFMT='('' A='','//DFORMT//',1X,''B='','//DFORMT//
     $   ',1X,''C='','//DFORMT//
     $   ',1X,''ALPHA='',F8.4,1X,''BETA='',F8.4,1X,''GAMMA='',F8.4,'
     $   //' '' Vol='','//VFORMT//')'
102   FORMAT(' Number of experimental lines INDEXED :',I4
     $   ,5X,'number of lines rejected :',I3
     $   /' Lattice type : ',A1)
      F1005='(/'' Standard deviations :'',T80,F8.4,8X,'//QFORMT//
     $  '/'' Reduced chi**2:'',F7.3,'' Reduced chi:'',F7.3)'
      F1002='(3X,3A,1X,A1,1X,A4,3I3,1X,F9.4,'
     $   //DFORMT//','//QFORMT//',F8.4,F8.3,'
     $   //QFORMT//',A,I5)'
      F1001='(1X,I3,F9.4,'//DFORMT//','//QFORMT//
     $   ',1X,A1,1X,A4,3I3,1X,F9.4,'//DFORMT//','//QFORMT//
     $   ',F8.4,F8.3,'//QFORMT//','//QFORMT//',I5)'
      F2012='(1X,I3,F9.4,'//DFORMT//','//QFORMT//
     $    ',1X,A1,1X,58(''*''),'' NOT INDEXED '')'
C 
C this gets the current real time as a string of 30 characters,
C to be replaced by any convenient subroutine, or by nothing
C 
      CALL FRTIMC(DATTIM)
C 
C multiplicity factor
      FMU=FAKOND(NLAT)/FRACT
C 
      KYSYS=ISYS(1:4)
      IF(KYSYS .EQ. IHTRI) KYSYS='3   '
2051  FORMAT(1X,A1,10X,A60/I3,',,,,,,,,,,,,,,,')
      NBON=NQ-NBAD
      IF(INDICN(8)) WRITE(IPUNCH,2051)  KYSYS,TITLE ,NBON
      WRITE(IPRNT,100) ISYS,TITLE,DATTIM
100   FORMAT('1 '/' '/' System : ',A,3X,A,' *** ',A,' *** '/)
      OUTFUL=.FALSE.
C 
CECI EST LA RECHERCHE DES RAIES NON INDEXEES. ELLES SONT INTERCALEES A L
C PLACE DANS LA LISTE ET IMPRIMEES AVEC UN FORMAT SPECIAL
C 
      OVERFL=X .GE. NCMAX
      X=MIN(X,NCMAX-1)
      NN=N
      WRITE(IPRNT,3999) (JT(K),K=1,NN)
      WRITE(IPRNT,3999) (MT(K),K=1,NN)
3999  FORMAT(1X,11I6)
      NQ1=NQ
      DO 1100 K=1,NQ1
      DO 1101 I=1,X
      M=MREF(I)
      IF(Q(K)-Q(M)) 1102,1100,1101
 1101 CONTINUE
      I=X+1
      IF(X .LT. NCMAX-1) GO TO 1103
      OVERFL=.TRUE.
      GO TO 1110
 1102 CONTINUE
      L=X
      IF(X .LT. NCMAX-1) GO TO 1144
      OVERFL=.TRUE.
      GO TO 1110
 1144 CONTINUE
      MREF(L+1)=MREF(L)
      QTH(L+1)=QTH(L)
      VTAB(L+1)=VTAB(L)
      IREF(L+1)=IREF(L)
      L=L-1
      IF(L .GE. I) GO TO 1144
 1103 X=X+1
      QTH(I)=0
      MREF(I)=K
      VTAB(I)=0.1E38
      IREF(I)=0
 1100 CONTINUE
1110  IF(OVERFL) WRITE(IPRNT, 1111)
1111  FORMAT(' TOO MANY OUTPUT LINES. LISTING TRUNCATED.')
      MREF(X+1)=0
      QTH(X+1)=0
      IREF(X+1)=0
C 
C DEBUT DE L'IMPRESSION DES RESULTATS
C 
      ME=0
      PWINFO=0
      QC=0
      VV=0
      SIGCHI=0
      SIGCHI=0
      SIGTOT=0
      SIGDWL=0
      SIGDD2=1.E-28
      DD=0
      NBON=0
      WRITE(IPRNT,1000)
1000  FORMAT(1X/3X,'  2-th obs.  D obs.  1/D**2 obs.',
     $ 5X,'  H  K  L  2-th cal.  D cal.  1/D**2 cal'
     $ ,' d(2-th)  %-d(D) d(1/D**2) max.dev. ref.',
     $ ' Merit Info'  /)
      II=2
      DO 2000 I=1,X
      M=MREF(I)
      ICAR=' '
      IF(.NOT. CERT(M)) ICAR='?'
      IF(ICON(M) .EQ. 0) GO TO 1080
      IC=ICON(M)
      IF(JT(IC) .NE. IREF(I)) GO TO 1080
      ICAR='D'
1080  CONTINUE
      IF(II .GE. 50) THEN
        II=0
        WRITE(IPRNT,101)
        WRITE(IPRNT,1000)
      END IF
101   FORMAT('1  '/)
      ICAB='    '
      NN=N
      DO 1050 J=1,NN
      IF(IREF(I) .NE. JT(J)) GO TO 1050
      IF(M .NE. MT(J)) GO TO 1050
      ICAB=IAST
1050  CONTINUE
      IF(IBON(M) .EQ. 0) THEN
C 
C this given line is not indexed, since IBON(I)=0
        DD=0
        WRITE(IPRNT,F2012) M,TWOT(M),D(M),Q(M),ICAR
        GO TO 2011
      END IF
C 
C This line is indexed.
C 
      IREFI=IREF(I)
      IF(INDICN(8)) WRITE(IPUNCH,2050)D(M),(HKLT(JJ,IREFI),JJ=1,3),WL(M)
2050  FORMAT(F10.5,12X,3I3,3X,F10.5)
      DCAL=SQRT(1/QTH(I))
      PCENTD=200.0*(D(M)-DCAL)/(D(M)+DCAL)
      SINCAL=WL(M)*0.5/DCAL
      COSCAL=SQRT(MAX(0.,1-SINCAL**2))
      TWOCAL=(360.0/PI)*ATAN2(SINCAL,COSCAL)
      DTWCAL=TWOT(M)-TWOCAL
      IF(M .NE. ME) THEN
C This line is distinct from the previous one, it deserves complete list
          NBON=NBON+1
          VV=ABS(VTAB(I))
          DCHI=(VTAB(I)/(CHIFAC*EPS(M)))**2
          DD=DTWCAL**2
          M=M
          CALL OPURGE
          WRITE(OUTLNE,F1001)
     $    M,TWOT(M),D(M),Q(M),ICAR,ICAB,(HKLT(JJ,IREFI),JJ=1,3),
     $    TWOCAL,DCAL,QTH(I),DTWCAL,PCENTD,VTAB(I),(CHIFAC*EPS(M)),
     $    IREF(I)
          OUTFUL=.TRUE.
C 
C CETTE RAIE CORRESPOND A LA MEME EXPERIMENTALE QUE LA PRECEDENTE
C 
      ELSE IF(QTH(I) .NE. QC) THEN
C RAIE THEORIQUE DIFFERENTE, MAIS MEME EXPERIMENTALE; LISTING PARTIEL.
          VV2=ABS(VTAB(I))
          IF(VV2 .LT. VV) THEN
             VV=VV2
             DD=DTWCAL**2
             DCHI=(VTAB(I)/(CHIFAC*EPS(M)))**2
          END IF
          CALL OPURGE
          WRITE(OUTLNE,F1002) VDOTSF,VDOTSF,VDOTSF,
     $    ICAR,ICAB,(HKLT(JJ,IREFI),JJ=1,3),TWOCAL,DCAL,
     $    QTH(I),DTWCAL,PCENTD,VTAB(I),VDOTSF,IREF(I)
          OUTFUL=.TRUE.
      ELSE
          CALL OPURGE
          WRITE(OUTLNE,1003)
     $      ICAR,ICAB,(HKLT(JJ,IREFI),JJ=1,3),IREF(I)
1003  FORMAT(3X,3('    ..... '),1X,A1,1X,A4,3I3,1X,
     $    '  ......    ......    ......  ',
     $    '  ....    ....    .......   .....  ',I5)
      END IF
C 
C RETOUR COMMUN POUR LES RAIES INDEXEES
C 
      IF(M .EQ. MREF(I+1) .AND. I .LT. X) GO TO 2011
      SIGTOT=SIGTOT+VV**2
      SIGDWL=SIGDWL+VV
      SIGCHI=SIGCHI+DCHI
      SIGDD2=SIGDD2+DD
      DELTAI=(CHIFAC*EPS(M))*CHI1R
      IF(M .EQ. 1) THEN
        DELTAM=DELTAI
      ELSE
        DELTAM=MIN(DELTAI,ABS(Q(M)-Q(M-1))*0.5)
      END IF
      IF(M .EQ. NQ) THEN
        DELTAP=DELTAI
      ELSE
        DELTAP=MIN(DELTAI,ABS(Q(M)-Q(M+1))*0.5)
      END IF
      EXPONT=(DELTAM+DELTAP)*2*PI*VC/(FMU*D(M))
      PWINFO=PWINFO+LOG(1-EXP(-EXPONT))
      SIGDD2=SIGDD2+DD
      DEWOLF=D(M)/((8*PI/3)*VC*(SIGDWL/NBON))*FMU
      IF(OUTFUL) THEN
        IF(DEWOLF .LT. 100) THEN
          WRITE(OUTLNE(121:125),'(F5.1)') DEWOLF
        ELSE
          WRITE(OUTLNE(121:125),'(F5.0)') MIN(DEWOLF,9999.0)
        END IF
        IF(PWINFO*ULOG2 .LT. 1000) THEN
          WRITE(OUTLNE(127:131),'(F5.1)') PWINFO*ULOG2
        ELSE
          WRITE(OUTLNE(127:131),'(F5.0)') MIN(PWINFO*ULOG2,9999.0)
        END IF
        CALL OPURGE
      ELSE
          WRITE(IPRNT,2568,ERR=12568) DEWOLF,PWINFO*ULOG2
12568     CONTINUE
2568  FORMAT(' ',119X,F5.1,1X,F5.1)
      END IF
C 
C RETOUR COMMUN POUR TOUTES LES RAIES (INDEXEES OU NON).
C 
 2011 CONTINUE
      ME=M
      QC=QTH(I)
      II=II+1
2000  CONTINUE
      CALL OPURGE
      SIGMAQ=SQRT(SIGTOT/NBON)
      CHI2R=SIGCHI/(NBON-NINC)
      SIGMAD=MIN(999.0,SQRT(SIGDD2/NBON))
      WRITE(IPRNT,F1005) SIGMAD,SIGMAQ,CHI2R,CHI1R
      WRITE(IPRNT,F0102) A,B,C,ALPHA,BETA,GAMMA,VC
  
C     GGJJ MODIFICATION TO PUT OUT RESULTS IN TERSE FILE AT 80 CHARACTERS
  
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,90112)
90112 FORMAT(/' ****************************************************'/)
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,90102) A,B,C,ALPHA,BETA,GAMMA,VC
90102 FORMAT(' A       = ',F10.4,' B        = ',F10.4,
     1       ' C         = ',F10.4,/
     1       ' ALPHA   = ',F10.4,' BETA     = ',F10.4,
     1       ' GAMMA     = ',F10.4,/
     1       ' VOLUME  = ',F10.4)
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,4545)
     $     MIN(DEWOLF,9999.0),MIN(PWINFO*ULOG2,9999.0)
4545  FORMAT(' DeWolf Figure of Merit ',F8.2,' Information Merit ',
     1         F8.2)
  
C     GGJJ NOTE IF THIS VALUE WERE TO BE SET ON INPUT, IT COULD BE
C          SET EQUAL TO 100, AND THE PROGRAM WOULD RUN AS DELIVERED.
C          IF SET EQUAL TO A SMALLER VALUE (IE 10), THEN AS AT MRL/PSU.
  
      IF(ILOGF .NE. 0) THEN
        WRITE(ILOGF,*)ISYS(1:8),' ',TITLE(:ITRIML(TITLE))
        WRITE(ILOGF,LOGFMT) A,B,C,ALPHA,BETA,GAMMA,VC
      END IF
      WRITE(IPRNT,102) NBON,NBAD,SYMSYM(NLAT:NLAT)
      IF(ISUMRY .NE. 0) WRITE(ISUMRY,102) NBON,NBAD,SYMSYM(NLAT:NLAT)
      IF(INDICN(9)) THEN
        VMOL=VMOL
        FNV=VC/VMOL
        WRITE(IPRNT,3176) FNV
3176    FORMAT(' Number of asymmetrical UNITS :',F10.5)
      END IF
      CALL HEURE(IPRNT)
      FWMAXI=MAX(FWMAXI,PWINFO*ULOG2)
      IF(ILOGF .NE. 0) WRITE(ILOGF,3077) ULOG2*PWINFO,NBON,NQ-NBON
3077  FORMAT(' Merit: ',F10.2,'  indexed:',I5,'  rejected:',I4)
      IF(.NOT.INDICN(10)) THEN
        FWMINI=MAX(FWMINI,FWMAXI-10)
        CHIVOX=FVDMER(FWMINI)
        VMAXI=CHIVOX/CHIMIN
        VMMIN=MAX(VMMIN,1/VMAXI**2)
        VMAXI=1/SQRT(VMMIN)
        WRITE(IPRNT,*) 'updated minimum merit:',FWMINI,
     $   '  --> maximum chi_r*volume:' ,CHIVOX,
     $   '  -->  updated maximum volume:',VMAXI
      END IF
      WRITE(IPRNT,3177)
3177  FORMAT(/' ',127('*')/1X)
      IF(INDICN(8)) WRITE(IPUNCH,2052)
2052  FORMAT(72('*'))
      RETURN
      END
      SUBROUTINE OPURGE
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      CHARACTER*132 OUTLNE
      LOGICAL OUTFUL
C 
      COMMON/OPUFLG/OUTFUL
      COMMON/OUTLNE/OUTLNE
      IF(OUTFUL) THEN
        WRITE(IPRNT,2099) OUTLNE(:ITRIML(OUTLNE))
        OUTLNE=' '
        OUTFUL=.FALSE.
      END IF
2099  FORMAT(A)
      RETURN
      END
       SUBROUTINE MAILLE
C 
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
      A=-99.9
      B=-99.9
      C=-99.9
      VC=0
      ALPHA=0
      BETA=0
      GAMMA=0
      IF(VRECI2 .LE. 0) RETURN
      VRECI=SQRT(VRECI2)
      VC=1/VRECI
      GO TO (100,200,300,300,200,300),NSYS
300   IF(AA(3) .LE. 0) RETURN
      CR=SQRT(AA(3))
200   IF(AA(2) .LE. 0) RETURN
      BR=SQRT(AA(2))
100   IF(AA(1) .LE. 0) RETURN
      AR=SQRT(AA(1))
      GO TO (1000,2000,3000,4000,5000,6000),NSYS
1000  CONTINUE
      A=1/AR
      B=A
      C=A
      RETURN
2000  CONTINUE
      A=1/AR
      C=1/BR
      B=A
       RETURN
3000   CONTINUE
       A=1/AR
       B=1/BR
       C=1/CR
       RETURN
 4000  CONTINUE
       A=BR*CR/VRECI
       B=CR*AR/VRECI
       C=1/CR
       SINC=VC/(A*B*C)
       COSC=-AA(4)/(AR*BR)
       GO TO 700
 5000  CONTINUE
       A=SQRT(4./(3.*AA(1)))
       B=A
       C=1/BR
       RETURN
 6000  CONTINUE
       COSCR=AA(4)/(AR*BR)
       COSAR=AA(5)/(BR*CR)
       COSBR=AA(6)/(CR*AR)
      COSAR=MAX(-1.0,MIN(1.0,COSAR))
      COSBR=MAX(-1.0,MIN(1.0,COSBR))
      COSCR=MAX(-1.0,MIN(1.0,COSCR))
       SINAR=SQRT(1-COSAR**2)
       SINBR=SQRT(1-COSBR**2)
       SINCR=SQRT(1-COSCR**2)
       COSA=(COSBR*COSCR-COSAR)/(SINBR*SINCR)
       COSB=(COSCR*COSAR-COSBR)/(SINCR*SINAR)
       COSC=(COSAR*COSBR-COSCR)/(SINAR*SINBR)
      COSA=MAX(-1.0,MIN(1.0,COSA))
      COSB=MAX(-1.0,MIN(1.0,COSB))
      COSC=MAX(-1.0,MIN(1.0,COSC))
       SINA=SQRT(1-COSA**2)
       SINB=SQRT(1-COSB**2)
       SINC=SQRT(1-COSC**2)
       ALPHA=90. - (180./PI)*ATAN2(COSA,SINA)
       BETA=90. - (180./PI)*ATAN2(COSB,SINB)
       A=BR*CR*SINAR/VRECI
       B=CR*AR*SINBR/VRECI
       C=AR*BR*SINCR/VRECI
  700  GAMMA=90. - (180./PI)*ATAN2(COSC,SINC)
       RETURN
      END
       SUBROUTINE FINISH
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER*4 K
C 
C DATA
C 
       DATA K/0/
C 
C END DATA
C 
C This subroutine tests whether maximum c.p.u. time is exceeded
C If it is, and if GENDAT(5) is positive it saves data and stops
C if it is, but GENDAT(5) < 0 or no save/restart file is allocated,
C           then it continues and swaps the output file
C 
      CALL ELAPSE(K)
      RNSEC=K*TINTVL
      IF(RNSEC.LT.TIMMAX.AND.NBMMX.GT.0.AND.NBHITS.LT.MAXHIT) RETURN
      CALL PCAUSE
      IF(IRREST .NE. 0) THEN
        CALL SAVERS(1)
        IF(GENDAT(5) .GE. 0) THEN
          WRITE(IPRNT,58)
58        FORMAT(/' Programme suspended.'/1X)
          CALL GCLOSE(1)
          STOP
        END IF
      END IF
      IF(NBHITS .GE. MAXHIT) THEN
        PRINT *,' maximum number of possible lattices exhausted: stop'
        STOP
      END IF
C 
C this routine is supposed to close IPRNT (if not zero)
C and to open another file of name ad libitum and returned
C into PRTFIL (CHARACTER*60)
C 
        CALL PRTSWP(IPRNT,PRTFIL,.TRUE.)
        IF(TIMMAX .GT. 8*TIMQTM) TIMQTM=2*TIMQTM
        TIMMAX=TIMMAX+TIMQTM
        IF(NBMMX .LE. 0) NBMMX=NINT(GENDAT(16))    ! DT 03-JAN-1991
        IF(NBMMX .LE. 0) NBMMX=128                 ! DT 03-JAN-1991
      RETURN
      END
       SUBROUTINE SAVERS(KPRT)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
      CHARACTER*80 INPLIN
C 
C THIS ROUTINE SAVES RESTART DATA IN CASE OF A 'MAX TIME' ABORT...
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER*4 KPART
      CALL HEURE(IPRNT)
      IF(IRREST .NE. 0) THEN
        OPEN(IRREST,FILE=RNAME,STATUS='OLD',IOSTAT=IERR)
        IF(IERR .NE. 0) THEN
          WRITE(IPRNT,*)
     $    'Unable to re-open ',RNAME(:ITRIML(RNAME)),IERR
          IRREST=0
        ELSE
          WRITE(IRREST,58) TOMAKE
          WRITE(IRREST,55) NPERMU,N
          WRITE(IRREST,59) JT
          WRITE(IRREST,561) NCAUSE
          WRITE(IRREST,56) FWMINI,FWMAXI
          CALL ATIMER(KPART,1)
          WRITE(IRREST,561) KTIM1,KSTART+KPART
          CLOSE(IRREST)
          WRITE(IPRNT,52)
52        FORMAT(' Restart data saved.' /1X)
          IF(KPRT .NE. 0) THEN
          WRITE(IPRNT,58) TOMAKE
          WRITE(IPRNT,55) NPERMU,N
          WRITE(IPRNT,59) JT
          WRITE(IPRNT,561) NCAUSE
          WRITE(IPRNT,56) FWMINI,FWMAXI
          WRITE(IPRNT,*) KTIM1,KSTART+KPART
     $    ,' (',KSTART,'+',KPART,')'
          END IF
        END IF
      END IF
      RETURN
C 
      ENTRY RESTRS
      IF(IRREST .NE. 0) THEN
        OPEN(IRREST,FILE=RNAME,STATUS='OLD',IOSTAT=IERR)
        IF(IERR .NE. 0) THEN
          WRITE(IPRNT,*)
     $     'Unable to re-open ',RNAME(:ITRIML(RNAME)),IERR
          IRREST=0
        ELSE
          WRITE(IPRNT,574) IRREST
  574     FORMAT(/' *** JOB restarted using following'
     $      ,' data from UNIT No.' ,I3,' ***'/)
          READ(IRREST,555,END=57) INPLIN
555       FORMAT(A)
          IF(INPLIN .EQ. ' ') GO TO 57
          READ(INPLIN,58) TOMAKE
          WRITE(IPRNT,58) TOMAKE
58        FORMAT(36L2)
          READ(IRREST,55) NPERMR,NR
          WRITE(IPRNT,55) NPERMR,NR
55        FORMAT(2I4)
          READ(IRREST,59) JDEPR
          WRITE(IPRNT,59) (JDEPR(I),I=0,NR)
59        FORMAT(12I6)
          IF(NPERMR .LE. 0) GO TO 57
          IF(NR .GT. JMAX) GO TO 57
          READ(IRREST,561) NCAUSE
          WRITE(IPRNT,561) NCAUSE
561       FORMAT(7I10)
          READ(IRREST,56) FWMINR,FWMAXR
          WRITE(IPRNT,56) FWMINR,FWMAXR
56        FORMAT(6G12.4)
          READ(IRREST,561) KTIM1,KSTART
          WRITE(IPRNT,561) KTIM1,KSTART
          DOREST=.TRUE.
57        CONTINUE
          CLOSE(IRREST)
        END IF
      END IF
      END
      SUBROUTINE REMOVE(N)
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      WRITE(IPRNT,149) N
149   FORMAT(/' The indices given to the',I3,'-th line cannot fit',
     $  ' the tried lattice.')
      END
      SUBROUTINE TETRAG(LATLET)
C 
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/7     /
C 
C END DATA
C 
      IF(INDEX('FIABP',LATLET) .EQ. 0) RETURN
      NINC=2
      NSYS=2
      FRACT=1./16.
      ISYS=LATLET//'-TETRAGONAL'
C 
      MAXFND=0
      TROUVE=.FALSE.
      ALPHA=90
      BETA=90
      GAMMA=90.
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      L=0
  11  CONTINUE
      K=0
      ISS=0
  12  CONTINUE
      H=INT(SQRT(0.5+MAX(K**2,HPKPL-K**2-L**2)))
  13  CONTINUE
      IF(H**2+K**2+L**2-HPKPL)14,2,15
   2  CONTINUE
      IBRAV=IBRAVF(H,K,L,MASK(NLAT))
      IF(IBRAV .EQ. 0) GO TO 14
      IF(NT .GE. NTMX) GO TO 19
      NT=NT+1
      H2T(1,NT)=H**2+K**2
      H2T(2,NT)=L**2
      H2T(3,NT)=K**2
      HKLT(1,NT)=H
      HKLT(2,NT)=K
      HKLT(3,NT)=L
      SHKL(NT)=ISS
      ISS=2
      HPKPLX=HPKPL
      NTMAXE=NT
      GO TO 15
  14  H=H+1
      GO TO 13
  15  K=K+1
      IF(L**2+2*K**2 .LE. HPKPL) GO TO 12
      L=L+1
      IF(L**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
  19  CONTINUE
      IF(.NOT. INDICN(12)) GO TO 69
  73  FORMAT(7(I5,'.',3I4))
      IPAGE=COLONN*50
      DO 70 I=1,NTMAXE,IPAGE
      WRITE(IPRNT,74) ISYS
  74  FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table '/1X)
      JJMAX=MIN(NTMAXE,I+49)
      DO 71 J=I,JJMAX
      KMAX=MIN(NTMAXE,J+IPAGE-1)
      WRITE(IPRNT,73) (K,H2T(1,K),H2T(2,K),H2T(3,K),K=J,KMAX,50)
   71  CONTINUE
   70  CONTINUE
   69  CONTINUE
      NPERMU=0
      IF(NCON.EQ. 0) GO TO 140
      DO 141 N=1,NCON
      DO 145 J=1,NT
      IF(HKLCON(1,N)**2+HKLCON(2,N)**2 .NE. H2T(1,J)) GO TO 145
      IF(HKLCON(3,N)**2 .EQ. H2T(2,J)) GO TO 146
145    CONTINUE
      CALL REMOVE(N)
      RETURN
146   JCON(N)=J
  141  CONTINUE
  140  CONTINUE
      CALL MANAGE
      RETURN
      END
      SUBROUTINE HEXAGO(LATLET)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/7     /
C 
C END DATA
C 
      IF(INDEX('IP',LATLET) .EQ. 0) RETURN
      NINC=2
      NSYS=5
      FRACT=1./24.
C 
      MAXFND=0
      TROUVE=.FALSE.
      ISYS=LATLET//'-HEXAGONAL'
      ALPHA=90
      BETA=90
      GAMMA=120.
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      L=0
  11  CONTINUE
      K=0
       ISS=0
  12  CONTINUE
      H=INT(SQRT(0.5+(HPKPL-K**2-L**2))*0.5)
  13  CONTINUE
      IF(H**2+H*K+K**2+L**2-HPKPL)14,2,15
   2  CONTINUE
      IBRAV=IBRAVF(H,K,L,MASK(NLAT))
      IF(IBRAV .EQ. 0) GO TO 14
      IF(NT .GE. NTMX) GO TO 19
      NT=NT+1
      H2T(1,NT)=H**2+K**2+H*K
      H2T(2,NT)=L**2
      H2T(3,NT)=K**2
      HKLT(1,NT)=H
      HKLT(2,NT)=K
      HKLT(3,NT)=L
      SHKL(NT)=ISS
      ISS=2
      HPKPLX=HPKPL
      NTMAXE=NT
      GO TO 15
  14  H=H+1
      GO TO 13
  15  K=K+1
      IF(L**2+K**2 .LE. HPKPL) GO TO 12
      L=L+1
      IF(L**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
   19  CONTINUE
       IF(.NOT. INDICN(12)) GO TO 69
   73  FORMAT(7(I5,'.',3I4))
       IPAGE=COLONN*50
       DO 70 I=1,NTMAXE,IPAGE
       WRITE(IPRNT,74) ISYS
  74  FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table'/1X)
       JJMAX=MIN(NTMAXE,I+49)
       DO 71 J=I,JJMAX
       KMAX=MIN(NTMAXE,J+IPAGE-1)
       WRITE(IPRNT,73) (K,H2T(1,K),H2T(2,K),H2T(3,K),K=J,KMAX,50)
   71  CONTINUE
   70  CONTINUE
   69  CONTINUE
       NPERMU=0
       IF(NCON.EQ. 0) GO TO 140
       DO 141 N=1,NCON
       DO 145 J=1,NT
       IF(HKLCON(1,N)**2+HKLCON(2,N)**2+HKLCON(1,N)*HKLCON(2,N)
     $  .NE. H2T(1,J)) GO TO 145
       IF(HKLCON(3,N)**2 .EQ. H2T(2,J)) GO TO 146
  145  CONTINUE
       CALL REMOVE(N)
      RETURN
146    JCON(N)=J
141    CONTINUE
140    CONTINUE
       CALL MANAGE
       RETURN
      END
      SUBROUTINE ORTHOR(LATLET)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
      LOGICAL SYM1
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/7     /
C 
C END DATA
C 
      IF(INDEX('FIABCP',LATLET) .EQ. 0) RETURN
      NINC=3
      NSYS=3
      FRACT=1./8.
C 
      MAXFND=0
      TROUVE=.FALSE.
      ISYS=LATLET//'-ORTHORHOMBIC'
      ALPHA=90
      BETA=90
      GAMMA=90.
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      H=0
11    CONTINUE
      K=0
12    CONTINUE
      L=INT(SQRT(HPKPL-H**2-K**2+0.5))
      IF(H**2+K**2+L**2 .EQ. HPKPL) THEN
        IBRAV=IBRAVF(H,K,L,MASK(NLAT))
        IF(IBRAV .NE. 0) THEN
          IF(NT .GE. NTMX) GO TO 19
          NT=NT+1
          H2T(1,NT)=H**2
          H2T(2,NT)=K**2
          H2T(3,NT)=L**2
          HKLT(1,NT)=H
          HKLT(2,NT)=K
          HKLT(3,NT)=L
          SHKL(NT)=0
          HPKPLX=HPKPL
          NTMAXE=NT
        END IF
      END IF
      K=K+1
      IF(H**2+K**2 .LE. HPKPL) GO TO 12
      H=H+1
      IF(H**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
  19  CONTINUE
      IF(.NOT. INDICN(12)) GO TO 69
  73  FORMAT(7(I5,'.',3I4))
      IPAGE=COLONN*50
      DO 70 I=1,NTMAXE,IPAGE
      WRITE(IPRNT,74) ISYS
  74  FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table '/1X)
      JJMAX=MIN(NTMAXE,I+49)
      DO 71 J=I,JJMAX
      KMAX=MIN(NTMAXE,J+IPAGE-1)
      WRITE(IPRNT,73) (K,H2T(1,K),H2T(2,K),H2T(3,K),K=J,KMAX,50)
  71  CONTINUE
  70  CONTINUE
   69  CONTINUE
       NPERMU=0
       IF(NCON.EQ. 0) GO TO 140
C 
C SPECIAL ORTHORHOMBIQUE INITIALISATION DE LA PERMUTATION DES INDICES CO
       SYM1=.FALSE.
  400  SYM2=0
  401  CONTINUE
       DO 141 N=1,NCON
       DO 145 J=1,NT
       IF(HKLCON(1,N)**2 .NE. H2T(1,J)) GO TO 145
       IF(HKLCON(2,N)**2 .NE. H2T(2,J)) GO TO 145
       IF(HKLCON(3,N)**2 .EQ. H2T(3,J)) GO TO 146
145    CONTINUE
       CALL REMOVE(N)
      RETURN
146    JCON(N)=J
141    CONTINUE
140    CONTINUE
       CALL MANAGE
C 
C SPECIAL ORTHORHOMBIQUE: PERMUTER LES INDICES DES RAIES CONNUES
      IF(NCON)40,9997,40
   40  CONTINUE
       SYM2=SYM2+1
       DO 402 I=1,NCON
       LL=HKLCON(1,I)
       HKLCON(1,I)=HKLCON(2,I)
       HKLCON(2,I)=HKLCON(3,I)
       HKLCON(3,I)=LL
  402  CONTINUE
       IF(SYM2 .LT. 3) GO TO 401
       SYM1=.NOT. SYM1
       DO 403 I=1,NCON
       LL=HKLCON(1,I)
       HKLCON(1,I)=HKLCON(2,I)
       HKLCON(2,I)=LL
  403  CONTINUE
       IF(SYM1) GO TO 400
C GENERAL
C 
 9997  CONTINUE
      RETURN
      END
      SUBROUTINE MONOCL(LATLET)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
C 
      LOGICAL SYM1,SYM2
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/6/
C 
C END DATA
C 
      IF(INDEX('IABP',LATLET) .EQ. 0) RETURN
      NINC=4
      NSYS=4
      FRACT=1./4.
C 
      MAXFND=0
      TROUVE=.FALSE.
      ISYS=LATLET//'-MONOCLINIC'
       ALPHA=90
       BETA=90
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      H=0
11    CONTINUE
      K=0
12    CONTINUE
      L=INT(SQRT(HPKPL-H**2-K**2+0.5))
      IF(H**2+K**2+L**2 .EQ. HPKPL) THEN
        IF(H*K .NE. 0) THEN
          ISKEND=-1
        ELSE
          ISKEND=1
        END IF
        DO 2 ISK=1,ISKEND,-2
        IBRAV=IBRAVF(H,K*ISK,L,MASK(NLAT))
        IF(IBRAV .NE. 0) THEN
          IF(NT .GE. NTMX) GO TO 19
          NT=NT+1
          H2T(1,NT)=H**2
          H2T(2,NT)=K**2
          H2T(3,NT)=L**2
          H2T(4,NT)=H*K*ISK*2
          HKLT(1,NT)=H
          HKLT(2,NT)=K*ISK
          HKLT(3,NT)=L
          SHKL(NT)=0
          HPKPLX=HPKPL
          NTMAXE=NT
        END IF
2       CONTINUE
      END IF
      K=K+1
      IF(H**2+K**2 .LE. HPKPL) GO TO 12
      H=H+1
      IF(H**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
19    CONTINUE
      IF(INDICN(12)) THEN
73      FORMAT(6(I5,'.',4I4))
        IPAGE=COLONN*50
        DO 70 I=1,NTMAXE,IPAGE
        WRITE(IPRNT,74) ISYS
74      FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table '/1X)
         JJMAX=MIN(NTMAXE,I+49)
         DO 71 J=I,JJMAX
         KMAX=MIN(NTMAXE,J+IPAGE-1)
         WRITE(IPRNT,73)
     $      (K,H2T(1,K),H2T(2,K),H2T(3,K),H2T(4,K),K=J,KMAX,50)
71       CONTINUE
70       CONTINUE
      END IF
       NPERMU=0
       IF(NCON.EQ. 0) GO TO 140
C 
C SPECIAL MONOCLINIQUE . INITIALISATION DE LA PERMUTATION DES INDICES CO
       SYM1=.FALSE.
  400  SYM2=.FALSE.
  401  CONTINUE
       DO 141 N=1,NCON
       DO 145 J=1,NT
       IF(HKLCON(1,N)**2 .NE. H2T(1,J)) GO TO 145
       IF(HKLCON(2,N)**2 .NE. H2T(2,J)) GO TO 145
       IF(HKLCON(3,N)**2 .NE. H2T(3,J)) GO TO 145
       IF(HKLCON(1,N)*HKLCON(2,N)*2 .EQ. H2T(4,J)) GO TO 146
145    CONTINUE
       CALL REMOVE(N)
      RETURN
146    JCON(N)=J
141    CONTINUE
140    CONTINUE
       CALL MANAGE
       IF(NCON .EQ. 0) GO TO 9997
       SYM2=.NOT. SYM2
       DO 402 I=1,NCON
       LL=HKLCON(1,I)
       HKLCON(1,I)=HKLCON(2,I)
       HKLCON(2,I)=LL
  402  CONTINUE
       IF(SYM2) GO TO 401
       SYM1=.NOT. SYM1
       DO 403 I=1,NCON
       HKLCON(2,I)=-HKLCON(2,I)
  403  CONTINUE
       IF(SYM1) GO TO 400
C GENERAL
C 
 9997  CONTINUE
      RETURN
      END
      SUBROUTINE CUBIC(LATLET)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/7     /
C 
C END DATA
C 
      IF(INDEX('FIP',LATLET) .EQ. 0) RETURN
      NINC=1
      NSYS=1
      ISYS=LATLET//'-CUBIC'
      FRACT=1./32.
C 
      MAXFND=0
      TROUVE=.FALSE.
      ALPHA=90
      BETA=90
      GAMMA=90.
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      ISS=0
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      L=0
  11  CONTINUE
      K=L
  12  CONTINUE
      H=INT(SQRT(0.5+(HPKPL-K**2-L**2)))
      IF(H**2+K**2+L**2 .EQ. HPKPL) THEN
        IBRAV=IBRAVF(H,K,L,MASK(NLAT))
        IF(IBRAV .NE. 0) THEN
          IF(NT .GE. NTMX) GO TO 19
          NT=NT+1
          H2T(1,NT)=H**2+K**2+L**2
          H2T(2,NT)=K**2
          H2T(3,NT)=L**2
          HKLT(1,NT)=H
          HKLT(2,NT)=K
          HKLT(3,NT)=L
          SHKL(NT)=ISS
          ISS=2
          HPKPLX=HPKPL
          NTMAXE=NT
        END IF
      END IF
      K=K+1
      IF(L**2+2*K**2 .LE. HPKPL) GO TO 12
      L=L+1
      IF(3*L**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
  19  CONTINUE
      IF(.NOT. INDICN(12)) GO TO 69
  73  FORMAT(7(I5,'.',3I4))
      IPAGE=COLONN*50
      DO 70 I=1,NTMAXE,IPAGE
      WRITE(IPRNT,74) ISYS
  74  FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table '/1X)
      JJMAX=MIN(NTMAXE,I+49)
      DO 71 J=I,JJMAX
      KMAX=MIN(NTMAXE,J+IPAGE-1)
      WRITE(IPRNT,73) (K,H2T(1,K),H2T(2,K),H2T(3,K),K=J,KMAX,50)
  71  CONTINUE
  70  CONTINUE
  69  CONTINUE
      NPERMU=0
      IF(NCON.EQ. 0) GO TO 140
      DO 141 N=1,NCON
      DO 145 J=1,NT
       IF(HKLCON(1,N)**2+HKLCON(2,N)**2+HKLCON(3,N)**2
     $  .EQ. H2T(1,J)) GO TO 146
145    CONTINUE
       CALL REMOVE(N)
      RETURN
146    JCON(N)=J
  141  CONTINUE
  140  CONTINUE
       CALL  MANAGE
       RETURN
      END
      SUBROUTINE TRICLI(LATLET)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER HPKPL,COLONN
      LOGICAL SYM1,SYM2,SYM4
C 
      CHARACTER*1 LATLET
C 
C DATA
C 
      DATA COLONN/4/
C 
C END DATA
C 
      IF(INDEX('P',LATLET) .EQ. 0) RETURN
      NINC=6
      NSYS=6
      FRACT=1./2.
C 
      MAXFND=0
      TROUVE=.FALSE.
      ISYS=LATLET//'-TRICLINIC'
C 
C PREPARATION DES TABLES
C 
      CALL HEURE(IPRNT)
      HPKPL=1
      NT=0
10    CONTINUE
      IHKL(HPKPL)=MIN(NT+1,NTMX)
      H=0
11    CONTINUE
      K=0
12    CONTINUE
      L=INT(SQRT(HPKPL-H**2-K**2+0.5))
      IF(H**2+K**2+L**2 .EQ. HPKPL) THEN
        IF(H*L .NE. 0 .OR. K*L .NE. 0) THEN
          ISLEND=-1
        ELSE
          ISLEND=1
        END IF
        DO 2 ISL=1,ISLEND,-2
        IF(H*K .NE. 0 .OR. K*L .NE. 0) THEN
          ISKEND=-1
        ELSE
          ISKEND=1
        END IF
        DO 2 ISK=1,ISKEND,-2
        IBRAV=IBRAVF(H,K*ISK,L*ISL,MASK(NLAT))
        IF(IBRAV .NE. 0) THEN
           IF(NT .GE. NTMX) GO TO 19
           NT=NT+1
           H2T(1,NT)=H**2
           H2T(2,NT)=K**2
           H2T(3,NT)=L**2
           H2T(4,NT)=H*K*ISK*2
           H2T(5,NT)=K*ISK*L*ISL*2
           H2T(6,NT)=L*ISL*H*2
           HKLT(1,NT)=H
           HKLT(2,NT)=K*ISK
           HKLT(3,NT)=L*ISL
           SHKL(NT)=0
           HPKPLX=HPKPL
           NTMAXE=NT
        END IF
2       CONTINUE
      END IF
      K=K+1
      IF(H**2+K**2 .LE. HPKPL) GO TO 12
      H=H+1
      IF(H**2 .LE. HPKPL) GO TO 11
      HPKPL=HPKPL+1
      IF(HPKPL .LE. NCMAX) GO TO 10
19    CONTINUE
      IF(.NOT. INDICN(12)) GO TO 69
  73  FORMAT(4(I5,'.',6I4))
      IPAGE=COLONN*50
      DO 70 I=1,NTMAXE,IPAGE
      WRITE(IPRNT,74) ISYS
  74  FORMAT('1 '/' SYSTEM: ',A15,' Internal intex table'/1X)
      JJMAX=MIN(NTMAXE,I+49)
      DO 71 J=I,JJMAX
      KMAX=MIN(NTMAXE,J+IPAGE-1)
      WRITE(IPRNT,73) (K,(H2T(LL,K),LL=1,NINC),K=J,KMAX,50)
  71  CONTINUE
  70  CONTINUE
  69  CONTINUE
       NPERMU=0
       IF(NCON.EQ. 0) GO TO 140
C 
C SPECIAL TRICLINIQUE. INITIALISATION DE LA PERMUTATION DES INDICES
       SYM3=0
  398  SYM4=.FALSE.
  399  SYM1=.FALSE.
  400  SYM2=.FALSE.
  401  CONTINUE
       DO 141 N=1,NCON
       DO 145 J=1,NT
       IF(HKLCON(1,N)**2 .NE. H2T(1,J)) GO TO 145
       IF(HKLCON(2,N)**2 .NE. H2T(2,J)) GO TO 145
       IF(HKLCON(3,N)**2 .NE. H2T(3,J)) GO TO 145
       IF(HKLCON(2,N)*HKLCON(3,N)*2 .NE. H2T(5,J)) GO TO 145
       IF(HKLCON(1,N)*HKLCON(2,N)*2 .NE. H2T(4,J)) GO TO 145
       IF(HKLCON(3,N)*HKLCON(1,N)*2 .NE. H2T(6,J)) GO TO 145
       GO TO 146
145    CONTINUE
       CALL REMOVE(N)
      RETURN
146    JCON(N)=J
141    CONTINUE
140    CONTINUE
       CALL MANAGE
       IF(NCON .EQ. 0) GO TO 9997
       SYM2=.NOT. SYM2
       DO 402 I=1,NCON
       HKLCON(3,I)=-HKLCON(3,I)
  402  CONTINUE
       IF(SYM2) GO TO 401
       SYM1=.NOT. SYM1
       DO 403 I=1,NCON
       HKLCON(2,I)=-HKLCON(2,I)
  403  CONTINUE
       IF(SYM1) GO TO 400
       SYM4=.NOT. SYM4
       DO 405 I=1,NCON
       LL=HKLCON(2,I)
       HKLCON(2,I)=HKLCON(3,I)
       HKLCON(3,I)=LL
  405  CONTINUE
       IF(SYM4) GO TO 399
       SYM3=SYM3+1
       DO 404 I=1,NCON
       LL=HKLCON(1,I)
       HKLCON(1,I)=HKLCON(2,I)
       HKLCON(2,I)=HKLCON(3,I)
       HKLCON(3,I)=LL
  404  CONTINUE
       IF(SYM3 .LT. 3) GO TO 398
C GENERAL
C 
 9997  CONTINUE
      RETURN
      END
      SUBROUTINE APPEND(A,B)
      IMPLICIT INTEGER(A-Z)
      CHARACTER*(*) A,B
C 
C ajoute la chaine B dans la chaine A a partir des blancs finaux
C 
      Z=ITRIML(A)+1
      IF(Z .GT. LEN(A)) RETURN
      A(Z:)=B
      RETURN
      END
      SUBROUTINE KEYEXT(CMDSTG,KEY,VALUE,TERMX,TERMR)
      IMPLICIT INTEGER(A-Z)
      CHARACTER*(*) CMDSTG,KEY,VALUE,TERMX,TERMR
      CHARACTER*255 SUITE
C 
C RECHERCHE KEY DANS CMDSTG,
C RETOURNE DANS VALUE CE QUI SUIT KEY JQA:',' OU '/' OU ')'
C ELIMINE KEY//VALUE//TERMINATEUR DE CMDSTG, ET COMPACTE CMDSTG
C 
      VALUE=' '
      ZZ=INDEX(CMDSTG,KEY)
      IF(ZZ .EQ. 0) RETURN
      SUITE=CMDSTG(ZZ+LEN(KEY):)
      CMDSTG(ZZ:)=' '
      ZEND=LEN(SUITE)
      DO 10 I=1,LEN(TERMX)
      ZEND=MIN(ZEND,MINDEX(SUITE,TERMX(I:I)))
10    CONTINUE
      DO 11 I=1,LEN(TERMR)
      ZEND=MIN(ZEND,MINDEX(SUITE,TERMR(I:I)))
11    CONTINUE
      IF(1 .LT. ZEND) THEN
        VALUE=SUITE(:ZEND-1)
        SUITE(:ZEND-1)=' '
      END IF
      IF(INDEX(TERMX,SUITE(ZEND:ZEND)) .NE. 0) THEN
        SUITE(ZEND:ZEND)=' '
      END IF
      CALL APPEND(CMDSTG,SUITE)
      CALL LJSTRG(CMDSTG)
      RETURN
      END
      FUNCTION MINDEX(A,B)
      IMPLICIT INTEGER(A-Z)
      CHARACTER*(*) A,B
      MINDEX=INDEX(A,B)
      IF(MINDEX .EQ. 0) MINDEX=1+ITRIML(A)
      RETURN
      END
      SUBROUTINE CHTABL
      IMPLICIT INTEGER(A-Z)
      COMMON/TYPCHR/DIGIT(0:255),MAJUSC(0:255),LETTER(0:255)
C 
C INITIALISATIONS
C 
      DO 40 I=0,255
      LETTER(I)=0
      MAJUSC(I)=I
      DIGIT(I)=-1
40    CONTINUE
      MAJMIN=ICHAR('A')-ICHAR('a')
      J=0
      DO 41 I=ICHAR('A'),ICHAR('I')
      J=J+1
      LETTER(I)=J
      MAJUSC(I-MAJMIN)=I
41    CONTINUE
      DO 42 I=ICHAR('J'),ICHAR('R')
      J=J+1
      LETTER(I)=J
      MAJUSC(I-MAJMIN)=I
42    CONTINUE
      DO 43 I=ICHAR('S'),ICHAR('Z')
      J=J+1
      LETTER(I)=J
      MAJUSC(I-MAJMIN)=I
43    CONTINUE
      J=0
      DO 44 I=ICHAR('0'),ICHAR('9')
      DIGIT(I)=J
      J=J+1
44    CONTINUE
      RETURN
      END
      SUBROUTINE UPPERS(STRING)
      IMPLICIT INTEGER(A-Z)
      COMMON/TYPCHR/DIGIT(0:255),MAJUSC(0:255),LETTER(0:255)
C 
      CHARACTER*(*) STRING
C 
      IF(LETTER(ICHAR('A')) .NE. 1) THEN
        CALL CHTABL
      END IF
C 
      Z=LEN(STRING)
      DO 10 I=1,Z
      STRING(I:I)=CHAR(MAJUSC(ICHAR(STRING(I:I))))
10    CONTINUE
      RETURN
      END
      SUBROUTINE LJSTRG(STR)
      IMPLICIT NONE
      CHARACTER*(*) STR
C 
C SOUS PROGRAMME DE RECALAGE A GAUCHE D'UNE CHAINE, AVEC ELIMINATION
C DES BLANCS
C 
      CHARACTER*1 CH
      INTEGER I,K,J
      K=LEN(STR)
      IF(K .EQ. 0) RETURN
      J=0
      DO 1 I=1,K
      CH=STR(I:I)
      IF(CH .NE. ' ') THEN
          J=J+1
          STR(J:J)=CH
      END IF
1     CONTINUE
      IF(J .LT. K) STR(J+1:K)=' '
      RETURN
      END
      SUBROUTINE BLKOMA(U)
      IMPLICIT INTEGER(A-Z)
      CHARACTER*(*) U
      CHARACTER*1 KAR,AKAR
C 
      L=LEN(U)
      AKAR=','
      J=0
      DO 100 I=1,L
101   J=J+1
      IF(J .GT. L) THEN
        KAR=','
      ELSE
        KAR=U(J:J)
      END IF
      IF(KAR .EQ. ' ') THEN
        IF(AKAR .EQ. ' ') GO TO 101
        IF(AKAR .EQ. ',') GO TO 101
        U(I:I)=','
        AKAR=' '
      ELSE IF(KAR .EQ. ',') THEN
        IF(AKAR .EQ. ' ') THEN
          AKAR=','
          GO TO 101
        END IF
        U(I:I)=','
        AKAR=','
      ELSE IF(INDEX(U,'=') .EQ. 0) THEN
        IF(KAR .EQ. 'O') KAR='0'
        IF(KAR .EQ. 'o') KAR='0'
        IF(KAR .EQ. 'I') KAR='1'
        IF(KAR .EQ. 'i') KAR='1'
        U(I:I)=KAR
        AKAR=KAR
      ELSE
        U(I:I)=KAR
        AKAR=KAR
      END IF
100   CONTINUE
      RETURN
      END
      INTEGER FUNCTION ITRIML(STRING)
      IMPLICIT INTEGER(A-Z)
      CHARACTER*(*) STRING
      ITRIML=LEN(STRING)
100   CONTINUE
      IF(ITRIML .EQ. 0) RETURN
      IF(STRING(ITRIML:ITRIML) .NE. ' ') RETURN
      ITRIML=ITRIML-1
      GO TO 100
      END
      SUBROUTINE RTIMER
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER*4 LSTIME,NXTIME
C 
      DATA LSTIME/0/
C 
      CALL ELAPSE(LSTIME)
      DO 10 L=1,NTIMER
      KTIM1(L)=0
10    CONTINUE
      RETURN
C 
      ENTRY ATIMER(NXTIME,NT)
      CALL ELAPSE(NXTIME)
      KTIM1(NT)=KTIM1(NT)+(NXTIME-LSTIME)
      LSTIME=NXTIME
      RETURN
      END
       SUBROUTINE HEURE(IOUT)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
      INTEGER*4 K
      CHARACTER*16 HMSEC
      CHARACTER*30 DATTIM
C 
C DATA
C 
       DATA K/10000/
C 
C END DATA
C 
       CALL ELAPSE(K)
       K=K+KSTART
       IF(K .EQ. 0) RETURN
       CALL GHMSEC(K,HMSEC)
       CALL FRTIMC(DATTIM)
       WRITE(IOUT, 2) HMSEC,DATTIM(:ITRIML(DATTIM))
2      FORMAT(' ***** Elapsed C.P.U. time: ',A,' ***** ',A,' *****')
       RETURN
      END
       SUBROUTINE GHMSEC(K,HMSEC)
C 
C Working storage for COMMAND parsing
      CHARACTER*120 CMDBUF
C 
C File names for input, restart, printout
      CHARACTER*60 FNAME,RNAME,PRTFIL,LOGFIL
C 
      COMMON/CMDBUF/CMDBUF,FNAME,RNAME,PRTFIL,LOGFIL
      REAL TINTVL
      INTEGER INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF,NUMSWP,ISUMRY
      INTEGER*4 KTNUM
      COMMON/TIMING/TINTVL,KTNUM,INPUT,IPRNT,IRREST,IPUNCH,ITERM,ILOGF
      COMMON/TIMING/NUMSWP,ISUMRY
       INTEGER*4 K,HOURS,MINUTE,SECOND,CENTS
       CHARACTER*16 HMSEC
       RTIME=K*TINTVL
       SECOND=RTIME
       CENTS=100*(RTIME-SECOND)
       MINUTE=SECOND/60
       SECOND=SECOND-60*MINUTE
       HOURS=MINUTE/60
       MINUTE=MINUTE-60*HOURS
       WRITE(HMSEC,2) HOURS,MINUTE,SECOND,CENTS
2      FORMAT(I6,':',I2.2,':',I2.2,'.',I2.2,' ')
       RETURN
      END
       FUNCTION IBRAVF(J,K,L,IMASK)
       INTEGER AC,BC,CC,IC,FC,PC
       AC=MOD(IABS(K+L+1),2)
       BC=MOD(IABS(L+J+1),2)
       CC=MOD(IABS(J+K+1),2)
       IC=MOD(IABS(J+K+L+1),2)
       FC=AC*BC*CC
       PC=1
       ICD=FC+2*(IC+2*(AC+2*(BC+2*(CC+2*PC))))
       IBRAVF=IAND(ICD,IMASK)
       RETURN
      END
      FUNCTION GFORMT(W)
C 
C........................... C O M M O N S .............................
      PARAMETER(NQMAX=120,NCMAX=3*NQMAX,NTMX=2400,NINX=6,JMAX=20,
     $  NOPT=20,JMAX1=JMAX+1,NMOLIM=128,PI=3.141593,NGENDA=18)
      PARAMETER (KDIGIT=10,MAXCSE=11,NMAXPL=0,NINCMX=6,NVOLMR=100)
      COMMON/PARM/NQ,NBMAX,VMOL,DV2R,A,B,C,ALPHA,BETA,GAMMA,ULOG2,
     $VC,MPP,X,SIGMA,INDMAX,INDICN,NDEGEN,TIMMAX,TIMQTM,FWMINI,MASK(6)
     $,NINC,NSYS,NUMSYS,NMAX,CHIFAC,CHIORG,CHIFCN(0:JMAX1),CHIMIN,NBMMX
     $,FAKOND(6),NLAT,PARMIN,PARMAX,TOMAKE,GENDAT(NGENDA),MAXHIT
      COMMON/QQ/Q(0:NQMAX),QFINAL,EPS(NQMAX),D(NQMAX),
     $CERT(NQMAX),MBASE(NQMAX),ICON(NQMAX),JDEP(JMAX),QMCERT,VMMIN
      COMMON/QGEN/QGEN(NTMX),DGEN(NTMX),SHKL(NTMX)
      COMMON/TABL/QTH(NCMAX),VTAB(NCMAX)
      COMMON/MREF/MREF(NCMAX),IREF(NCMAX),IBON(NQMAX),NREF(NQMAX)
      COMMON/TITRE/TITLE,SYMSYM,ISYS
      CHARACTER*60 TITLE
      CHARACTER*6 SYMSYM
      CHARACTER*15 ISYS
      INTEGER H2T(NINCMX,NTMX),IHKL(NCMAX),HKLT(3,NTMX),HPKPLX
      LOGICAL INDICN(NOPT),TOMAKE(6,6),DOREST
      COMMON/H2T/H2T,HKLT
      COMMON/IHKL/IHKL
      COMMON/CONNU/NCON,HKLCON(3,JMAX),MCON(JMAX),JCON(JMAX)
      COMMON/VLIM/VLIMI(NMOLIM),VLIMS(NMOLIM),NMOMAX
      COMMON/TRAV/MT(0:JMAX1),JT(0:JMAX1),AA(NINCMX),
     $AANOT(NINCMX),AE(NINCMX),
     $VSUP2(0:JMAX1),AAINF(NINCMX,0:JMAX1),AASUP(NINCMX,0:JMAX1),
     $TMAT(NINCMX,NINCMX),WMAT(NINCMX,NINCMX),INDK(JMAX1)
      COMMON/TRAVS/N,AAMIN,AAMAX,HPKPLX,NTMAXE,TROUVE,H,IMIN,
     $IMAX,IMAXX,NBAD,VRECI2,MAXFND,FRACT,FWMAXI,CHI1R,NBHITS
      LOGICAL TROUVE,CERT,AANOT
      INTEGER HKLCON,X,H,SHKL
      COMMON/PERMU/NPERMU,JNT(JMAX1,24)
      INTEGER*4 NCAUSE
      COMMON/NCAUSE/NCAUSE(MAXCSE,JMAX1)
      COMMON/REPRIS/NR,DOREST,NPERMR,JDEPR(0:JMAX1),FWMINR,FWMAXR
      COMMON/ANGLES/WL(0:NQMAX),TWOT(0:NQMAX),DTWO(0:NQMAX)
      COMMON/FMTPAR/DFORMT,PFORMT,QFORMT,VFORMT,VDOTSF
      CHARACTER*8 DFORMT,PFORMT,QFORMT,VFORMT
      CHARACTER*(KDIGIT) VDOTSF
      COMMON/VOLMER/VOLMER(0:NVOLMR),VOLTAB(0:NVOLMR),DVOLMR
      PARAMETER(NTIMER=2)
      INTEGER*4 KTIM1(NTIMER),KSTART
      COMMON/TIMERS/KTIM1,KSTART
C .............. FIN DES COMMUNS .......................................
C 
C this function returns the Fxx.nn adequate format for editing
C correctly a value whose maximum is W
C 
      CHARACTER*8 GFORMT,WFORMT
C 
      ITEN=0
      WFORMT=' '
      WW=ABS(W)
      DO 100 K=1,KDIGIT-2
      IF(WW .LT. 0.9) GO TO 101
      WW=WW/10
      ITEN=ITEN+1
100   CONTINUE
C 
C value too big, use G format
C 
      KDEC=KDIGIT-6
      WRITE(WFORMT,90) KDIGIT,KDEC
90    FORMAT('(G',I2.2,'.',I2.2,')')
      GFORMT=WFORMT
      RETURN
C 
101   CONTINUE
      KDEC=KDIGIT-ITEN-3
      WRITE(WFORMT,92) KDIGIT,KDEC
92    FORMAT('(F',I2.2,'.',I2.2,')')
      GFORMT=WFORMT
      RETURN
      END
  
      SUBROUTINE VERSION(IO)
      IF (IO .NE. 0) THEN
        WRITE(IO,*) 'Version 06:00:00 VEN 12 JUL 1991 (193) '
      ELSE
        WRITE(*,*) 'Version 06:00:00 VEN 12 JUL 1991 (193) '
      END IF
      RETURN
      END
      SUBROUTINE FRTIMC(EDTIM)
      CHARACTER*(*) EDTIM
      CHARACTER*30 FDATE
C 
      INTEGER UNIT
      PARAMETER(UNIT=7)
      LOGICAL EXISTS
      CHARACTER*40 TEMP_FILE
C 
      TEMP_FILE='time@fil.tmp'
      DO 100 K=1,100
      INQUIRE(FILE=TEMP_FILE,EXIST=EXISTS)
      IF(.NOT. EXISTS) GOTO 101
      WRITE(TEMP_FILE,102) K
102   FORMAT('time@',I3.3,'.tmp')
100   CONTINUE
      CALL SYSTEM('DEL '//TEMP_FILE)
101   CONTINUE
      call system('DOS_TIME > '//TEMP_FILE)
      open (unit=unit,file=TEMP_FILE)
      read (unit,'(A)') FDATE
      close(unit=unit)
      call system('DEL '//TEMP_FILE)
      EDTIM=FDATE
C 
      RETURN
      END

      SUBROUTINE ELAPSE(K)
C 
C time in K, in units equal to TINTVL seconds.
C 
      INTEGER*4 K
      REAL TARRAY(2),ETIME,FIRST,GLOBAL
C 
C DATA
C 
      DATA FIRST/0/
      IF(FIRST .EQ. 0) THEN
          FIRST=ETIME(TARRAY)
          K=0
      ELSE
          GLOBAL=ETIME(TARRAY)
          K=INT(100.0*(GLOBAL-FIRST))
      END IF
      RETURN
      END
      SUBROUTINE GETITV(TINTVL)
      TINTVL=0.01
      RETURN
      END