C PROGRAM MTZTONA4
C ================
C FMY  1-5-91 MTZ WORKSHOP, CAMBRIDGE
C VERSION MODIFIED TO USE CHARACTER*4  IJT, BIRKBECK.
C THIS PROGRAM IS USED TO TRANSLATE REFLECTION DATA BETWEEN 'MTZ' FORMAT
C AND A ASCII FILE . THE EXCHANGE FORMAT MAY BE
C USED FOR TRANSFERRING REFLECTION DATA BETWEEN DIFFERENT COMPUTERS.
C
C      MTZ --> Ascii 
C
C FORTRAN77
C
C
C
C SPECIFICATION STATEMENTS
C ========================
C
C     .. Parameters ..
      INTEGER MBLENG,CBLENG
      PARAMETER (MBLENG=185,CBLENG=70+3*8)
      REAL RBATCH(MBLENG)
      CHARACTER CBATCH(CBLENG)*1
C     ..
      INTEGER MCOLS
      PARAMETER (MCOLS=200)
      INTEGER MHISTL
      PARAMETER (MHISTL = 30)
      INTEGER MBATCH
      PARAMETER (MBATCH =240)
C 
      INTEGER IUNOUT,IUNIN,INDEX,IPRINT,NCOL,NREFL,JFAIL,
     +        NBATCH,BATCH(MBATCH),LENTITL,ISTAT,SORT(5),
     +        NSPGR,NSYM,NSYMP,NHIST
C
C     .. Local Arrays ..
      CHARACTER ADATA(MCOLS)*4
      INTEGER   IDATA(2,MCOLS)
      REAL      RDATA(MCOLS),RANGES(2,MCOLS),CELL(6),RSYM(4,4,96)
C
      CHARACTER BUF*80, SPGRN*10, CTYPS(MCOLS)*1,CLABS(MCOLS)*30,
     +           LTYPE*1, TITLE*70, VERSN*10, SYMCHS(96)*80,
     +           HSCR(MHISTL)*80, PGNAME*10
C
      LOGICAL EOF
C
      CHARACTER A4REAL*4
C
C
C INITIALISATIONS
C ===============
C
      LUNIN = 5
      LUNOUT = 6
      CALL CCPFYP
      CALL MTZINI
      CALL CCPRCS(6,'MTZTONA4','$Date: 2005/08/24 12:42:36 $')
C
C
C TRANSLATE FROM 'MTZ' TO 'EXCHANGE' FORMAT
C =========================================
C
C INITIALISATIONS
C ---------------
C
      INDEX = 1
      IUNOUT = 55
      IPRINT = 2
      JFAIL=0
      CALL CCPDPN(IUNOUT,'HKLOUT','NEW','F',LDUM,JFAIL)
C
C  Open MTZ file 
C
        CALL LROPEN(INDEX,'HKLIN',IPRINT,JFAIL)
C read header info from mtz and
C Write header info from to ASCII file for each keyword.
C
        CALL LRINFO (INDEX,VERSN,NCOL,NREFL,RANGES)
        CALL LRCLAB (INDEX,CLABS,CTYPS,NCOL)
        CALL LRBATS (INDEX,NBATCH,BATCH)
C
C VERS
        WRITE(IUNOUT,2010)'VERS',VERSN        
 2010   FORMAT (A,1X,A)
C
C NCOL
        WRITE(IUNOUT,2020)'NCOL',NCOL,NREFL,NBATCH
 2020   FORMAT (A,1X,3I8)
C
C COLUMN
        DO 30 JDO30 =1 ,NCOL
C
C--Get index values for REALA4
C
        CALL CVR4A4(RANGES(1,JDO30),IDATA(1,JDO30))
        WRITE (IUNOUT,2030)'COLUMN',CLABS(JDO30),CTYPS(JDO30),
     +         RANGES(1,JDO30),RANGES(2,JDO30),
     &         IDATA(1,JDO30),IDATA(2,JDO30)
 2030   FORMAT (A,1X,A,1X,A,2(1X,1PE15.8),1X,I2,1X,I4)
C 
 30     CONTINUE
C
C title
        CALL LRTITL(INDEX,TITLE,LENTITL)
        WRITE (IUNOUT,2040)'TITLE',TITLE(1:LENTITL)
 2040   FORMAT (A5,1X,A)
C
C CELL
        CALL LRCELL(INDEX,CELL)
        WRITE (IUNOUT,2050)'CELL',(CELL(I),I =1,6)
 2050   FORMAT (A,1X,6F10.4)
C
C SORT
        CALL LRSORT(INDEX,SORT)
        WRITE (IUNOUT,2060)'SORT',(SORT(I),I=1,5)
 2060   FORMAT(A,1X,5I4)
C
C SYMINF
        CALL LRSYMI(INDEX,NSYMP,LTYPE,NSPGR,SPGRN,PGNAME)
        CALL LRSYMM(INDEX,NSYM,RSYM) 
C
        IF (NSYM.GT.0) THEN
           WRITE (IUNOUT,2070)
     $          'SYMINF',NSYM,NSYMP,LTYPE,NSPGR,SPGRN,PGNAME
 2070      FORMAT(A,1X,2I3,1X,A1,1X,I5,1X,A,1X,A)
C
C SYMM
           ISTAT = 0
           CALL SYMTR3 (NSYM,RSYM(1,1,1),SYMCHS,ISTAT)
C
           DO 80 JDO80 = 1,NSYM
              WRITE (IUNOUT,2080) 'SYMM',
     +                 SYMCHS(JDO80)(1:LENSTR(SYMCHS(JDO80)))
 80        CONTINUE   
 2080         FORMAT (A,1X,A)
       ENDIF
C
C  BATCH serial numbers if multi-record
C
      IF (NBATCH .GT.0) THEN
          IBPRT = 0
C
C
          DO 90 JDO90 = 1, NBATCH
             WRITE (IUNOUT,2090)'BATCH',BATCH(JDO90)
2090         FORMAT (A5,1X,I10)
C
C---- Call lrbat to set up arrays printing everything
C     BUT requires change in library that
C       if IPRINT .gt. 30 then set print = 2
C                and use as unit number in subroutines
C                LBPRT and LBPRTH
C
C      IUNOUT = 55
C
             CALL LRBAT(INDEX,BATCH(JDO90),RBATCH,CBATCH,IUNOUT)
C
C
90        CONTINUE
      ENDIF
C
C
C END of header
            WRITE (IUNOUT,'(A)') 'END'
C
C History headers
C
       CALL LRHIST (INDEX,HSCR,NHIST)
       IF (NHIST.GT.0) THEN
             WRITE (IUNOUT,2100)'MTZHIST',NHIST
 2100        FORMAT (A7,1X,I3)
C
C
             DO 110 JDO110 =1, NHIST
               WRITE (IUNOUT,2110) HSCR (JDO110)
 2110          FORMAT (A)
C
 110         CONTINUE
C
       END IF
C
C
       WRITE (IUNOUT,'(A)') 'MTZENDOFHEADERS'
C END OF ALL HEADERS
CC
C
C--HEADER INFO OUTPUT TO ASCII FILE
C
C
C Loop for all reflections
        NREFL = 0
400     CALL LRREFL (INDEX,S,RDATA,EOF)
        IF (.NOT.EOF) THEN
          DO 390 II=1,NCOL
390         ADATA(II)=A4REAL(IDATA(1,II),RDATA(II))
          WRITE (IUNOUT,'(20A)') (ADATA(II),II=1,NCOL)
          NREFL = NREFL + 1
          IF (NINT(RDATA(5)).EQ.-6519)
     &	  WRITE (6,'((1X,3I5,3(1PE18.8),4X,A))')(II,(IDATA(I,II),I=1,2),
     &    RANGES(1,II),RANGES(2,II),RDATA(II),ADATA(II),II=1,NCOL)
          GOTO 400
        ENDIF
C
C--- end of MTZ file reached
c
	WRITE(IUNOUT,2190)NREFL
2190   FORMAT ( '*** END ***   Number of Reflections output ...',I8)
C
800    CONTINUE
C
       END
C
C
C
C
      SUBROUTINE CVR4A4(RANGE, INDXR4)
C
C==== Machine-independent routine to get indices for REAL*4 <--> CHARACTER*4
C==== conversions.
C
C==== REAL array argument    :  Minimum and maximum values of series of
C==== REALs to be converted.
C
C==== INTEGER array argument :  Indices for use by A4REAL and REALA4.
C
C==== Ian Tickle, Birkbeck.
C
C
      INTEGER INDXR4(2)
      REAL RANGE(2)
      INTEGER I, J, N
      REAL A, P
C
      IF (RANGE(1).EQ.0. .AND. RANGE(2).EQ.0.) THEN
        INDXR4(1) = 0
        INDXR4(2) = 999
      ELSE
        A = MAX(ABS(RANGE(1)),ABS(RANGE(2)))
        P = 24. - LOG(DBLE(A))/LOG(2.D0)
        IF (P.LE.0.) THEN
          I = P - 1.
        ELSE
          I = P
        ENDIF
C
        N = A * 2.**I
        IF (N.LT.2**23) THEN
          I = I + 1
        ELSEIF (N.GE.2**24) THEN
          I = I - 1
        ENDIF
C
        N = 0
        DO 10 J = 1, 2
          IF (RANGE(J).LT.0.) THEN
            N = N - 1
          ELSEIF (RANGE(J).GT.0.) THEN
            N = N + 1
          ENDIF
10      CONTINUE
C
        INDXR4(1) = N
        IF (N.EQ.0) THEN
          INDXR4(2) = I - 1
        ELSE
          INDXR4(2) = I
        ENDIF
      ENDIF
      END
C
C
      CHARACTER*4 FUNCTION A4REAL(INDXR4, RVAL)
C
C
C==== Machine-independent routine for REAL*4 --> CHARACTER*4 conversion.
C
C==== INTEGER array argument :  Indices from INDXR4 function call.
C
C==== REAL argument          :  REAL value to be converted.
C
C==== CHARACTER*4 return     :  Converted string.
C====                         A **** string returned indicates overflow;
C====                         this will happen if the absolute value of
C====                         the REAL falls outside the range specified
C====                         in the call to INDXR4.
C
      INTEGER INDXR4(2)
      REAL RVAL
      CHARACTER*64 CHRTAB/
     &'0123456789-+ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
     &/
      INTEGER I, J, M, N
C
C==== First convert REAL to INTEGER in the range 0 to 2**24-1.
C==== Negative numbers are converted to 2's complement.
C
      IF (RVAL.EQ.0.) THEN
        A4REAL = '0000'
      ELSEIF (INDXR4(2).EQ.999) THEN
        A4REAL = '****'
      ELSEIF (INDXR4(1).NE.0 .AND.
     &        (ISIGN(1, INDXR4(1)).NE.SIGN(1., RVAL))) THEN
        A4REAL = '****'
      ELSE
        N = NINT(ABS(RVAL) * 2.**INDXR4(2))
        IF (INDXR4(1).EQ.0) THEN
          M = 2**23
        ELSE
          M = 2**24
        ENDIF
        IF (N.EQ.M) THEN
          N = M - 1
        ELSEIF (N.GT.M) THEN
          A4REAL = '****'
          RETURN
        ENDIF
C
        IF (INDXR4(1).EQ.0 .AND. RVAL.LT.0.) N = 2**24 - N
C
C==== Then convert INTEGER to CHAR*4 using 64-character translation table.
C
        DO 10 I = 4, 1, -1
          M = N/64
          J = N - 64*M + 1
          A4REAL(I:I) = CHRTAB(J:J)
10        N = M
      ENDIF
      END
