C PROGRAM NA4TOMTZ
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 
C
C FORTRAN77
C
C     .. Parameters ..
      INTEGER MFILES,MCOLS,MBATCH
      PARAMETER (MFILES=3,MCOLS=200,MBATCH=240)
      INTEGER MBLENG,CBLENG
      PARAMETER (MBLENG=90+56,CBLENG=70+3*8)
      INTEGER MHISTL
      PARAMETER (MHISTL=30)
      INTEGER NPARSE
      PARAMETER (NPARSE=200)
C     ..
      INTEGER NTOK
      LOGICAL LEND,EOF
      CHARACTER KEY*4,LINE*80
C     ..
C     .. Arrays  for Parser ..
      REAL    FVALUE(NPARSE)
      INTEGER IBEG(NPARSE),IDEC(NPARSE),IEND(NPARSE),
     +        ITYP(NPARSE)
      CHARACTER CVALUE(NPARSE)*4
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, PGNAM*6, 
     &          CTYPS(MCOLS)*1,CLABS(MCOLS)*30,
     +           LTYPE*1, TITLE*70, VERSN*10, SYMCHS(96)*80,
     +           HSCR(MHISTL)*80
C
      INTEGER EFLAG,ISTAT,IUNIN,JDO10,JDO20,JDO30,JDO40,JDO50,
     +        JDO60,JDO80,JDO90,JDO100,JDO110,JDO120,JDO130,JDO140,
     +        JDO150,JDO190,JDO200,NCOLR,NSYMIN,NBATR,
     +        IUNOUT,INDEX,IPRINT,NCOL,NREFL,JFAIL,
     +        NBATCH,BATCH(MBATCH),LENTITL,SORT(5),
     +        NSPGR,NSYM,NSYMP,NHIST
C
      REAL      REALA4
C     ..
C
C INITIALISATIONS
C ===============
C
      LUNIN = 5
      LUNOUT = 6
      CALL CCPFYP
      CALL CCPDPN(LUNIN,'DATA','READONLY','F',LDUM,IFAIL)
      CALL CCPDPN(LUNOUT,'PRINTER','PRINTER','F',LDUM,IFAIL)
      CALL CCPRCS(6,'NA4TOMTZ','$Date: 2005/08/24 12:42:36 $')
C
C TRANSLATE FROM   'EXCHANGE' TO MTZ FORMAT
C =========================================
C
C INITIALISATIONS
C ---------------
C
      NSYMIN = 0
      NCOLR = 0
      NBATR = 0
      INDEX = 1
      IPRINT = 2
      JFAIL=1
      IUNIN = 55
      CALL CCPOPN(IUNIN,'HKLIN',5,1,LDUM,JFAIL)
       IF(JFAIL.EQ.-1) THEN
          WRITE (6,*)' CCPOPN ERROR on unit',IUNIN
          STOP
       END IF          
C
C  Open MTZ file 
C
        CALL LWOPEN(INDEX,'HKLOUT')
C
C---- Start of loop over header lines
C     -------------------------------
C
 70         CONTINUE
C
C
            NTOK = NPARSE
            READ(IUNIN,9876) LINE
9876        FORMAT(A)
C
C---- Pass header line to MRC parser (later Compose parser)
C
C                *******************************************************
            CALL PARSER(KEY,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK,
     +           LEND,.TRUE.)
C                *******************************************************
C
C---- And loop over possible keywords
C     -------------------------------
C
C---- VERS - version of routines which wrote the file
C               could test versions here in the future
C
            IF (KEY.EQ.'VERS') THEN
C
              VERSN = LINE(IBEG(2):IEND(2))
             GO TO 70
C
C---- TITL - read file title
C
            ELSE IF (KEY.EQ.'TITL') THEN
              TITLE = ' '
              IF(NTOK.GE.2)TITLE = LINE(IBEG(2) :IEND(NTOK))
           CALL LWTITL (INDEX,TITLE,0)   
           GO TO 70
C
C---- NCOL - no. of cols and refls in file
C
            ELSE IF (KEY.EQ.'NCOL') THEN
C
C                  **************************************
              CALL GTPINT(2,NCOL,NTOK,ITYP,FVALUE)
              CALL GTPINT(3,NREFS,NTOK,ITYP,FVALUE)
              CALL GTPINT(4,NBATCH,NTOK,ITYP,FVALUE)
C                  **************************************
C
              GO TO 70
C
C---- CELL - read in the Cell parameters
C
            ELSE IF (KEY.EQ.'CELL') THEN
C
C
              DO 80 JDO80 = 1,6
C
C                    *************************************************
                CALL GTPREA(JDO80+1,CELL(JDO80),NTOK,ITYP,FVALUE)
C                    *************************************************
C
 80           CONTINUE
C
         CALL LWCELL(INDEX,CELL)
C
             GO TO 70
C
C---- SORT - read in sort order
C
          ELSE IF (KEY.EQ.'SORT') THEN
C
C
              DO 90 JDO90 = 1,5
C
C                    **************************************************
               CALL GTPINT(JDO90+1,SORT(JDO90),NTOK,ITYP,FVALUE)
C                    **************************************************
C
90           CONTINUE
        CALL LWSORT(INDEX,SORT)
          GO TO 70
C
C---- SYMINF - various symmetry stuff
C
            ELSE IF (KEY.EQ.'SYMI') THEN
C
C                  **************************************
              CALL GTPINT(2,NSYM,NTOK,ITYP,FVALUE)
              CALL GTPINT(3,NSYMP,NTOK,ITYP,FVALUE)
C                  ***************************************
C
              LTYPE = LINE(IBEG(4) :IBEG(4))
C
C                  ***************************************
              CALL GTPINT(5,NSPGR,NTOK,ITYP,FVALUE)
C                  ***************************************
C
            SPGRN = LINE(IBEG(6) :IEND(6))
            PGNAM = LINE(IBEG(7) :IEND(7))
C
C
              GO TO 70
C
C---- SYMM - read in the symmetry cards and convert to matrices
C
        ELSE IF (KEY.EQ.'SYMM') THEN
             NSYMIN = NSYMIN + 1
             ISTAT = 5
C
C                    *************************************************
                CALL SYMFR3(LINE,ISTAT,NSYMIN,RSYM(1,1,1),EFLAG)
C                    *************************************************
C
        GO TO 70
C
C---- COLS - column labels, types and ranges
C
          ELSE IF (KEY.EQ.'COLU') THEN
              NCOLR = NCOLR + 1
              CLABS(NCOLR) = LINE(IBEG(2) :IEND(2))
              CTYPS(NCOLR) = LINE(IBEG(3) :IBEG(3))
C
C                  ************************************************
              CALL GTPREA(4,RANGES(1,NCOLR),NTOK,ITYP,FVALUE)
              CALL GTPREA(5,RANGES(2,NCOLR),NTOK,ITYP,FVALUE)
C                  ************************************************
C
C--Get index values for REALA4
C
C                  ************************************************
              CALL GTPINT(6,IDATA(1,NCOLR),NTOK,ITYP,FVALUE)
              CALL GTPINT(7,IDATA(2,NCOLR),NTOK,ITYP,FVALUE)
C                  ************************************************
C
           GO TO 70
C
C---- BATCH - serial numbers of the batches in the file (only if NBATCH>0)
C
         ELSE IF (KEY.EQ.'BATC') THEN
             NBATR = NBATR + 1
             CALL GTPINT(2,BATCH(NBATR),NTOK,ITYP,FVALUE)
             CALL XRBAT(BATCH(NBATR),IUNIN,INDEX)
               GOTO 70
C
C---- END of header card
C
            ELSE IF (KEY.EQ.'END') THEN
              GOTO 155
            ELSE
C
              GO TO 70
C
C----   End of loop over keywords
C       -------------------------
            END IF
C
C
 155        CONTINUE
C---- Main header read, continue with any other headers
C
C       
180         READ(IUNIN,2100)LINE
2100        FORMAT (A)
C
C
C---- History header ?
C
        IF (LINE(1:7).EQ.'MTZHIST') THEN
            READ(LINE(9:),'(BN,I72)') NHIST
C
            READ(IUNIN,'(A)') (HSCR(JDO110),JDO110 =1, NHIST)
            CALL LWHIST (INDEX,HSCR,NHIST)  
C
C
        GOTO 180
C
C---- Batch headers
C
          ELSE IF (LINE(1:7).EQ.'MTZBATS') THEN
C
                DO 200 JDO200 = 1,NBATCH
C
200            CONTINUE
           GOTO 180
C
C---- Absolute end of MTZ file record
C
         ELSE IF (LINE(1:15).EQ.'MTZENDOFHEADERS') THEN
              GOTO 210
         END IF
C
C---- End of MTZ header processing
C
C END OF ALL HEADERS
C
C
210      CONTINUE
C
       CALL LWCLAB(INDEX,CLABS,NCOL,CTYPS,IFLAG)
       CALL LWSYMM(INDEX,NSYM,NSYMP,RSYM,LTYPE,NSPGR,SPGRN,PGNAM)
C
C
C--HEADER INFO OUTPUT TO ASCCII FILE
C
C Loop for all reflections
        DO 400 JDO400=1 ,NREFS 
          READ (IUNIN,'(20A)') (ADATA(II),II=1,NCOL)
          DO 390 II=1,NCOL
390         RDATA(II)=REALA4(IDATA(1,II),ADATA(II))
400       CALL LWREFL(INDEX,RDATA)
C
C--- end of MTZ file reached
C
       CALL LWCLOS(INDEX,IPRINT)
       END
C
C
      BLOCK DATA
C     ..
C     .. Common blocks ..
      INTEGER NWORDS,NINTGR,NREALS,IORTYP,LBCELL,MISFLG,
     .     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD
      REAL   CELL,UMAT,PHIXYZ,CRYDAT,ETAD,DATUM,
     +     PHISTT,PHIEND,SCANAX,TIME1,TIME2,
     +     BSCALE,BBFAC,SDBSCL,SDBFAC,BATPAD,E1,E2,E3,GONPAD,
     +     SOURCE,S0,BEMDAT,ALAMBD,DELAMB,DELCOR,DIVHD,DIVVD,
     +     DX1,THETA1,DETLM1,DX2,THETA2,DETLM2,DETPAD,ETADH,ETADV
      CHARACTER INGONLAB*8
C     
      COMMON /RX/ 
     +     NWORDS,NINTGR,NREALS,IORTYP,LBCELL(6),MISFLG,
     +     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD(9),
     +     CELL(6),UMAT(3,3),PHIXYZ(3,2),CRYDAT(12),DATUM(3),
     +     PHISTT,PHIEND,SCANAX(3),TIME1,TIME2,
     +     BSCALE,BBFAC,SDBSCL,SDBFAC,BATPAD(12),E1(3),E2(3),E3(3),
     +     GONPAD(12),SOURCE(3),S0(3),BEMDAT(25),
     +     DX1,THETA1,DETLM1(2,2),DX2,THETA2,DETLM2(2,2),DETPAD(33)
      REAL E123(3,3)
      EQUIVALENCE (E123(1,1),E1(1))
      SAVE
C
        DATA MISFLG/1/, JUMPAX/0/,NCRYST/1/,LCRFLG/0/,
     +       LBCELL/6*0/,LDTYPE/1/,NGONAX/1/,LBMFLG/0/,
     +       UMAT/1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0/,
     +       PHIXYZ/6*0.0/,CRYDAT/12*0.0/,DATUM/3*0.0/,
     +       PHISTT/0.0/,PHIEND/0.0/,TIME1/0.0/,TIME2/0.0/,
     +       BSCALE/1.0/,SDBSCL/0.0/,BBFAC/0.0/,SDBFAC/0.0/,
     +       SOURCE/3*0.0/,S0/3*0.0/,DX1/0.0/,THETA1/0.0/,
     +       DETLM1/4*0.0/,E123/9*0.0/
          DATA IORTYP/0/,JSCAXS/0/,NBSCAL/0/,INTPAD/9*0/,
     +         SCANAX/3*0.0/,BATPAD/12*0.0/,GONPAD/12*0.0/,
     +         DX2/0.0/,THETA2/0.0/,DETLM2/4*0.0/,DETPAD/33*0.0/  
C
      END
C
C
      REAL FUNCTION REALA4(INDXR4, A4)
C
C==== Machine-independent routine for CHARACTER*4 --> REAL*4 conversion.
C
C==== INTEGER array argument :  Indices from INDXR4 function call.
C
C==== CHARACTER*4 argument   :  String to be converted.
C
C==== REAL return            :  REAL converted value.
C
C
      INTEGER INDXR4(2)
      CHARACTER*4 A4
      CHARACTER*64 CHRTAB
      INTEGER I, J, N
      DATA CHRTAB/
     &'0123456789-+ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
     &/
C
C==== First convert CHAR*4 to INTEGER using 64-character translation table.
C
      N = 0
      DO 10 I = 1, 4
        J = INDEX(CHRTAB, A4(I:I))
        IF (J.EQ.0) THEN
          WRITE (6,*)
     &    '**** A4REAL ERROR: Illegal character(s) >> '//A4//' <<.'
          REALA4 = 0.
          RETURN
        ENDIF
10      N = 64*N + J - 1
C
C==== Then convert INTEGER in the range 0 to 2**24-1 to REAL.
C==== Negative numbers are 2's complement.
C
      IF (INDXR4(1).NE.0) THEN
        REALA4 = ISIGN(N, INDXR4(1)) * .5**INDXR4(2)
      ELSEIF (N.LT.2**23) THEN
        REALA4 = N * .5**INDXR4(2)
      ELSE
        REALA4 = (N - 2**24) * .5**INDXR4(2)
      ENDIF
      END
C     
C     =====================================
      SUBROUTINE XRBAT(IBATCH,IUNIT,MTZOUT)
C     =====================================
C     
      INTEGER MBLENG,MBLINT,MBLREA
      PARAMETER (MBLENG=185,MBLINT=29,MBLREA=156)
C     ..
C     .. Common blocks ..
      INTEGER NWORDS,NINTGR,NREALS,IORTYP,LBCELL,MISFLG,
     .     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD
      REAL   CELL,UMAT,PHIXYZ,CRYDAT,ETAD,DATUM,
     +     PHISTT,PHIEND,SCANAX,TIME1,TIME2,
     +     BSCALE,BBFAC,SDBSCL,SDBFAC,BATPAD,E1,E2,E3,GONPAD,
     +     SOURCE,S0,BEMDAT,ALAMBD,DELAMB,DELCOR,DIVHD,DIVVD,
     +     DX1,THETA1,DETLM1,DX2,THETA2,DETLM2,DETPAD,ETADH,ETADV
      CHARACTER BTITLE*70, GONLAB*8,INGONLAB*8
C     
      COMMON /CX/BTITLE,GONLAB(3)
      COMMON /RX/ 
     +     NWORDS,NINTGR,NREALS,IORTYP,LBCELL(6),MISFLG,
     +     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD(9),
     +     CELL(6),UMAT(3,3),PHIXYZ(3,2),CRYDAT(12),DATUM(3),
     +     PHISTT,PHIEND,SCANAX(3),TIME1,TIME2,
     +     BSCALE,BBFAC,SDBSCL,SDBFAC,BATPAD(12),E1(3),E2(3),E3(3),
     +     GONPAD(12),SOURCE(3),S0(3),BEMDAT(25),
     +     DX1,THETA1,DETLM1(2,2),DX2,THETA2,DETLM2(2,2),DETPAD(33)
C     
C     *** Note well the following equivalences: these are to allow for
C     alternative definitions of crystal mosaicity, beam parameters, etc
      EQUIVALENCE (ETAD,CRYDAT(1))
      EQUIVALENCE (ETADH,CRYDAT(1)),(ETADV,CRYDAT(2))
      EQUIVALENCE (BEMDAT(1),ALAMBD)
      EQUIVALENCE (BEMDAT(2),DELAMB)
      EQUIVALENCE (BEMDAT(3),DELCOR)
      EQUIVALENCE (BEMDAT(4),DIVHD)
      EQUIVALENCE (BEMDAT(5),DIVVD)
C ***
C This equivalence is strictly for convenience in printing
      REAL E123(3,3)
      EQUIVALENCE (E123(1,1),E1(1))
      INTEGER IBATCH,IUNIT
      INTEGER I,J,JDO
      CHARACTER BAXIS*4,STRING*80,CBATCH*94,STRING1*80
      CHARACTER AXES(4)*4
      CHARACTER*25 LABTYP(0:3),INLABTYP
C
C
      REAL XRBATH(MBLENG)
      CHARACTER  NULLCHAR*1
      EQUIVALENCE       (NWORDS,XRBATH(1))
C
        SAVE
C
      DATA AXES/'none','a*','b*','c*'/
C
C Types of data
C
      DATA LABTYP/'*** unknown data type ***','oscillation data',
     +     'area detector data','Laue data'/
C
C---- Set word count for /ORIENT/. 
C     positions orientation blocks in output
C     MTZ file, and setup all the orientation block data
C
      NWORDS = MBLENG
      NINTGR = MBLINT
      NREALS = MBLREA
C
C---- gonlab not set properly in abscale
C
       DO 77 JDO=1,3
       GONLAB(JDO) = ' '
77     CONTINUE
C
C
      NULLCHAR = CHAR(0)
      READ (IUNIT,8888)
      READ (IUNIT,8899)BTITLE
8899  FORMAT(11X,A) 
      READ (IUNIT,8888)
      READ (IUNIT,8888)
      READ (IUNIT,8888)
      READ (IUNIT, FMT=6000) INLABTYP
 6000 FORMAT(40X,A)
C
C
      DO 1 JDO=0,3
      IF (INLABTYP.EQ.LABTYP(JDO)) GOTO 2
1     CONTINUE
C
C
      LDTYPE = 0
      GO TO 3
2     LDTYPE = JDO
3     CONTINUE
C
C
C
      READ (IUNIT,8888)
      READ (IUNIT, FMT=6600) NCRYST
6600  FORMAT(37X,I7)
      READ (IUNIT, FMT=6301) CELL
6301  FORMAT(37X,6F7.2)
      READ (IUNIT, FMT=6201) LBCELL
6201  FORMAT(37X,6I7)
C
C
      MISFLG = 0
      LCRFLG = 0
C
C
1000  CONTINUE
C
C
       READ(IUNIT,7600) STRING
7600   FORMAT(A)
1001     CONTINUE
         DO 66 JDO=1,80
         IF(STRING(JDO:JDO).EQ.NULLCHAR) STRING(JDO:JDO)=' '
66        CONTINUE
C
       IF (STRING(1:23).EQ.'   Orientation matrix U') THEN
         READ (STRING,6608) (UMAT(J,1),J=1,3)
         MISFLG = 0
         READ (IUNIT,6608) (UMAT(J,2),J=1,3)
6608     FORMAT(37X,3F10.4)
         READ (IUNIT,6608) (UMAT(J,3),J=1,3)
         GOTO 1000
       ELSE IF (STRING(1:37).EQ.'   Standard orientat') THEN
         READ (STRING,6608) (UMAT(J,1),J=1,3)
         READ (IUNIT,6608) (UMAT(J,2),J=1,3)
         READ (IUNIT,6608) (UMAT(J,3),J=1,3)
         MISFLG = 2
         READ(IUNIT,6609) ((PHIXYZ(I,J),I=1,3),J=1,2)
 6609    FORMAT(37X,6F7.2)
         IF (PHIXYZ(3,2).EQ.0.000) MISFLG = 1
         GOTO 1000
       ELSE IF (STRING(1:26).EQ.'   Reciprocal axis nearest') THEN
          READ (STRING, FMT=6020) GONLAB(1),BAXIS
 6020     FORMAT(27X,A8,5X,A4)
          DO 13 JDO=1,4
          IF (BAXIS.EQ.AXES(JDO)) GOTO 14
13        CONTINUE
          JUMPAX = 0
          GO TO 15
14        CONTINUE
          JUMPAX = JDO -1
15        CONTINUE
          GO TO 1000
C
C---- Isotropic mosaicity
       ELSE IF (STRING(1:15).EQ.'   Mosaicity ..')THEN
         READ (STRING, FMT=6030) ETAD
 6030    FORMAT(37X,F7.3)
         LCRFLG = 0
         GOTO 1000
       ELSE IF (STRING(1:17).EQ.'   Mosaicity (hor')THEN
              LCRFLG = 1
              READ(STRING,FMT=6035) ETADH,ETADV
 6035         FORMAT(37X,2F7.3)
              GOTO 1000
         ELSE IF (STRING(1:20).EQ.'   Datum goniostat a') THEN
             NGONAX = 2
             READ (STRING, FMT=6040) (DATUM(I),I=1,NGONAX) 
 6040        FORMAT(37X,F8.3,2F9.3)
             IF(DATUM(2).EQ.0.00) NGONAX = 1
             GOTO 1000
         ELSE IF (STRING(1:12).EQ.'   Scan axis') THEN
C
C---- here should be GONLAB(JSCAXS) dont know how to get it back
C       JSCAXS that is
C
         READ (STRING, FMT=6050) GONLAB(2)
 6050    FORMAT(39X,A8)
         GOTO 1000
        ELSE IF (STRING(1:17).EQ.'   Start & stop P')THEN
           READ(STRING,6060)PHISTT,PHIEND
6060       FORMAT(37X,2F9.3)
           READ(IUNIT,6061)TIME1,TIME2
6061       FORMAT(37X,2F9.0)
           GOTO 1000
         ELSE IF (STRING(1:19).EQ.'   Batch scale & SD')THEN
           READ(STRING,6065)BSCALE,SDBSCL
6065       FORMAT(37X,2F9.4)
           READ(IUNIT,6165)BBFAC,SDBFAC 
6165       FORMAT(37X,2F9.4)
           GOTO 1000
         ELSE IF (STRING(1:15).EQ.' Crystal gonios') THEN
            READ(IUNIT,6070) NGONAX
6070        FORMAT(37X,I7)
            READ(IUNIT,6170) (E123(I,1),I=1,3)
            READ(IUNIT,6170) (E123(I,2),I=1,3)
            READ(IUNIT,6170) (E123(I,3),I=1,3)
 6170       FORMAT(37X,3F9.4)
            GOTO 1000
          ELSE IF (STRING(1:14).EQ.' Beam informat') THEN
           READ(IUNIT,6080) SOURCE
           READ(IUNIT,6080) S0
6080       FORMAT(37X,3F9.4)
           GOTO 1000
         ELSEIF(STRING(1:24).EQ.'   Wavelength and disper')THEN
            READ (STRING,6090)  ALAMBD,DELAMB
            LBMFLG = 0
 6090       FORMAT(37X,3F9.5)
            READ(IUNIT,7600) STRING1
              IF (STRING1(1:16).EQ.'   Divergence ..') THEN
                LBMFLG = 1
                READ (STRING,6090)  ALAMBD,DELAMB,DELCOR
                READ (STRING1,6095)DIVHD,DIVVD
 6095           FORMAT(37X,2F7.3)
                GOTO 1000
              ELSE
                STRING = STRING1
                GO TO 1001
              END IF
                GO TO 1000
          ELSE IF (STRING(1:17).EQ.' Detector informat') THEN
            READ(IUNIT,6111) NDET
 6111 FORMAT(37X,I7)
            READ(IUNIT,6110) DX1
            READ(IUNIT,6110) THETA1
 6110 FORMAT(37X,F9.3)
            READ(IUNIT,6910) DETLM1
 6910 FORMAT(37X,4F7.1)
           READ (IUNIT,8888)
            GOTO1000
         ELSE IF(STRING(1:4).EQ.' +++') THEN
           READ (IUNIT,8888)
8888       FORMAT(1X)
           GOTO 2000
         ELSE 
           GOTO 1000
         ENDIF
2000     CONTINUE
          CBATCH(1:70) = BTITLE
C
C     ========================================
      CALL LWBAT (MTZOUT,IBATCH,XRBATH,CBATCH)
C     ========================================
C
      RETURN
      END 
