C     Modified at the Cambridge Workshop, 3/10/91  by Sandra
C       General tidy up, add code to take User input column types.
C
C
      PROGRAM LCFTOMTZ
C     ================
C
C   IJT made NPAR = 400 Oct 1991
C
C     Eleanor Dodson/Sandra McLaughlin       November 1989
C     Reading of symmetry cards taken from Phil
C
C---- Program to convert old LCF files to MTZ files
C     The extra header information can be added by keyworded input.
C     This program will remove an S column if it is present
C     as the MTZ library routines calculate the resolution internally.
C
C
C     Program require HKLIN, HKLOUT and SYMOP (if symmetry info is to
C     be added to the file header.
C
C     Add extra info to the header with keyworded input, eg. -
C
C     SYMM  4
C     HISTORY  A TEST OF TRANSLATING OLD TYPE LCF TO NEW MTZ
C     HISTORY JULY 1989
C     TITLE    GMT NATIVE DATA  PCEM
C     CTYPE    F_NAT=F
C     END
C
C     Only use CTYPE input if you are not happy with the 'guessed'
C     column types. See MTZLIB documentation for list of legal
C     column types and their interpretation.
C
C
C
C
C     .. Parameters ..
      INTEGER LPTINP
      PARAMETER (LPTINP=5)
      INTEGER NPAR
      PARAMETER (NPAR=400)
      INTEGER MCOLS
      PARAMETER (MCOLS=200)
C     ..
C     .. Local Scalars ..
      INTEGER IAPPND,IBATCH,IFLAG,ILST,IPRINT,IST,J,JDO10,JDO30,JDO40,
     +        JDO100,JDO130,JJ,JSYM,LBATCH,LFLAG,NCOL,NHIST,NLOOK,
     +        NSPGRP,NSYM,NSYMCH,NSYMP,NTOK,SCOL,JDO125,JDO126
      LOGICAL LEND
      CHARACTER LTYPE*1,KEY*4,PGNAM*10,CALDAT*8,SPGNAM*10,TITL*70,
     +          TITL2*70,TITLE*80,LINE*400,LTITL*400,STROUT*400
C     ..
C     .. Local Arrays ..
      REAL ADATA(MCOLS),CELL(6),FVALUE(NPAR),RSYM(4,4,96),
     +     FACTML(MCOLS)
      INTEGER IBEG(NPAR),IDATA(MCOLS),IDEC(NPAR),IEND(NPAR),ISRT(5),
     +        ITYP(NPAR),JBATCH(400),LCOL(MCOLS)
      CHARACTER CTP(MCOLS)*1,CVALUE(NPAR)*4,LOOK(21)*4,CLAB(MCOLS)*30,
     +          BTITLS(400)*70,HISNEW(30)*80
C     ..
C     .. External Functions ..
      INTEGER LENSTR
      EXTERNAL LENSTR
C     ..
C     .. External Subroutines ..
      EXTERNAL CCPDAT,CCPUPC,GTPINT,LCHKHD,LERROR,LKYTYP,LROLDH,LWCELL,
     +         LWCLAB,LWCLOS,LWHIST,LWOPEN,LWREFL,LWSORT,LWSYMM,LWTITL,
     +         MSYMLB,ORNCNV,PARSER,PUTLIN,RLCF1,SRLCF1,SYMFR2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC NINT
C     ..
C     .. Data statements ..
      DATA NLOOK/0/,LCOL/MCOLS*0/
      DATA NSYM/0/,NSYMP/0/,ISRT/5*0/
      DATA LTYPE/' '/,SPGNAM/' '/,PGNAM/' '/,TITL/' '/
      DATA FACTML/MCOLS*1.0/
C     ..
C
C---- Initialize various things
C
C     ***********
      CALL MTZINI
      CALL CCPFYP
C     ***********
C
C---- Open the old LCF file first since we need to know
C     column labels straight away.
C
C          ***************************************************
      CALL SRLCF1(11,'HKLIN',NLOOK,LOOK,LCOL,.TRUE.,NCOL,CELL)
C          ***************************************************
C
C---- Decode the title and the column labels (CLAB) from the old file
C     Assign "guessed" column types (CTP) and multiplication factor
C     from integer*2 to real in FACTML
C
C          ****************************************
      CALL LROLDH(TITL2,LTITL,CLAB,CTP,FACTML,SCOL)
C          ****************************************
C
C---- If there is an S column, MTZ output file will have one less total cols
C
      IF (SCOL.GT.0) NCOL = NCOL - 1
C
      NHIST = 0
      JSYM = 0
C
C---- Read any input cards
C
   20 CONTINUE
      LINE = ' '
      NTOK = NPAR
C
C          *******************************************************
      CALL PARSER(KEY,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK,
     +              LEND,.TRUE.)
C          *******************************************************
C
      IF (LEND) GO TO 50
C
C---- Loop over possible key-words
C
C          ***********
      CALL CCPUPC(KEY)
C          ***********
C
C---- read symmetry information
C
      IF (KEY.EQ.'SYMM') THEN
C
C---- Look at next field on line: this can be
C       (a) a space-group number
C       (b) a space-group name,
C           ie a string beginning P,I,R,F,A,B or C
C       (c) a symmetry operation (anything else)
C
C    for cases (a) & (b), this is a single field:
C         case (c) is more than 1 field
C
            J = 2
C
C
            IF (J.GT.NTOK) THEN
              STROUT = '**ERROR : No symmetry data on line !!!'
C
C                  ***********************
              CALL PUTLIN(STROUT,'ERRWIN')
C                  ***********************
C
              GO TO 20
            END IF
C
            IF (J.EQ.NTOK) THEN
C
C---- One item only - spacegroup number or name..
C
C---- it's a number, treat as space-group number
C
                IF (ITYP(J).EQ.2) NSPGRP = NINT(FVALUE(J))
C
C---- it's a string, treat as space-group name
C
                IF (ITYP(J).EQ.1) THEN
                  SPGNAM = LINE(IBEG(J) :IEND(J))
                  NSPGRP = 0
                END IF
C
C---- Now read symmetry from SYMOP
C     open symop on channel 24 - closed at end of reading
C
                NSYMCH = 24
C
C                    **************************************************
                CALL MSYMLB(NSYMCH,NSPGRP,SPGNAM,PGNAM,NSYMP,NSYM,RSYM)
C                    **************************************************
C
C---- More than one item - it is a symmetry operator
C     Read symmetry operations
C
            ELSE
C
                JSYM = JSYM + 1
C
C                    *************************************
                CALL SYMFR2(LINE,IBEG(J),JSYM,RSYM(1,1,1))
C                    *************************************
C
                NSPGRP = 0
                SPGNAM = ' '
                PGNAM = ' '
            END IF
C
            GO TO 20
C
C---- Input history line
C
      ELSE IF (KEY.EQ.'HIST') THEN
C
            NHIST = NHIST + 1
C
            IF (NHIST.GT.30) THEN
              WRITE (STROUT,FMT='(A)') '  Only 30 history lines allowed'
              CALL PUTLIN(STROUT,'ERRWIN')
            ELSE
              HISNEW(NHIST) = LINE(IBEG(2) :IEND(NTOK))
            END IF
C
C
            GO TO 20
C
C---- Input project title
C
      ELSE IF (KEY.EQ.'TITL') THEN
C
            TITL = LINE(IBEG(2) :IEND(NTOK))
            GO TO 20
C
C---- Input user chosen column types
C
      ELSE IF (KEY.EQ.'CTYP') THEN
C
C     Keyword  CTYPE  will indicate column TYPE assignments.
C     eg   F1=F
C     Only necessary if you are not satisfied with
C     the "guessed"  assignments.
C
C               ***********************************************
           CALL LKYTYP(CLAB,NCOL,CTP,FACTML,NTOK,LINE,IBEG,IEND)
C               ***********************************************
C
           GOTO 20
C
C---- Check end of header
C
      ELSE IF (KEY(1:3).EQ.'END') THEN
           GO TO 50
C
      ELSE
C
C---- Unrecognised keyword
C
            WRITE (STROUT,FMT='(A,5X,A)')
     +        ' **ERROR : Unrecognised keyword, Line ignored .. ',
     +        LINE(IBEG(1) :IEND(1))
            CALL PUTLIN(STROUT,'ERRWIN')
            GO TO 20
      END IF
C
C---- End of loop over input cards
C
   50 CONTINUE
C
      IF (NSYM .LE. 0) THEN
         WRITE (STROUT, '(A)')
     $        ' !!!! No symmetry given - COMPULSORY !!!!'
         CALL CCPERR(1,'*** Must give symmetry for MTZ ***')
      ENDIF
C
C---- Open the new MTZ file
C
C          ******************
      CALL LWOPEN(1,'HKLOUT')
C          ******************
C
C---- Write the Cell to the new header
C
C          **************
      CALL LWCELL(1,CELL)
C          **************
C
      IF (TITL.EQ.' ') TITL = TITL2
      IFLAG = 1
C
C          ********************
      CALL LWTITL(1,TITL,IFLAG)
C          ********************
C
C---- Build comletely new list of labels
C
      IAPPND = 0
C
C          ******************************
      CALL LWCLAB(1,CLAB,NCOL,CTP,IAPPND)
C          ******************************
C
C---- Don't put tile into history if History records input
C Otherwise:-
C---- Write long title to the history header breaking it into lines
C     of 80 chars, trying not to break in the middle of a word,
C
      IF (NHIST .EQ. 0) THEN
         JJ = LENSTR(LTITL)
         IST = 0
 60      CONTINUE
C
C
         ILST = IST + 80
         NHIST = NHIST + 1
C
C
         IF (NHIST.GT.30) THEN
            GO TO 80
         ELSE
            IF (ILST.GT.JJ) THEN
               ILST = JJ
            ELSE
 70            CONTINUE
C     
               IF (LTITL(ILST:ILST).NE.' ') THEN
                  ILST = ILST - 1
                  GO TO 70
               END IF
            END IF
C
C
            HISNEW(NHIST) = LTITL(IST+1:ILST)
            IST = ILST
            IF (IST.LT.JJ) GO TO 60
         END IF
      END IF
C
C---- And while we're here, write a final history line,
C     saying that the file was converted, and when
C
      IF (NHIST.LE.29) THEN
C
C            **************
        CALL CCPDAT(CALDAT)
C            **************
C
        NHIST = NHIST + 1
        WRITE (HISNEW(NHIST),FMT='(A,A8)')
     +    'File converted to MTZ file mark 1 on ',CALDAT(1:8)
      END IF
C
   80 CONTINUE
C
C           *********************
      CALL LWHIST(1,HISNEW,NHIST)
C           *********************
C
C---- Now the symmetry, if any
C
      IF (NSYM.GT.0) THEN
C
C
        IF (SPGNAM(1:1).NE.' ') LTYPE = SPGNAM(1:1)
C
C            ***************************************************
        CALL LWSYMM(1,NSYM,NSYMP,RSYM,LTYPE,NSPGRP,SPGNAM,PGNAM)
C            ***************************************************
C
C
      END IF
   90 CONTINUE
C
C
C---- At last, read the reflections records, and convert to real
C
C          **********************
      CALL RLCF1(IDATA,*150,*140)
C          **********************
C
C---- Check for header record
C
C          ********************************
      CALL LCHKHD(IDATA,LFLAG,IBATCH,TITLE)
C          ********************************
C
      IF (LFLAG.EQ.1) THEN
C
C---- Batch title found, store it in an array
C
          LBATCH = LBATCH + 1
          BTITLS(LBATCH) = TITLE
          JBATCH(LBATCH) = IBATCH
C
C
      ELSE IF (LFLAG.EQ.2) THEN
C
C---- Orientation block found, write out batch title
C        (assumed to have been already read!)
C    and orientation block
C
          DO 100 JDO100 = 1,LBATCH
C
C---- Find corresponding batch title
C
            IF (IBATCH.EQ.JBATCH(JDO100)) GO TO 110
  100     CONTINUE
C
C---- Failed to find it
C
          WRITE (LINE,FMT='(A,I6,A)') 'Orientation block for batch ',
     +      IBATCH,' has no matching batch title'
C
C              ****************
          CALL LERROR(1,0,LINE)
C              ****************
C
C---- Dummy title
C
          TITLE = ' '
          GO TO 120
C
C---- Found, store pointer & title
C
  110     J = JDO100
          TITLE = BTITLS(J)
C
C---- Convert orientation data & output both title
C     & orientation information
C
C              **********************
  120     CALL ORNCNV(IBATCH,TITLE,1)
C              **********************
C
      ELSE
C
C---- Normal reflection record
C
C---- Do various number conversions based on column type
C---- Column type S, are removed
C---- Column type FRACTIONCALC or RATSDEL  multiply by *0.001
C---- Column type M (figure of merit), divide by 100
C---- Column type A (Hendrickson-Lattmann coefficient),
C     divide by 100
C
        IF (SCOL.GT.0) THEN
C----   Drop the S column 
          DO 125 JDO125 = 1,SCOL-1
            ADATA(JDO125) = IDATA(JDO125)
            ADATA(JDO125) = ADATA(JDO125)* FACTML(JDO125)
  125     CONTINUE
          DO 126 JDO126 = SCOL,NCOL
            ADATA(JDO126) = IDATA(JDO126+1)
            ADATA(JDO126) = ADATA(JDO126)* FACTML(JDO126)
  126     CONTINUE
C
        ELSE
C
          DO 130 JDO130 = 1,NCOL
            ADATA(JDO130) = IDATA(JDO130)
            ADATA(JDO130) = ADATA(JDO130)* FACTML(JDO130)
  130     CONTINUE
        END IF
C
C            ***************
        CALL LWREFL(1,ADATA)
C            ***************
C
      END IF
      GO TO 90
C
C---- Branch here at end of input file
C     Call LWCLOS with IPRINT=3,
C     so we get a full dump of what we did
C
 140  IPRINT = 3
C
C          ****************
      CALL LWCLOS(1,IPRINT)
C          ****************
C
C---- Hopefully the end
C
      CALL CCPERR(0,' Normal Termination of lcf2mtz.for')
C
C---- Branch here if file read error
C
 150  CONTINUE
C
C
      WRITE (STROUT,FMT='(A,5I4,4I6)')
     +  '**ERROR reading record from input LCF file .. ',IDATA
C
C          ***********************
      CALL PUTLIN(STROUT,'ERRWIN')
C          ***********************
C
      CALL CCPERR(1,' error in lcf read')
C
C
      END
C
C
C
C     ===========================================
      SUBROUTINE LCHKHD(IDATA,LFLAG,IBATCH,TITLE)
C     ===========================================
C
C Check record IDATA for batch header or orientation
C
C On entry, IDATA contains current record
C
C On exit:
C  LFLAG    = 0  not header record
C           = 1  batch title found, returned in TITLE
C           = 2  orientation block found, returned in common /ORIENT/
C  IBATCH   batch number of header (only if LFLAG .gt. 0)
C
C   If LFLAG .gt. 0,
C    then IDATA on exit holds the last record of the header
C
C
C
C
C     .. Scalar Arguments ..
      INTEGER IBATCH,LFLAG
      CHARACTER TITLE*72
C     ..
C     .. Array Arguments ..
      INTEGER IDATA(*)
C     ..
C     .. Scalars in Common ..
      CHARACTER BTITLE*72
C     ..
C     .. External Subroutines ..
      EXTERNAL GTORN1,RTLCF1
C     ..
C     .. Common blocks ..
      COMMON /TITLCF/BTITLE
C     ..
C
C
      LFLAG = 0
C
C---- Batch header?
C
      IF (IDATA(1).LE.-32000) THEN
C
C---- Batch title?
C
        IF (IDATA(1).EQ.-32750) THEN
          WRITE (6,FMT=6000)
C
C              ********************
          CALL RTLCF1(IBATCH,IDATA)
C              ********************
C
          TITLE = BTITLE
          LFLAG = 1
        END IF
C
C---- Orientation data
C
        IF (IDATA(1).EQ.-32740) THEN
C
C              ********************
          CALL GTORN1(IBATCH,IDATA)
C              ********************
C
          IF (IBATCH.LT.0) THEN
            RETURN
          ELSE
            LFLAG = 2
          END IF
        END IF
C
      END IF
C
C---- Format statements
C
 6000 FORMAT (/' Batch title :')
C
C
      END
C
C
C
C     ==================================================
      SUBROUTINE LROLDH(TITL,LTITL,CLAB,CTP,FACTML,SCOL)
C     ==================================================
C
C---- Subroutine to decode the character info from an old LCF file
C     It unscrambles the column labels into the array clab(100) and
C     attempts to make intelligent guesses about the column type.
C
C---- arrayn is the character array in an old type LCF file which
C     holds  both the titl and column labels
C
C---- it truncates the old title to 70 characters, into TITL, and
C     also returns the full title in LTITL, so that it can be written
C     to the history header.
C
C---- with the MTZ files there is no need for an S column, because
C     the resolution is calculated internally, and resolution limits
C     are held in the MTZ header. this subroutine will return the
C     column number of the S column (if one exists) in the variable
C     SCOL, and will remove the S column label from the CLAB array.
C     In this case the resulting output MTZ file will have one 
C     column less than the input LCF file.
C
C
C
C
C     .. Parameters ..
      INTEGER NPAR
      PARAMETER (NPAR=400)
C     ..
C     .. Scalar Arguments ..
      CHARACTER TITL*70,LTITL*400
      INTEGER SCOL
C     ..
C     .. Array Arguments ..
      CHARACTER CTP(*)*1,CLAB(*)*30
      REAL FACTML(*)
C     ..
C     .. Scalars in Common ..
      INTEGER IDDN,LABELN,LRECLN,LTITN,MAXDN
      CHARACTER ARRAYN*1000
C     ..
C     .. Arrays in Common ..
      REAL CELLN
C     ..
C     .. Local Scalars ..
      INTEGER IC,JDO30,LCH0,LCH1,NTOK
      LOGICAL LEND
      CHARACTER KEY*4,LABEL*30,LINE*400
C     ..
C     .. Local Arrays ..
      REAL FVALUE(NPAR)
      INTEGER IBEG(NPAR),IDEC(NPAR),IEND(NPAR),ITYP(NPAR)
      CHARACTER CVALUE(NPAR)*4
C     ..
C     .. External Subroutines ..
      EXTERNAL CCPUPC,PARSER
C     ..
C     .. Common blocks ..
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
C     ..
C     .. Save statement ..
      SAVE
C     ..
C
      SCOL = 0
C
C---- Decode titl - truncate to 70 characters.
C     New philosophy means most info. now kept in history header
C
      IF (LTITN.LT.80) THEN
        TITL = ARRAYN(LABELN+1:LABELN+LTITN)
      ELSE
        TITL = ARRAYN(LABELN+1:LABELN+70)
      END IF
C
      LTITL = ARRAYN(LABELN+1:LABELN+LTITN)
C
C---- Decode labels  - PARSER only accepts 80 character lines
C      at one pass.
C     I must be careful not to cut a label in half !
C     put in one blank at end
C
      LABELN = LABELN + 1
      ARRAYN(LABELN:LABELN) = ' '
C
      LCH0 = 1
      IC = 1
   10 CONTINUE
C
C
      LCH1 = LCH0 + 69
      IF (LCH1.GT.LABELN) LCH1 = LABELN
   20 CONTINUE
C
C---- find a blank character to end "line" so labels are not split
C
      IF (ARRAYN(LCH1:LCH1).NE.' ') THEN
        LCH1 = LCH1 - 1
        GO TO 20
      END IF
C
C
      LINE = ' '//ARRAYN(LCH0:LCH1)//' '
      NTOK = NPAR
C
C---- MRC parser .
C
C          ***********************************************************
      CALL PARSER(KEY,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK,LEND,
     +            .TRUE.)
C          ***********************************************************
C
      IF (.NOT.LEND) THEN
C
C---- Try to decide on column TYPE from the column clabel
C     It is possible to input new types during translation program run.
C
        DO 30 JDO30 = 1,NTOK
          CLAB(IC) = LINE(IBEG(JDO30) :IEND(JDO30))
C
C---- Default type is REAL
C
          CTP(IC) = 'R'
C
C---- Make some intelligent guesses
C
C---- Change to upper case
C
          LABEL = CLAB(IC)
C
C              *************
          CALL CCPUPC(LABEL)
C              *************
C
C          NFCCOL = MTZLOK(8)    FRACTIONCALC   ncfs  R
C          NSFCOL = MTZLOK(9)    SIGFRACTCALC         Q
C          NRDCOL = MTZLOK(10)   RATDELSD       ncr   R
C          NABCOL = MTZLOK(11)   ABSFAC nca           R
C          NSACOL = MTZLOK(12)   SIGABS ncas          Q
C
          IF (LABEL.EQ.'H ' .OR. LABEL.EQ.'K ' .OR.
     +        LABEL.EQ.'L ') THEN
       	 CTP(IC) = 'H'
          ELSE IF (
     $        LABEL(1:4).EQ.'A   ' .OR.
     $        LABEL(1:4).EQ.'B   ' .OR.
     $        LABEL(1:4).EQ.'C   ' .OR.
     $        LABEL(1:4).EQ.'D   ' ) THEN
             CTP(IC) = 'A'
             FACTML(IC) = 0.01
          ELSE IF (LABEL(1:4).EQ.'ABSF') THEN
       	CTP(IC) = 'R'
       	FACTML(IC) = 0.001
       	GO TO 3333
          ELSE IF (LABEL(1:6).EQ.'SIGABS') THEN
       	CTP(IC) = 'Q'
       	FACTML(IC) = 0.001
       	GO TO 3333
          ELSE IF (LABEL(1:6).EQ.'SIGFRA') THEN
       	CTP(IC) = 'Q'
       	FACTML(IC) = 0.001
       	GO TO 3333
          ELSE IF (LABEL.EQ.'S ') THEN
       	  SCOL = IC
       	  GOTO 30
          ELSE IF (LABEL(1:6).EQ.'FRACTI') THEN
       	   CTP(IC) = 'R'
       	   FACTML(IC) = 0.001
       	   GO TO 3333
          ELSE IF (LABEL(1:3).EQ.'RAT') THEN
       	    CTP(IC) = 'R'
       	    FACTML(IC) = 0.001
          ELSE IF (LABEL(1:3).EQ.'FOM') THEN
       	    CTP(IC) = 'W'
       	    FACTML(IC) = 1.0/100.0
          ELSE IF (LABEL(1:1).EQ.'F') THEN
       	    CTP(IC) = 'F'
          ELSE IF (LABEL(1:1).EQ.'I') THEN
       	    CTP(IC) = 'J'
          ELSE IF (LABEL(1:3).EQ.'SIG' .OR. 
     +             LABEL(1:2).EQ.'SD') THEN
       	    CTP(IC) = 'Q'
          ELSE IF (LABEL(1:2).EQ.'PH' .OR. 
     +             LABEL(1:2).EQ.'AC') THEN
       	    CTP(IC) = 'P'
          ELSE IF (LABEL(1:1).EQ.'W') THEN
       	    CTP(IC) = 'W'
          ELSE IF (LABEL(1:6).EQ.'M/ISYM') THEN
       	    CTP(IC) = 'Y'
          ELSE IF (LABEL(1:5).EQ.'BATCH') THEN
       	    CTP(IC) = 'B'
          ELSE IF (LABEL(1:3).EQ.'DEL' .OR. 
     +             LABEL(1:3).EQ.'DAN') THEN
       	    CTP(IC) = 'D'
          END IF
C
C
3333      CONTINUE
          IC = IC + 1
   30   CONTINUE
C
C
        LCH0 = LCH1 + 1
        IF (LCH0.LT.LABELN) GO TO 10
      END IF
C
C
      END
C
C
      SUBROUTINE ORNCNV(IBATCH,TITLE,LFLAG)
C     =====================================
C
C  If LFLAG = 0, just write out batch title TITLE for batch IBATCH
C
C  If LFLAG = 1, convert orientation block in /ORIENT/ to new
C   form, & write it out
C
C
C
C This is the film orientation block, only used here to test JUMPAX
C
C
C     .. Scalar Arguments ..
      INTEGER IBATCH,LFLAG
      CHARACTER TITLE* (*)
C     ..
C     .. Scalars in Common ..
      REAL ALAMBD_LCF, BBFAC_LCF,  BSCALE_LCF, DELAMB_LCF,
     +     DELCOR_LCF, DELRAX_LCF, DIVHD_LCF,  DIVVD_LCF,
     +     ETAD_LCF,   PHIEND_LCF, PHISTT_LCF, SDBB_LCF,
     +     SDSCAL_LCF
      INTEGER IFTCRD_LCF, JUMPAX_LCF, NRAST_LCF, NWORDS_LCF
C     ..
C     .. Arrays in Common ..
      REAL    CELL_LCF,  PHIXYZ_LCF, UMAT_LCF
      INTEGER IRAST_LCF, LCELL_LCF,  DUMMY_LCF
C     ..
C     .. Local Arrays ..
      INTEGER IDUMMY(1)
C     ..
C     .. External Subroutines ..
      EXTERNAL LWBAT,ORNCVA,ORNCVF
C     ..
C     .. Common blocks ..
c
c---- Old LCF orientation block
c
      COMMON /ORIENT/NWORDS_LCF,CELL_LCF(6),LCELL_LCF(6),
     +               UMAT_LCF(3,3),JUMPAX_LCF,PHIXYZ_LCF(3,2),
     +               DELRAX_LCF,PHISTT_LCF,PHIEND_LCF,IFTCRD_LCF,
     +               ETAD_LCF,ALAMBD_LCF,DELAMB_LCF,DELCOR_LCF,
     +               DIVHD_LCF,DIVVD_LCF,BSCALE_LCF,BBFAC_LCF,
     +               SDSCAL_LCF,SDBB_LCF,NRAST_LCF,IRAST_LCF(9),
     +               DUMMY_LCF(98)
C     ..
C
C
      IF (LFLAG.EQ.0) THEN
C
C---- No orientation block, set NWORDS = 0
C
        IDUMMY(1) = 0
C
C            ****************************
        CALL LWBAT(1,IBATCH,IDUMMY,TITLE)
C            ****************************
C
      ELSE
C
C---- Convert orientation block, depending on what type it is
C
        IF (JUMPAX_LCF.GE.100) THEN
C
C---- Area detector type
C
C              ********************
          CALL ORNCVA(IBATCH,TITLE)
C              ********************
C
        ELSE
C
C---- Film type
C
C              ********************
          CALL ORNCVF(IBATCH,TITLE)
C              ********************
C
        END IF
      END IF
C
      END
C
C
C
      SUBROUTINE ORNCVA(IBATCH,TITLE)
C     ================================
C
C Convert area detector (Madnes) orientation block & output
C
C
C        Below is the /ORIENT/ for Fast Data in the OLD-LCF style
C
C
C
C
C
C         Below is the NEW-MTZ Internal common for the Orientation
C         data   ... For Film data you RETURN array of 53 WORDS
C                ... For Fast data you RETURN array of 90 WORDS
C
C
C
C---- MBLENG is length of this common block
C            (so that it can be zeroed)
C
C
C
C     .. Scalar Arguments ..
      INTEGER IBATCH
      CHARACTER TITLE* (*)
C     ..
C     .. Scalars and Arrays in Common  block /orient for LCF/ ..
      REAL UALAMB,UDELCO,UDELLM,UDIVHD,UDIVVD,UDX,UETAD,
     +     UPSI1,UPSI2,UTHETA,UTIME1,UTIME2
      INTEGER UICRYS,UJSCAX,UJUMPA,ULBMFL,ULCRFL,UNDET,
     +        UNGONA,UNWORD
      REAL UCELL,UDATUM,UDETLI,UDUM1,UDUM2,UDUM3,UDUM4,UE1,
     +     UE2,UE3,US0,USCANA,USOURC,UU
      INTEGER ULABEL,ULCELL
      COMMON /ORIENT/UNWORD,UCELL(6),ULCELL(6),UU(3,3),UJUMPA,UICRYS,
     +       ULCRFL,UETAD,UDUM1(19),UDATUM(3),UPSI1,UPSI2,UJSCAX,
     +       USCANA(3),UTIME1,UTIME2,UDUM2(20),UNGONA,UE1(3),UE2(3),
     +       UE3(3),ULABEL(6),UDUM3(20),USOURC(3),US0(3),ULBMFL,UALAMB,
     +       UDELLM,UDELCO,UDIVHD,UDIVVD,UDUM4(20),UNDET,UDX,UTHETA,
     +       UDETLI(2,2)
C     ..
C
C
C     Lengths: MBLENG is total length of block, MBLINT, MBLREA are numbers
C              of integers & reals
      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   BCELL,BUMAT,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
C     
      COMMON /CBTHDR/BTITLE,GONLAB(3)
C     
      COMMON /MBTHDR/ NWORDS,NINTGR,NREALS,IORTYP,LBCELL(6),MISFLG,
     .     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD(9),
     +     BCELL(6),BUMAT(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))
C     ..
C
C
C
C
C     .. Local Scalars ..
      INTEGER J,JDO10,K
C     ..
C     .. External Subroutines ..
      EXTERNAL CCPMVI,CCPZI,LWBAT
C     ..
C     .. Save it ..
      SAVE /CBTHDR/,/MBTHDR/
C
C---- Clear down new common block, MBLENG words, from NWORDS, set to 0
C
C          *********************
      CALL CCPZI(NWORDS,MBLENG)
C          *********************
C
C---- & the character common
C
      LDTYPE = 2
      BTITLE = ' '
      GONLAB(1) = ' '
      GONLAB(2) = ' '
      GONLAB(3) = ' '
C
C---- Now copy everything
C
      NWORDS = MBLENG
      NINTGR = MBLINT
      NREALS = MBLREA
C
C          ***********************
      CALL CCPMVI(BCELL,UCELL,6)
      CALL CCPMVI(LBCELL,ULCELL,6)
      CALL CCPMVI(BUMAT,UU,9)
C          ***********************
C
      JUMPAX = UJUMPA
      PHISTT = UPSI1
      PHIEND = UPSI2
      ETAD = UETAD
      ALAMBD = UALAMB
      DELAMB = UDELLM
      DELCOR = UDELCO
      DIVHD = UDIVHD
      DIVVD = UDIVVD
      NCRYST = UICRYS
      LCRFLG = ULCRFL
C
C          **********************
      CALL CCPMVI(DATUM,UDATUM,3)
C          **********************
C
      JSCAXS = UJSCAX
C
C          ***********************
      CALL CCPMVI(SCANAX,USCANA,3)
C          ***********************
C
      NGONAX = UNGONA
      TIME1 = UTIME1
      TIME2 = UTIME2
C
C          ***********************
      CALL CCPMVI(E1,UE1,3)
      CALL CCPMVI(E2,UE2,3)
      CALL CCPMVI(E3,UE3,3)
      CALL CCPMVI(SOURCE,USOURC,3)
      CALL CCPMVI(S0,US0,3)
C          ***********************
C
      LBMFLG = ULBMFL
      NDET = UNDET
      DX1 = UDX
      THETA1 = UTHETA
C
C          ***********************
      CALL CCPMVI(DETLM1,UDETLI,4)
C          ***********************
C
C---- & character things
C
      BTITLE = TITLE
C
C
      DO 10 JDO10 = 1,3
        K = JDO10*2 - 1
        WRITE (GONLAB(JDO10),FMT='(2A4)') (ULABEL(J),J=K,K+1)
   10 CONTINUE
C
C---- Now write it out
C
C          *****************************
      CALL LWBAT(1,IBATCH,NWORDS,BTITLE)
C          *****************************
C
      END
C
C
      SUBROUTINE ORNCVF(IBATCH,TITLE)
C     ================================
C
C Convert film orientation block & output
C
C
C  LCF film orientation block
C
C
C
C
C         Below is the NEW-MTZ Internal common for the Orientation
C         data   ... For Film data you RETURN array of 53 WORDS
C                ... For Fast data you RETURN array of 90 WORDS
C
C
C
C---- MBLENG is length of this common block
C     (so that it can be zeroed)
C
C
C
C     .. Scalar Arguments ..
      INTEGER IBATCH
      CHARACTER TITLE* (*)
C     ..
C
C
C
C     .. Scalars and Arrays in Common  block /orient for LCF/ ..
      REAL UALAMB,UBBFAC,UBSCAL,UDELAM,UDELCO,UDELRA,UDIVHD,
     +     UDIVVD,UETAD,UPHIEN,UPHIST,USDBB,USDSCA
      INTEGER UIFTCR,UJUMPA,UNRAST,UNWORD
      REAL UCELL,UPHIXY,UUMAT,DUMMY
      INTEGER UIRAST,ULCELL
      COMMON /ORIENT/UNWORD,UCELL(6),ULCELL(6),UUMAT(3,3),UJUMPA,
     +       UPHIXY(3,2),UDELRA,UPHIST,UPHIEN,UIFTCR,UETAD,UALAMB,
     +       UDELAM,UDELCO,UDIVHD,UDIVVD,UBSCAL,UBBFAC,USDSCA,USDBB,
     +       UNRAST,UIRAST(9),DUMMY(98)
C     ..
C
C
C
C     .. External Subroutines ..
      EXTERNAL CCPMVI,CCPZI,LWBAT
C     ..
C     
C     Lengths: MBLENG is total length of block, MBLINT, MBLREA are numbers
C              of integers & reals
      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   BCELL,BUMAT,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
      COMMON /CBTHDR/BTITLE,GONLAB(3)
      COMMON /MBTHDR/ NWORDS,NINTGR,NREALS,IORTYP,LBCELL(6),MISFLG,
     .     JUMPAX,NCRYST,LCRFLG,LDTYPE,JSCAXS,NBSCAL,NGONAX,LBMFLG,
     +     NDET,INTPAD(9),
     +     BCELL(6),BUMAT(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))
C     ..
C
C---- Save it
      SAVE /CBTHDR/,/MBTHDR/
C
C
C---- Clear down new common block, MBLENG words, from NWORDS, set to 0
C
C          *********************
      CALL CCPZI(NWORDS,MBLENG)
C          *********************
C
C---- & the character common
C
      LDTYPE = 1
      BTITLE = ' '
      GONLAB(1) = ' '
      GONLAB(2) = ' '
      GONLAB(3) = ' '
C
C---- Now copy everything
C
      NWORDS = MBLENG
      NINTGR = MBLINT
      NREALS = MBLREA
C
C          ***********************
      CALL CCPMVI(BCELL,UCELL,6)
      CALL CCPMVI(LBCELL,ULCELL,6)
      CALL CCPMVI(BUMAT,UUMAT,9)
C          ***********************
C
      JUMPAX = UJUMPA
C
C          ***********************
      CALL CCPMVI(PHIXYZ,UPHIXY,6)
C          ***********************
C
cc??      DELRAX = UDELRA
      PHISTT = UPHIST
      PHIEND = UPHIEN
cc??      IFTCRD = UIFTCR
      ETAD = UETAD
      ALAMBD = UALAMB
      DELAMB = UDELAM
      DELCOR = UDELCO
      DIVHD = UDIVHD
      DIVVD = UDIVVD
      BSCALE = UBSCAL
      BBFAC = UBBFAC
      SDBSCL = USDSCA
      SDBFAC = USDBB
cc??      NRAST = UNRAST
C
C          ***********************
cc??      CALL CCPMVI(IRASTR,UIRAST,9)
C          ***********************
C
C---- & title
C
      BTITLE = TITLE
C
C---- Now write it out
C
C          *****************************
      CALL LWBAT(1,IBATCH,NWORDS,BTITLE)
C          *****************************
C
      END
C
C
C
C     ===============================================================
      SUBROUTINE LKYTYP(LSPRGO,NLPRGO,TYPRGO,CFACT,NTOK,LINE,IBEG,IEND)
C     ===============================================================
C
C-----Subroutine to read standard input lines of the form
C              CTYPE  Label_IN_FILE=userTYPE 
C     ie the user is chosing his own column types
C
C---- Arguments:
C
C     LSPRGO    CHARACTER*30    program label strings (array)
C                               L(abel) S(tring) PRG(rammme) O(utput)
C
C     NLPRGO    INTEGER         number of program output labels
C                               N(umber of) L(abels) PRG(ramme) O(utput)
C
C     TYPRGO    CHARACTER*1     column types which have been assigned
C                               by the program
C
C     CFACT     REAL            returns scale factor for each column
C
C     NTOK      INTEGER         from Parser, number of tokens on line
C
C     LINE      CHARACTER*400   the input line
C
C     IBEG,IEND INTEGER         arrays from the parser, delimiters
C                               for each token
C
C
C
C
C     .. Parameters ..
      INTEGER MCOLS
      PARAMETER (MCOLS=200)
      INTEGER NTYP,LTYP
      PARAMETER (NTYP=14,LTYP=8)
C     ..
C     .. Scalar Arguments ..
      INTEGER NLPRGO,NTOK
      CHARACTER LINE* (*)
C     ..
C     .. Array Arguments ..
      INTEGER IBEG(*),IEND(*)
      CHARACTER LSPRGO(*)*30,TYPRGO(*)*1
      REAL CFACT(*)
C     ..
C     .. Local Scalars ..
      INTEGER JDO,JLENG,JLOOP,JSTART,JTOK,JJ,IFAIL,ISTAT
      CHARACTER CWORK*30,CWORK2*30,LC1*30,LC2*30,STROUT*400,LINE2*100
C     ..
C     .. Local Arrays ..
      CHARACTER CTYPES(NTYP)*1,LTYPES(LTYP)*1
      REAL TYPSCL(NTYP)
C     ..
C     .. External Functions ..
      INTEGER LENSTR
      EXTERNAL LENSTR
C     ..
C     .. External Subroutines ..
      EXTERNAL CCPUPC,PUTLIN
C     ..
C     .. Data statements ..
      DATA CTYPES/'H','S','J','F','D','Q','P','M','W','A','B','Y','I',
     +     'R'/
C Scales for each type: = 0.01 for 'M','W','A' else = 1.0
      DATA TYPSCL/7*1.0,0.01,0.01,0.01,4*1.0/
      DATA LTYPES/'P','A','B','C','I','F','R','?'/
C     ..
C
C
      JTOK = NTOK
      JSTART = 2
C
C
      IF (NLPRGO.LE.0) THEN
        STROUT = ' Error this program has no OUTPUT LABELS'
C
C            ***********************
        CALL PUTLIN(STROUT,'ERRWIN')
C            ***********************
C
      ELSE IF (JTOK.LE.1) THEN
        STROUT = ' **** Warning no argument given for CTYPE card'
C
C            ***********************
        CALL PUTLIN(STROUT,'ERRWIN')
C            ***********************
C
        WRITE (STROUT,FMT='(A)')
     + ' For This Conversion guessed types will be used if possible'
C
C            ***********************
        CALL PUTLIN(STROUT,'ERRWIN')
C            ***********************
C
      ELSE
C
C---- Find output label assignments
C
C
        DO 40 JLOOP = JSTART,NTOK,2
C
C
          IF ((JLOOP+1).GT.JTOK) THEN
            GO TO 50
          ELSE
            CWORK = LINE(IBEG(JLOOP) :IEND(JLOOP))
            LC1 = CWORK
C
C                *************
cc            CALL CCPUPC(CWORK)
C                *************
C
            CWORK2 = LINE(IBEG(JLOOP+1) :IEND(JLOOP+1))
            LC2 = CWORK2
C
C                **************
cc            CALL CCPUPC(CWORK2)
C                **************
C
            DO 10 JDO = 1,NLPRGO
              JLENG = LENSTR(LSPRGO(JDO))
              IF ((CWORK.EQ.LSPRGO(JDO)).AND.
     +                              (LENSTR(CWORK).EQ.JLENG)) THEN
                GO TO 30
              ELSE IF ((CWORK2.EQ.LSPRGO(JDO)).AND.
     +                              (LENSTR(CWORK2).EQ.JLENG)) THEN
                GO TO 20
              END IF
   10       CONTINUE
C
C
            STROUT = ' **** Error output assignment does not match'//
     +               ' program labels'
C
C                ***********************
            CALL PUTLIN(STROUT,'ERRWIN')
            WRITE (STROUT,FMT=
     +        '(''  Neither '',A,'' nor '',A,'' recognised'')') CWORK(1:
     +        LENSTR(CWORK)),CWORK2(1:LENSTR(CWORK2))
            CALL PUTLIN(STROUT,'ERRWIN')
C                ***********************
C
            GO TO 40
C
   20       CONTINUE
   25       ISTAT = 0
            CALL CCPUPC(LC1)
            DO 26 JJ = 1,NTYP
              IF (LC1.EQ.CTYPES(JJ)) ISTAT = JJ
   26       CONTINUE
            IF (ISTAT.EQ.0) THEN
              WRITE (LINE2,FMT='(A,I4,A)')
     +          '**ERROR : Unrecognised output column type, column',
     +          JDO,', set to R'
C
              ISTAT = 1
C                  ************************
              CALL LERROR(ISTAT,IFAIL,LINE2)
C                  ************************
C
              TYPRGO(JDO) = 'R'
            ELSE
              TYPRGO(JDO) = LC1
              CFACT(JDO)  = TYPSCL(ISTAT)
            END IF
            GO TO 40
C
   30       CONTINUE
   35       ISTAT = 0
            CALL CCPUPC(LC2)
            DO 36 JJ = 1,NTYP
              IF (LC2.EQ.CTYPES(JJ)) ISTAT = JJ
   36       CONTINUE
            IF (ISTAT.EQ.0) THEN
              WRITE (LINE2,FMT='(A,I4,A)')
     +          '**ERROR : Unrecognised output column type, column',
     +          JDO,', set to R'
C
              ISTAT = 1
C                  ************************
              CALL LERROR(ISTAT,IFAIL,LINE2)
C                  ************************
C
              TYPRGO(JDO) = 'R'
            ELSE
              TYPRGO(JDO) = LC2
              CFACT(JDO)  = TYPSCL(ISTAT)
            END IF
          END IF
   40   CONTINUE
        RETURN
C
C
   50   STROUT = ' **** Error !!!! for CTYPE card ****'
C
C            ***********************
        CALL PUTLIN(STROUT,'ERRWIN')
        STROUT = ' NOT ENOUGH ARGUMENT PAIRS of type '//
     +           ' File_Label = User_Column_Type'
        CALL PUTLIN(STROUT,'ERRWIN')
C            ***********************
C
      END IF
C
C
      END
