C-----------------------------------------------------------------------
C  Use one of the transformation matrices from CREDUC to make a new
C  orientation matrix (RNEW) and list the old and new indices of 
C  peaks found by the OC command.
C-----------------------------------------------------------------------
      SUBROUTINE LISTER
      INCLUDE 'COMDIF'
      DIMENSION RNEW(3,3),IRNEW(3,3),IROLD(3,3),RSAVE(3,3),
     $          THETAS(NSIZE),OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),
     $          ICNTS(NSIZE),ROLDI(3,3),RNEWI(3,3),XA(3),HOLD(3),
     $          HNEW(3),APSAVE(3),COSAVE(3),SISAVE(3),ANG(3),
     $          IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),
     $          BCHI(10),BPHI(10)
      CHARACTER FLAG*1,OLDNEW*1,STRING*14,FSTRIN*10,CMODE(7)*1,
     $          CSYMB(7)*8
      EQUIVALENCE (ACOUNT(        1),THETAS(1)),
     $            (ACOUNT(  NSIZE+1),OMEGAS(1)),
     $            (ACOUNT(2*NSIZE+1),CHIS(1)),  
     $            (ACOUNT(3*NSIZE+1),PHIS(1)),
     $            (ACOUNT(4*NSIZE+1),ICNTS(1))
      EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)),
     $            (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)),
     $            (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1))
      DATA CMODE/'P','A','B','C','I','F','R'/,
     $     CSYMB/'-1','2/m','m m m','4/m','6/m','-3','m 3'/
C-----------------------------------------------------------------------
C  Save the old cell and R matrix in case of trouble
C  Extract the cell params from the matrix from BLIND and put in place
C  for CREDUC to use.
C-----------------------------------------------------------------------
      DO 100 I = 1,3
        APSAVE(I) = AP(I)
        COSAVE(I) = CANG(I)
        SISAVE(I) = SANG(I)
        DO 100 J = 1,3
          RSAVE(I,J) = R(I,J)
          RNEW(J,I) = BLINDR(I,J)
  100 CONTINUE
      CALL MATRIX (RNEW,BLINDR,ROLDI,ROLDI,'MATMUL')
      CALL MATRIX (ROLDI,RNEW,RNEW,RNEW,'INVERT')
      CALL PARAMS (RNEW,AP,ANG)
      DO 105 I = 1,3
        CANG(I) = COS(ANG(I)/DEG)
        SANG(I) = SIN(ANG(I)/DEG)
        DO 105 J = 1,3
          BLINDR(I,J) = BLINDR(I,J)*WAVE
          R(I,J) = BLINDR(I,J)
  105 CONTINUE
C-----------------------------------------------------------------------
C  Reduce the cell obtained by BLIND
C-----------------------------------------------------------------------
      WRITE (COUT,9000)
      CALL GWRITE (ITP,' ')
      CALL CREDUC (KI)
C-----------------------------------------------------------------------
C  If there are two or more transformations from CREDUC, find out 
C  which to use 
C-----------------------------------------------------------------------
      INEW = 1
      IF (NTMATS .GT. 1) THEN
        WRITE (COUT,10000)
        CALL FREEFM (ITR)
        INEW = IFREE(1)
        IF (INEW .EQ. 0) INEW = 1
      ENDIF
      DO 110 I = 1,3
        DO 110 J = 1,3
          ROLD(I,J) = TMATS(I,J,INEW)
  110 CONTINUE
      ISYSF = IFSYS(INEW)
      IMODE = IFMODE(INEW)
C-----------------------------------------------------------------------
C  Get the old and new indices needed to generate the new orientation
C  matrix and cell.  Make sure the old indices (ROLD) are integers.
C-----------------------------------------------------------------------
      DO 130 IT = 1,6
        DO 120 I = 1,3
          DO 120 J = 1,3
            IRNEW(I,J) = 0
            IF (I .EQ. J) IRNEW(I,J) = IT
            ROUND = 0.00001
            IF (ROLD(I,J) .LT. 0.0) ROUND = -0.00001
            IROLD(I,J) = IT*ROLD(I,J) + ROUND
            IF (ABS(IT*ROLD(I,J) - IROLD(I,J)) .GT. 0.001) GO TO 130
  120   CONTINUE
        GO TO 140
  130 CONTINUE 
C-----------------------------------------------------------------------
C  IRNEW now has the new index values to use for reorientation
C  Calculate the angles needed with the old indices and matrix and
C  then calculate the new R matrix with ORMAT3
C-----------------------------------------------------------------------
  140 DO 150 I = 1,3
        IH = IROLD(I,1)
        IK = IROLD(I,2)
        IL = IROLD(I,3)
        NN = -1
        IPRVAL = 0
        CALL ANGCAL
        IHK(I)    = IRNEW(I,1)
        NREFB(I)  = IRNEW(I,2)
        ILA(I)    = IRNEW(I,3)
        BCOUNT(I) = THETA
        BBGR1(I)  = OMEGA
        BBGR2(I)  = CHI
        BTIME(I)  = PHI
  150 CONTINUE
      KI = 'OP'
      CALL ORMAT3
      DO 160 I = 1,3
        DO 160 J = 1,3
          RNEW(I,J) = R(I,J)
  160 CONTINUE
      CALL MATRIX (BLINDR,ROLDI,RJUNK,RJUNK,'INVERT')
      CALL MATRIX (RNEW,RNEWI,RJUNK,RJUNK,'INVERT')
C-----------------------------------------------------------------------
C  Read the angles found by OC and calculate the old and new indices
C-----------------------------------------------------------------------
      CALL ANGRW (0,5,NREFS,140,0)
      WRITE (LPT,13000)
      NINBLK = 0
      NBLOCK = 250
      DO 200 N = 1,NREFS
        ST = 2.0*SIN(0.5*THETAS(N)/DEG)
        CO = COS(OMEGAS(N)/DEG)
        SO = SIN(OMEGAS(N)/DEG)
        CC = COS(CHIS(N)/DEG) 
        SC = SIN(CHIS(N)/DEG)
        CP = COS(PHIS(N)/DEG)
        SP = SIN(PHIS(N)/DEG)
        XA(1) = ST*(CO*CC*CP - SO*SP)
        XA(2) = ST*(CO*CC*SP + SO*CP)
        XA(3) = ST*CO*SC
        CALL MATRIX (ROLDI,XA,HOLD,RJUNK,'MVMULT')
        CALL MATRIX (RNEWI,XA,HNEW,RJUNK,'MVMULT')
        FLAG = ' '
        IF (ICNTS(N) .LE. 0) FLAG = '*'
        WRITE (LPT,11000) N,HOLD,THETAS(N),OMEGAS(N),CHIS(N),PHIS(N),
     $                    HNEW,FLAG
        NINBLK = NINBLK + 1
        IF (HNEW(1) .GE. 0.0) THEN
          IHNEW = HNEW(1) + 0.5
        ELSE
          IHNEW = HNEW(1) - 0.5
        ENDIF
        IF (HNEW(2) .GE. 0.0) THEN
          IKNEW = HNEW(2) + 0.5
        ELSE
          IKNEW = HNEW(2) - 0.5
        ENDIF
        IF (HNEW(3) .GE. 0.0) THEN
          ILNEW = HNEW(3) + 0.5
        ELSE
          ILNEW = HNEW(3) - 0.5
        ENDIF
        I = 0
        IF (ICNTS(N) .LE. 0) I = 1
        IBH(NINBLK) = IHNEW
        IBK(NINBLK) = IKNEW
        IBL(NINBLK) = ILNEW
        BTHETA(NINBLK) = THETAS(N)
        BOMEGA(NINBLK) = OMEGAS(N)
        BCHI(NINBLK)   = CHIS(N)
        BPHI(NINBLK)   = PHIS(N)
        BPSI(NINBLK)   = I
        IF (NINBLK .EQ. 10) THEN
          WRITE (ISD,REC=NBLOCK) 
     $           IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,BPSI,NINBLK
          NINBLK = 0
          NBLOCK = NBLOCK + 1
        ENDIF
  200 CONTINUE
      IF (NINBLK .GT. 0) THEN
        WRITE (ISD,REC=NBLOCK) 
     $         IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,BPSI,NINBLK
        NBLOCK = NBLOCK + 1
      ENDIF
      NINBLK = 0
      WRITE (ISD,REC=NBLOCK) (NINBLK,I = 1,81)
      OLDNEW = 'N'
      WRITE (COUT,14000)
      CALL YESNO ('N',OLDNEW)
      IF (OLDNEW .EQ. 'Y') THEN
        KI = 'OP'
        CALL LSORMT
        ST = 2.0*SIN(0.5*THEMAX/DEG)
        IHMAX = 1.0 + ST/(APS(1)*SANGS(2)*SANG(3)*WAVE)
        IKMAX = 1.0 + ST/(APS(2)*SANGS(3)*SANG(1)*WAVE)
        ILMAX = 1.0 + ST/(APS(3)*SANGS(1)*SANG(2)*WAVE)
        CALL SYSANG (AP,SANG,CANG,ISYS,KI)
        IF (ISYS .EQ.  1) STRING = 'P -1'
        IF (ISYS .EQ.  8) STRING = 'P 2/m 1 1'
        IF (ISYS .EQ.  9) STRING = 'P 2/m'
        IF (ISYS .EQ. 10) STRING = 'P 1 1 2/m'
        IF (ISYS .EQ.  3) STRING = 'P m m m'
        IF (ISYS .EQ.  4) STRING = 'P 4/m'
        IF (ISYS .EQ.  5) STRING = 'P 6/m or P -3'
        IF (ISYS .EQ.  6) STRING = 'R -3 R'
        IF (ISYS .EQ.  7) STRING = 'P m 3'
        FSTRIN = CMODE(IMODE)//' '
        FSTRIN(3:10) = CSYMB(ISYSF)
        IF (ISYSF .EQ. 6) ISYSF = 5
        WRITE (COUT,15000) FSTRIN,STRING
15000 FORMAT (' Space-group choices are as follows :--'/
     $        ' 1. The safest space-group based on cell-reduction ', A/
     $        ' 2. The safest space-group based on cell lengths   ', A/
     $        ' 3. Any other space-group.'/
     $        ' Which do you want (1) ',$)
16000 FORMAT (' Type the space-group symbol ',$)
        CALL FREEFM (ITR)
        IF (IFREE(1) .LT. 2) THEN
          STRING = FSTRIN//' '
          ISYS = ISYSF
        ELSE IF (IFREE(1) .EQ. 2) THEN
          IF (STRING(6:9) .EQ. ' or ') THEN
            WRITE (COUT,16100) STRING
16100 FORMAT (' The space-group symbol CANNOT be both ',A/
     $        ' Please type the correct symbol ',$)
            CALL ALFNUM (STRING)
          ENDIF
        ELSE IF (IFREE(1) .EQ. 3) THEN
          WRITE (COUT,16000)
          CALL ALFNUM (STRING)
        ENDIF
        DO 205 I = 3,10
          IF (STRING(I:I) .GE. 'a' .AND. STRING(I:I) .LE. 'z')
     $        STRING(I:I) = CHAR(ICHAR(STRING(I:I)) - 32)
  205   CONTINUE
        READ (STRING,'(10A1)') SGSYMB
        CALL SPACEG (-2,1)
        CALL SINMAT
        IND(1) = IHO(1)
        IND(2) = IKO(1)
        IND(3) = ILO(1)
        NREF = 1
        NSET = 1
        NMSEG = 1
        NBLOCK = 20
        CALL WRBAS
      ELSE
        DO 210 I = 1,3
          AP(I) = APSAVE(I)
          CANG(I) = COSAVE(I)
          SANG(I) = SISAVE(I)
          DO 210 J = 1,3
            R(I,J) = RSAVE(I,J)
  210   CONTINUE
      ENDIF
      RETURN
 9000 FORMAT (/,'      Cell Reduction Step'/'%')
10000 FORMAT (' Which transformation do you wish to use (1) ? ',$)
11000 FORMAT (I4,2X,3F6.2,3X,4F7.2,3X,3F6.2,1X,A)
13000 FORMAT ('   N    hold  kold  lold    2theta  omega    chi    phi',
     $           '     hnew  knew  lnew')
14000 FORMAT (/' Do you want to replace the old matrix with this',
     $        ' new matrix (N) ? ',$)
      END
