CDC   PROGRAM LOSH(INPUT,OUTPUT,TEMP,REFINE,TAPE5=INPUT,TAPE6=OUTPUT,    LOSHREF
CDC  1 TAPE8=TEMP,TAPE9=REFINE)                                          LOSHREF
C     PROGRAMME POUR LA RECHERCHE PAR DICHOTOMIE DE D ET E LORSQUE A,B,F LOSH
C     ,C SONT CONNUS                                                     LOSH
C     DANIEL LOUER  ET  ROBIN SHIRLEY                                    LOSH
C     VERSION  OCTOBRE 1977   LOSHFZRF                                   LOSHFZR
C---MODIFIED (ULCC VERSION ONLY) TO WRITE SOLUTIONS TO REFINE FILE       REFTEXT
C---(CHANNEL 9) IN FORMAT SUITABLE FOR REFINEMENT BY FZON(6)             REFTEXT
CDC   DIMENSION IDENT(30)                                                LOSH-1N
C     THE FOLLOWING ARRAYS SHOULD BE DIMENSIONED TO AGREE WITH NSOLMX    LOSH-1N
      DIMENSION E(500),DD(500),ALP(500),BET(500)                         LOSH-1N
      COMMON D(50),EPSIL(50),Q(50),EPSQ(50),KQ(50),KEPSQ(50),KQT(50),N,N LOSH
     1H,NMH,NK,NMK,NL,LMIN,KA,KB,KC,KF                                   LOSH
C---USED TO PASS TITLE TO S/R REFSET FOR REFORMATTING (ULCC)             REFIDTC
      COMMON /IDTCOM/ IDENT(30)                                          REFIDTC
C---QCELL IS FOR PASSING SOLUTIONS TO S/R REFINC (ULCC)                  REFQCEL
      DIMENSION QCELL(6)                                                 REFQCEL
      EQUIVALENCE (QA,QCELL(1)),(QB,QCELL(2)),(QC,QCELL(3)),             LOSHREF
     1 (QD,QCELL(4)),(QE,QCELL(5)),(QF,QCELL(6))                         LOSHREF
      READ(5,1)(IDENT(K),K=1,30)                                         LOSH
      READ(5,2)QA,QB,QC,QF                                               LOSH
      READ(5,3)N,LMIN,NSPURI                                             LOSH
      READ(5,4)ALPMIN,BETMIN                                             LOSH
      READ(5,5)(D(I),EPSIL(I),I=1,N)                                     LOSH
    1 FORMAT(30A2)                                                       LOSH
    2 FORMAT(4F10.5)                                                     LOSH
    3 FORMAT(3I3)                                                        LOSH
    4 FORMAT(2F7.2)                                                      LOSH
    5 FORMAT(2F7.4)                                                      LOSH
    6 FORMAT(10X,8(I10,5X))                                              LOSH
    7 FORMAT(1H1/1H0,30X,30A2/1H ,30X,60(1H*))                           LOSH
    8 FORMAT(1H0/1H0,45X,30HDONNEES FOURNIES A L EXECUTION/1H ,45X,30(1H LOSH
     1*)/1H0,20X,37HDISTANCES RETICULAIRES EXPERIMENTALES,20X,20HERREUR  LOSH
     2EXPERIMENTALE)                                                     LOSH
    9 FORMAT(//1H0,20X,4HQA =,F12.5,10X,4HQB =,F12.5,10X,4HQC =,F12.5,10 LOSH
     1X,4HQF =,F12.5,2X,8H(Q UNIT)/                                      LOSH-1V
     2 20X,I2,15H OBSERVED LINES,10X,6HLMIN =,I2,10X,8HNSPURI =,I2/      LOSH-1V
     3 20X,26HALPHA RECIPROQUE MINIMUM =,F8.3,10X,                       LOSH-2
     4 25HBETA RECIPROQUE MINIMUM =,F8.3///                              LOSH-2
     5 1H0,55X,10(1H*))                                                  LOSH-2
   11 FORMAT(1H0,50X,25HPAS D INDEXATION POSSIBLE)                       LOSH
   12 FORMAT(1H0/1H0,10X,9HSOLUTION ,I4/1H ,10X,13(1H*))                 LOSH
   13 FORMAT(1H0,5X,4HQA =,F10.5,5X,4HQB =,F10.5,5X,4HQC =,F10.5,5X,4HQD LOSH
     1 =,F10.5,5X,4HQE =,F10.5,5X,4HQF =,F10.5,5X,8H(Q UNIT))            LOSH-1V
   14 FORMAT(1H0,2X,23HPARAMETRES RECIPROQUES:,2X,3HA*=,F9.5,2X,3HB*=,F9 LOSH-1V
     1.5,2X,3HC*=,F9.5,2X,7HALPHA*=,F7.3,2X,6HBETA*=,F7.3,2X,7HGAMMA*=,F LOSH
     27.3,2X,3HV*=,F8.5)                                                 LOSH-1V
   15 FORMAT(1H0,2X,19HPARAMETRES DIRECTS:,2X,3HA =,F8.4,2X,3HB =,F8.4,2 LOSH-1V
     1X,3HC =,F8.4,2X,7HALPHA =,F8.3,2X,6HBETA =,F8.3,2X,7HGAMMA =,F8.3, LOSH
     22X,3HV =,F10.3)                                                    LOSH-1V
   16 FORMAT(1H0,50X,3HFIN/1H ,50X,3(1H*))                               LOSH
   17 FORMAT(1H ,33X,F10.4,36X,F10.4)                                    LOSH
   18 FORMAT(1H0,50HCELL VOLUME IS IMAGINARY - FACTV PRINTED INSTEAD. ,  LOSH-1V
     1 43HDIRECT CELL PARAMETERS CANNOT BE CALCULATED,                   LOSH-1V
     2 22H  ** FALSE SOLUTION **)                                        LOSH-1V
   19 FORMAT(1H0,36H** SOLUTION STORAGE LIMIT REACHED **/                LOSH-1N
     1 1H0,21HSTORAGE PROVIDED FOR ,I3,33H SOLUTIONS - ATTEMPTING TO STO LOSH-1N
     2RE ,I3,32H-TH. ABANDON REMAINING SOLUTIONS)                        LOSH-1N
      WRITE(6,7)(IDENT(K),K=1,30)                                        LOSH
      WRITE(6,8)                                                         LOSH
      WRITE(6,17)(D(I),EPSIL(I),I=1,N)                                   LOSH
      WRITE(6,9) QA,QB,QC,QF,L,LMIN,NSPURI,ALPMIN,BETMIN                 LOSH-1V
C---REFINEMENT INITIALISATION (ULCC)                                     REFINIT
      CALL REFSET                                                        REFINIT
      CONST=1.0E08                                                       LOSH
      QUNIT=1.0E-04                                                      LOSH
C     NSOLMX IS THE MAXIMUM NUMBER OF SOLUTIONS FOR WHICH STORAGE        LOSH-1N
C     HAS BEEN ALLOCATED - IT SHOULD AGREE WITH THE DIMENSIONING         LOSH-1N
C     OF E,DD,ALP,BET                                                    LOSH-1N
      NSOLMX=500                                                         LOSH-1N
      A=QA*QUNIT                                                         LOSH
      B=QB*QUNIT                                                         LOSH
      C=QC*QUNIT                                                         LOSH
      F=QF*QUNIT                                                         LOSH
      NSPURI=NSPURI+1                                                    LOSH
      J=0                                                                LOSH
      ALAL=3.                                                            LOSH
      BEBE=3.                                                            LOSH
      AREC=SQRT(A)                                                       LOSH
      BREC=SQRT(B)                                                       LOSH
      CREC=SQRT(C)                                                       LOSH
      ARGU=F/(2.*AREC*BREC)                                              LOSH
      GAREC=ARCOS(ARGU)                                                  LOSH
      CGAR=COS(GAREC)                                                    LOSH
      SGAR=SIN(GAREC)                                                    LOSH
      DO 21 I=1,N                                                        LOSH
      PR=D(I)*D(I)                                                       LOSH
      Q(I)=1./PR                                                         LOSH
      KQ(I)=CONST*Q(I)                                                   LOSH
      EPSQ(I)=(2.*EPSIL(I))/(PR*D(I))                                    LOSH
   21 KEPSQ(I)=CONST*EPSQ(I)                                             LOSH
      PI=3.1415926                                                       LOSH
      KA=A*CONST                                                         LOSH
      KB=B*CONST                                                         LOSH
      KC=C*CONST                                                         LOSH
      KF=F*CONST                                                         LOSH
      PIDEG=PI/180.                                                      LOSH
      PASANG=PIDEG*2.5                                                   LOSH
      PAS2=PASANG/2.                                                     LOSH
      PAS4=PASANG/4.                                                     LOSH
      PAS8=PASANG/8.                                                     LOSH
      PAS16=PASANG/16.                                                   LOSH
      PAS32=PASANG/32.                                                   LOSH
      PAS64=PASANG/64.                                                   LOSH
C---ENSURE THAT ALPMIN AND BETMIN ARE ACUTE                              LOSH-2
      IF(ALPMIN.GT.90.) ALPMIN=180.-ALPMIN                               LOSH-2
      IF(BETMIN.GT.90.) BETMIN=180.-BETMIN                               LOSH-2
C---CONVERT TO RADIANS                                                   LOSH-2
      ALMRAD=ALPMIN*PIDEG                                                LOSH-2
      BEMRAD=BETMIN*PIDEG                                                LOSH-2
C---CALCULATE MAXIMUM VALUES TO COVER THE 2 UNIQUE SEARCH QUADRANTS      LOSH-2
      ALPMAX=PI/2.                                                       LOSH
      BETMAX=PI-BEMRAD                                                   LOSH-2
      NALPHA=(ALPMAX-ALMRAD)/PASANG+1.                                   LOSH-2
      NBETA=(BETMAX-BEMRAD)/PASANG+1.                                    LOSH-2
      BC=2.*SQRT(B*C)                                                    LOSH
      AC=2.*SQRT(A*C)                                                    LOSH
      ALIMH2=Q(N)/A                                                      LOSH
      NH=SQRT(ALIMH2)                                                    LOSH
      NMH=2*NH+1                                                         LOSH
      ALIMK2=Q(N)/B                                                      LOSH
      NK=SQRT(ALIMK2)                                                    LOSH
      NMK=2*NK+1                                                         LOSH
      ALIML2=Q(N)/C                                                      LOSH
      NL=SQRT(ALIML2)                                                    LOSH
      NL=-LMIN+NL+1                                                      LOSH
      KKK=2                                                              LOSH
      IF(KF.EQ.0)KKK=1                                                   LOSH
      DO 1000 IBETA=1,NBETA                                              LOSH
      DO 1001 ISIGN=1,KKK                                                LOSH
      BETW=IBETA-1                                                       LOSH
      BESUP1=BETMAX-(BETW*PASANG)                                        LOSH-2
      BEINF1=BESUP1-PASANG                                               LOSH
      EPLUS1=AC*COS(BEINF1)                                              LOSH
      EMOIN1=AC*COS(BESUP1)                                              LOSH
      KEP1=EPLUS1*CONST                                                  LOSH
      KEM1=EMOIN1*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 10                                             LOSH
      KEP1=-KEP1                                                         LOSH
      KEM1=-KEM1                                                         LOSH
   10 DO 1100 IALPHA=1,NALPHA                                            LOSH
      ALPW=IALPHA-1                                                      LOSH
      ALSUP1=ALPMAX-(ALPW*PASANG)                                        LOSH
      ALINF1=ALSUP1-PASANG                                               LOSH
      DPLUS1=BC*COS(ALINF1)                                              LOSH
      DMOIN1=BC*COS(ALSUP1)                                              LOSH
      KDP1=DPLUS1*CONST                                                  LOSH
      KDM1=DMOIN1*CONST                                                  LOSH
      CALL TRIHKL(KEP1,KEM1,KDP1,KDM1,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 100 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 1100                                        LOSH
  100 CONTINUE                                                           LOSH
      DO 2000 IBET2=1,2                                                  LOSH
      BETW=IBET2-1                                                       LOSH
      BESUP2=BESUP1-(BETW*PAS2)                                          LOSH
      BEINF2=BESUP2-PAS2                                                 LOSH
      EPLUS2=AC*COS(BEINF2)                                              LOSH
      EMOIN2=AC*COS(BESUP2)                                              LOSH
      KEP2=EPLUS2*CONST                                                  LOSH
      KEM2=EMOIN2*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 20                                             LOSH
      KEP2=-KEP2                                                         LOSH
      KEM2=-KEM2                                                         LOSH
   20 DO 2100 IALP2=1,2                                                  LOSH
      ALPW=IALP2-1                                                       LOSH
      ALSUP2=ALSUP1-(ALPW*PAS2)                                          LOSH
      ALINF2=ALSUP2-PAS2                                                 LOSH
      ALTEST=ABS(ALINF2-ALAL)                                            LOSH
      BETEST=ABS(BEINF2-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 2100                  LOSH
      DPLUS2=BC*COS(ALINF2)                                              LOSH
      DMOIN2=BC*COS(ALSUP2)                                              LOSH
      KDP2=DPLUS2*CONST                                                  LOSH
      KDM2=DMOIN2*CONST                                                  LOSH
      CALL TRIHKL(KEP2,KEM2,KDP2,KDM2,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 200 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 2100                                        LOSH
  200 CONTINUE                                                           LOSH
      DO 3000 IBET3=1,2                                                  LOSH
      BETW=IBET3-1                                                       LOSH
      BESUP3=BESUP2-(BETW*PAS4)                                          LOSH
      BEINF3=BESUP3-PAS4                                                 LOSH
      EPLUS3=AC*COS(BEINF3)                                              LOSH
      EMOIN3=AC*COS(BESUP3)                                              LOSH
      KEP3=EPLUS3*CONST                                                  LOSH
      KEM3=EMOIN3*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 30                                             LOSH
      KEP3=-KEP3                                                         LOSH
      KEM3=-KEM3                                                         LOSH
   30 DO 3100 IALP3=1,2                                                  LOSH
      ALPW=IALP3-1                                                       LOSH
      ALSUP3=ALSUP2-(ALPW*PAS4)                                          LOSH
      ALINF3=ALSUP3-PAS4                                                 LOSH
      ALTEST=ABS(ALINF3-ALAL)                                            LOSH
      BETEST=ABS(BEINF3-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 3100                  LOSH
      DPLUS3=BC*COS(ALINF3)                                              LOSH
      DMOIN3=BC*COS(ALSUP3)                                              LOSH
      KDP3=DPLUS3*CONST                                                  LOSH
      KDM3=DMOIN3*CONST                                                  LOSH
      CALL TRIHKL(KEP3,KEM3,KDP3,KDM3,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 300 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 3100                                        LOSH
  300 CONTINUE                                                           LOSH
      DO 4000 IBET4=1,2                                                  LOSH
      BETW=IBET4-1                                                       LOSH
      BESUP4=BESUP3-(BETW*PAS8)                                          LOSH
      BEINF4=BESUP4-PAS8                                                 LOSH
      EPLUS4=AC*COS(BEINF4)                                              LOSH
      EMOIN4=AC*COS(BESUP4)                                              LOSH
      KEP4=EPLUS4*CONST                                                  LOSH
      KEM4=EMOIN4*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 40                                             LOSH
      KEP4=-KEP4                                                         LOSH
      KEM4=-KEM4                                                         LOSH
   40 DO 4100 IALP4=1,2                                                  LOSH
      ALPW=IALP4-1                                                       LOSH
      ALSUP4=ALSUP3-(ALPW*PAS8)                                          LOSH
      ALINF4=ALSUP4-PAS8                                                 LOSH
      ALTEST=ABS(ALINF4-ALAL)                                            LOSH
      BETEST=ABS(BEINF4-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 4100                  LOSH
      DPLUS4=BC*COS(ALINF4)                                              LOSH
      DMOIN4=BC*COS(ALSUP4)                                              LOSH
      KDP4=DPLUS4*CONST                                                  LOSH
      KDM4=DMOIN4*CONST                                                  LOSH
      CALL TRIHKL(KEP4,KEM4,KDP4,KDM4,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 400 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 4100                                        LOSH
  400 CONTINUE                                                           LOSH
      DO 5000 IBET5=1,2                                                  LOSH
      BETW=IBET5-1                                                       LOSH
      BESUP5=BESUP4-(BETW*PAS16)                                         LOSH
      BEINF5=BESUP5-PAS16                                                LOSH
      EPLUS5=AC*COS(BEINF5)                                              LOSH
      EMOIN5=AC*COS(BESUP5)                                              LOSH
      KEP5=EPLUS5*CONST                                                  LOSH
      KEM5=EMOIN5*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 50                                             LOSH
      KEP5=-KEP5                                                         LOSH
      KEM5=-KEM5                                                         LOSH
   50 DO 5100IALP5=1,2                                                   LOSH
      ALPW=IALP5-1                                                       LOSH
      ALSUP5=ALSUP4-(ALPW*PAS16)                                         LOSH
      ALINF5=ALSUP5-PAS16                                                LOSH
      ALTEST=ABS(ALINF5-ALAL)                                            LOSH
      BETEST=ABS(BEINF5-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 5100                  LOSH
      DPLUS5=BC*COS(ALINF5)                                              LOSH
      DMOIN5=BC*COS(ALSUP5)                                              LOSH
      KDP5=DPLUS5*CONST                                                  LOSH
      KDM5=DMOIN5*CONST                                                  LOSH
      CALL TRIHKL(KEP5,KEM5,KDP5,KDM5,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 500 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 5100                                        LOSH
  500 CONTINUE                                                           LOSH
      DO 6000 IBET6=1,2                                                  LOSH
      BETW=IBET6-1                                                       LOSH
      BESUP6=BESUP5-(BETW*PAS32)                                         LOSH
      BEINF6=BESUP6-PAS32                                                LOSH
      EPLUS6=AC*COS(BEINF6)                                              LOSH
      EMOIN6=AC*COS(BESUP6)                                              LOSH
      KEP6=EPLUS6*CONST                                                  LOSH
      KEM6=EMOIN6*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 60                                             LOSH
      KEP6=-KEP6                                                         LOSH
      KEM6=-KEM6                                                         LOSH
   60 DO 6100 IALP6=1,2                                                  LOSH
      ALPW=IALP6-1                                                       LOSH
      ALSUP6=ALSUP5-(ALPW*PAS32)                                         LOSH
      ALINF6=ALSUP6-PAS32                                                LOSH
      ALTEST=ABS(ALINF6-ALAL)                                            LOSH
      BETEST=ABS(BEINF6-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 6100                  LOSH
      DPLUS6=BC*COS(ALINF6)                                              LOSH
      DMOIN6=BC*COS(ALSUP6)                                              LOSH
      KDP6=DPLUS6*CONST                                                  LOSH
      KDM6=DMOIN6*CONST                                                  LOSH
      CALL TRIHKL(KEP6,KEM6,KDP6,KDM6,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 600 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 6100                                        LOSH
  600 CONTINUE                                                           LOSH
      DO 7000 IBET7=1,2                                                  LOSH
      BETW=IBET7-1                                                       LOSH
      BESUP7=BESUP6-(BETW*PAS64)                                         LOSH
      BEINF7=BESUP7-PAS64                                                LOSH
      EPLUS7=AC*COS(BEINF7)                                              LOSH
      EMOIN7=AC*COS(BESUP7)                                              LOSH
      KEP7=EPLUS7*CONST                                                  LOSH
      KEM7=EMOIN7*CONST                                                  LOSH
      IF(ISIGN.EQ.1)GO TO 70                                             LOSH
      KEP7=-KEP7                                                         LOSH
      KEM7=-KEM7                                                         LOSH
   70 DO 7100 IALP7=1,2                                                  LOSH
      ALPW=IALP7-1                                                       LOSH
      ALSUP7=ALSUP6-(ALPW*PAS64)                                         LOSH
      ALINF7=ALSUP7-PAS64                                                LOSH
      ALTEST=ABS(ALINF7-ALAL)                                            LOSH
      BETEST=ABS(BEINF7-BEBE)                                            LOSH
      IF(ALTEST.LT.0.035.AND.BETEST.LT.0.035)GO TO 7100                  LOSH
      DPLUS7=BC*COS(ALINF7)                                              LOSH
      DMOIN7=BC*COS(ALSUP7)                                              LOSH
      KDP7=DPLUS7*CONST                                                  LOSH
      KDM7=DMOIN7*CONST                                                  LOSH
      CALL TRIHKL(KEP7,KEM7,KDP7,KDM7,ISIGN)                             LOSH
      IMP=0                                                              LOSH
      DO 700 I=1,N                                                       LOSH
      IF(KQT(I).LT.0)IMP=IMP+1                                           LOSH
      IF(IMP.GT.NSPURI)GO TO 7100                                        LOSH
  700 CONTINUE                                                           LOSH
      J=J+1                                                              LOSH
      IF(J.LE.NSOLMX) GOTO 705                                           LOSH-1N
      WRITE(6,19) NSOLMX,J                                               LOSH-1N
      J=NSOLMX                                                           LOSH-1N
      GOTO 110                                                           LOSH-1N
  705 CONTINUE                                                           LOSH-1N
      E(J)=EMOIN7+(EPLUS7-EMOIN7)/2.                                     LOSH
      DD(J)=DMOIN7+(DPLUS7-DMOIN7)/2.                                    LOSH
      ALP(J)=ALINF7+PAS32                                                LOSH
      BET(J)=BEINF7+PAS32                                                LOSH
      ALAL=ALP(J)                                                        LOSH
      BEBE=BET(J)                                                        LOSH
 7100 CONTINUE                                                           LOSH
 7000 CONTINUE                                                           LOSH
 6100 CONTINUE                                                           LOSH
 6000 CONTINUE                                                           LOSH
 5100 CONTINUE                                                           LOSH
 5000 CONTINUE                                                           LOSH
 4100 CONTINUE                                                           LOSH
 4000 CONTINUE                                                           LOSH
 3100 CONTINUE                                                           LOSH
 3000 CONTINUE                                                           LOSH
 2100 CONTINUE                                                           LOSH
 2000 CONTINUE                                                           LOSH
 1100 CONTINUE                                                           LOSH
 1001 CONTINUE                                                           LOSH
 1000 CONTINUE                                                           LOSH
C     IMPRESSION DES RESULTATS                                           LOSH
      IF(J.NE.0)GO TO 110                                                LOSH
      WRITE(6,11)                                                        LOSH
      GO TO 190                                                          LOSH
  110 DO 120 I=1,J                                                       LOSH
      CALR=COS(ALP(I))                                                   LOSH
      SALR=SIN(ALP(I))                                                   LOSH
      CBER=COS(BET(I))                                                   LOSH
      SBER=SIN(BET(I))                                                   LOSH
      FACTV=1.-CALR**2-CBER**2-CGAR**2+(2.*CALR*CBER*CGAR)               LOSH
      IF(FACTV.GT.0.) GOTO 112                                           LOSH-1V
      VOLR=FACTV                                                         LOSH-1V
      GOTO 115                                                           LOSH-1V
  112 CONTINUE                                                           LOSH-1V
      VOLR=AREC*BREC*CREC*SQRT(FACTV)                                    LOSH
      ADIR=BREC*CREC*SALR/VOLR                                           LOSH
      BDIR=CREC*AREC*SBER/VOLR                                           LOSH
      CDIR=AREC*BREC*SGAR/VOLR                                           LOSH
      CALD=((CBER*CGAR)-CALR)/(SBER*SGAR)                                LOSH
      CBED=((CGAR*CALR)-CBER)/(SGAR*SALR)                                LOSH
      CGAD=((CALR*CBER)-CGAR)/(SALR*SBER)                                LOSH
      ALDIR=ARCOS(CALD)/PIDEG                                            LOSH
      BEDIR=ARCOS(CBED)/PIDEG                                            LOSH
      GADIR=ARCOS(CGAD)/PIDEG                                            LOSH
  115 CONTINUE                                                           LOSH-1V
      ALREC=ARCOS(CALR)/PIDEG                                            LOSH
      BEREC=ARCOS(CBER)/PIDEG                                            LOSH
      GAR=GAREC/PIDEG                                                    LOSH
      VDIR=1./VOLR                                                       LOSH
      DD(I)=DD(I)/QUNIT                                                  LOSH
      E(I)=E(I)/QUNIT                                                    LOSH
C---STORE SOLUTION FOR SUBSEQUENT COPYING TO COMPILE FILE (ULCC)         LOSHREF
      QD=DD(I)                                                           LOSHREF
      QE=E(I)                                                            LOSHREF
      CALL REFINC(QCELL)                                                 LOSHREF
      WRITE(6,12)I                                                       LOSH
      WRITE(6,13)QA,QB,QC,DD(I),E(I),QF                                  LOSH
      WRITE(6,14)AREC,BREC,CREC,ALREC,BEREC,GAR,VOLR                     LOSH
      IF(FACTV.GT.0.) GOTO 118                                           LOSH-1V
      WRITE(6,18)                                                        LOSH-1V
      GOTO 120                                                           LOSH-1V
  118 CONTINUE                                                           LOSH-1V
      WRITE(6,15)ADIR,BDIR,CDIR,ALDIR,BEDIR,GADIR,VDIR                   LOSH
  120 CONTINUE                                                           LOSH
  190 WRITE(6,16)                                                        LOSH
C---COPY SAVED SOLUTIONS TO REFINE FILE (ULCC)                           REFSAVE
      CALL REFSAV                                                        REFSAVE
C---READ SOLUTIONS, ETC. FROM REFINE FILE AND USE MODIFIED VERSION       FZRFCOM
C--- OF DUTCH ZONE-INDEXING PROGRAM FOR NORMALISATION, REFINEMENT        FZRFCOM
C--- AND EVALUATION (ULCC)                                               FZRFCOM
      CALL FZONRF                                                        FZRFCOM
      STOP                                                               LOSH
      END                                                                LOSH
      SUBROUTINE TRIHKL(KEP,KEM,KDP,KDM,ISIGN)                           LOSH
      COMMON D(50),EPSIL(50),Q(50),EPSQ(50),KQ(50),KEPSQ(50),KQT(50),N,N LOSH
     1H,NMH,NK,NMK,NL,LMIN,KA,KB,KC,KF                                   LOSH
      DO 1 I=1,N                                                         LOSH
      KQT(I)=-1                                                          LOSH
    1 CONTINUE                                                           LOSH
      DO 10 M=1,NMH                                                      LOSH
      MXH=-NH+M-1                                                        LOSH
      MA=MXH*MXH*KA                                                      LOSH
      DO 20 K=1,NMK                                                      LOSH
      MXK=-NK+K-1                                                        LOSH
      MB=MXK*MXK*KB                                                      LOSH
      MF=MXH*MXK*KF                                                      LOSH
      M1=MA+MB+MF                                                        LOSH
      DO 30 L=1,NL                                                       LOSH
      MXL=LMIN+L-1                                                       LOSH
      MC=MXL*MXL*KC                                                      LOSH
      M2=M1+MC                                                           LOSH
      KL=MXL*MXK                                                         LOSH
      LH=MXH*MXL                                                         LOSH
      IF(ISIGN.EQ.2)GO TO 31                                             LOSH
      IF((MXH.GT.0.OR.MXH.EQ.0).AND.(MXK.GT.0.OR.MXK.EQ.0))GO TO 500     LOSH
      IF((MXH.LT.0).AND.(MXK.GT.0.OR.MXK.EQ.0))GO TO 501                 LOSH
      IF((MXH.LT.0.OR.MXH.EQ.0).AND.(MXK.LT.0))GO TO 502                 LOSH
      IF((MXH.GT.0).AND.(MXK.LT.0))GO TO 503                             LOSH
   31 IF((MXH.GT.0.OR.MXH.EQ.0).AND.(MXK.GT.0.OR.MXK.EQ.0))GO TO 501     LOSH
      IF((MXH.LT.0).AND.(MXK.GT.0.OR.MXK.EQ.0))GO TO 500                 LOSH
      IF((MXH.LT.0.OR.MXH.EQ.0).AND.(MXK.LT.0))GO TO 503                 LOSH
      IF((MXH.GT.0).AND.(MXK.LT.0))GO TO 502                             LOSH
  500 KQMIN=M2+(KL*KDM)+(LH*KEM)                                         LOSH
      KQMAX=M2+(KL*KDP)+(LH*KEP)                                         LOSH
      GO TO 600                                                          LOSH
  501 KQMIN=M2+(KL*KDM)+(LH*KEP)                                         LOSH
      KQMAX=M2+(KL*KDP)+(LH*KEM)                                         LOSH
      GO TO 600                                                          LOSH
  502 KQMIN=M2+(KL*KDP)+(LH*KEP)                                         LOSH
      KQMAX=M2+(KL*KDM)+(LH*KEM)                                         LOSH
      GO TO 600                                                          LOSH
  503 KQMIN=M2+(KL*KDP)+(LH*KEM)                                         LOSH
      KQMAX=M2+(KL*KDM)+(LH*KEP)                                         LOSH
  600 IF((KQMAX+KEPSQ(1)).LT.KQ(1))GO TO 30                              LOSH
      IF((KQMIN-KEPSQ(N)).GT.KQ(N))GO TO 30                              LOSH
      DO 100 I=1,N                                                       LOSH
      KBORIN=KQMIN-KEPSQ(I)                                              LOSH
      IF(KBORIN.GT.KQ(I))GO TO 100                                       LOSH
      KBORSU=KQMAX+KEPSQ(I)                                              LOSH
      IF(KBORSU.GT.KQ(I))KQT(I)=1                                        LOSH
  100 CONTINUE                                                           LOSH
   30 CONTINUE                                                           LOSH
   20 CONTINUE                                                           LOSH
   10 CONTINUE                                                           LOSH
      RETURN                                                             LOSH
      END                                                                LOSH
      FUNCTION ARCOS(X)                                                  LOSH-1
C---PROVIDED BECAUSE ARCOS IS NOT A STANDARD FUNCTION                    LOSH-1
C---ARCOS GIVES THE ANGLE IN RADIANS (IN THE RANGE 0 TO PI)              LOSH-1
C---  WHOSE COSINE IS THE SINGLE PRECISION NUMBER X                      LOSH-1
C---IN THIS CASE ONLY A CHANGE OF NAME TO ACOS IS NEEDED                 LOSH-1
      ARCOS=ACOS(X)                                                      LOSH-1
      RETURN                                                             LOSH-1
      END                                                                LOSH-1
      SUBROUTINE REFSET                                                  REFSR1
C---INITIALISES TEMP STORAGE FOR REFINEMENT                              REFSR1
      COMMON D(50),EPSIL(50),Q(50),EPSQ(50),KQ(50),KEPSQ(50),KQT(50),N,N LOSHREF
     1H,NMH,NK,NMK,NL,LMIN,KA,KB,KC,KF                                   LOSHREF
      COMMON /REFCOM/ TITLE(20),ALAMBD,AMOLWT,DOBS,NSOL,NOBS,ITEMCH,     REFCOM
     1 IREFCH                                                            REFCOM
C---USED TO PASS TITLE TO S/R REFSET FOR REFORMATTING (ULCC)             REFIDTC
      COMMON /IDTCOM/ IDENT(30)                                          REFIDTC
      ITEMCH=38                                                          REFSR2
      IREFCH=39                                                          REFSR2
      NSOL=0                                                             REFSR2
      NOBS=N                                                             LOUTITL
      REWIND ITEMCH                                                      LOUTITL
      WRITE(ITEMCH,1) (IDENT(I),I=1,30)                                  LOUTITL
    1 FORMAT(30A2,20X)                                                   LOUTITL
      REWIND ITEMCH                                                      LOUTITL
      READ(ITEMCH,2) (TITLE(I),I=1,20)                                   LOUTITL
    2 FORMAT(20A4)                                                       LOUTITL
      ALAMBD=0.                                                          LOUMSH
      AMOLWT=0.                                                          LOUMSH
      DOBS=0.                                                            LOUMSH
      REWIND ITEMCH                                                      REFSR3
      RETURN                                                             REFSR3
      END                                                                REFSR3
      SUBROUTINE REFINC(QCELL)                                           REFSR3
C---INCREMENTS NSOL AND WRITES QCELL TO FILE ITEMCH FOR TEMP STORAGE     REFSR3
C---PRIOR TO RE-READING, OUTPUT AND REFINEMENT (QCELL IS IN QU.)         REFSR3
      DIMENSION QCELL(6)                                                 REFSR3
      COMMON /REFCOM/ TITLE(20),ALAMBD,AMOLWT,DOBS,NSOL,NOBS,ITEMCH,     REFCOM
     1 IREFCH                                                            REFCOM
      NSOL=NSOL+1                                                        REFSR3A
      WRITE(ITEMCH,1) (QCELL(I),I=1,6)                                   REFSR3A
    1 FORMAT(6F10.5)                                                     REFSR3A
      RETURN                                                             REFSR3A
      END                                                                REFSR3A
      SUBROUTINE REFSAV                                                  REFSR3A
C---CALLED WHEN SOLUTION-FINDING IS COMPLETE. ALL NSOL SOLUTIONS FOUND   REFSR3A
C---ARE READ BACK FROM TEMPORARY STORAGE CHANNEL ITEMCH AND WRITTEN TO   REFSR3A
C---CHANNEL IREFCH IN THE FORM OF CARD IMAGES THAT MAKE UP A DATA        REFSR3A
C---DECK FOR FZON(6), WITH THE NSOL SOLUTIONS AS SPECIFIED LATTICES      REFSR3A
C---TO BE NORMALISED, REFINED AND EVALUATED                              REFSR3A
      COMMON D(50),EPSIL(50),Q(50),EPSQ(50),KQ(50),KEPSQ(50),KQT(50),N,N LOSHREF
     1H,NMH,NK,NMK,NL,LMIN,KA,KB,KC,KF                                   LOSHREF
      COMMON /REFCOM/ TITLE(20),ALAMBD,AMOLWT,DOBS,NSOL,NOBS,ITEMCH,     REFCOM
     1 IREFCH                                                            REFCOM
      DIMENSION QCELL(6)                                                 REFSR4
      ENDFILE ITEMCH                                                     REFSR4
      REWIND ITEMCH                                                      REFSR4
      REWIND IREFCH                                                      REFSR4
      NR=NSOL                                                            REFSR4-
      IF(NR.GT.99) NR=99                                                 REFSR4-
      WRITE(IREFCH,100) (TITLE(I),I=1,20),ALAMBD,NR,AMOLWT,DOBS          REFSR4-
  100 FORMAT(20A4/                                                       REFSR4
     1 1H9,19X,F10.6,3X,1H1,6X,I4,3X,1H1,2X,F10.3,F10.4,10X)             REFSR4
      WRITE(IREFCH,150) (D(I),I=1,NOBS)                                  REFSR4
  150 FORMAT(F10.6,70X)                                                  REFSR4
      WRITE(IREFCH,160)                                                  REFSR4
  160 FORMAT(1H0,79X)                                                    REFSR4
      DO 200 J=1,NSOL                                                    REFSR4
      READ(ITEMCH,180) (QCELL(I),I=1,6)                                  REFSR4
      WRITE(IREFCH,180) (QCELL(I),I=1,6)                                 REFSR4
  180 FORMAT(6F10.5,20X)                                                 REFSR4
  200 CONTINUE                                                           REFSR4
      WRITE(IREFCH,250)                                                  REFSR4
  250 FORMAT(1H0,79X/3HEND,77X)                                          REFSR4-
      ENDFILE IREFCH                                                     REFSR4
      REWIND IREFCH                                                      REFSR4
      RETURN                                                             REFSR4
      END                                                                REFSR4
      SUBROUTINE FZONRF                                                  FZRF
C  --------------------------------------------------------------------- FZRF
C---THIS IS A CUT-DOWN VERSION OF JAN VISSER'S ZONE-INDEXING PROGRAM,    FZRF
C--- DESIGNED TO BE CALLED AS A SUBROUTINE FOR NORMALISING, REFINING,    FZRF
C--- EVALUATING AND DISPLAYING SPECIFIED SOLUTIONS. IT EXPECTS DATA      FZRF
C--- IN THE FORM OF A DECK OF CARD IMAGES IN THE =REFINE= FILE           FZRF
C--- (CHANNEL 9). AS THIS CAN ALSO BE PRINTED TO GIVE A LISTING OF THE   FZRF
C--- INPUT DATA, SUBROUTINE ECHO HAS BEEN MADE A DUMMY IN THIS VERSION.  FZRF
C-- *** BASED ON VERSION 6                                               FZRF
C-- *** INCLUDING UNIVERSITY OF SURREY MODS UP TO FZON6-7A AND 8         FZRF
C-- *** DATED OCTOBER 1977                                               FZRF
C-- *** ROBIN SHIRLEY, CHEMICAL PHYSICS DEPARTMENT                       FZRF
C  --------------------------------------------------------------------- FZRF
C                                                                        FZRF
C             THIS PROGRAM WAS WRITTEN BY                                FZRF
C                        J.W. VISSER                                     FZRF
C             OF THE TECHNISCH PHYSISCHE DIENST TNO-TH                   FZRF
C             P.O.BOX 155 DELFT NETHERLANDS.                             FZRF
C              IT CONTAINS MANY IDEAS AND SUGGESTIONS FROM               FZRF
C                       PROF.DR. P.M. DE WOLFF                           FZRF
C             OF THE TECHNICAL UNIVERSITY (T.H) DELFT.                   FZRF
C                                                                        FZRF
C                                                                        FZRF
C             A DESCRIPTION OF THE PROGRAM WAS PUBLISHED IN              FZRF
C             JOURNAL OF APPLIED CRYSTALLOGRAPHY.(1969) 2,89.            FZRF
C                                                                        FZRF
C                                                                        FZRF
C             THIS WORK WAS LARGELY SPONSORED BY THE                     FZRF
C             JOINT COMMITTEE ON POWDER  DIFFRACTION STANDARDS           FZRF
C             NOW AT  1601 PARK LANE, SWARTHMORE, PA. 19081              FZRF
C             AND THE CENTRAL ORGANIZATION FOR  TNO, THE HAGUE,          FZRF
C             NETHERLANDS.                                               FZRF
C                                                                        FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C     THE INPUT OF THIS PROGRAM SHOULD CONSIST OF0                       FZRF
C     1. A TITLE CARD,CONTAINING UP TO 80 CHARACTERS                     FZRF
C     2. A PARAMETER CARD,WHICH MAY BE  COMPLETELY BLANK.                FZRF
C     3. A NUMBER OF LINES CARDS, CONTAINING THE POSITIONS OF THE LINES  FZRF
C        THESE CAN BE ENTERED AS D-,Q- OR TWOTHETA VALUES. ( 8 F10.5 )   FZRF
C        YOU MAY LEAVE ANY NUMBER OF POSITIONS PER CARD  BLANK.          FZRF
C        THIS MEANS THAT YOU CAN ALSO ENTER ONLY ONE LINE PER CARD,      FZRF
C        IN ANY ONE OF THE POSITIONS OF 8F10.5                           FZRF
C     4. A BLANK CARD, TO FINISH THE INPUT OF ONE PROBLEM.               FZRF
C                                                                        FZRF
C        REPEAT THE ABOVE  AS MANY TIMES AS PROBLEMS,   -- THEN --       FZRF
C     5. A CARD CONTAINING THE WORD  --  END  -- IN THE FOUR FIRST COLUM FZRF
C        EITHER RIGHT- OR LEFT ADJUSTED,  TO FINISH THE INPUT.           FZRF
C                                                                        FZRF
C  THE PROGRAM WILL TAKE ITS OWN (DEFAULT) PARAMETERS.                   FZRF
C  FOR THE INITIATED THE SUBROUTINE READER GIVES FULL DETAILS ABOUT      FZRF
C  ALL THE  POSIBILITIES OF THE PROGRAM.                                 FZRF
C                                                                        FZRF
C  THE INPUT OF THE PROGRAM IS ON UNIT 5,                                FZRF
C  THE OUTPUT IS ON UNIT  6.                                             FZRF
C  ON UNIT 4 YOU MAY GET TEST OUTPUT, THESE ARE THE CARD IMAGES          FZRF
C  OF THE INPUT CARDS.                                                   FZRF
C                                                                        FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
C                         GENERAL FLOW OF SUBROUTINES                    FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
C                                                                        FZRF
C        *******            *******           **********                 FZRF
C        *     *            *     * <-------> *  ECHO  *                 FZRF
C        *     *            *  R  *           **********                 FZRF
C        *     *            *     *                                      FZRF
C        *     * <--------> *  E  *           **********                 FZRF
C        *     *            *     * <-------> * MANUAL *                 FZRF
C        *     *            *  A  *           **********                 FZRF
C        *     *            *     *                                      FZRF
C        *     *            *  D  *           **********                 FZRF
C        *     *            *     * <-------> * INSTRS *                 FZRF
C        *     *            *  E  *           **********                 FZRF
C        *     *            *     *                                      FZRF
C        *     *            *  R  *           **********                 FZRF
C        *     *            *     * <-------> * SRTRON *                 FZRF
C        *     *            *******           **********                 FZRF
C        *     *                                                         FZRF
C        *  M  *            *********                                    FZRF
C        *     *  <-------> * NORM3 *                                    FZRF
C        *     *            *********                                    FZRF
C        *     *                                                         FZRF
C        *     *            *******           **********                 FZRF
C        *  A  *            *     *  <------> * WISSEL *                 FZRF
C        *     *            *  R  *           **********                 FZRF
C        *     *            *     *           *********                  FZRF
C        *     *            *  E  *  <------> * WRISP *                  FZRF
C        *     *            *     *           *********                  FZRF
C        *     *  <-------> *  F  *           *********                  FZRF
C        *     *            *     *  <------> * ARRAY *                  FZRF
C        *  I  *            *  P  *           *********                  FZRF
C        *     *            *     *           ********                   FZRF
C        *     *            *  A  *  <------> * MINV *                   FZRF
C        *     *            *     *           ********                   FZRF
C        *     *            *  R  *           *********                  FZRF
C        *     *            *     *  <------> * NORM3 *                  FZRF
C        *     *            *     *           *********                  FZRF
C        *     *            *     *           **********                 FZRF
C        *     *            *     *  <------> * LISTM  *                 FZRF
C        *     *            *******           **********                 FZRF
C        *     *                                                         FZRF
C        *     *                                                         FZRF
C        *     *            **********                                   FZRF
C        *  N  *  <-------> * UNTCEL *                                   FZRF
C        *     *            **********                                   FZRF
C        *     *                                                         FZRF
C        *     *                                                         FZRF
C        *     *            **********                                   FZRF
C        *     *  <-------> * SYMTST *                                   FZRF
C        *     *            **********                                   FZRF
C        *     *                                                         FZRF
C        *     *                                                         FZRF
C        *******                                                         FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
      DIMENSION STORE(200,6 ),BRAVTP(6),ISYST(3,3)                       FZRF
      INTEGER  H,H1                                                      FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
C        ****************************                                    FZRF
C        * ATTENTION   H = INTEGER  *                                    FZRF
C        ****************************                                    FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
      LOGICAL SELF,ENL,TEST,LIST                                         FZRF
      LOGICAL RECTAN                                                     FZRF
CDC---LEVEL STATEMENTS FOR CDC 7600 FOLLOW---REMOVE FOR OTHER MACHINES-- LEV2
CDC   LEVEL 2, LINCO,NQ2,NSOLMX,ROSTER                                   FZRFL2
C---COMMON BLOCK /TEMRES/, LENGTH 11613 (OCTAL), 5003 (DECIMAL)          FZRFL2
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      COMMON /TEMRES/ LINCO,NQ2,NSOLMX,ROSTER(500,10)                    FZONRFM
      COMMON /REFP/ IREF                                                 FZRF
      DATA  BRAVTP/1HA,1HB,1HC,1HI,1HF,1HP/                              FZRF
      DATA ISYST(1,1)/4HORTH/,ISYST(1,2)/4HORHO/,ISYST(1,3)/4HMBIC/,     FZRF
     1     ISYST(2,1)/4HMONO/,ISYST(2,2)/4HCLIN/,ISYST(2,3)/4HIC  /,     FZRF
     2     ISYST(3,1)/4HTRIC/,ISYST(3,2)/4HLINI/,ISYST(3,3)/4HIC   /     FZRF
C                                                                        FZRF
      JOB=0                                                              FZRF
    1 RAD=57.29578                                                       FZRF
      INP=39                                                             FZRF
C---INPUT WILL BE TAKEN FROM THE =REFINE= FILE                           FZRF
      IOUT=6                                                             FZRF
      NRMAX=200                                                          FZRF
      NSOLMX=500                                                         FZRF
      NREFMX=10                                                          FZRF
      NORDER=4                                                           FZRF
      DO 10 I=1,100                                                      FZRF
      DO 5 J=1,10                                                        FZRF
   5  ROSTER(I,J)=0.0                                                    FZRF
  10  CONTINUE                                                           FZRF
      DO 30 I=1,200                                                      FZRF
      DO 20 J=1,6                                                        FZRF
   20 STORE(I,J)=0.0                                                     FZRF
  30  CONTINUE                                                           FZRF
C                                                                        FZRF
      CALL       READER(NZ1,NZ2,NR,WMOL,DOBS)                            FZRF
      IF (NR .EQ. -1) GOTO 8000                                          FZRF
C                                                                        FZRF
      N4=NR                                                              FZRF
      NR=0                                                               FZRF
C  --------------------------------------------------------------------- FZRF
C--THE LATTICES FOUND WILL BE PUT INTO A STANDARD SHAPE.(NORMALISED)     FZRF
C  --------------------------------------------------------------------- FZRF
      IF (ENL) WRITE (IOUT,9936)                                         FZRF
      DO  1990 J=1,N4                                                    FZRF
      IF (ROSTER(J,7) .LT. 1.0) GO TO  1990                              FZRF
      DO 1950  I=1,6                                                     FZRF
 1950 CEL(I)=ROSTER(J,I)                                                 FZRF
      CALL NORM3                                                         FZRF
      DO 1955 I=1,6                                                      FZRF
 1955 ROSTER(J,I)=CEL(I)                                                 FZRF
      DO 1960 K=1,3                                                      FZRF
      IF (ROSTER(J,K) .LT. FMINIM) GO TO 1990                            FZRF
 1960 CONTINUE                                                           FZRF
      NR=NR+1                                                            FZRF
      DO 1965 K=1,8                                                      FZRF
 1965 ROSTER(NR,K)=ROSTER(J,K)                                           FZRF
      IF(ENL) WRITE(IOUT,9937) NR,(ROSTER(NR,K),K=1,8)                   FZRF
 1990 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C  THE LATTICES ARE NOW NORMALIZED,AND THE PATHOLOGICAL CASES HAVE       FZRF
C  BEEN DROPPED. THE NEXT STEP IS TO TRY AND REFINE THE LATTICES THAT    FZRF
C  ARE LEFT.                                                             FZRF
C  --------------------------------------------------------------------- FZRF
C  --------------------------------------------------------------------- FZRF
C  FIRST WE ELIMINATE 'EQUAL' LATTICES .                                 FZRF
      NR1=NR-1                                                           FZRF
      DO 2050 H=1,NR1                                                    FZRF
      H1=H+1                                                             FZRF
      DO 2040 K=H1,NR                                                    FZRF
      U=0.0                                                              FZRF
      DO 2030 L=1,6                                                      FZRF
 2030 U=U+ABS( ROSTER(H,L)- ROSTER(K,L))                                 FZRF
      IF (U.GT. FMINEQ) GO TO 2040                                       FZRF
      IF ( ROSTER(H,7).GE.  ROSTER(K,7)) GO TO 2035                      FZRF
       ROSTER(H,7)=0.0                                                   FZRF
      GO TO 2040                                                         FZRF
 2035  ROSTER(K,7)=0.0                                                   FZRF
 2040 CONTINUE                                                           FZRF
 2050 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C  A FIRST ROUND OF LEAST SQUARES (IN REFPAR) WILL NOW BE RUN.           FZRF
C  --------------------------------------------------------------------- FZRF
 2055 NSOL=0                                                             FZRF
      NREFCY=3                                                           FZRF
      DO 2100 I=1,NR                                                     FZRF
      IF ( ROSTER(I,7) .LT. 1.0) GO TO 2100                              FZRF
      DO 2060 K=1,10                                                     FZRF
 2060 CEL(K)= ROSTER(I,K)                                                FZRF
      CEL(7)=0.0                                                         FZRF
      CEL(10)=CEL(8)                                                     FZRF
      NSOL=NSOL+1                                                        FZRF
      DO 2065 IREF=1,NREFCY                                              FZRF
      CALL REFPAR(NSOL)                                                  FZRF
 2065 CONTINUE                                                           FZRF
      IREF=0                                                             FZRF
      DO 2070 K=1,10                                                     FZRF
 2070 ROSTER(NSOL,K)=CEL(K)                                              FZRF
 2100 CONTINUE                                                           FZRF
      NR=NSOL                                                            FZRF
C  --------------------------------------------------------------------- FZRF
C--A DOUBLE SORT WILL NOW BE CARRIED OUT, FIRST ON THE NUMBER OF         FZRF
C  LINES INDEXED(POS. 7)   AND SECONDLY ON THE FIGURE OF MERIT (POS. 8)  FZRF
C--OF THE LATTICES.                                                      FZRF
C  --------------------------------------------------------------------- FZRF
      WRITE(IOUT,9950) NAME                                              FZRF
      WRITE(IOUT,9951)                                                   FZRF
      JJ=100                                                             FZRF
      DO 3050 L=1,NR                                                     FZRF
      K=0                                                                FZRF
      AA=0.                                                              FZRF
      DO 3040 H=L,NR                                                     FZRF
      M= ROSTER(H,7)+0.5                                                 FZRF
      B= ROSTER(H,8)                                                     FZRF
      IF (M-K) 3040,3020,3010                                            FZRF
 3010 K=M                                                                FZRF
      I=H                                                                FZRF
      AA=B                                                               FZRF
      GO TO 3040                                                         FZRF
 3020 IF(B.LE.AA) GO TO 3040                                             FZRF
      AA=B                                                               FZRF
      I=H                                                                FZRF
 3040 CONTINUE                                                           FZRF
      IF (K.GE.JJ) GO TO 3045                                            FZRF
      WRITE(IOUT,9952)                                                   FZRF
      JJ=K                                                               FZRF
 3045 DO 3048 N=1,10                                                     FZRF
      A= ROSTER(I,N)                                                     FZRF
       ROSTER(I,N)= ROSTER(L,N)                                          FZRF
       ROSTER(L,N)=A                                                     FZRF
      CEL(N)=ROSTER(L,N)                                                 FZRF
 3048 CONTINUE                                                           FZRF
      CALL UNTCEL(WMOL,DOBS,VOL,0)                                       FZRF
      KKK=INT(ROSTER(L,9)+0.5)                                           FZRF
      WRITE(IOUT,9953) (ROSTER(L,N),N=1,8),BRAVTP(KKK),                  FZRF
     * ROSTER(L,10), VOL                                                 FZRF
 3050 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C--END OF SORT AND PRINT.                                                FZRF
C----------------------------------------------------------------------- FZRF
      WRITE(IOUT,9963)                                                   FZRF
C----------------------------------------------------------------------- FZRF
C--WE NOW PRINT OUT THE BEST FOUR SOLUTIONS WITH AN INDEXED LIST         FZRF
C  OF THE FIRST TWENTY LINES.  IF YOU HAVE SET  'ENL' THEN YOU ALSO      FZRF
C--GET  THE Q-VALUES PRINTED OUT AS A  LATTICE.                          FZRF
C----------------------------------------------------------------------- FZRF
      WRITE(IOUT,9964) NREFMX                                            FZRF
      N=0                                                                FZRF
      SELF=.TRUE.                                                        FZRF
      DO 3052 I=1,3                                                      FZRF
 3052 IF (NSYST(I) .EQ.1) N=I                                            FZRF
      IF (N .NE. 0) SELF=.FALSE.                                         FZRF
      IF (SELF) GO TO 3058                                               FZRF
      MIN=-1                                                             FZRF
      N=0                                                                FZRF
      M=0                                                                FZRF
      DO 3054 K=1,3                                                      FZRF
      IF (NSYST(K) .EQ. 1) WRITE(IOUT,9965) (ISYST(K,I),I=1,3)           FZRF
      IF (NSYST(K) .EQ. 1) N=N+1                                         FZRF
      IF (NSYST(K) .EQ.(-1)) WRITE(IOUT,9966) (ISYST(K,I),I=1,3)         FZRF
      IF (NSYST(K) .EQ.(-1) ) M=M+1                                      FZRF
 3054 CONTINUE                                                           FZRF
      IF (N .GT. 0) MIN=1                                                FZRF
      IF (M .GT. 0) MIN=0                                                FZRF
      DO 3056 M=1,MAX                                                    FZRF
      DIF=OBS(M)-OBSMT(M)                                                FZRF
      OBSMT(M)=OBSMT(M)-DIF                                              FZRF
 3056 OBSPT(M)=OBSPT(M)+DIF                                              FZRF
C  THE TOLERANCES HAVE BEEN DOUBLED WHEN YOU WANT TO  FORCE A CERTAIN    FZRF
C  CRYSTAL SYSTEM.                                                       FZRF
 3058 NSOL=0                                                             FZRF
      DO 3100 I=1,NR                                                     FZRF
      IF(NSOL.EQ.NREFMX) GOTO 3105                                       FZRF
      IF (SELF) GO TO 3090                                               FZRF
      NORDE=1                                                            FZRF
      DO 3080 J=4,6                                                      FZRF
 3080 IF (ABS(ROSTER(I,J)) .GT. FMINEQ) NORDE=NORDE+1                    FZRF
      IF (NORDE .EQ. 4) NORDE=3                                          FZRF
      IF (NSYST(NORDE) .LT. MIN) GO TO 3100                              FZRF
 3090 NSOL=NSOL+1                                                        FZRF
      DO 3060 J=1,10                                                     FZRF
 3060 CEL(J)= ROSTER(I,J)                                                FZRF
      CALL REFPAR(NSOL)                                                  FZRF
      DO 3070 J=1,10                                                     FZRF
 3070  ROSTER(I,J)=CEL(J)                                                FZRF
 3100 CONTINUE                                                           FZRF
C  AFTER THIS REFINEMENT CYCLE, A NEW DOUBLE SORT IS MADE                FZRF
 3105 NSOL=NREFMX                                                        FZRF
      IF(NR.LT.NREFMX) NSOL=NR                                           FZRF
      DO 3250 L=1,NSOL                                                   FZRF
      K=0                                                                FZRF
      AA=0.                                                              FZRF
      DO 3240 H=L,NR                                                     FZRF
      M=ROSTER(H,7)+0.5                                                  FZRF
      B=ROSTER(H,8)                                                      FZRF
      IF (M-K) 3240,3220,3210                                            FZRF
 3210 K=M                                                                FZRF
      I=H                                                                FZRF
      AA=B                                                               FZRF
      GO TO 3240                                                         FZRF
 3220 IF(B.LE.AA) GO TO 3240                                             FZRF
      AA=B                                                               FZRF
      I=H                                                                FZRF
 3240 CONTINUE                                                           FZRF
      DO 3248 N=1,10                                                     FZRF
      A=ROSTER(I,N)                                                      FZRF
      ROSTER(I,N)=ROSTER(L,N)                                            FZRF
      ROSTER(L,N)=A                                                      FZRF
 3248 CONTINUE                                                           FZRF
 3250 CONTINUE                                                           FZRF
      WRITE(IOUT,9954) NAME,NREFMX                                       FZRF
      DO 3110 I=1,NSOL                                                   FZRF
      KKK=INT(ROSTER(I,9)+0.5)                                           FZRF
 3110 WRITE(IOUT,9955) ( ROSTER(I,N),N=1,8),  ROSTER(I,10),BRAVTP(KKK)   FZRF
      WRITE(IOUT,9956)                                                   FZRF
      DO 3120 I=1,NSOL                                                   FZRF
      DO 3115 J=1,10                                                     FZRF
 3115 CEL(J)= ROSTER(I,J)                                                FZRF
      CALL UNTCEL(WMOL,DOBS,VOL,1)                                       FZRF
 3120 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C--PRINTS THE VALUES OF THE PARAMETERS OF THE DIRECT LATTICE.            FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
      DO 3150  I=1,NSOL                                                  FZRF
      DO 3140 J=1,10                                                     FZRF
 3140 CEL(J)=ROSTER(I,J)                                                 FZRF
      CALL SYMTST                                                        FZRF
 3150 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C  THE BEST SOLUTIONS ARE TESTED ON HIGHER SYMMETRIES,THAT MAY BE        FZRF
C  CONCEALED IN THE Q-VALUES.                                            FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
      WRITE(IOUT,9957)                                                   FZRF
      WRITE(IOUT,9959)                                                   FZRF
      WRITE(IOUT,9958) NAME                                              FZRF
C  --------------------------------------------------------------------- FZRF
      GO TO 1                                                            FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C--- FINAL RETURN                                                        FZRF
 8000 CONTINUE                                                           FZRF
      RETURN                                                             FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
 9936 FORMAT(                                                            FZRF
     160H1        LATTICES REDUCED AND PUT INTO STANDARD FORM        //  FZRF
     260H SERIAL   A       B       C        D       E       F       H,   FZRF
     320HITS   PEDIGREE        )                                         FZRF
 9937 FORMAT(1H ,I5,6F8.1, 2F8.0)                                        FZRF
 9950 FORMAT(1H1,20A4)                                                   FZRF
 9951 FORMAT(1H0,14X,47HTRIAL LATTICES AFTER INDEXING AND LS REFINEMENT  FZRF
     *//14X,52HONLY THE FIRST 20 LINES ARE CONSIDERED FOR INDEXING  //   FZRF
     *59X,24HLINES  FIGURE    BRAVAIS/                                   FZRF
     *95H      A        B        C        D         E        F    INDEXE FZRF
     *D  OF MERIT  LATTICE  PEDIGREE   ,6HVOLUME )                       FZRF
 9952 FORMAT(1H )                                                        FZRF
 9953 FORMAT(1H ,6F9.1,F9.0,F9.1,8X,A1,F9.0,F8.1 )                       FZRF
 9954 FORMAT(1H1,20A4 /// 30X,                                           FZRF
     1 4HTHE ,I2,24H MOST PROBABLE SOLUTIONS//// 58X,                    FZRF
     234HLINES  FIGURE OF           BRAVAIS/                             FZRF
     360H    Q(A)     Q(B)     Q(C)      Q(D)     Q(E)     Q(F)   IND,   FZRF
     433HEXED   MERIT   PEDIGREE  LATTICE        )                       FZRF
 9955 FORMAT(1H ,6F9.2,F9.0,F9.1,F9.0,8X,A1)                             FZRF
 9956 FORMAT(1H0,20X,38HTHE DIRECT CONSTANTS OF THESE LATTICES//         FZRF
     *60H     A        B        C       ALFA     BETA     GAMMA      ,   FZRF
     * 6HVOLUME)                                                         FZRF
 9957 FORMAT(1H0///40X,24H ****   ATTENTION   ****//                     FZRF
     160H 1. ANY 'SOLUTION' WITH A FIGURE OF MERIT LESS THAN 4.0 IS W,   FZRF
     260HORTHLESS AND SHOULD BE REJECTED RIGHT AWAY.                 //  FZRF
     360H 2. ANY 'SOLUTION'THAT LEAVES MORE THAN TWO VERY WEAK LINES ,   FZRF
     460HUNEXPLAINED  IS WORTHLESS.   HOWEVER, IF THE FIGURE OF MERIT/   FZRF
     560H    IS GREATER THAN 10.0 IT MIGHT BE WORTHWHILE TO EXAMINE  ,   FZRF
     660HTHE INPUT DATA  AND THE 'SOLUTION' MORE CLOSELY.            //  FZRF
     760H 3. EVEN 'SOLUTIONS' THAT INDEX ALL LINES WITH A FIGURE OF M,   FZRF
     860HERIT GREATER THAN 10.0 SHOULD NOT BE ACCEPTED UNCRITICALLY  /   FZRF
     933H    WITHOUT FURTHER INVESTIGATION//)                            FZRF
 9958 FORMAT(1H0,20A4)                                                   FZRF
 9959 FORMAT(71H0******************************************************* FZRF
     1***************/2H *,68X,1H*/2H *,  69H  THIS PROGRAM GIVES A NUMB FZRF
     2ER OF SUGGESTIONS THAT MAY HELP YOU TO   */ 71H *  FIND THE UNIT C FZRF
     3ELL THAT EXPLAINS YOUR EXPERIMENTAL DATA. HOWEVER  */2H *,68X,     FZRF
     4 1H*/ 2H *,5X,58HWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW FZRF
     4WWWWWWWWW,         6H     */8H *     W,56X,7HW     */ 8H *     W,  FZRF
     5 63H   IT IS ENTIRELY THE USERS RESPONSIBILITY TO DECIDE    W      FZRF
     6* /71H *     W   WHETHER ANY OF THE SUGGESTED UNIT CELLS IS THE    FZRF
     7    W     *  / 71H *     W   CORRECT CELL.                         FZRF
     8                W     * / 8H *     W, 56X, 7HW     * / 7H *      , FZRF
     9 58(1HW), 6H     * / 2H *,68X,1H*/1H ,70(1H*) )                    FZRF
 9963 FORMAT(7H0NOTES0//                                                 FZRF
     160H  1. 'LINES INDEXED' REFERS TO THE NUMBER OF LINES FROM THE ,   FZRF
     260HFIRST 20 OBSERVED LINES THAT HAVE BEEN ACCEPTED AS INDEXED  /   FZRF
     360H     BY THIS LATTICE, UP TO A MAXIMUM OF 20, WHICH WOULD REP,   FZRF
     460HRESENT COMPLETE SUCCESS.                                    //  FZRF
     560H  2. 'FIGURE OF MERIT' IS DEFINED AS QOBS(20)/(2*MEANDIFF*NC,   FZRF
     660HALC) WHERE DIFFERENCES ARE TAKEN FOR INDEXED LINES ONLY     /   FZRF
     760H     AND 'NCALC' IS THE NUMBER OF LINES GENERATED UP TO Q=1.,   FZRF
     860H003*Q(20),REGARDLESS OF WHETHER OR NOT THEY CONTRIBUTE TO   /   FZRF
     960H     THE INDEXINGS, BUT EXCLUDING SYSTEMATIC ABSENCES DUE TO,   FZRF
     *27H THE BRAVAIS LATTICE TYPE. /                                    FZRF
     A60H     IT IS CLOSELY RELATED TO  M20 ,DE WOLFF(J.APPL.CRYST.19,   FZRF
     B60H68,1972), ALLOWING FOR LESS THAN 20 SUCCESSFUL INDEXINGS.   )   FZRF
 9964 FORMAT(5H0THE ,I2,49H BEST SOLUTIONS ARE NOW PRINTED MORE EXTENSIV FZRF
     1ELY.)                                                              FZRF
 9965 FORMAT( 1H0,3A4, 23H LATTICES ARE PRINTED.  )                      FZRF
 9966 FORMAT( 1H0,3A4,27H LATTICES ARE NOT PRINTED.  )                   FZRF
      END                                                                FZRF
      SUBROUTINE ARRAY(MODE,I,J,N,M,S,D)                                 FZRF
C                                                                        FZRF
C  COPIED FROM  THE I.B.M.  SCIENTIFIC SUBROUTINE PACKAGE.               FZRF
C  TO BE USED IN COMBINATION WITH THE SUBROUTINE  MINV (MATRIX INVERSION FZRF
C                                                                        FZRF
      DIMENSION S(36),D(36)                                              FZRF
      NI=N-I                                                             FZRF
      IF(MODE .GT. 1) GO TO 20                                           FZRF
      IJ=I*J+1                                                           FZRF
      NM=N*J+1                                                           FZRF
      DO 10 K=1,J                                                        FZRF
      NM=NM-NI                                                           FZRF
      DO 10 L=1,I                                                        FZRF
      IJ=IJ-1                                                            FZRF
      NM=NM-1                                                            FZRF
      D(NM)=S(IJ)                                                        FZRF
   10 CONTINUE                                                           FZRF
      GO TO 40                                                           FZRF
   20 IJ=0                                                               FZRF
      NM=0                                                               FZRF
      DO 30 K=1,J                                                        FZRF
      DO 25 L=1,I                                                        FZRF
      IJ=IJ+1                                                            FZRF
      NM=NM+1                                                            FZRF
      S(IJ)=D(NM)                                                        FZRF
   25 CONTINUE                                                           FZRF
      NM=NM+NI                                                           FZRF
   30 CONTINUE                                                           FZRF
   40 RETURN                                                             FZRF
      END                                                                FZRF
      SUBROUTINE ECHO                                                    FZRF
C----------------------------------------------------------------------- FZRF
C  THE PURPOSE OF THIS SUBROUTINE IS TO PRINT THE CARD IMAGES OF THE INP FZRF
C     CARDS ON A SEPARATE PAGE                                           FZRF
C  THIS IS VERY USEFUL FOR TEST PURPOSES AND FOR DOCUMENTATION.          FZRF
C                                                                        FZRF
C  ON SOME MACHINES IT IS NOT POSSIBLE AT ALL TO  BACKSPACE  THE         FZRF
C  INPUT FILE.  IN THIS CASE YOU COULD READ THE INPUT DATA FROM          FZRF
C  THE INPUT FILE(IN ECHO), WRITE THEM AGAIN ON A TEMPORARY FILE         FZRF
C  AND READ THEM FROM THIS TEMPORARY FILE IN SUBROUTINE  READER.         FZRF
C  SINCE THIS IS RATHER  'MACHINE-DEPENDENT', I LEAVE IT TO YOUR         FZRF
C  OWN IMAGINATION AND INGENUITY..............                           FZRF
C----------------------------------------------------------------------- FZRF
C  YOU CAN ALSO GET RID OF THE WHOLE  PROBLEM BY REPLACING THE           FZRF
C  SUBROUTINE BY A  DUMMY SUBROUTINE, AS FOLLOWS                         FZRF
C                                                                        FZRF
C     SUBROUTINE  ECHO                                                   FZRF
C     RETURN                                                             FZRF
C     END                                                                FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
      RETURN                                                             FZRF
      END                                                                FZRF
      SUBROUTINE  LISTM(NCALC)                                           FZRF
      DIMENSION INSTOR(100,3),QSTOR(100)                                 FZRF
      LOGICAL SELF,ENL,TEST,LIST                                         FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      COMMON /LINSTR/ INSTOR,QSTOR                                       FZRF
      SWAVEL=WAVEL/200.                                                  FZRF
      NOLIM=20                                                           FZRF
      IF(MAX.LE.20) NOLIM=MAX-1                                          FZRF
C--SORT CALCULATED VALUES.                                               FZRF
      DO 100 I=1,NCALC                                                   FZRF
      Q=1.E+6                                                            FZRF
      DO  60 J=I,NCALC                                                   FZRF
      IF (QSTOR(J).GT. Q) GO TO 60                                       FZRF
      Q=QSTOR(J)                                                         FZRF
      N=J                                                                FZRF
   60 CONTINUE                                                           FZRF
      U=QSTOR(I)                                                         FZRF
      QSTOR(I)=QSTOR(N)                                                  FZRF
      QSTOR(N)=U                                                         FZRF
      DO  80 K=1,3                                                       FZRF
      INX  =INSTOR(I,K)                                                  FZRF
      INSTOR(I,K)=INSTOR(N,K)                                            FZRF
   80 INSTOR(N,K)= INX                                                   FZRF
  100 CONTINUE                                                           FZRF
      NO=1                                                               FZRF
      NC=1                                                               FZRF
      UL=0.                                                              FZRF
      NWR=21                                                             FZRF
      IF(MAX.LT.21) NWR=MAX                                              FZRF
      WRITE(IOUT,9903) NWR                                               FZRF
      WRITE(IOUT,9904)                                                   FZRF
C--PRINT QCALC AND QOBS IN ORDER OF TWOTHETA.                            FZRF
  110 CONTINUE                                                           FZRF
      IF (NC .GT. NCALC) GO TO 200                                       FZRF
      IF (NO .GT. NWR) GO TO 115                                         FZRF
      IF (QSTOR(NC) .GT. OBS(NO)) GO TO 200                              FZRF
  115 CONTINUE                                                           FZRF
      W=SQRT(QSTOR(NC))                                                  FZRF
      U=SWAVEL*W                                                         FZRF
      W=100./W                                                           FZRF
      U=114.59156*ATAN(U/SQRT(1.0-U*U))                                  FZRF
      IF (U-UL .GT. 0.05) WRITE(IOUT,9905)                               FZRF
      WRITE(IOUT,9901) U,W,(INSTOR(NC,K),K=1,3),QSTOR(NC)                FZRF
      UL=U                                                               FZRF
      NC=NC+1                                                            FZRF
      IF (NC .LE. NCALC ) GO TO 110                                      FZRF
      IF (NO .GE. NWR) GO TO 300                                         FZRF
  200 W=SQRT(OBS(NO))                                                    FZRF
      U=SWAVEL*W                                                         FZRF
      W=100./W                                                           FZRF
      U=114.59156*ATAN(U/SQRT(1.0-U*U))                                  FZRF
      IF (U-UL .GT. 0.05) WRITE(IOUT,9905)                               FZRF
      WRITE(IOUT,9902) U,W, OBS(NO)                                      FZRF
      UL=U                                                               FZRF
      NO=NO+1                                                            FZRF
      IF(NO.LE.NOLIM) GOTO 110                                           FZRF
      IF (NC .LE. NCALC) GO TO 110                                       FZRF
  300 RETURN                                                             FZRF
 9901 FORMAT(1H ,F10.2,F10.3,2X,3I4,F8.1)                                FZRF
 9902 FORMAT(1H ,F10.2,F10.3,14H     *OBSERVED ,F8.1)                    FZRF
 9903 FORMAT(53H0LIST OF ALL OBSERVED AND CALCULATED LINES UP TO THE ,   FZRF
     1 I2,3H-TH/74H IF THE TWOTHETAS DIFFER MORE THAN 0.05 DEGREES, A BL FZRF
     2ANK LINE IS INSERTED.)                                             FZRF
 9904 FORMAT(45H0  TWOTHETA       D       H   K   L     Q          )     FZRF
 9905 FORMAT(3X)                                                         FZRF
      END                                                                FZRF
      SUBROUTINE MINV(A,N,D,L,M)                                         FZRF
C                                                                        FZRF
C  MATRIX INVERSION. COPIED FROM THE I.B.M. SCIENTIFIC SUBROUTINE PACKAG FZRF
C                                                                        FZRF
      DIMENSION A(36),L(6),M(6)                                          FZRF
      D=1.0                                                              FZRF
      NK=-N                                                              FZRF
      DO 80 K=1,N                                                        FZRF
      NK=NK+N                                                            FZRF
      L(K)=K                                                             FZRF
      M(K)=K                                                             FZRF
      KK=NK+K                                                            FZRF
      BIGA=A(KK)                                                         FZRF
      DO 20 J=K,N                                                        FZRF
      IZ=N*(J-1)                                                         FZRF
      DO 20 I=K,N                                                        FZRF
      IJ=IZ+I                                                            FZRF
   10 IF(ABS(BIGA).GE.ABS(A(IJ))) GO TO 20                               FZRF
      BIGA=A(IJ)                                                         FZRF
      L(K)=I                                                             FZRF
      M(K)=J                                                             FZRF
   20 CONTINUE                                                           FZRF
      J=L(K)                                                             FZRF
      IF(J .LE. K) GO TO 35                                              FZRF
      KI=K-N                                                             FZRF
      DO 30 I=1,N                                                        FZRF
      KI=KI+N                                                            FZRF
      HOLD=-A(KI)                                                        FZRF
      JI=KI-K+J                                                          FZRF
      A(KI)=A(JI)                                                        FZRF
      A(JI)=HOLD                                                         FZRF
   30 CONTINUE                                                           FZRF
   35 I=M(K)                                                             FZRF
      IF(I .LE. K) GO TO 45                                              FZRF
      JP=N*(I-1)                                                         FZRF
      DO 40 J=1,N                                                        FZRF
      JK=NK+J                                                            FZRF
      JI=JP+J                                                            FZRF
      HOLD=-A(JK)                                                        FZRF
      A(JK)=A(JI)                                                        FZRF
      A(JI)=HOLD                                                         FZRF
   40 CONTINUE                                                           FZRF
   45 IF (ABS(BIGA) .GT. 0.0001) GO TO 48                                FZRF
      D=0.0                                                              FZRF
      RETURN                                                             FZRF
   48 DO 55 I=1,N                                                        FZRF
      IF(I .EQ. K) GO TO 55                                              FZRF
      IK=NK+I                                                            FZRF
      A(IK)=A(IK)/(-BIGA)                                                FZRF
   55 CONTINUE                                                           FZRF
      DO 65 I=1,N                                                        FZRF
      IK=NK+I                                                            FZRF
      HOLD=A(IK)                                                         FZRF
      IJ=I-N                                                             FZRF
      DO 65 J=1,N                                                        FZRF
      IJ=IJ+N                                                            FZRF
      IF(I .EQ. K) GO TO 65                                              FZRF
      IF(J .EQ. K) GO TO 65                                              FZRF
      KJ=IJ-I+K                                                          FZRF
      A(IJ)=HOLD*A(KJ)+A(IJ)                                             FZRF
   65 CONTINUE                                                           FZRF
      KJ=K-N                                                             FZRF
      DO 75 J=1,N                                                        FZRF
      KJ=KJ+N                                                            FZRF
      IF(J .EQ. K) GO TO 75                                              FZRF
      A(KJ)=A(KJ)/BIGA                                                   FZRF
   75 CONTINUE                                                           FZRF
      D=D*BIGA                                                           FZRF
      A(KK)=1.0/BIGA                                                     FZRF
   80 CONTINUE                                                           FZRF
      K=N                                                                FZRF
  100 K=(K-1)                                                            FZRF
      IF(K .LE. 0) GO TO 150                                             FZRF
      I=L(K)                                                             FZRF
      IF(I .LE. K) GO TO 120                                             FZRF
      JQ=N*(K-1)                                                         FZRF
      JR=N*(I-1)                                                         FZRF
      DO 110 J=1,N                                                       FZRF
      JK=JQ+J                                                            FZRF
      HOLD=A(JK)                                                         FZRF
      JI=JR+J                                                            FZRF
      A(JK)=-A(JI)                                                       FZRF
      A(JI)=HOLD                                                         FZRF
  110 CONTINUE                                                           FZRF
  120 J=M(K)                                                             FZRF
      IF(J .LE. K) GO TO 100                                             FZRF
      KI=K-N                                                             FZRF
      DO 130 I=1,N                                                       FZRF
      KI=KI+N                                                            FZRF
      HOLD=A(KI)                                                         FZRF
      JI=KI-K+J                                                          FZRF
      A(KI)=-A(JI)                                                       FZRF
      A(JI)=HOLD                                                         FZRF
  130 CONTINUE                                                           FZRF
      GO TO 100                                                          FZRF
  150 RETURN                                                             FZRF
      END                                                                FZRF
      SUBROUTINE NORM3                                                   FZRF
C----------------------------------------------------------------------- FZRF
C  THIS SUBROUTINE 'NORMALIZES THE LATTICES AND PUTS THEM INTO A         FZRF
C  STANDARD SHAPE                                                        FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
      DIMENSION  OLD(6),          IZON(3,6),QVAL(5,5,5)                  FZRF
      INTEGER H,H1                                                       FZRF
      LOGICAL SELF,ENL,TEST,LIST,CHANGE                                  FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      EQUIVALENCE (CEL(1),A),(CEL(2),B),(CEL(3),C),(CEL(4),D),           FZRF
     *(CEL(5),E),(CEL(6),F),(FMINEQ,EQMIN)                               FZRF
      DO 80 I=1,6                                                        FZRF
   80 OLD(I)=CEL(I)                                                      FZRF
C  INITIALIZING *OLD*                                                    FZRF
      GO TO 100                                                          FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C  THE NEXT PART IS THE OLD PROCEDURE 'MAZEN'                            FZRF
C  MAZEN FINDS THE  VALUES OF D,E AND F IN A LATTICE, WHEN THE COORDINAT FZRF
C  OF A,B,AND C HAVE BEEN GIVEN.                                         FZRF
   10 I1=IZON(H,1)+IZON(K,1)-3                                           FZRF
      I2=IZON(H,2)+IZON(K,2)-3                                           FZRF
      I3=IZON(H,3)+IZON(K,3)-3                                           FZRF
      X=QVAL(I1,I2,I3)                                                   FZRF
      I1=IZON(H,1)-IZON(K,1)+3                                           FZRF
      I2=IZON(H,2)-IZON(K,2)+3                                           FZRF
      I3=IZON(H,3)-IZON(K,3)+3                                           FZRF
      Y=QVAL(I1,I2,I3)                                                   FZRF
      Z=(X-Y)/2.0                                                        FZRF
      GO TO (601,602,603),ISW                                            FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
C                                                                        FZRF
C----------------------------------------------------------------------- FZRF
C  THE FOLLOWING IS THE PROCEDURE 'CHANGE'                               FZRF
C  IF ANY CONSTANT HAS BEEN  CHANGED,THE PROGRAM REPEATS UNTIL NO        FZRF
C  MORE CHANGES ARE DETECTED.                                            FZRF
   20 U=0.0                                                              FZRF
      DO 30 I=1,6                                                        FZRF
      U=U+ ABS(CEL(I)   -OLD(I))                                         FZRF
      OLD(I)=CEL(I)                                                      FZRF
   30 CONTINUE                                                           FZRF
      CHANGE=.FALSE.                                                     FZRF
      IF (U.GT.0.1 ) CHANGE=.TRUE.                                       FZRF
      GO TO (310,610),ISW                                                FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
  100 IF (TEST) WRITE(IOUT,9930) A,B,C,D,E,F                             FZRF
      QMAX=10000.0                                                       FZRF
C--CHECK ON  CERTAIN RELATIONS BETWEEN A,B,C,D,E,F  WHICH MEAN THAT      FZRF
C--THE LATTICE HAS HIGHER SYMMETRY.                                      FZRF
  200 DO 300 II=1,3                                                      FZRF
      X=A                                                                FZRF
      A=B                                                                FZRF
      B=C                                                                FZRF
      C=X                                                                FZRF
      X=D                                                                FZRF
      D=E                                                                FZRF
      E=F                                                                FZRF
      F=X                                                                FZRF
      IF (B .LT. FMINIM) GO TO 1000                                      FZRF
      IF (D.GT. 0.0)  GO TO 205                                          FZRF
      D=-D                                                               FZRF
      E=-E                                                               FZRF
  205 IF (E.GT. 0.0)  GO TO 210                                          FZRF
      E=-E                                                               FZRF
      F=-F                                                               FZRF
  210 IF (ABS(A-C).LT.EQMIN  .AND.   E.GT. EQMIN) GO TO 220              FZRF
      GO TO 230                                                          FZRF
  220 A=(A+C+E)/4.                                                       FZRF
      C=A-E/2.                                                           FZRF
      F=(D+F)/2.                                                         FZRF
      D=ABS(D-F)                                                         FZRF
      E=0                                                                FZRF
  230 IF (ABS(E-A).GT.EQMIN ) GO TO 240                                  FZRF
      A=A/4.                                                             FZRF
      C=C-A                                                              FZRF
      E=0.0                                                              FZRF
      F=F/2.                                                             FZRF
      D=ABS(D-F)                                                         FZRF
  240 IF (ABS(E-C).GT.EQMIN) GO TO 250                                   FZRF
      C=C/4.0                                                            FZRF
      A=A-C                                                              FZRF
      E=0.0                                                              FZRF
      D=D/2.                                                             FZRF
      F=ABS(D-F)                                                         FZRF
  250 IF (ABS(D) .LE. EQMIN) D=0.0                                       FZRF
      IF (ABS(E) .LE. EQMIN) E=0.0                                       FZRF
      IF (ABS(F) .LE. EQMIN) F=0.0                                       FZRF
  300 CONTINUE                                                           FZRF
      IF (TEST) WRITE(IOUT,9931) A,B,C,D,E,F                             FZRF
      ISW=1                                                              FZRF
      GO TO 20                                                           FZRF
C--TEST ON CHANGES.                                                      FZRF
  310 IF (CHANGE) GO TO 200                                              FZRF
C--CALCULATE  THE Q-VALUES NEAR THE ORIGIN                               FZRF
      DO 400 L1=3,4                                                      FZRF
      L=L1-3                                                             FZRF
      DO 390 K1=2,4                                                      FZRF
      K=K1-3                                                             FZRF
      DO 380 H1=2, 4                                                     FZRF
      H=H1-3                                                             FZRF
      IF (L  .EQ.0 .AND. K .LT.1) GO TO 330                              FZRF
      X=A*FLOAT(H*H)+B*FLOAT(K*K)+C*FLOAT(L*L)+D*FLOAT(K*L)+E*FLOAT(H*L) FZRF
     1  +F*FLOAT(H*K)                                                    FZRF
      IF (X .GT.(-0.1))GO TO 320                                         FZRF
      A=0.0                                                              FZRF
      GO  TO  1000                                                       FZRF
  320 QVAL (H1,K1,L1)=X                                                  FZRF
      GO TO 380                                                          FZRF
  330 QVAL(H1,K1,L1)=QMAX                                                FZRF
  380 CONTINUE                                                           FZRF
  390 CONTINUE                                                           FZRF
  400 CONTINUE                                                           FZRF
      QVAL(4,3,3) =A                                                     FZRF
C--NOW FIND THE SMALLEST Q-VALUES.                                       FZRF
      N1=0                                                               FZRF
  410 N1=N1+1                                                            FZRF
      U=QMAX-10.0                                                        FZRF
      DO 500 L=3,4                                                       FZRF
      DO 490 K=2,4                                                       FZRF
      DO 480 H=2,4                                                       FZRF
      IF (QVAL(H,K,L).GE.U) GO TO 480                                    FZRF
      U=QVAL(H,K,L)                                                      FZRF
      IZON(N1,3)=L                                                       FZRF
      IZON(N1,1)=H                                                       FZRF
      IZON(N1,4)=H                                                       FZRF
      IZON(N1,2)=K                                                       FZRF
      IZON(N1,5)=K                                                       FZRF
  480 CONTINUE                                                           FZRF
  490 CONTINUE                                                           FZRF
  500 CONTINUE                                                           FZRF
      I1=IZON(N1,1)                                                      FZRF
      I2=IZON(N1,2)                                                      FZRF
      I3=IZON(N1,3)                                                      FZRF
      QVAL(I1,I2,I3)=QMAX                                                FZRF
      IF (N1.LT.3) GO TO 410                                             FZRF
C--CHECK WHETHER THEY ARE IN ONE PLANE.                                  FZRF
      II=0                                                               FZRF
      DO  510 I=1,3                                                      FZRF
      K=IZON(1,I+1)-3                                                    FZRF
      L=IZON(2,I+2)-3                                                    FZRF
      M=IZON(2,I+1)-3                                                    FZRF
      N=IZON(1,I+2)-3                                                    FZRF
      J=K*L-M*N                                                          FZRF
      II=II+J*(IZON(3,I)-3)                                              FZRF
  510 CONTINUE                                                           FZRF
      IF (II .NE. 0) GO TO 520                                           FZRF
      N1=2                                                               FZRF
      GO TO  410                                                         FZRF
C--CALCULATE THE RECIPROCAL LATTICE AGAIN., TO DETERMINE D,E, AND F.     FZRF
  520 DO 580 L1=1,5                                                      FZRF
      L=L1-3                                                             FZRF
      DO 570 K1=1,5                                                      FZRF
      K=K1-3                                                             FZRF
      DO 560 H1=1,5                                                      FZRF
      H=H1-3                                                             FZRF
      Q=A*FLOAT(H*H)+B*FLOAT(K*K)+C*FLOAT(L*L)+D*FLOAT(K*L)+E*FLOAT(H*L) FZRF
     1  +F*FLOAT(H*K)                                                    FZRF
      IF (Q .GT.(-0.1)) GO TO 550                                        FZRF
      A=0.0                                                              FZRF
      GO TO 1000                                                         FZRF
C  IF ANY Q-VALUE IS NEGATIVE,THE LATTICE SHOULD BE DISCARDED            FZRF
  550 QVAL(H1,K1,L1)=Q                                                   FZRF
  560 CONTINUE                                                           FZRF
  570 CONTINUE                                                           FZRF
  580 CONTINUE                                                           FZRF
      I11=IZON(1,1)                                                      FZRF
      I12=IZON(1,2)                                                      FZRF
      I13=IZON(1,3)                                                      FZRF
      I21=IZON(2,1)                                                      FZRF
      I22=IZON(2,2)                                                      FZRF
      I23=IZON(2,3)                                                      FZRF
      I31=IZON(3,1)                                                      FZRF
      I32=IZON(3,2)                                                      FZRF
      I33=IZON(3,3)                                                      FZRF
      B=QVAL(I11,I12,I13)                                                FZRF
      A=QVAL(I21,I22,I23)                                                FZRF
      C=QVAL(I31,I32,I33)                                                FZRF
C  I KNOW, IKNOW,    BUT THIS PIDGIN-FORTRAN WORKS ON ALL MACHINES....   FZRF
C--NOW FIND D,E AND F.                                                   FZRF
      ISW=1                                                              FZRF
      H=1                                                                FZRF
      K=3                                                                FZRF
      GO TO  10                                                          FZRF
  601 D=Z                                                                FZRF
      ISW=2                                                              FZRF
      K=2                                                                FZRF
      GO TO 10                                                           FZRF
  602 F=Z                                                                FZRF
      ISW=3                                                              FZRF
      H=3                                                                FZRF
      GO TO 10                                                           FZRF
  603 E=Z                                                                FZRF
      IF (TEST) WRITE(IOUT,9934) (CEL(I),I=1,6)                          FZRF
      ISW=2                                                              FZRF
      GO TO 20                                                           FZRF
C--TEST ON CHANGES.                                                      FZRF
  610 IF (CHANGE) GO TO 200                                              FZRF
C--FROM HERE TO LABEL 670, H COUNTS THE NUMBER OF TERMS AMONG D,E,F      FZRF
C--THAT ARE EQUAL TO ZERO, WHILE K POINTS OUT WHICH ONE IF THERE         FZRF
C--IS ONLY ONE.                                                          FZRF
      H=0                                                                FZRF
      IF (ABS(D).GT.EQMIN) GO TO 620                                     FZRF
      D=0.0                                                              FZRF
      GO TO  621                                                         FZRF
  620 H=H+1                                                              FZRF
      K=1                                                                FZRF
  621 IF (ABS(E).GT.EQMIN) GO TO 630                                     FZRF
      E=0.0                                                              FZRF
      GO TO 631                                                          FZRF
  630 H=H+1                                                              FZRF
      K=2                                                                FZRF
  631 IF (ABS(F).GT.EQMIN) GO TO 640                                     FZRF
      F=0.0                                                              FZRF
      GO TO 641                                                          FZRF
  640 H=H+1                                                              FZRF
      K=3                                                                FZRF
  641 IF (H.NE. 1)  GO  TO  670                                          FZRF
      IF (K.NE. 1)  GO  TO  650                                          FZRF
C--REARRANGE INTO STANDARD MONOCLINIC SETTING.                           FZRF
      U=A                                                                FZRF
      A=B                                                                FZRF
      B=U                                                                FZRF
      E=ABS(D)                                                           FZRF
      D=0.0                                                              FZRF
      F=0.0                                                              FZRF
  650 IF (K .NE.3)  GO TO 660                                            FZRF
C--REARRANGE INTO STANDARD MONOCLINIC SETTING.                           FZRF
      U=A                                                                FZRF
      A=B                                                                FZRF
      B=C                                                                FZRF
      C=U                                                                FZRF
      E=ABS(F)                                                           FZRF
      D=0.0                                                              FZRF
      F=0.0                                                              FZRF
  660 IF (E .LE.A) GO TO 670                                             FZRF
      C=A+C-E                                                            FZRF
      E=A+A-E                                                            FZRF
C--ADJUST THE SIGNS OF TRICLINIC COSINE TERMS SO THAT ONLY QF CAN BE -VE FZRF
  670 IF (D .GT.(-0.1))   GO TO 675                                      FZRF
      D=-D                                                               FZRF
      E=-E                                                               FZRF
  675 IF (E .GT. (-0.1) ) GO TO 680                                      FZRF
      E=-E                                                               FZRF
      F=-F                                                               FZRF
  680 IF (H.EQ.3 .AND. ABS(A+B+F-D-E) .LT. EQMIN ) GO TO 690             FZRF
C--THIS IS A MONOCLINIC LATTICE IN DISGUISE.                             FZRF
      GO TO 700                                                          FZRF
  690 E=(A-B)*0.5                                                        FZRF
      A=(A+B+F)/4.                                                       FZRF
      B=C-A                                                              FZRF
      C=A-F/2.                                                           FZRF
      D=0.0                                                              FZRF
      F=0.0                                                              FZRF
C  THIS WAS THE TRANSFORMATION OF CERTAIN MONOCLINIC CENTERED LATTICES.  FZRF
 700  CONTINUE                                                           FZRF
      IF (TEST) WRITE(IOUT,9935) (CEL(I),I=1,6)                          FZRF
 1000 RETURN                                                             FZRF
 9930 FORMAT(11H LATTICE IS, 6F8.1)                                      FZRF
 9931 FORMAT(11H REDUCED   , 6F8.1)                                      FZRF
 9934 FORMAT(11H REDUCED2  ,6F8.1)                                       FZRF
 9935 FORMAT(11H REDUCED3  , 6F8.1)                                      FZRF
      END                                                                FZRF
      SUBROUTINE READER(NZ1,NZ2,NR,WMOL,DOBS)                            FZRF
C  --------------------------------------------------------------------- FZRF
C----THE FIRST CARD MUST CONTAIN THE NAME OF THE PROBLEM (TITLE).        FZRF
C    THE NEXT CARD IS USUALLY COMPLETELY BLANK. THE PROGRAM              FZRF
C    THEN TAKES THE DEFAULT VALUES.. IF YOU WANT TO SPECIFY YOUR         FZRF
C    OWN PARAMETERS, YOU SHOULD DO THIS AS FOLLOWS0                      FZRF
C  COLUMN  FORMAT  NAME   DEFAULT   MEANING                              FZRF
C    1      A1     MAN      0       PRINTS INSTRUCTIONS,UNLESS MAN=9     FZRF
C    2      A1     INSTR    0       PRINTS INSTRUCTIONS FOR SPECIAL      FZRF
C                                   FEATURES IF INSTR=1                  FZRF
C    3      A1     INTENS   0       READS INTENSITIES BESIDES LINE       FZRF
C                                   POSITIONS IF INTENS=1                FZRF
C   5- 6    I2     NSYST(1) 0       ORTHORHOMBIC SOLUTION. +1=YES, -1=NO FZRF
C   7- 8    I2     NSYST(2) 0       MONOCLINIC SYSTEM.   0 MEANS  INDIFF FZRF
C   9-10    I2     NSYST(3) 0       TRICLINIC SYSTEM                     FZRF
C  11-15   F5.2    TOL2    3.0      TOLERANCE ON 2-DIMENSIONAL SEARCH    FZRF
C  16-20   F5.2    TOL3    4.5      TOLERANCE ON 3-DIMENSIONAL SEARCH    FZRF
C  21-30   F10.5   WAVEL   1.5405   WAVELENGTH                           FZRF
C  31-32    I2     LINCO    0       NUMBER OF GIVEN LINE COMBINATIONS    FZRF
C                                   FOR THE 2-DIMENSIONAL SEARCH         FZRF
C  33-34    I2     K (ENL)  0       ENL0 OUTPUT OF INTERMEDIATE RESULTS( FZRF
C  35-36    I2     NQ1      3       NQ1 AND NQ2 DETERMINE THE NUMBERS OF FZRF
C  37-38    I2     NQ2      6       LINES TO BE USED IN COMBINATIONS     FZRF
C                                   FOR FINDING ZONES .                  FZRF
C  39-40    I2     NZ1      6       NZ1 AND NZ2 DO THE SAME FOR          FZRF
C  41-42    I2     NZ2      6       FINDING LATTICES FROM ZONES.         FZRF
C  43-44    I2     NR       0       REFINEMENT AND EVALUATION RUN ONLY   FZRF
C                                   IF NR>0. THE DECK OF COMPLETE        FZRF
C                                   LATTICES TO BE REFINED (6F10.2)      FZRF
C                                   WILL FOLLOW THE LINES DECK, ALSO     FZRF
C                                   TERMINATED BY A CARD WITH ZERO OR    FZRF
C                                   BLANKS IN COLS 1-10.                 FZRF
C  45-46    I2     INP      5       NUMBER OF THE UNIT ON WHICH TO READ  FZRF
C                                   THE LINE POSITIONS.                  FZRF
C  47-48    I2     LST      0       LIST OF CALCULATED LINES IF LST=1    FZRF
C  49-50    I2     J (TEST) 0       TEST OUTPUT IF J>0                   FZRF
C  51-60   F10.5   WMOL    0.0      MOLECULAR WEIGHT.                    FZRF
C  61-70   F10.5   DOBS    0.0      OBSERVED DENSITY.                    FZRF
C  71-80   F10.5   TOLG    3.0      TOLERANCE ON MATCH BETWEEN CALCULATE FZRF
C                                   AND OBSERVED Q-VALUES.               FZRF
C  --------------------------------------------------------------------- FZRF
C  --------------------------------------------------------------------- FZRF
      DIMENSION QIN(200),IIN(200),INTY(8),ISYST(3,3)                     FZRF
      LOGICAL SELF,ENL,TEST,LIST                                         FZRF
CDC---LEVEL STATEMENTS FOR CDC 7600 FOLLOW---REMOVE FOR OTHER MACHINES-- LEV2
CDC   LEVEL 2, LINCO,NQ2,NSOLMX,ROSTER                                   FZRFL2
C---COMMON BLOCK /TEMRES/, LENGTH 11613 (OCTAL), 5003 (DECIMAL)          FZRFL2
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      COMMON /TEMRES/ LINCO,NQ2,NSOLMX,ROSTER(500,10)                    FZONRFM
      DATA ISYST(1,1)/4HORTH/,ISYST(1,2)/4HORHO/,ISYST(1,3)/4HMBIC/,     FZRF
     1     ISYST(2,1)/4HMONO/,ISYST(2,2)/4HCLIN/,ISYST(2,3)/4HIC  /,     FZRF
     2     ISYST(3,1)/4HTRIC/,ISYST(3,2)/4HLINI/,ISYST(3,3)/4HIC   /     FZRF
      DATA NEND1/4HEND /,NEND2/4H END/                                   FZRF
      DATA NINE/1H9/,IONE/1H1/,IBLA/3H   /                               FZRF
C  --------------------------------------------------------------------- FZRF
C  --------------------------------------------------------------------- FZRF
C  AFTER THE PARAMETER CARD WE MUST ENTER THE LINES,  EITHER AS          FZRF
C  TWOTHETA, D- OR Q- VALUES.                                            FZRF
C  THE PROGRAM WILL FIND OUT WHAT KIND OF VALUES IT HAS.                 FZRF
C  THE NUMBER OF LINES MUST BE AT LEAST 20  AND MUST NOT EXCEED 200.     FZRF
C  A MAXIMUM OF 40 LINES IS ACTUALLY USED, THE REST IS HARMLESS.         FZRF
C  ONLY THE FIRST SIX LINES SHOULD BE IN THEIR CORRECT ORDER, THE REST   FZRF
C  CAN BE ENTERED IN A RANDOM WAY.  EVEN LINES THAT SHOULD BE AMONG      FZRF
C  THE FIRST SIX CAN BE ENTERED LATER.                                   FZRF
C  THE LINES CARDS SHOULD BE TERMINATED BY A BLANK CARD.                 FZRF
C  THE PROGRAM TESTS ON THIS  BLANK CARD AND THEN COUNTS THE NUMBER      FZRF
C  OF REFLECTIONS.                                                       FZRF
C  --------------------------------------------------------------------- FZRF
 9990 CONTINUE                                                           FZRF
C  --------------------------------------------------------------------- FZRF
C--IF YOU SET LINCO  UNEQUAL  ZERO YOU MUST NOW ADD LINCO CARDS.         FZRF
C  THERE ARE SEVERAL POSSIBILITIES0                                      FZRF
C  A. YOU ENTER TWO Q-VALUES (2F10.5) PER CARD.                          FZRF
C    IN THIS CASE THE PROGRAM TREATS THEM AS ONE OF HIS OWN              FZRF
C    LINE COMBINATIONS AND TRIES TO FIND THE ANGLE IN FINZON  ETC.       FZRF
C  B. YOU ENTER THREE CONSTANTS (3F10.5).                                FZRF
C     THE PROGRAM RECOGNIZES THIS AS A COMPLETE ZONE, BUT WILL           FZRF
C     DETERMINE THE QUALITY OF THIS ZONE. THIS MAY LEAD TO AN            FZRF
C     UNEXPECTED DOUBLING OF AXES.                                       FZRF
C     NOTE0 A RECTANGULARZONE MUST BE ENTERED AS  A,B, 0.1  FOR READING  FZRF
C     IN CORRECTLY.  THE PROGRAM WILL VERY SOON  REPLACE 0.1 BY 0.0      FZRF
C  C. YOU ENTER 4 VALUES  (4F10.5).  THE FOURTH VALUE IS THE             FZRF
C     QUALITY OF THE ZONE.  IF YOU SET THIS HIGH ENOUGH, THE ZONE        FZRF
C     WILL CERTAINLY BE USED IN LATTICE-FINDING.                         FZRF
C     ENTERING A SINGLE DIGIT IN COLUMN 31 ASSURES YOU OF A HIGH QUALITY FZRF
C  --------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C                                                                        FZRF
      IOUT=38                                                            FZRF
C---OUTPUT FROM =READER= IS DISCARDED BY DIVERTING IT TO CHANNEL 8       FZRF
      CEL(10)=0.                                                         FZRF
      JOB=JOB+1                                                          FZRF
      CALL ECHO                                                          FZRF
      READ(INP,9901)  NAME                                               FZRF
C     READ(INP,9901,END=9999)  NAME           (IBM ONLY)                 FZRF
C  FOR   IBM MACHINES THE TRICK WITH THE  END  CARD IS NOT NECESSARY.    FZRF
      IF( NAME(1) .EQ.NEND1)GOTO 9999                                    FZRF
      IF( NAME(1) .EQ.NEND2)GOTO 9999                                    FZRF
      RAD=57.29578                                                       FZRF
      DO 6 I=1,8                                                         FZRF
    6 INTY(I)=IBLA                                                       FZRF
      DO 7 I=1,200                                                       FZRF
    7 IIN(I)=IBLA                                                        FZRF
      DO 8 I=1,40                                                        FZRF
    8 INTSY(I)=IBLA                                                      FZRF
      TOLG=3.                                                            FZRF
      ENL=.TRUE.                                                         FZRF
      TEST=.TRUE.                                                        FZRF
      LIST=.FALSE.                                                       FZRF
      SELF=.FALSE.                                                       FZRF
      CALL ECHO                                                          FZRF
      READ(INP,9902) MAN,INSTR,INTENS,NSYST,TOL2,TOL3,WAVEL,LINCO,K,     FZRF
     * NQ1,NQ2,NZ1,NZ2,NR,INP,LST,J,WMOL,DOBS,TOLG                       FZRF
C--PARAMETER CARD                                                        FZRF
      IF(NR.GT.0) GOTO 9                                                 FZRF
      IOUT=6                                                             FZRF
      WRITE(IOUT,9000)                                                   FZRF
 9000 FORMAT(27H0NO SOLUTIONS TO BE REFINED/)                            FZRF
      GOTO 9999                                                          FZRF
    9 CONTINUE                                                           FZRF
      WRITE(IOUT,9920) NAME                                              FZRF
      WRITE(IOUT,9950)                                                   FZRF
      IF (TOL2.LT. 0.1) TOL2=3.0                                         FZRF
      IF (TOL3.LT. 0.1) TOL3=4.5                                         FZRF
      IF (WAVEL.LT.0.1) WAVEL=1.54050                                    FZRF
      IF ( K   .EQ. 0) ENL =.FALSE.                                      FZRF
      IF (NQ1 .EQ. 0) NQ1=3                                              FZRF
      IF (NQ2 .EQ. 0) NQ2=6                                              FZRF
      IF (NZ1 .EQ. 0) NZ1=6                                              FZRF
      IF (NZ2 .EQ. 0) NZ2=6                                              FZRF
      IF (INP .EQ. 0) INP=39                                             FZRF
      IF (LST .EQ. 1) LIST=.TRUE.                                        FZRF
      IF ( J   .EQ. 0) TEST=.FALSE.                                      FZRF
      IF (TEST) SELF=.TRUE.                                              FZRF
      IF (TOLG .LT. 0.1) TOLG=3.0                                        FZRF
      L=0                                                                FZRF
   10 CONTINUE                                                           FZRF
      CALL ECHO                                                          FZRF
      IF (INTENS .EQ. IONE) GO TO 12                                     FZRF
      READ(INP,9903)  (CEL(J),J=1,8)                                     FZRF
      GO TO 14                                                           FZRF
   12 READ(INP,9912)  (  CEL(J),INTY(J)  ,J=1,8)                         FZRF
   14 U=0.0                                                              FZRF
      DO 15 I=1,8                                                        FZRF
   15 U=U+ABS(CEL(I) )                                                   FZRF
C  IT IS POSSIBLE TO GET RID OF A LINE BY SIMPLY PUNCHING A MINUS  SIGN  FZRF
C  IN FRONT OF THE VALUE(PROVIDED THERE WAS ENOUGH SPACE IN THE FORMAT). FZRF
C  THIS TRICK NOW ALSO WORKS WITH ONLY ONE LINE PER CARD.                FZRF
      IF (U .LT. 0.1) GO TO 30                                           FZRF
      DO  20 I=1,8                                                       FZRF
      IF (CEL(I) .LT. 0.1) GOTO 20                                       FZRF
      L=L+1                                                              FZRF
      QIN(L)  =CEL(I)                                                    FZRF
      IIN(L)=INTY(I)                                                     FZRF
   20 CONTINUE                                                           FZRF
      GO TO 10                                                           FZRF
C----------------------------------------------------------------------- FZRF
C--END OF READING LINES CARDS                                            FZRF
C----------------------------------------------------------------------- FZRF
   30 L=L+1                                                              FZRF
      DO 40 I=1,8                                                        FZRF
      MAX=L-I                                                            FZRF
      IF (QIN(MAX) .GT. 0.1) GO TO 90                                    FZRF
   40 CONTINUE                                                           FZRF
      GO TO 90                                                           FZRF
   90 CONTINUE                                                           FZRF
      WRITE(IOUT, 9918)  MAX                                             FZRF
      WRITE(IOUT, 9915) ( QIN(M),IIN(M) ,M=1,MAX)                        FZRF
C----------------------------------------------------------------------- FZRF
C--WE NOW KNOW THE NUMBER OF LINES. NEXT WE TRY TO FIND OUT,             FZRF
C--WHAT KIND OF VALUES WE HAVE  AND PRINT THEM OUT.                      FZRF
C----------------------------------------------------------------------- FZRF
      IF (MAX .GE. 40) MAX=40                                            FZRF
      DO 150 I=1,8                                                       FZRF
  150 CEL(I)=QIN(I)                                                      FZRF
      DO 160 M=1,5                                                       FZRF
      IF(CEL(M+1) .LT. CEL(M)) GO TO 180                                 FZRF
  160 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C--IF INPUT IS IN DESCENDING ORDER, WE HAVE  D-VALUES                    FZRF
C----------------------------------------------------------------------- FZRF
      DO 170 M=1,MAX                                                     FZRF
      OBS(M)=QIN(M)                                                      FZRF
      INTSY(M)=IIN(M)                                                    FZRF
  170 CONTINUE                                                           FZRF
      ISTYG=1                                                            FZRF
      CALL SRTRON(ISTYG)                                                 FZRF
      IF(OBS(MAX) .GE. 180.0) GO TO 290                                  FZRF
C----------------------------------------------------------------------- FZRF
C--IF THE LAST INPUT VALUE IS GREATER THAN 180 WE DO NOT HAVE TWOTHETAS. FZRF
C----------------------------------------------------------------------- FZRF
      A=WAVEL/200.0                                                      FZRF
      B=1.0/(A*A)                                                        FZRF
      C=1.0/(2.0*RAD)                                                    FZRF
      WRITE(IOUT,9906)                                                   FZRF
      WRITE(IOUT,9909)                                                   FZRF
      DO 280 M=1,MAX                                                     FZRF
      W=OBS(M)                                                           FZRF
      D=SIN(C*W)                                                         FZRF
      OBS(M)=B*D*D                                                       FZRF
  280 CONTINUE                                                           FZRF
      WRITE(IOUT,9911)  WAVEL                                            FZRF
      GO TO 300                                                          FZRF
  290 CONTINUE                                                           FZRF
      WRITE(IOUT,9921)  MAX                                              FZRF
      WRITE(IOUT,9906)                                                   FZRF
      WRITE(IOUT,9908)                                                   FZRF
      GO TO 302                                                          FZRF
  180 DO 200 M=1,MAX                                                     FZRF
      OBS(M)=QIN(M)                                                      FZRF
      INTSY(M)=IIN(M)                                                    FZRF
  200 CONTINUE                                                           FZRF
      ISTYG=0                                                            FZRF
      CALL SRTRON(ISTYG)                                                 FZRF
      WRITE(IOUT,9906)                                                   FZRF
      WRITE(IOUT,9907)                                                   FZRF
      DO 210 M=1,MAX                                                     FZRF
      OBS(M)=10000.0/(OBS(M)*OBS(M))                                     FZRF
  210 CONTINUE                                                           FZRF
  300 WRITE(IOUT,9921)  MAX                                              FZRF
      WRITE(IOUT,9910)                                                   FZRF
  302 WRITE(IOUT,9916)  ( OBS(M),INTSY(M) ,M=1,MAX)                      FZRF
      IF (MAX .GE. 20 ) GO  TO 305                                       FZRF
      WRITE(IOUT, 9930) MAX                                              FZRF
      GO TO 9990                                                         FZRF
  305 CONTINUE                                                           FZRF
C----------------------------------------------------------------------- FZRF
C--THE ARRAY OF Q-VALUES HAS NOW BEEN ESTABLISHED.                       FZRF
C----------------------------------------------------------------------- FZRF
      ST=1.0E-3*TOLG                                                     FZRF
      IF (TEST) WRITE(IOUT,9936)                                         FZRF
      DO 306 M=1,MAX                                                     FZRF
      W=OBS(M)                                                           FZRF
      T=TOLG                                                             FZRF
      IF (W .GT. 1000.) T=ST*W                                           FZRF
      OBSMT(M)=W-T                                                       FZRF
      OBSPT(M)=W+T                                                       FZRF
      IF (TEST) WRITE(IOUT,9937) W,OBSMT(M),OBSPT(M)                     FZRF
  306 CONTINUE                                                           FZRF
C--THE RANGE FOR MATCHING Q-VALUES HAS BEEN SET                          FZRF
      IF (NQ1 .LE. NQ2) GO TO 308                                        FZRF
      I=NQ2                                                              FZRF
      NQ2=NQ1                                                            FZRF
      NQ1=I                                                              FZRF
  308 IF (NZ1 .LE. NZ2) GO TO 309                                        FZRF
      I=NZ2                                                              FZRF
      NZ2=NZ1                                                            FZRF
      NZ1=I                                                              FZRF
  309 FMINIM=1.                                                          FZRF-2
C--- FMINIM HAS BEEN CHANGED FROM 0.1*OBS(1) IN ORDER TO INHIBIT         FZRF-2
C--- THE TEST ON MINIMUM QA,QB,QC WHEN INCORPORATED INTO S/R FZONRF      FZRF-2
      FMINEQ=OBS(20)*5.0E-4                                              FZRF
      IF (FMINEQ .LT. 0.8)  FMINEQ=0.8                                   FZRF
      A=4.0 *FMINEQ                                                      FZRF
      C=2.0*FMINEQ                                                       FZRF
      DO 310 M=2,MAX                                                     FZRF
      B=OBS(M)-OBS(M-1)                                                  FZRF
      IF  (B .GT. A) GO TO 310                                           FZRF
      A=B                                                                FZRF
      IF ( B .GE. C) GO TO 310                                           FZRF
      I=M-1                                                              FZRF
      D=RAD*WAVEL*B/( 200.0*SQRT(OBS(M)))                                FZRF
      WRITE(IOUT,9914) I,B,D                                             FZRF
  310 CONTINUE                                                           FZRF
      FMINEQ=0.25*A                                                      FZRF
      IF (TEST) ENL=.TRUE.                                               FZRF
      IF (.NOT. ENL) WRITE(IOUT,9927)                                    FZRF
      IF (ENL .AND. (.NOT. TEST)  ) WRITE(IOUT,9923)                     FZRF
      IF (TEST) WRITE(IOUT, 9924)                                        FZRF
      WRITE (IOUT,9925) FMINIM                                           FZRF
      WRITE(IOUT,9926) FMINEQ                                            FZRF
      WRITE(IOUT,9922) TOL2,TOL3                                         FZRF
      IF (ABS(TOLG-3.0) .GT. 0.01) WRITE(IOUT,9928) TOLG                 FZRF
      IF (NR.EQ.0) GOTO 315                                              FZRF
C----------------------------------------------------------------------- FZRF
C---READ THE COMPLETE LATTICES (REFINEMENT RUN ONLY)                     FZRF
      WRITE(IOUT,9941)                                                   FZRF
      I=0                                                                FZRF
      IOUT=6                                                             FZRF
C---REINSTATE IOUT IN ORDER TO PRINT THE LIST OF SOLUTIONS AS INPUT      FZRF
      WRITE(IOUT,9312)                                                   FZRF
 9312 FORMAT(48H1** LIST OF CELLS TO BE REFINED AND EVALUATED **//)      FZRF
  311 CALL ECHO                                                          FZRF
      READ(INP,9940) (CEL(J),J=1,6)                                      FZRF
      IF (CEL(1).EQ.0.) GOTO 314                                         FZRF
      I=I+1                                                              FZRF
      IF (I.GT.NSOLMX) GOTO 313                                          FZRF
      DO 312 J=1,6                                                       FZRF
  312 ROSTER(I,J)=CEL(J)                                                 FZRF
      ROSTER(I,7)=99                                                     FZRF
      ROSTER(I,8)=I                                                      FZRF
  313 IF (I.EQ.NSOLMX+1) WRITE(IOUT,9943) NSOLMX                         FZRF
      WRITE(IOUT, 9942) I,(CEL(J),J=1,6)                                 FZRF
      GOTO 311                                                           FZRF
  314 NR=I                                                               FZRF
      IF (NR.GT.NSOLMX) NR=NSOLMX                                        FZRF
      WRITE(IOUT,9944) NR                                                FZRF
  315 CONTINUE                                                           FZRF
      IOUT=8                                                             FZRF
C---SUPPRESS OUTPUT AGAIN                                                FZRF
  500 CONTINUE                                                           FZRF
      DO 510 N=1,3                                                       FZRF
  510 IF (NSYST(N) .EQ. 1) WRITE(IOUT,9952) (ISYST(N,I),I=1,3)           FZRF
      WRITE(IOUT,9934) WMOL                                              FZRF
      WRITE(IOUT,9935) DOBS                                              FZRF
      IOUT=6                                                             FZRF
C---HAVE NOW FINISHED DISCARDING OUTPUT                                  FZRF
      RETURN                                                             FZRF
 9999 WRITE(IOUT,9998)                                                   FZRF
      NR=-1                                                              FZRF
      RETURN                                                             FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C  THE FOLLOWING CARDS ARE USEFUL FOR TEST PURPOSES0                     FZRF
C     WRITE(IOUT,9945) TOL2,TOL3,TOLG,WAVEL,LINCO,SELF,ENL,TEST,         FZRF
C    * NQ1,NQ2,NZ1,NZ2 ,NR,INP,WMOL,DOBS                                 FZRF
C9945 FORMAT(53H   TOL2  TOL3  TOLG  WAVEL   LINCO   SELF   ENL  TEST,   FZRF
C    *33H NQ1 NQ2 NZ1 NZ2 NR INP WMOL DOBS/                              FZRF
C    *  3F6.1, F8.5, I8, 3L6,    6I4 ,2F8.5)                             FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
C----------------------------------------------------------------------- FZRF
 9901 FORMAT(20A4)                                                       FZRF
 9902 FORMAT(3A1,1X,3I2,2F5.2,F10.5,4I2,2I1,I4,3I2,3F10.5)               FZRF
 9903 FORMAT( 8F10.5 )                                                   FZRF
 9906 FORMAT(23H0THE INPUT CONSISTED OF   )                              FZRF
 9907 FORMAT(1H+, 23X,10H D-VALUES.)                                     FZRF
 9908 FORMAT(1H+, 23X,10H Q-VALUES.)                                     FZRF
 9909 FORMAT(1H+, 23X,12H TWO THETAS. )                                  FZRF
 9910 FORMAT(45H0THE INPUT LEADS TO THE FOLLOWING Q-VALUES   )           FZRF
 9911 FORMAT(20H0THE WAVELENGTH IS  , F8.4)                              FZRF
 9912 FORMAT( 8(F7.3,A3) )                                               FZRF
 9914 FORMAT(40H0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      /          FZRF
     * 41H THE DIFFERENCE IN Q-VALUES BETWEEN LINE ,  I3,                FZRF
     * 22H AND THE NEXT IS ONLY  , F6.2 /                                FZRF
     * 14H THIS IS ONLY  ,F5.2,  18H DEGREES TWO THETA     /             FZRF
     * 40H            PLEASE  CHECK  YOUR  INPUT     /                   FZRF
     * 56H THE PROGRAM WILL CONTINUE, BUT MAY NOT GIVE THE CORRECT,      FZRF
     * 59H ANSWERS SINCE THE LIMIT FOR  'EQUAL' VALUES CAN BE TOO LOW /  FZRF
     * 40H XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      )                FZRF
 9915 FORMAT( 10(1X,F8.3,1X,A3)  )                                       FZRF
 9916 FORMAT( 10(1X,F7.1,2X,A3)  )                                       FZRF
 9917 FORMAT(15H INPUT ZONE NR., I3, 4F8.1)                              FZRF
 9918 FORMAT(37H0THE INPUT CONSISTED OF THE FOLLOWING,I4,7H LINES   )    FZRF
 9919 FORMAT(3F10.2, F10.1)                                              FZRF
 9920 FORMAT(50H1THIS PROGRAM TRIES TO FIND THE UNITCELL FROM THE ,      FZRF
     *18H POWDER PATTERN OF ///20X,20A4///26H WITH A METHOD PROPOSED BY, FZRF
     *61H  DE WOLFF AND PROGRAMMED BY VISSER (J.APPL.CRYST.2,89(1969))/  FZRF
     *40H            FORTRAN  VERSION    6         )                     FZRF
 9921 FORMAT(41H0THE NUMBER OF LINES THAT WILL BE USED IS ,I4)           FZRF
 9922 FORMAT(43H0(COL 11-15)THE TOLERANCE ON THE TRIAL F IS, F4.1//      FZRF
     *44H (COL 16-20) THE TOLERANCE ON THE TRIAL D IS , F4.1)            FZRF
 9923 FORMAT(38H0INTERMEDIATE RESULTS ARE PRINTED OUT./                  FZRF
     * 58H PUNCH A 1 IN COLUMN 50 OF THE PARAMETER CARD IF YOU WANT  ,   FZRF
     * 18H THE TEST OUTPUT.   )                                          FZRF
 9924 FORMAT(39H0TESTRUN, ALL TEST RESULTS ARE PRINTED.)                 FZRF
 9925 FORMAT(44H0THE LOWER LIMIT FOR THE VALUES OF A,B,C IS ,  F8.2)     FZRF
 9926 FORMAT(66H0VALUES WILL BE CONSIDERED TO BE EQUAL WHEN THEY DIFFER  FZRF
     * LESS THAN , F4.1 )                                                FZRF
 9927 FORMAT(55H0ONLY A MINIMUM OF INTERMEDIATE RESULTS WILL BE PRINTED/ FZRF
     * 59H PUNCH A 1 IN COLUMN 34 OF THE PARAMETER CARD IF YOU WANT  ,   FZRF
     * 14H MORE OUTPUT.  )                                               FZRF
 9928 FORMAT(48H ***********************************************/        FZRF
     1       40H * THE OVERALL TOLERANCE IS CHANGED INTO,F6.2,2H */      FZRF
     2       48H *********************************************** )       FZRF
 9930 FORMAT(32H0THE NUMBER OF USEFUL LINES  IS ,I4 /                    FZRF
     *60H SINCE THIS IS LESS THAN THE MINIMUM NUMBER OF LINES THAT TH ,  FZRF
     *60HE PROGRAM NEEDS (20),YOU CANNOT EXPECT RELIABLE  RESULTS.   //  FZRF
     *24H THIS PROBLEM IS SKIPPED  )                                     FZRF
 9931 FORMAT(21H0THE PROGRAM WILL USE ,I3,24H GIVEN LINE COMBINATIONS)   FZRF
 9932 FORMAT(35H0THE PROGRAM WILL COMBINE THE FIRST ,I3,                 FZRF
     * 21H LINES WITH THE FIRST  ,I3)                                    FZRF
 9933 FORMAT(42H0THE PROGRAM WILL TRY TO COMBINE THE FIRST  ,I3,         FZRF
     * 21H ZONES WITH THE FIRST ,I3)                                     FZRF
 9934 FORMAT(30H0THE GIVEN MOLECULAR WEIGHT IS,  F10.3)                  FZRF
 9935 FORMAT(30H0THE GIVEN OBSERVED DENSITY IS,  F10.4)                  FZRF
 9936 FORMAT(63H0THE Q-VALUES WITH THEIR LIMITS OF ERROR,Q +/- TOLERANCE FZRF
     1 (TOLG)/ 32H       Q        Q-TOL     Q+TOL    )                   FZRF
 9937 FORMAT(1H ,3F10.1)                                                 FZRF
 9940 FORMAT( 8F10.2 )                                                   FZRF
 9941 FORMAT(57H0INPUT OF COMPLETE LATTICES FOLLOWS (REFINEMENT RUN ONLY FZRF
     1)/)                                                                FZRF
 9942 FORMAT(18H INPUT LATTICE NR., I3, 8F10.2 )                         FZRF
 9943 FORMAT(1H0,40H** EXCEEDS STORAGE ALLOCATED, ONLY FIRST,I4,         FZRF
     1 21H WILL BE PROCESSED **/)                                        FZRF
 9944 FORMAT(30H0LATTICE INPUT FINISHED: FIRST,I4,18H WILL BE PROCESSED) FZRF
 9950 FORMAT(65H0******************************************************* FZRF
     1*********/  2H *,62X,1H*/ 65H *   ARE YOUR INPUT DATA REALLY THE B FZRF
     2EST THAT CAN BE OBTAINED   */2H *,62X,1H*/   65H ***************** FZRF
     3***********************************************    ///             FZRF
     480H FINDING THE UNIT CELL  DEPENDS FOR 95 PERCENT ON THE QUALITY O FZRF
     5F THE INPUT DATA./118H A RANDOM ERROR OF 0.03 DEGREES TWOTHETA CAN FZRF
     6 USUALLY BE TOLERATED, BUT A SYSTEMATIC (ZERO POINT) ERROR OF 0.02 FZRF
     7 DEGREES/77H IS PROBABLY DISASTROUS.  CHECK YOUR INPUT LINES AGAIN FZRF
     8ST THEIR HIGHER ORDERS.//  83H DO NOT USE A DEBIJE-SCHERRER CAMERA FZRF
     9  UNLESS THE UNIT CELL TO BE EXPECTED IS SMALL./76H WOULD YOU LIKE FZRF
     O TO SOLVE A JIGSAW PUZZLE WHEN HALF THE PIECES ARE MISSING---)     FZRF
 9952 FORMAT(15H0LATTICES WITH , 3A4, 35H SYMMETRY WILL GET AN EXTRA CHA FZRF
     *NCE  )                                                             FZRF
 9998 FORMAT(16H END OF PROGRAM   )                                      FZRF
      END                                                                FZRF
      SUBROUTINE REFPAR(NSOL)                                            FZRF
C----------------------------------------------------------------------- FZRF
C--REFPAR REFINES  THE PARAMETERS, PRINTS OUT THE LATTICE IF ENL=.TRUE.  FZRF
C--AND PRINTS OUT A LIST OF   TWOTHETA,D,Q,H,K,L.                        FZRF
C----------------------------------------------------------------------- FZRF
      DIMENSION HULP(6),VAR(6),FYN(6),WE(10),WAR(6),QQSTOR(100),         FZRF
     1 MATR1(6),MATR2(6),REF(6,6)                                        FZRF
      DIMENSION KSTOR(20,5),LSTOR(20,5),QSTOR(20,5),INSTOR(100,3)        FZRF
      INTEGER HSTOR(20,5)                                                FZRF
      INTEGER TELOB(25),BR(21,5),P,  H,H1,HS,HMIN,HMAX,HMAX1,            FZRF
     1 COUNT,ORDE                                                        FZRF
      LOGICAL SELF,ENL,TEST,LIST                                         FZRF
      LOGICAL HEVEN,KEVEN,LEVEN,REPEAT,MIS,DRUK,PRIN,NOPRIN,LIST2        FZRF
      LOGICAL FIRST4,IGOOD,MGOOD,ROUND2                                  FZRF
      REAL M20MIN                                                        FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      COMMON /LINSTR/ INSTOR,QQSTOR                                      FZRF
      COMMON /REFP/ IREF                                                 FZRF
      EQUIVALENCE (INSTOR(1,1),HSTOR(1,1)),(INSTOR(1,2),KSTOR(1,1)),     FZRF
     1  (INSTOR(1,3),LSTOR(1,1)),(QQSTOR(1),QSTOR(1,1) )                 FZRF
C----------------------------------------------------------------------- FZRF
      SWAVEL=WAVEL/200.0                                                 FZRF
      QMAX=OBS(20)*(1.0+0.002*TOL3)                                      FZRF
      LIST2=.FALSE.                                                      FZRF
      ROUND2=IREF.EQ.0                                                   FZRF
      FIRST4=NSOL.LE.4                                                   FZRF
      I20MIN=15                                                          FZRF
      M20MIN=7.0                                                         FZRF
      IGOOD=CEL(7).GE.I20MIN                                             FZRF
      MGOOD=CEL(8).GE.M20MIN                                             FZRF
      IBRAV=6                                                            FZRF
      DRUK=.FALSE.                                                       FZRF
      DRUK= ROUND2 .AND. (FIRST4 .OR. MGOOD)                             FZRF
      IF (CEL(7) .LT. 2.0) GO TO 90                                      FZRF
C--THE FIRST TIME THAT REFPAR IS CALLED, CEL(7)=0.                       FZRF
      IBRAV= CEL(9)                                                      FZRF
   90 CONTINUE                                                           FZRF
      REPEAT=.TRUE.                                                      FZRF
      IVORDE=7                                                           FZRF
      PRIN= DRUK .AND. ENL .AND. MGOOD                                   FZRF
      NOPRIN=.NOT. PRIN                                                  FZRF
      GO TO 100                                                          FZRF
   95 IF ( (.NOT. DRUK) .AND. REPEAT)  CALL NORM3                        FZRF
  100 NIET=0                                                             FZRF
      ISPAT=1                                                            FZRF
      ORDE=3                                                             FZRF
      DO 110 J=4,6                                                       FZRF
      IF (ABS(CEL(J)) .GT. 0.5) GO TO 105                                FZRF
      CEL(J)=0.                                                          FZRF
      GO TO 110                                                          FZRF
  105 ORDE=ORDE+1                                                        FZRF
  110 CONTINUE                                                           FZRF
      IF (IVORDE .EQ. ORDE) REPEAT=.NOT. REPEAT                          FZRF
      IVORDE=ORDE                                                        FZRF
      IF (ORDE .NE. 5) GO TO 200                                         FZRF
      IF (ABS(CEL(6)) .LT. 0.1) GO TO 180                                FZRF
      IF (ABS(CEL(4)) .LT. 0.1) GO TO 160                                FZRF
      CALL WISSEL(2,3)                                                   FZRF
      GO  TO 180                                                         FZRF
  160 CALL WISSEL(1,3)                                                   FZRF
  180 IF (ABS(CEL(5)).LT. ABS(CEL(4))) CALL WISSEL(1,2)                  FZRF
  200 CONTINUE                                                           FZRF
      DO 211 I=1,21                                                      FZRF
      DO 210 J=1,5                                                       FZRF
  210 BR(I,J)=0                                                          FZRF
      TELOB(I)=0                                                         FZRF
  211 CONTINUE                                                           FZRF
  220 IF (DRUK) WRITE(IOUT,9916)  NAME,NSOL                              FZRF
      IF (PRIN) WRITE(IOUT,9926) (CEL(J),J=1,10)                         FZRF
      IF (TEST .AND. NOPRIN) WRITE(IOUT,9926) (CEL(J),J=1,10)            FZRF
C                                                                        FZRF
C                 START GENERATING  Q-VALUES                             FZRF
C                                                                        FZRF
      NN=0                                                               FZRF
      ASQ=CEL(1)                                                         FZRF
      BSQ=CEL(2)                                                         FZRF
      CSQ=CEL(3)                                                         FZRF
      ALFA=CEL(4)                                                        FZRF
      BETA=CEL(5)                                                        FZRF
      GAMMA=CEL(6)                                                       FZRF
      HMAX=INT(SQRT(QMAX/ASQ))+1                                         FZRF
      KMAX=INT(SQRT(QMAX/BSQ))+1                                         FZRF
      LMAX=INT(SQRT(QMAX/CSQ))+1                                         FZRF
      N20=0                                                              FZRF
      KEVEN=.FALSE.                                                      FZRF
      LMIN=-LMAX                                                         FZRF
      IF(ORDE .EQ. 3) LMIN=0                                             FZRF
      HMIN=0                                                             FZRF
      IF(ORDE .GE. 5) HMIN=-HMAX                                         FZRF
      IF (PRIN) WRITE(IOUT,9917)                                         FZRF
      KMAX1=KMAX+1                                                       FZRF
C  K-LOOP STARTS HERE                                                    FZRF
      DO 1050 K1=1,KMAX1                                                 FZRF
      K=K1-1                                                             FZRF
      RK=K                                                               FZRF
      IF(NOPRIN) GO TO 520                                               FZRF
      WRITE(IOUT,9918)  K                                                FZRF
      ISPAT=1                                                            FZRF
  520 C1=RK*RK*BSQ                                                       FZRF
      C2=RK*ALFA                                                         FZRF
      C3=RK*GAMMA                                                        FZRF
      KEVEN=.NOT. KEVEN                                                  FZRF
      HS=HMIN                                                            FZRF
      IF(K .EQ.  0) HS=0                                                 FZRF
      HEVEN=.TRUE.                                                       FZRF
      IF(2*(HS/2) .EQ. HS) HEVEN=.FALSE.                                 FZRF
      HMAX1=HMAX-HS+1                                                    FZRF
C  H-LOOP STARTS HERE                                                    FZRF
      DO 1040 H1=1,HMAX1                                                 FZRF
      H=H1+HS-1                                                          FZRF
      RH=H                                                               FZRF
      C4=C1+RH*(C3+RH*ASQ)                                               FZRF
      C5=C2+RH*BETA                                                      FZRF
      IF(NOPRIN) GO TO 530                                               FZRF
      WRITE(IOUT,9923)                                                   FZRF
      ISPAT=1                                                            FZRF
      IF((K+IABS(H)) .EQ. 0 .AND. ORDE .GT. 4) ISPAT=ISPAT+LMAX          FZRF
      IF(ORDE .EQ. 4 . AND. H .EQ. 0) ISPAT=ISPAT+LMAX                   FZRF
  530 HEVEN=.NOT. HEVEN                                                  FZRF
      LB=LMIN                                                            FZRF
      IF(H .NE. 0) GO TO 540                                             FZRF
      IF(K .EQ. 0.OR. ORDE .EQ. 4) LB=0                                  FZRF
  540 LEVEN=.TRUE.                                                       FZRF
      IF(2*(LB/2) .EQ. LB) LEVEN=.FALSE.                                 FZRF
      LMAX1=LMAX+1-LB                                                    FZRF
C  L-LOOP STARTS HERE                                                    FZRF
      DO 1030 L1=1,LMAX1                                                 FZRF
      L=L1-1+LB                                                          FZRF
      LEVEN=.NOT. LEVEN                                                  FZRF
      Q=C4+FLOAT(L)*(C5+FLOAT(L)*CSQ)                                    FZRF
      IF (Q .GT. 1.0) GO TO 630                                          FZRF
      IF (PRIN) CALL WRISP(ISPAT,0. ,0)                                  FZRF
      GO TO 1020                                                         FZRF
  630 IF(Q .GE. QMAX) GO TO 1020                                         FZRF
      IF (.NOT. DRUK)      GO TO 700                                     FZRF
      GO TO (640,650,660,670,680,700,950),IBRAV                          FZRF
  640 IF(KEVEN.AND.LEVEN.OR..NOT.KEVEN.AND..NOT.LEVEN) GO TO 700         FZRF
      GO TO 1020                                                         FZRF
  650 IF(HEVEN.AND.LEVEN.OR..NOT.HEVEN.AND..NOT.LEVEN) GO TO 700         FZRF
      GO TO 1020                                                         FZRF
  660 IF(HEVEN.AND.KEVEN.OR..NOT.HEVEN.AND..NOT.KEVEN) GO TO 700         FZRF
      GO TO 1020                                                         FZRF
  670 IF (2*((H+K+L)/2) .EQ. H+K+L) GO TO 700                            FZRF
C--I-LATTICE                                                             FZRF
      GO TO 1020                                                         FZRF
  680 IF(HEVEN.AND.KEVEN.OR..NOT.HEVEN.AND..NOT.KEVEN) GO TO 690         FZRF
      GO TO 1020                                                         FZRF
  690 IF(KEVEN.AND.LEVEN.OR..NOT.KEVEN.AND..NOT.LEVEN) GO TO 700         FZRF
      GO TO 1020                                                         FZRF
  700 N20=N20+1                                                          FZRF
      IF (.NOT. LIST2) GO TO 720                                         FZRF
      NN=NN+1                                                            FZRF
      INSTOR(NN,1)=H                                                     FZRF
      INSTOR(NN,2)=K                                                     FZRF
      INSTOR(NN,3)=L                                                     FZRF
      QQSTOR(NN)=Q                                                       FZRF
      GO TO 1030                                                         FZRF
  720 CONTINUE                                                           FZRF
      IF (PRIN) CALL WRISP(ISPAT,Q,0)                                    FZRF
      MIS=.TRUE.                                                         FZRF
      DO 800 J=1,20                                                      FZRF
      IF (OBSPT(J) .LT. Q ) GO TO 800                                    FZRF
      IF (OBSMT(J) .GT. Q ) GO TO 950                                    FZRF
      P=J                                                                FZRF
      IF (NOPRIN) GO TO 750                                              FZRF
      CALL WRISP(ISPAT,Q,1)                                              FZRF
      MIS=.FALSE.                                                        FZRF
      GO TO 780                                                          FZRF
  750 CONTINUE                                                           FZRF
      IF(KEVEN.AND.LEVEN.OR..NOT.KEVEN.AND..NOT.LEVEN)                   FZRF
     * BR(P,1)=BR(P,1)+1                                                 FZRF
      IF(HEVEN.AND.LEVEN.OR..NOT.HEVEN.AND..NOT.LEVEN)                   FZRF
     * BR(P,2)=BR(P,2)+1                                                 FZRF
      IF(HEVEN.AND.KEVEN.OR..NOT.HEVEN.AND..NOT.KEVEN)                   FZRF
     * BR(P,3)=BR(P,3)+1                                                 FZRF
      IF (2*((H+K+L)/2) .EQ. H+K+L) BR(P,4)=BR(P,4)+1                    FZRF
      IF ((HEVEN.AND.KEVEN.OR..NOT.HEVEN.AND..NOT.KEVEN)  .AND.          FZRF
     * (KEVEN.AND.LEVEN.OR..NOT.KEVEN.AND..NOT.LEVEN))BR(P,5)=BR(P,5)+1  FZRF
  780 I=TELOB(P)+1                                                       FZRF
      IF (I .GT.  5) GO TO 800                                           FZRF
      TELOB(P)=I                                                         FZRF
      HSTOR(P,I)=H                                                       FZRF
      KSTOR(P,I)=K                                                       FZRF
      LSTOR(P,I)=L                                                       FZRF
      QSTOR(P,I)=Q                                                       FZRF
  800 CONTINUE                                                           FZRF
  950 CONTINUE                                                           FZRF
 1020 IF (PRIN) ISPAT=ISPAT+1                                            FZRF
C  END OF K,H,L-LOOP ON 1050,1040,1030 RESPECTIVELY                      FZRF
 1030 CONTINUE                                                           FZRF
      IF (PRIN) CALL WRISP(ISPAT,Q,2)                                    FZRF
 1040 CONTINUE                                                           FZRF
 1050 CONTINUE                                                           FZRF
C                                                                        FZRF
C             END GENERATING Q                                           FZRF
C                                                                        FZRF
      IF (.NOT. LIST2) GO TO 1100                                        FZRF
      CALL LISTM(NN)                                                     FZRF
       WRITE(IOUT,9941)  (CEL(J),J=1,6),N20,NAME,NSOL                    FZRF
      GO TO  1360                                                        FZRF
 1100 DO 1110 H=1,6                                                      FZRF
      DO 1105 K=1,6                                                      FZRF
 1105 REF(H,K)=0.0                                                       FZRF
 1110 CONTINUE                                                           FZRF
      DO 1120 H=1,6                                                      FZRF
      FYN(H)=0.0                                                         FZRF
      WAR(H)=0.0                                                         FZRF
 1120 CONTINUE                                                           FZRF
      T=0.0                                                              FZRF
      RMS=0.0                                                            FZRF
      SUMEPS=1.E-3                                                       FZRF
C  WHEN THE NUMBER OF LINES INDEXED  EQUALS THE NUMBER OF PARAMETERS,    FZRF
C  SUMEPS WILL KEEP ITS STARTING VALUE.  THE VALUE ZERO CAUSES ACCIDENTS FZRF
      COUNT=0                                                            FZRF
      IF (DRUK)  WRITE(IOUT,9910)                                        FZRF
      DO 1180 P=1,20                                                     FZRF
      NR=TELOB(P)                                                        FZRF
      QOBS=OBS(P)                                                        FZRF
      IF (.NOT. DRUK) GO TO 1122                                         FZRF
      W=SQRT(QOBS)                                                       FZRF
      U=SWAVEL*W                                                         FZRF
      W=100.0/W                                                          FZRF
      U=114.59156*ATAN(U/SQRT(1.0-U*U))                                  FZRF
      WRITE(IOUT,9911) U,W,QOBS,INTSY(P)                                 FZRF
 1122 CONTINUE                                                           FZRF
      IF (NR .GT. 0) GO TO 1124                                          FZRF
      IF (DRUK) WRITE(IOUT,9912)                                         FZRF
      NIET=NIET+1                                                        FZRF
      GO TO 1180                                                         FZRF
 1124 CONTINUE                                                           FZRF
      EPS=1000.0                                                         FZRF
      SUMW=0.0                                                           FZRF
      DO 1130 N=1,NR                                                     FZRF
      D=ABS(QOBS-QSTOR(P,N))                                             FZRF
      IF(D .LT. EPS)EPS=D                                                FZRF
      IF (D .GT. 9.0) D=9.0                                              FZRF
C--NECESSARY TO PREVENT UNDERFLOW ON  PDP-10 (AND UNIVAC?)               FZRF
      W=EXP(-D*D)                                                        FZRF
      WE(N)=W                                                            FZRF
      SUMW=SUMW+W                                                        FZRF
 1130 CONTINUE                                                           FZRF
      SUMEPS=SUMEPS+EPS                                                  FZRF
      DO 1170 N=1,NR                                                     FZRF
      H=HSTOR(P,N)                                                       FZRF
      K=KSTOR(P,N)                                                       FZRF
      L=LSTOR(P,N)                                                       FZRF
      Q=QSTOR(P,N)                                                       FZRF
      IF (.NOT. DRUK) GO TO 1042                                         FZRF
      W=SQRT(Q)                                                          FZRF
      U=SWAVEL*W                                                         FZRF
      W=100.0/W                                                          FZRF
      U=114.59156*ATAN(U/SQRT(1.0-U*U))                                  FZRF
      WRITE(IOUT,9914) U,W,Q,H,K,L                                       FZRF
 1042 CONTINUE                                                           FZRF
      DIF=QOBS-Q                                                         FZRF
      COUNT=COUNT+1                                                      FZRF
      W=WE(N)/SUMW                                                       FZRF
      RMS=RMS+W*DIF*DIF                                                  FZRF
      T=T+W                                                              FZRF
      VAR(1)=H*H                                                         FZRF
      VAR(2)=K*K                                                         FZRF
      VAR(3)=L*L                                                         FZRF
      VAR(4)=H*L                                                         FZRF
      VAR(5)=K*L                                                         FZRF
      VAR(6)=H*K                                                         FZRF
      DO 1150 J=1,ORDE                                                   FZRF
      HULP(J)=W*VAR(J)                                                   FZRF
      WAR(J)=WAR(J)+W*DIF*VAR(J)                                         FZRF
 1150 CONTINUE                                                           FZRF
      DO 1160 J=1,ORDE                                                   FZRF
      DO 1155 I=1,ORDE                                                   FZRF
 1155 REF(I,J)=REF(I,J)+VAR(I)*HULP(J)                                   FZRF
 1160 CONTINUE                                                           FZRF
 1170 CONTINUE                                                           FZRF
 1180 CONTINUE                                                           FZRF
      CALL ARRAY(2,ORDE,ORDE,6,6,REF,REF)                                FZRF
      CALL MINV(REF,ORDE,DETER,MATR1,MATR2)                              FZRF
      CALL ARRAY(1,ORDE,ORDE,6,6,REF,REF)                                FZRF
      IF (ABS(DETER) .GE. 0.001) GO TO 1185                              FZRF
      IF (TEST) WRITE(IOUT,9931)                                         FZRF
      GO TO 1210                                                         FZRF
 1185 IF(T .GT. FLOAT(ORDE+1)) RMS=RMS/(T-FLOAT(ORDE))                   FZRF
      DO 1195 I=1,ORDE                                                   FZRF
      DO 1190 J=1,ORDE                                                   FZRF
 1190 FYN(I)=FYN(I)+REF(I,J)*WAR(J)                                      FZRF
 1195 CONTINUE                                                           FZRF
      DO 1200 N=1,3                                                      FZRF
 1200 CEL(N)=CEL(N)+FYN(N)                                               FZRF
      IF (ORDE .GT. 3) CEL(5)=CEL(5)+FYN(4)                              FZRF
      IF (ORDE .GT. 4) CEL(4)=CEL(4)+FYN(5)                              FZRF
      IF (ORDE .GT. 5) CEL(6)=CEL(6)+FYN(6)                              FZRF
 1210 NIET=20-NIET                                                       FZRF
      IF (DRUK) GO TO 1350                                               FZRF
      IF (REPEAT) GO TO 95                                               FZRF
      DO 1320 J=1,5                                                      FZRF
      N=0                                                                FZRF
      DO 1310 M=1,20                                                     FZRF
 1310 IF (BR(M,J) .GT. 0 ) N=N+1                                         FZRF
      BR(21,J)=N                                                         FZRF
 1320 CONTINUE                                                           FZRF
      IBRAV=6                                                            FZRF
      DO 1330 J=1,5                                                      FZRF
      IF ( BR(21,J) .GE. NIET) IBRAV=J                                   FZRF
 1330 CONTINUE                                                           FZRF
 1350 CEL(7)=NIET                                                        FZRF
      CEL(9)=IBRAV                                                       FZRF
      CEL(8)=FLOAT(NIET)*OBS(20)/(FLOAT(2*N20)*SUMEPS)                   FZRF
      IF (PRIN) WRITE(IOUT,9940) (CEL(J),J=7,10)                         FZRF
      IF (DRUK) WRITE(IOUT,9941)  (CEL(J),J=1,6),N20,NAME,NSOL           FZRF
      LIST2=LIST .AND. DRUK                                              FZRF
      LIST2=LIST2.AND.FIRST4.AND.MGOOD                                   FZRF
      PRIN=.FALSE.                                                       FZRF
      NOPRIN=.TRUE.                                                      FZRF
      IF (LIST2 .AND. (N20 .LE. 100) ) GO TO 220                         FZRF
      IF (LIST2) WRITE(IOUT,9942) N20                                    FZRF
 1360 RETURN                                                             FZRF
 9910 FORMAT(41H0TWOTHETA     D       Q       H    K    L)               FZRF
 9911 FORMAT(1H0, F8.2, F8.3, F9.1, 18H    *OBSERVED**    ,A3)           FZRF
 9912 FORMAT(1H+,45X ,  12H NOT INDEXED)                                 FZRF
 9914 FORMAT(1H ,F8.2,F8.3,F9.1, 3I5)                                    FZRF
 9916 FORMAT(1H1,20A4,14H   SOLUTION NR,I3)                              FZRF
 9917 FORMAT(36H0LATTICE PRINTED OUT FOR INSPECTION //                   FZRF
     156H DISPLAYED IN LAYERS UP --K-- ,    --L-- ACROSS THE PAGE,       FZRF
     222H --H-- DOWN THE PAGE.   //)                                     FZRF
 9918 FORMAT( 8H ***  H ,I2,8H  L  ***   // )                            FZRF
 9923 FORMAT(1H0)                                                        FZRF
 9926 FORMAT(1H ,6F9.2, F9.0,F9.1, 2F9.0 )                               FZRF
 9931 FORMAT(1H ,14X,19HMATRIX IS SINGULAR )                             FZRF
 9940 FORMAT(1H0//14H LINES INDEXED,F5.0,16H FIGURE OF MERIT, F8.1,      FZRF
     *13H LATTICE TYPE, F6.0, 9H PEDIGREE,F8.0)                          FZRF
 9941 FORMAT(1H0//46H RECIPROCAL LATTICE CONSTANTS AFTER REFINEMENT/     FZRF
     * 6F9.2, 5H N20=,I4 ///1H ,20A4,14H   SOLUTION NR, I3)              FZRF
 9942 FORMAT(35H0THE NUMBER OF CALCULATED LINES IS  ,I4,                 FZRF
     *50H. NO LISTING IS PRINTED WHEN N20 IS MORE THAN 100   /           FZRF
     * 30H SEE END OF SUBROUTINE REFPAR  )                               FZRF
      END                                                                FZRF
      SUBROUTINE SRTRON(ISTYG)                                           FZRF
C                                                                        FZRF
C                                                                        FZRF
C     THIS SUBPROGRAM SORTS THE TWOTHETA-,D- OR Q-VALUES (POSSIBLY       FZRF
C     TOGETHER WITH INTENSITIES).THE TWOTHETA- OR Q-VALUES ARE PUT IN    FZRF
C     INCREASING ORDER,THE D-VALUES IN DECREASING ORDER.                 FZRF
C                                                                        FZRF
C     ISTYG=1 - DATA ARE TWOTHETA- OR Q-VALUES (TO PUT IN INCREASING     FZRF
C               ORDER).                                                  FZRF
C     ISTYG=0 - DATA ARE D-VALUES (TO PUT IN DECREASING ORDER).          FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
C                                                                        FZRF
      FAKTOR=1.0                                                         FZRF
      IF(ISTYG.EQ.0)FAKTOR=-1.0                                          FZRF
   20 IEIND=MAX-1                                                        FZRF
C                                                                        FZRF
      DO 70 I=1,IEIND                                                    FZRF
      IF(FAKTOR*(OBS(I+1)-OBS(I)))30,70,70                               FZRF
   30 OBSTR=OBS(I+1)                                                     FZRF
      IINT=INTSY(I+1)                                                    FZRF
      DO 40 J=1,I                                                        FZRF
C                                                                        FZRF
      IF(FAKTOR*(OBSTR-OBS(J)))50,40,40                                  FZRF
   40 CONTINUE                                                           FZRF
C                                                                        FZRF
   50 MEIND=I+1-J                                                        FZRF
C                                                                        FZRF
      DO 60 M=1,MEIND                                                    FZRF
      K=I+1-M                                                            FZRF
      OBS(K+1)=OBS(K)                                                    FZRF
      INTSY(K+1)=INTSY(K)                                                FZRF
   60 CONTINUE                                                           FZRF
      OBS(J)=OBSTR                                                       FZRF
      INTSY(J)=IINT                                                      FZRF
   70 CONTINUE                                                           FZRF
      DO 80 I=1,IEIND                                                    FZRF
      IF (ABS(OBS(I+1)-OBS(I) ) .GT. 0.0001) GO TO 80                    FZRF
      WRITE(IOUT,99) OBS(I)                                              FZRF
      OBS(I+1)=OBS(MAX)                                                  FZRF
      INTSY(I+1)=INTSY(MAX)                                              FZRF
      MAX=MAX-1                                                          FZRF
      GO TO 20                                                           FZRF
   80 CONTINUE                                                           FZRF
C                                                                        FZRF
      RETURN                                                             FZRF
   99 FORMAT(41H0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   /            FZRF
     * 17H THE INPUT VALUE  ,F10.5, 15H APPEARS TWICE   /                FZRF
     * 27H           CHECK YOUR INPUT    /                               FZRF
     * 41H XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX   )                  FZRF
      END                                                                FZRF
      SUBROUTINE  SYMTST                                                 FZRF
C  SUBROUTINE SYMTEST TRIES TO FIND OUT WHETHER THE LATTICES FOUND       FZRF
C  ARE LATTICES OF A HIGHER SYMMETRY IN DISGUISE.                        FZRF
      DIMENSION NAM(3,2)                                                 FZRF
      INTEGER  H                                                         FZRF
      LOGICAL SELF,ENL,TEST,LIST                                         FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      COMMON /PARMS / TOL2,TOL3,WAVEL,FMINEQ,FMINIM,SELF,ENL,TEST,LIST,  FZRF
     *                NSYST(3),OBSMT(40),OBSPT(40)                       FZRF
      EQUIVALENCE(CEL(1),A),(CEL(2),B),(CEL(3),C),(CEL(5),E)             FZRF
      DATA NAM/4HIS P,4HROBA,4HBLY ,4H   M,4HIGHT,4H BE /                FZRF
      NPASS=0                                                            FZRF
      DIFMIN=FMINEQ                                                      FZRF
      IF (CEL(4)+ABS(CEL(6)) .GT. FMINEQ) GO TO 3010                     FZRF
   5  DIFMIN=3.0*DIFMIN                                                  FZRF
      NPASS=NPASS+1                                                      FZRF
      IF ( E .LT. FMINEQ) GO TO 1000                                     FZRF
C  THE NEXT PART   FINDS OUT WHETHER A MONOCLINIC LATTICE IS A DISGUISED FZRF
C  RHOMBOHEDRIC LATTICE.                                                 FZRF
      AA=A                                                               FZRF
      IF (ABS(E-2.*B) .GT. DIFMIN) GO TO 20                              FZRF
      IF (ABS(C-3.*B) .GT. DIFMIN) GO TO 10                              FZRF
      GO TO 200                                                          FZRF
   10 IF (ABS(A-3.*B) .GT. DIFMIN) GO TO 20                              FZRF
      AA=C                                                               FZRF
      GO TO 200                                                          FZRF
   20 IF (ABS(A+B-C) .GT. DIFMIN) GO TO 30                               FZRF
      IF (ABS(2.*ABS(B-A)-E).GT.DIFMIN) GO TO 30                         FZRF
      GO TO 200                                                          FZRF
   30 IF (ABS(B+C-4.*A).GT. DIFMIN) GO TO 40                             FZRF
      IF (ABS(E-ABS(B-C)) .GT. DIFMIN) GO TO 40                          FZRF
      GO TO 200                                                          FZRF
   40 IF (ABS(2.*C-3.*E).GT.DIFMIN) GO TO 50                             FZRF
      IF (ABS(2.*B+E-6.*A).GT. DIFMIN*FLOAT(NPASS) ) GO TO 50            FZRF
      GO TO 200                                                          FZRF
   50 IF (ABS(2.*A-3.*E) .GT. DIFMIN) GO TO 60                           FZRF
      IF (ABS(2.*B+E-6.*C).GT. DIFMIN*FLOAT(NPASS) ) GO TO 60            FZRF
      AA=C                                                               FZRF
      GO TO 200                                                          FZRF
   60 IF (NPASS .EQ. 1) GO TO 5                                          FZRF
      GO TO 3010                                                         FZRF
  200 X=B/3.0                                                            FZRF
      Z=AA-X                                                             FZRF
      IF (Z .LT. 1.) RETURN                                              FZRF
      WRITE(IOUT,900)  (CEL(J),J=1,6),(NAM(J,NPASS),J=1,3)               FZRF
      A=200./SQRT(B)                                                     FZRF
      C=100./SQRT(Z)                                                     FZRF
      WRITE(IOUT,901) X,Z, A, C                                          FZRF
      X=4.*X                                                             FZRF
      A=0.5*A                                                            FZRF
      IF (CEL(9).LT. 6.) WRITE(IOUT,902) X,A                             FZRF
      RETURN                                                             FZRF
 1000 DO 1200 I=1,2                                                      FZRF
      J=3-I                                                              FZRF
      G=CEL(J)                                                           FZRF
      H=INT(A/G+0.5 )                                                    FZRF
      K=INT(B/G+0.5 )                                                    FZRF
      L=INT(C/G+0.5 )                                                    FZRF
      IH=0                                                               FZRF
      IK=0                                                               FZRF
      IL=0                                                               FZRF
      IF (ABS(A-G*FLOAT(H)) .LT. DIFMIN) IH=1                            FZRF
      IF (ABS(B-G*FLOAT(K) ) .LT. DIFMIN) IK=1                           FZRF
      IF (ABS(C-G*FLOAT(L) ) .LT. DIFMIN) IL=1                           FZRF
      II=IH+IK+IL -2                                                     FZRF
      IF (II) 1200,1020,1010                                             FZRF
 1010 WRITE(IOUT,900)  (CEL(J),J=1,6),(NAM(J,NPASS),J=1,3)               FZRF
      X=100./SQRT(G)                                                     FZRF
      WRITE(IOUT, 911) G,X                                               FZRF
      RETURN                                                             FZRF
 1020 IF (IK*IL .EQ. 0) GO TO 1050                                       FZRF
      N=L/K                                                              FZRF
      X=B                                                                FZRF
      Z=A                                                                FZRF
      GO TO 1500                                                         FZRF
 1050 IF (IH*IL .EQ. 0) GO TO 1100                                       FZRF
      N=L/H                                                              FZRF
      X=A                                                                FZRF
      Z=B                                                                FZRF
      GO TO 1500                                                         FZRF
 1100 N=H/K                                                              FZRF
      X=B                                                                FZRF
      Z=C                                                                FZRF
      GO TO 1500                                                         FZRF
 1200 CONTINUE                                                           FZRF
C     IF (NPASS .EQ. 1) GO TO 5                                          FZRF
      GO TO 3010                                                         FZRF
 1500 WRITE(IOUT,900)  (CEL(J),J=1,6),(NAM(J,NPASS),J=1,3)               FZRF
      A=100./SQRT(X)                                                     FZRF
      C=100./SQRT(Z)                                                     FZRF
      IF (N-3) 1025,1030,1040                                            FZRF
 1025 WRITE(IOUT,912) X,Z, A,C                                           FZRF
      RETURN                                                             FZRF
 1030 A=2.0*A/SQRT(3.0)                                                  FZRF
      WRITE(IOUT,913) X,Z,A,C                                            FZRF
      RETURN                                                             FZRF
 1040 WRITE(IOUT,914) N                                                  FZRF
      RETURN                                                             FZRF
 3010 AA=OBS(MAX)                                                        FZRF
      Z=0.                                                               FZRF
      DIFMIN=FMINEQ                                                      FZRF
      DO 3020 J=1,6                                                      FZRF
      X=ABS(CEL(J))                                                      FZRF
      IF (X .LT. FMINEQ) GO TO 3020                                      FZRF
      IF (X .LT. AA) AA=X                                                FZRF
C  FINDS THE SMALLEST NON-ZERO VALUE OF THE CONSTANT, AA.                FZRF
      IF (X .GT. Z ) Z=X                                                 FZRF
C  AND THE LARGEST VALUE,  Z.                                            FZRF
 3020 CONTINUE                                                           FZRF
      DO 3050 I=1,3                                                      FZRF
      X=AA/FLOAT(I)                                                      FZRF
      IF (X .LT. 0.5*FMINIM) RETURN                                      FZRF
      L=INT(Z/X +0.5)                                                    FZRF
      X=Z/FLOAT(L)                                                       FZRF
C  REFINES THE VALUE OF THE CONSTANT BY USING THE LARGEST MULTIPLE.      FZRF
      N=0                                                                FZRF
      DO 3030 J=1,6                                                      FZRF
      G=ABS(CEL(J))                                                      FZRF
      L=INT(G/X+0.5)                                                     FZRF
      IF (ABS(G-X*FLOAT(L)) .LE. DIFMIN) N=N+1                           FZRF
 3030 CONTINUE                                                           FZRF
      IF (N .LT. 6) GO TO 3050                                           FZRF
      GO TO 3100                                                         FZRF
 3050 CONTINUE                                                           FZRF
      RETURN                                                             FZRF
 3100 WRITE(IOUT,900) (CEL(J),J=1,6),(NAM(J,2),J=1,3)                    FZRF
      Z=100./SQRT(X)                                                     FZRF
      WRITE(IOUT,911) X,Z                                                FZRF
      RETURN                                                             FZRF
  900 FORMAT(52H0THE LATTICE WITH THE RECIPROCAL LATTICE CONSTANTS0 ,    FZRF
     * 6F9.2 /1H ,3A4 )                                                  FZRF
  901 FORMAT(1H+, 12X, 24H RHOMBOHEDRAL, WITH THE   ,                    FZRF
     *45H (HEXAGONAL) RECIPROCAL LATTICE CONSTANTS0 X=,F9.2,4H  Z=,F9.2/ FZRF
     * 29H AND THE DIRECT CONSTANTS  A=, F7.4,4H  C=,F7.4 )              FZRF
  902 FORMAT(21H PROBABLY X SHOULD BE, F10.2,8H  AND A0  ,F8.4)          FZRF
  911 FORMAT(1H+,12X,44H CUBIC WITH A RECIPROCAL LATTICE CONSTANT OF  ,  FZRF
     *        F10.2,33H AND A DIRECT LATTICE CONSTANT OF , F10.4)        FZRF
  912 FORMAT(1H+,12X,42H TETRAGONAL WITH THE RECIPROCAL CONSTANTS  ,     FZRF
     * 2F10.2,29H AND THE DIRECT CONSTANTS  A=, F7.4,4H  C=,F7.4 )       FZRF
  913 FORMAT(1H+,12X,41H HEXAGONAL WITH THE RECIPROCAL CONSTANTS   ,     FZRF
     * 2F10.2,29H AND THE DIRECT CONSTANTS  A=, F7.4,4H  C=,F7.4 )       FZRF
  914 FORMAT(1H+,12X,43H A FREAK. THERE IS A RATIO IN THE CONSTANTS   ,  FZRF
     * 32H OF THE RECIPROCAL  LATTICE OF0  ,I3)                          FZRF
      END                                                                FZRF
      SUBROUTINE UNTCEL(WMOL,DOBS,VOLUM,ISW)                             FZRF
C----------------------------------------------------------------------- FZRF
C  THIS SUBROUTINE CALCULATES THE DIRECT CONSTANTS FROM THE CONSTANTS    FZRF
C  OF THE RECIPROCAL LATTICE.                                            FZRF
C  IF THE MOLECULAR WEIGHT AND THE DENSITY HAVE BEEN GIVEN,              FZRF
C  IT ALSO CALCULATES THE X-RAY DENSITY,DX,  AND THE NUMBER OF MOLECULES FZRF
C  PER UNIT CELL,  N.                                                    FZRF
C----------------------------------------------------------------------- FZRF
      DIMENSION          REC(3,6),REEL(3,6),WAAR(6)                      FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
C                                                                        FZRF
      DO 1100 J=1,6                                                      FZRF
 1100 WAAR(J)= CEL(J)                                                    FZRF
      DO 1220 J=1,3                                                      FZRF
      REC(1,J)=SQRT(WAAR(J))                                             FZRF
      REC(1,J+3)=REC(1,J)                                                FZRF
 1220 CONTINUE                                                           FZRF
      DO 1230 J=1,3                                                      FZRF
      W=WAAR(J+3)/(REC(1,J+1)*REC(1,J+2)*2.0)                            FZRF
      REC(2,J+3)=W                                                       FZRF
      REC(2,J)=W                                                         FZRF
      REC(3,J+3)=SQRT(1.0-W*W)                                           FZRF
      REC(3,J)=REC(3,J+3)                                                FZRF
 1230 CONTINUE                                                           FZRF
      DO 1240 J=1,3                                                      FZRF
      W=(REC(2,J+1)*REC(2,J+2)-REC(2,J))/(REC(3,J+1)*REC(3,J+2))         FZRF
      REEL(2,J+3)=W                                                      FZRF
      REEL(2,J)=W                                                        FZRF
      REEL(3,J)=SQRT(1.0-W*W)                                            FZRF
      REEL(3,J+3)=REEL(3,J)                                              FZRF
 1240 CONTINUE                                                           FZRF
      FNNN=REEL(3,1)*REEL(3,2)*REC(3,3)                                  FZRF
      DO 1250 J=1,3                                                      FZRF
      CEL(J)=REEL(3,J)/(FNNN*REC(1,J))*100.0                             FZRF
 1250 CONTINUE                                                           FZRF
      DO 1260 J=4,6                                                      FZRF
      CEL(J)=90.0-57.29578*ATAN(REEL(2,J)/REEL(3,J))                     FZRF
 1260 CONTINUE                                                           FZRF
      VOLUM=FNNN*CEL(1)*CEL(2)*CEL(3)                                    FZRF
      IF (ISW .EQ. 0) RETURN                                             FZRF
      WRITE(IOUT,9930) (CEL(J),J=1,6) ,VOLUM                             FZRF
      IF (WMOL .LT. 0.1) RETURN                                          FZRF
      PARTD=WMOL/(0.6025*VOLUM)                                          FZRF
      IF (DOBS .LT. 0.1) GO TO 1270                                      FZRF
      N=IFIX(1.1*DOBS/PARTD)                                             FZRF
      DX=PARTD*FLOAT(N)                                                  FZRF
      WRITE(IOUT,9931)  N,DX,DOBS                                        FZRF
      RETURN                                                             FZRF
 1270 WRITE(IOUT,9932) PARTD                                             FZRF
      RETURN                                                             FZRF
 9930 FORMAT(1H ,6F9.3,  F12.2)                                          FZRF
 9931 FORMAT(1H+,68X, 5H   Z=,I2,6H   DX=, F7.4, 8H   DOBS=, F7.4 )      FZRF
 9932 FORMAT(1H+,68X,11H   DCALC=Z*, F8.4)                               FZRF
      END                                                                FZRF
      SUBROUTINE WISSEL(I,J)                                             FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      A=CEL(I)                                                           FZRF
      CEL(I)=CEL(J)                                                      FZRF
       CEL(J)=A                                                          FZRF
      A=CEL(I+3)                                                         FZRF
      CEL(I+3)=CEL(J+3)                                                  FZRF
      CEL(J+3)=A                                                         FZRF
      RETURN                                                             FZRF
      END                                                                FZRF
      SUBROUTINE WRISP(NPOS,VAR,ICODE)                                   FZRF
C  THE FUNCTION OF  WRISP  IS TO WRITE THE Q-VALUES OF THE CALCULATED    FZRF
C  LINES IN A NEAT SCHEME, RECOGNISABLE FOR THOSE WHO  KNOW HOW TO       FZRF
C  HANDLE THESE SCHEMES.                                                 FZRF
C     IT WRITES  VAR  (THE Q-VALUE) IN THE FORMAT F8.1, PRECEDED BY      FZRF
C  (NPOS-1)*9 SPACES.   IF THE CALCULATED VALUE OF Q CORRESPONDS TO      FZRF
C  AN OBSERVED VALUE, AN X IS ADDED LATER.                               FZRF
C                                                                        FZRF
C  THE PARAMETERS OF WRISP ARE0                                          FZRF
C  1. NPOS     = POSITION OF Q-VALUE                                     FZRF
C  2. VAR      = VALUE OF Q                                              FZRF
C  3. ICODE    = CODE TO TELL WRISP WHAT  TO DO                          FZRF
C  ICODE=0  PUT VAR IN POSITION                                          FZRF
C       =1  PUT X IN POSITION.                                           FZRF
C       =2  PRINT THE LINE WITH Q-VALUES.                                FZRF
C  THIS PARTICULAR FORM OF WRISP TAKES A LITTLE BIT OF COMPUTING TIME    FZRF
C  BUT IT IS KIND TO THE PRINTER.  IT SHOULD BE USED WHEN YOU HAVE A     FZRF
C  RELATIVELY FAST COMPUTER AND A SLOW PRINTER (E.G. A SLOW TERMINAL     FZRF
C  ON A FAST COMPUTER).                                                  FZRF
      DIMENSION IFIGRS(10),ITXT(133)                                     FZRF
      COMMON /LINES /INP,IOUT,JOB,MAX,NAME(20),INTSY(40),OBS(40),CEL(10) FZRF
      DATA IBLANK/1H /,IX/1HX/,IPNT/1H./,IFIGRS(1)/1H0/,IFIGRS(2)/1H1/,  FZRF
     * IFIGRS(3)/1H2/,IFIGRS(4)/1H3/,IFIGRS(5)/1H4/,IFIGRS(6)/1H5/,      FZRF
     2 IFIGRS(7)/1H6/,IFIGRS(8)/1H7/,IFIGRS(9)/1H8/,IFIGRS(10)/1H9/      FZRF
      DATA NUSED/0/,ISTAR/1H*/                                           FZRF
      IF (NUSED .GT. 0) GO TO 20                                         FZRF
      GO TO 400                                                          FZRF
   20 NUSED=NUSED+1                                                      FZRF
      IF (ICODE-1) 100,200,300                                           FZRF
C                                                                        FZRF
  100 IF (NPOS .LE. 14) GO TO 150                                        FZRF
C  ONLY 132 PRINT POSITIONS AVAILABLE,  15*9=135!                        FZRF
      WRITE(IOUT,9990)ITXT                                               FZRF
      NPOS=1                                                             FZRF
      DO 110 K=1,133                                                     FZRF
  110 ITXT(K)=IBLANK                                                     FZRF
  150 N=9*(NPOS-1)                                                       FZRF
      IF (VAR .GT. 0.1) GO TO 156                                        FZRF
      DO 152 I=3,9                                                       FZRF
  152 ITXT(N+I)=ISTAR                                                    FZRF
      ITXT(N+6)=IFIGRS(1)                                                FZRF
      GO TO 180                                                          FZRF
  156 NR=IFIX(VAR*10.0+0.5)                                              FZRF
      IREST=NR/10                                                        FZRF
      NFIG=NR-10*IREST                                                   FZRF
      ITXT(N+8)=IFIGRS(NFIG+1)                                           FZRF
      ITXT(N+7)=IPNT                                                     FZRF
      NR=IREST                                                           FZRF
      DO 160 I=1,6                                                       FZRF
      INR=7-I                                                            FZRF
      IREST=NR/10                                                        FZRF
      NFIG=NR-10*IREST                                                   FZRF
      NR=IREST                                                           FZRF
      ITXT(N+INR)=IFIGRS(NFIG+1)                                         FZRF
      IF (NR .EQ. 0) GO TO 180                                           FZRF
  160 CONTINUE                                                           FZRF
  180 RETURN                                                             FZRF
C                                                                        FZRF
  200 N=9*NPOS                                                           FZRF
      ITXT(N)=IX                                                         FZRF
      RETURN                                                             FZRF
C                                                                        FZRF
  300 WRITE(IOUT,9990)ITXT                                               FZRF
      NPOS=1                                                             FZRF
C                                                                        FZRF
  400 ITXT(1)=IFIGRS(1)                                                  FZRF
      DO 410 K=2,133                                                     FZRF
  410 ITXT(K)=IBLANK                                                     FZRF
      IF (NUSED .EQ. 0) GO TO 20                                         FZRF
      RETURN                                                             FZRF
 9990 FORMAT(133A1)                                                      FZRF
      END                                                                FZRF
CDCCDC
 
 
 
 
