**==aa0001.f
C****************************
C**   Program: EXCHGE      **
C****************************
C
C Copy Laue .ge1/.ge2 files to/from an ascii formatted file to be used
C for exchanging the files between machines.
C
C
C      IMPLICIT NONE
C
      LOGICAL CCPEXS
      INTEGER LUNSTI,LUNSTO,NXTFLD,NBITST,INTVAL
      REAL FLPVAL
C
      LOGICAL CMPRSS,QUIT,START,ERR,HDONLY
      CHARACTER*76 TITLE
      CHARACTER*6 CRYST
      CHARACTER*80 STR,TEXT,SAVTEX
      CHARACTER*80 FILGE1,FILGE2,FILASC
      CHARACTER*1000 OPSTR
      CHARACTER*310 STR2
      REAL REC3(19),REC4(19),REC5(19),REC6(19)
      REAL REC7(19),REC8(19),REC9(19),REC10(19)
      REAL FIDX(6), FIDY(6), OMEGA(6)
      INTEGER REFBUF(19)
      INTEGER HARBUF(2)
      INTEGER ISL(2)
      INTEGER I,J,K,M,II,LL,M1,M2
      INTEGER IOPT,IEND,IFAIL,LAST
      INTEGER IUN,JUN,KUN
      INTEGER NREFL,NHARM,IREF
      INTEGER ISYS,ILAT
      INTEGER MAXREC
      INTEGER IREC
      INTEGER NUMGE2
      INTEGER MULT,NODFLG,IOVLP,ICLOS,IESCAP,NIDX
      INTEGER NVALS,NV
      REAL VALUES(200)
      REAL ALAMB2
      REAL CELLP(6)
C
      REAL CELL(6)
      INTEGER ISYLAT,IAXX,IAXZ
      EQUIVALENCE (CELL(1),REC3(11))
      EQUIVALENCE (ISYLAT,REC3(17))
      EQUIVALENCE (IAXX,REC3(18))
      EQUIVALENCE (IAXZ,REC3(19))
C
      REAL RASTER
      INTEGER IBOX(5)
      REAL PHIS(3),WSTD,WMIN,WMAX
      REAL DMIN,FILMR,SPINDL
      EQUIVALENCE (RASTER,REC4(1))
      EQUIVALENCE (IBOX,REC4(2))
      EQUIVALENCE (PHIS(1),REC4(11))
      EQUIVALENCE (WSTD,REC4(14))
      EQUIVALENCE (WMIN,REC4(15))
      EQUIVALENCE (WMAX,REC4(16))
      EQUIVALENCE (DMIN,REC4(17))
      EQUIVALENCE (FILMR,REC4(18))
      EQUIVALENCE (SPINDL,REC4(19))
C
      REAL XC(6),YC(6),WC(6),DELTA
      EQUIVALENCE (XC(1),REC5(1))
      EQUIVALENCE (YC(1),REC5(7))
      EQUIVALENCE (WC(1),REC5(13))
      EQUIVALENCE (DELTA,REC5(19))
C
      REAL TWISTS(6),TILTS(6),BULGES(6),CTOF
      EQUIVALENCE (TWISTS(1),REC6(1))
      EQUIVALENCE (TILTS(1),REC6(7))
      EQUIVALENCE (BULGES(1),REC6(13))
      EQUIVALENCE (CTOF,REC6(19))
C
      REAL YSCAL(6),CRAT(6)
      INTEGER MINI
      EQUIVALENCE (YSCAL(1),REC7(1))
      EQUIVALENCE (CRAT(1),REC7(7))
      EQUIVALENCE (MINI,REC7(13))
C
      INTEGER IMULTH(19)
      EQUIVALENCE (IMULTH(1),REC8(1))
C
      INTEGER IMH2(2),IWHIST(16),IVERS
      EQUIVALENCE (IMH2(1),REC9(1))
      EQUIVALENCE (IWHIST(1),REC9(3))
      EQUIVALENCE (IVERS,REC9(19))
C
      INTEGER IPACK,NSPOT,NMULT,NSPAT,NMSP,NNOD,NODH(12),ITGFLG
      EQUIVALENCE (IPACK,REC10(1))
      EQUIVALENCE (NSPOT,REC10(2))
      EQUIVALENCE (NMULT,REC10(3))
      EQUIVALENCE (NSPAT,REC10(4))
      EQUIVALENCE (NMSP,REC10(5))
      EQUIVALENCE (NNOD,REC10(6))
      EQUIVALENCE (NODH(1),REC10(7))
      EQUIVALENCE (ITGFLG,REC10(19))
C
      REAL X,Y,ALAM1,ALAM2,DMINTH
      INTEGER IESC
      EQUIVALENCE (X,REFBUF(1))
      EQUIVALENCE (Y,REFBUF(2))
      EQUIVALENCE (ALAM1,REFBUF(16))
      EQUIVALENCE (ALAM2,REFBUF(18))
      EQUIVALENCE (IESC,ALAM2)
      EQUIVALENCE (DMINTH,REFBUF(19))
C
      INTEGER MHKL(4),MFLGS,IH,IK,IL
      EQUIVALENCE (MFLGS,MHKL(1))
      EQUIVALENCE (IH,MHKL(2))
      EQUIVALENCE (IK,MHKL(3))
      EQUIVALENCE (IL,MHKL(4))
C
      INTEGER HKL2(4),IH2,IK2,IL2
      EQUIVALENCE (NIDX,HKL2(1))
      EQUIVALENCE (IH2,HKL2(2))
      EQUIVALENCE (IK2,HKL2(3))
      EQUIVALENCE (IL2,HKL2(4))
C
      INTEGER INTB(6),ISIGB(6),INTP(6),ISIGP(6)
C
      REAL BLAM
      EQUIVALENCE (BLAM,HARBUF(2))
C
C====== Initialisations
C
      TITLE = ' '
      CRYST = ' '
      DO 20 I = 1 , 19
         REC3(I) = 0.0
         REC4(I) = 0.0
         REC5(I) = 0.0
         REC6(I) = 0.0
         REC7(I) = 0.0
         REC8(I) = 0.0
         REC9(I) = 0.0
         REC10(I) = 0.0
 20   CONTINUE
      DO 30 I = 1 , 6
         FIDX(I) = 0.0
         FIDY(I) = 0.0
         OMEGA(I) = 0.0
 30   CONTINUE
      IUN = 1
      JUN = 2
      KUN = 3
      HDONLY = .FALSE.
      CMPRSS = .TRUE.
C
C====== Get required option
C
      CALL TRWSET(LUNSTI(0),LUNSTO(0),0,0,0)
 40   CALL TPROMP('Translate to ascii (t), from ascii (f)'//
     +            ' or print header (p) [t]: ')
      CALL TREAD(STR,QUIT)
      IF (QUIT) STOP
      LL = 0
      IOPT = 1
      I = NXTFLD(STR,80,LL,M1,M2)
      IF (I.GT.0) THEN
         CALL CCPUPC(STR)
         IF (STR(M1:M1).NE.'T' .AND. STR(M1:M1).NE.'F' .AND. STR(M1:M1)
     +       .NE.'P') THEN
            CALL TWRITE('**Error** Invalid option')
            GO TO 40
         END IF
         IF (STR(M1:M1).EQ.'P') HDONLY = .TRUE.
         IF (STR(M1:M1).EQ.'F') IOPT = 2
      END IF
 
      IF (IOPT.EQ.1) THEN
C
C====== Copy from .ge1/.ge2 files to ACSII files (or print header)
C====== ==========================================================
C
C
C====== Get compress option
C
         IF (.NOT.HDONLY) THEN
            CMPRSS = .TRUE.
            CALL TASKQ('Use compact form of output',CMPRSS,QUIT)
         END IF
C
C====== Get name of input .ge1/.ge2 files
C
 50      CALL TPROMP('Root name for input .ge1/.ge2 files: ')
         CALL TREAD(STR,QUIT)
         IF (QUIT) STOP
         CALL FILEXT(STR,'ge1',FILGE1,IEND)
         IF (.NOT.CCPEXS(FILGE1)) THEN
            CALL TWRITE('**Error** .ge1 file does not exist')
            GO TO 50
         END IF
         FILGE2 = FILGE1(1:IEND)//'.ge2'
         IF (.NOT.HDONLY) THEN
            IF (.NOT.CCPEXS(FILGE2)) THEN
               CALL TWRITE('**Error** .ge2 file does not exist')
               GO TO 50
            END IF
         END IF
         IFAIL = 0
         CALL CCPDPN(-IUN,FILGE1,'READONLY','DU',19,IFAIL)
         IF (.NOT.HDONLY) THEN
            IFAIL = 0
            CALL CCPDPN(-JUN,FILGE2,'READONLY','DU',2,IFAIL)
         END IF
C
C====== Get name of output file
C
 60      IF (HDONLY) THEN
            CALL TPROMP(
     +                'Name of output listing file (default ext=.lis): '
     +                )
         ELSE
            CALL TPROMP(
     +                'Name of output ascii file (default ext=.geasc): '
     +                )
         END IF
         CALL TREAD(STR,QUIT)
         IF (QUIT) STOP
         IF (HDONLY) THEN
            CALL FILEXT(STR,'lis',FILASC,I)
         ELSE
            CALL FILEXT(STR,'geasc',FILASC,I)
         END IF
         IFAIL = 0
         CALL CCPDPN(-KUN,FILASC,'NEW','F',0,IFAIL)
         IF (IFAIL.NE.0) THEN
            CALL TWRITE('**Error** Unable to open output file')
            GO TO 60
         END IF
C
C====== Read and write header data
C
         READ (IUN,REC=1) TITLE
         WRITE (KUN,6010)
         WRITE (KUN,6020) TITLE
         READ (IUN,REC=2) CRYST , FIDX , FIDY , (OMEGA(I),I=1,5)
         WRITE (KUN,6030) CRYST(1:6)
         WRITE (KUN,6040) FIDX
         WRITE (KUN,6050) FIDY
         READ (IUN,REC=3) REC3
         OMEGA(6) = REC3(1)
         WRITE (KUN,6060) OMEGA
         CALL CCPI2I(ISL,ISYLAT,2,.TRUE.,.FALSE.)
         ISYS = ISL(1)
         ILAT = ISL(2)
         CALL CELLCX(ISYS,CELL,VALUES,1,2)
         WRITE (KUN,6070) (VALUES(I),I=1,6)
         WRITE (KUN,6080) ISYS , ILAT , IAXX , IAXZ
         READ (IUN,REC=4) REC4
         WRITE (KUN,6090) RASTER
         WRITE (KUN,6100) IBOX
         WRITE (KUN,6110) PHIS
         WRITE (KUN,6120) WSTD , WMIN , WMAX
         WRITE (KUN,6130) DMIN
         WRITE (KUN,6140) FILMR
         WRITE (KUN,6150) SPINDL
         READ (IUN,REC=5) REC5
         WRITE (KUN,6160) XC
         WRITE (KUN,6170) YC
         WRITE (KUN,6180) WC
         WRITE (KUN,6190) DELTA
         READ (IUN,REC=6) REC6
         WRITE (KUN,6200) TWISTS
         WRITE (KUN,6210) TILTS
         WRITE (KUN,6220) BULGES
         WRITE (KUN,6230) CTOF
         READ (IUN,REC=7) REC7
         WRITE (KUN,6240) YSCAL
         WRITE (KUN,6250) CRAT
         WRITE (KUN,6260) MINI
         READ (IUN,REC=8) REC8
         READ (IUN,REC=9) REC9
         WRITE (KUN,6270)
         WRITE (KUN,6280) (IMULTH(I),I=1,10)
         WRITE (KUN,6280) (IMULTH(I),I=11,19) , IMH2(1)
         WRITE (KUN,6280) IMH2(2)
         WRITE (KUN,6290)
         WRITE (KUN,6300) (IWHIST(I),I=1,8)
         WRITE (KUN,6300) (IWHIST(I),I=9,16)
         WRITE (KUN,6310) IVERS
         READ (IUN,REC=10) REC10
         WRITE (KUN,6320) IPACK
         WRITE (KUN,6330) NSPOT , NMULT , NSPAT , NMSP , NNOD
         WRITE (KUN,6340)
         WRITE (KUN,6350) NODH
         WRITE (KUN,6360) ITGFLG
         IF (HDONLY) THEN
            CALL TWRITE('*Header translation complete*')
            CLOSE (UNIT=IUN)
            CLOSE (UNIT=KUN)
            STOP
         END IF
C
C====== Write reflection data
C
         WRITE (KUN,6420) NSPOT
         LAST = 0
         OPSTR = ' '
         NUMGE2 = 0
         MAXREC = 10 + NSPOT
         IREC = 10
 70      IREC = IREC + 1
         IF (IREC.GT.MAXREC) THEN
            IF (CMPRSS) THEN
               IF (LAST.GT.0) WRITE (KUN,6480) OPSTR(1:LAST)
            END IF
            WRITE (KUN,6430)
         ELSE
            READ (IUN,REC=IREC) REFBUF
            CALL CCPI2I(INTB,REFBUF(3),6,.TRUE.,.FALSE.)
            CALL CCPI2I(ISIGB,REFBUF(6),6,.TRUE.,.FALSE.)
            CALL CCPI2I(INTP,REFBUF(9),6,.TRUE.,.FALSE.)
            CALL CCPI2I(ISIGP,REFBUF(12),6,.TRUE.,.FALSE.)
            CALL CCPBYI(MHKL,REFBUF(15),-4)
            CALL CCPBYI(HKL2,REFBUF(17),-4)
            MULT = NBITST(MFLGS,0,5)
            NODFLG = NBITST(MFLGS,5,1)
            IOVLP = NBITST(MFLGS,6,1)
            ICLOS = NBITST(MFLGS,7,1)
            IESCAP = 0
            ALAMB2 = 0.0
            IF (MULT.GT.2) THEN
               IESCAP = IESC
               NUMGE2 = NUMGE2 + MULT - 1
            ELSE
               ALAMB2 = ALAM2
            END IF
            IF (CMPRSS) THEN
               WRITE (STR2,6410) IH , IK , IL , X , Y , ALAM1 , MULT , 
     +                           NODFLG , IOVLP , ICLOS , IH2 , IK2 , 
     +                           IL2 , NIDX , ALAMB2 , IESCAP , DMINTH , 
     +                           INTB , ISIGB , INTP , ISIGP
               LL = 0
 80            I = NXTFLD(STR2,310,LL,M1,M2)
               IF (I.GT.0) THEN
                  IF (LAST.GT.0) THEN
                     LAST = LAST + 1
                     OPSTR(LAST:LAST) = ' '
                  END IF
                  DO 90 M = M1 , M2
                     LAST = LAST + 1
                     OPSTR(LAST:LAST) = STR2(M:M)
 90               CONTINUE
                  GO TO 80
               END IF
 100           IF (LAST.LE.80) GO TO 70
               DO 110 I = 80 , 1 , -1
                  II = I
                  IF (OPSTR(I:I).NE.' ') THEN
                     IF (OPSTR(I+1:I+1).EQ.' ') GO TO 120
                  END IF
 110           CONTINUE
               II = 1
 120           WRITE (KUN,6480) OPSTR(1:II)
               START = .FALSE.
               J = 0
               DO 130 I = II + 1 , LAST
                  IF (.NOT.(.NOT.START .AND. OPSTR(I:I).EQ.' ')) THEN
                     J = J + 1
                     OPSTR(J:J) = OPSTR(I:I)
                     START = .TRUE.
                  END IF
 130           CONTINUE
               LAST = J
               GO TO 100
            ELSE
               WRITE (KUN,6370) IH , IK , IL , X , Y , ALAM1 , MULT , 
     +                          NODFLG , IOVLP , ICLOS , IH2 , IK2 , 
     +                          IL2 , NIDX
               WRITE (KUN,6380) ALAMB2 , IESCAP , DMINTH
               WRITE (KUN,6390) INTB , ISIGB
               WRITE (KUN,6400) INTP , ISIGP
               GO TO 70
            END IF
         END IF
         CLOSE (UNIT=IUN)
C
C====== Write harmonics data
C
         WRITE (KUN,6440) NUMGE2
         LAST = 0
         IF (NUMGE2.GT.0) THEN
            DO 200 IREC = 1 , NUMGE2
               READ (JUN,REC=IREC) HARBUF
               CALL CCPBYI(MHKL,HARBUF(1),-4)
               IF (CMPRSS) THEN
                  WRITE (STR2,6450) IH , IK , IL , BLAM
                  LL = 0
 140              I = NXTFLD(STR2,30,LL,M1,M2)
                  IF (I.GT.0) THEN
                     IF (LAST.GT.0) THEN
                        LAST = LAST + 1
                        OPSTR(LAST:LAST) = ' '
                     END IF
                     DO 150 M = M1 , M2
                        LAST = LAST + 1
                        OPSTR(LAST:LAST) = STR2(M:M)
 150                 CONTINUE
                     GO TO 140
                  END IF
 160              IF (LAST.GT.80) THEN
                     DO 170 I = 80 , 1 , -1
                        II = I
                        IF (OPSTR(I:I).NE.' ') THEN
                           IF (OPSTR(I+1:I+1).EQ.' ') GO TO 180
                        END IF
 170                 CONTINUE
                     II = 1
 180                 WRITE (KUN,6480) OPSTR(1:II)
                     START = .FALSE.
                     J = 0
                     DO 190 I = II + 1 , LAST
                        IF (.NOT.(.NOT.START .AND. OPSTR(I:I).EQ.' '))
     +                      THEN
                           J = J + 1
                           OPSTR(J:J) = OPSTR(I:I)
                           START = .TRUE.
                        END IF
 190                 CONTINUE
                     LAST = J
                     GO TO 160
                  END IF
               ELSE
                  WRITE (KUN,6460) IH , IK , IL , BLAM
               END IF
 200        CONTINUE
         END IF
         IF (CMPRSS .AND. LAST.GT.0) THEN
            WRITE (KUN,6480) OPSTR(1:LAST)
         END IF
         WRITE (KUN,6470)
         CLOSE (UNIT=JUN)
         CLOSE (UNIT=KUN)
         CALL TWRITE('*File translation completed*')
         STOP
C
C====== Copy from ASCII files to binary .ge1/.ge2 files
C====== ===============================================
C
      ELSE
C
C====== Get name of input file
C
 210     CALL TPROMP('Name of input ascii file (default ext=.geasc): ')
         CALL TREAD(STR,QUIT)
         IF (QUIT) STOP
         CALL FILEXT(STR,'geasc',FILASC,I)
         IF (.NOT.CCPEXS(FILASC)) THEN
            CALL TWRITE('**Error** File does not exist')
            GO TO 210
         END IF
         IFAIL = 0
         CALL CCPDPN(-KUN,FILASC,'READONLY','F',0,IFAIL)
         IF (IFAIL.NE.0) THEN
            CALL TWRITE('**Error** Unable to open input file')
            GO TO 210
         END IF
C
C====== Get names of output files
C
 220     CALL TPROMP('Root name for output .ge1/.ge2 files: ')
         CALL TREAD(STR,QUIT)
         IF (QUIT) STOP
         CALL FILEXT(STR,'ge1',FILGE1,IEND)
         FILGE2 = FILGE1(1:IEND)//'.ge2'
         IFAIL = 0
         CALL CCPDPN(-IUN,FILGE1,'NEW','DU',19,IFAIL)
         IF (IFAIL.NE.0) THEN
            CALL TWRITE('**Error** Unable to open output .ge1 file')
            GO TO 220
         END IF
         IFAIL = 0
         CALL CCPDPN(-JUN,FILGE2,'NEW','DU',2,IFAIL)
         IF (IFAIL.NE.0) THEN
            CALL TWRITE('**Error** Unable to open output .ge2 file')
            CLOSE (UNIT=IUN)
            GO TO 220
         END IF
C
C====== Read and write header data
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'TITL',LL,M2)
         READ (KUN,6480,END=360) TITLE
         WRITE (IUN,REC=1) TITLE
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'CRYS',LL,M2)
         K = M2 + 1
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.GT.0) K = M1
         CRYST = TEXT(K:K+5)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'FIDX',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,FIDX,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after FIDX keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'FIDY',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,FIDY,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after FIDY keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'OMEG',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,OMEGA,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after OMEG keyword'
     +                  )
            STOP
         END IF
         WRITE (IUN,REC=2) CRYST , FIDX , FIDY , (OMEGA(I),I=1,5)
C
         REC3(1) = OMEGA(6)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'CELL',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,CELLP,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after CELL keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'SYST',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',20,VALUES,NVALS)
         IF (NVALS.NE.4) THEN
            CALL TWRITE('**Error** 4 values expected after SYST keyword'
     +                  )
            STOP
         END IF
         ISYS = NINT(VALUES(1))
         ILAT = NINT(VALUES(2))
         ISL(1) = ISYS
         ISL(2) = ILAT
         CALL CCPII2(ISYLAT,ISL,2,.TRUE.,.FALSE.)
         IAXX = NINT(VALUES(3))
         IAXZ = NINT(VALUES(4))
         CALL CELLCX(ISYS,CELL,CELLP,2,2)
         WRITE (IUN,REC=3) REC3
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'RAST',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after RAST keyword')
            STOP
         END IF
         RASTER = VALUES(1)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'IBOX',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.5) THEN
            CALL TWRITE('**Error** 5 values expected after IBOX keyword'
     +                  )
            STOP
         END IF
         DO 230 I = 1 , 5
            IBOX(I) = NINT(VALUES(I))
 230     CONTINUE
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'PHIS',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',3,PHIS,NVALS)
         IF (NVALS.NE.3) THEN
            CALL TWRITE('**Error** 3 values expected after PHIS keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'LAMS',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.3) THEN
            CALL TWRITE('**Error** 3 values expected after LAMS keyword'
     +                  )
            STOP
         END IF
         WSTD = VALUES(1)
         WMIN = VALUES(2)
         WMAX = VALUES(3)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'DMIN',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after DMIN keyword')
            STOP
         END IF
         DMIN = VALUES(1)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'RADI',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after RADI keyword')
            STOP
         END IF
         FILMR = VALUES(1)
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'SPIN',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after SPIN keyword')
            STOP
         END IF
         SPINDL = VALUES(1)
         WRITE (IUN,REC=4) REC4
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'XC_S',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,XC,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after XC_S keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'YC_S',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,YC,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after YC_S keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'WC_S',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,WC,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after WC_S keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'DELT',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after DELT keyword')
            STOP
         END IF
         DELTA = VALUES(1)
         WRITE (IUN,REC=5) REC5
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'TWIS',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,TWISTS,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after TWIS keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'TILT',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,TILTS,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after TILT keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'BULG',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,BULGES,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after BULG keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'CTOF',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after CTOF keyword')
            STOP
         END IF
         CTOF = VALUES(1)
         WRITE (IUN,REC=6) REC6
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'YSCA',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,YSCAL,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after YSCA keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'CRAT',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',6,CRAT,NVALS)
         IF (NVALS.NE.6) THEN
            CALL TWRITE('**Error** 6 values expected after CRAT keyword'
     +                  )
            STOP
         END IF
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'MINI',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after MINI keyword')
            STOP
         END IF
         MINI = NINT(VALUES(1))
         WRITE (IUN,REC=7) REC7
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'MULT',LL,M2)
         NV = 0
         K = 1
 240     CALL STRVAL(TEXT(M2+1:),' ',50,VALUES(K),NVALS)
         NV = NV + NVALS
         K = K + NVALS
         IF (NV.LT.21) THEN
            READ (KUN,6480,END=360) TEXT
            M2 = 0
            GO TO 240
         END IF
         IF (NV.NE.21) THEN
            CALL TWRITE(
     +          '**Error** 21 values expected in multiplicity histogram'
     +          )
            STOP
         END IF
         DO 250 I = 1 , 19
            IMULTH(I) = NINT(VALUES(I))
 250     CONTINUE
         IMH2(1) = NINT(VALUES(20))
         IMH2(2) = NINT(VALUES(21))
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'LAMH',LL,M2)
         NV = 0
         K = 1
 260     CALL STRVAL(TEXT(M2+1:),' ',50,VALUES(K),NVALS)
         NV = NV + NVALS
         K = K + NVALS
         IF (NV.LT.16) THEN
            READ (KUN,6480,END=360) TEXT
            M2 = 0
            GO TO 260
         END IF
         IF (NV.NE.16) THEN
            CALL TWRITE(
     +            '**Error** 16 values expected in wavelength histogram'
     +            )
            STOP
         END IF
         DO 270 I = 1 , 16
            IWHIST(I) = NINT(VALUES(I))
 270     CONTINUE
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'VERS',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after VERS keyword')
            STOP
         END IF
         IVERS = NINT(VALUES(1))
         WRITE (IUN,REC=8) REC8
         WRITE (IUN,REC=9) REC9
C
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'PACK',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after PACK keyword')
            STOP
         END IF
         IPACK = NINT(VALUES(1))
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'NSPT',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.5) THEN
            CALL TWRITE('**Error** 5 values expected after NSPT keyword'
     +                  )
            STOP
         END IF
         NSPOT = NINT(VALUES(1))
         NMULT = NINT(VALUES(2))
         NSPAT = NINT(VALUES(3))
         NMSP = NINT(VALUES(4))
         NNOD = NINT(VALUES(5))
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'NODH',LL,M2)
         NV = 0
         K = 1
 280     CALL STRVAL(TEXT(M2+1:),' ',50,VALUES(K),NVALS)
         NV = NV + NVALS
         K = K + NVALS
         IF (NV.LT.12) THEN
            READ (KUN,6480,END=360) TEXT
            M2 = 0
            GO TO 280
         END IF
         IF (NV.NE.12) THEN
            CALL TWRITE(
     +                '**Error** 12 values expected in nodals histogram'
     +                )
            STOP
         END IF
         DO 290 I = 1 , 12
            NODH(I) = NINT(VALUES(I))
 290     CONTINUE
         READ (KUN,6480,END=360) TEXT
         CALL CHKKEY(TEXT,'INTF',LL,M2)
         CALL STRVAL(TEXT(M2+1:),' ',10,VALUES,NVALS)
         IF (NVALS.NE.1) THEN
            CALL TWRITE('**Error** 1 value expected after INTF keyword')
            STOP
         END IF
         ITGFLG = NINT(VALUES(1))
         WRITE (IUN,REC=10) REC10
C
C====== Read and write reflection data
C
         READ (KUN,6480,END=360) TEXT
         LL = 0
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE('**Error** REFLECTION DATA heading expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (TEXT(M1:M2).NE.'REFLECTION') THEN
            CALL TWRITE('**Error** REFLECTION DATA heading expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         I = NXTFLD(TEXT,80,LL,M1,M2)
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE('**Error** Count expected after REFLECTION DATA'
     +                  )
            CALL TWRITE(TEXT)
            STOP
         END IF
         NREFL = INTVAL(TEXT(M1:M2),ERR)
         IF (ERR) THEN
            CALL TWRITE('**Error** Invalid syntax for reflection count')
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (NREFL.NE.NSPOT) THEN
            CALL TWRITE(
     +               '**Error** Reflection count inconsistent with NSPT'
     +               )
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (NREFL.EQ.0) STOP
         TEXT = ' '
         SAVTEX = ' '
         LL = 80
         IREC = 10
         DO 340 IREF = 1 , NREFL
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IH = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('H',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IK = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('K',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IL = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('L',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            X = FLPVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('X',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            Y = FLPVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('Y',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            ALAM1 = FLPVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('LAMBDA1',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            MULT = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('MULT',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            NODFLG = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('NODAL FLAG',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IOVLP = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('OVERLAP FLAG',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            ICLOS = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('CLOSE FLAG',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IH2 = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('H2',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IK2 = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('K2',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IL2 = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('L2',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            NIDX = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('NODAL INDEX',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            ALAMB2 = FLPVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('LAMBDA2',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IESCAP = INTVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('ESCAPE POINTER',TEXT(M1:M2),IREF,1)
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            DMINTH = FLPVAL(TEXT(M1:M2),ERR)
            IF (ERR) CALL ITMERR('DMINTH',TEXT(M1:M2),IREF,1)
            DO 300 I = 1 , 6
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               INTB(I) = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('INTB',TEXT(M1:M2),IREF,1)
 300        CONTINUE
            DO 310 I = 1 , 6
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               ISIGB(I) = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('ISIGB',TEXT(M1:M2),IREF,1)
 310        CONTINUE
            DO 320 I = 1 , 6
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               INTP(I) = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('INTP',TEXT(M1:M2),IREF,1)
 320        CONTINUE
            DO 330 I = 1 , 6
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               ISIGP(I) = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('ISIGP',TEXT(M1:M2),IREF,1)
 330        CONTINUE
            CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
            IF (TEXT(M1:M2).NE.'*') THEN
               CALL TWRITE('**Error** Reflection separator * expected')
               CALL TWRITE(TEXT(M1:M2))
               STOP
            END IF
            IF (IESCAP.GT.0) THEN
               IESC = IESCAP
            ELSE
               ALAM2 = ALAMB2
            END IF
            MFLGS = 0
            CALL STBITS(MFLGS,0,5,MULT)
            IF (NODFLG.NE.0) CALL STBITS(MFLGS,5,1,1)
            IF (IOVLP.NE.0) CALL STBITS(MFLGS,6,1,1)
            IF (ICLOS.NE.0) CALL STBITS(MFLGS,7,1,1)
            CALL CCPII2(REFBUF(3),INTB,6,.TRUE.,.FALSE.)
            CALL CCPII2(REFBUF(6),ISIGB,6,.TRUE.,.FALSE.)
            CALL CCPII2(REFBUF(9),INTP,6,.TRUE.,.FALSE.)
            CALL CCPII2(REFBUF(12),ISIGP,6,.TRUE.,.FALSE.)
            CALL CCPIBY(REFBUF(15),MHKL,-4)
            CALL CCPIBY(REFBUF(17),HKL2,-4)
            IREC = IREC + 1
            WRITE (IUN,REC=IREC) REFBUF
 340     CONTINUE
         READ (KUN,6480,END=360) TEXT
         LL = 0
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE(
     +                '**Error** END-OF-REFLECTION-DATA marker expected'
     +                )
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (TEXT(M1:M2).NE.'END-OF-REFLECTION-DATA') THEN
            CALL TWRITE(
     +                '**Error** END-OF-REFLECTION-DATA marker expected'
     +                )
            CALL TWRITE(TEXT)
            STOP
         END IF
C
C====== Read and write harmonics data
C
         READ (KUN,6480,END=360) TEXT
         LL = 0
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE('**Error** HARMONICS DATA heading expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (TEXT(M1:M2).NE.'HARMONICS') THEN
            CALL TWRITE('**Error** HARMONICS DATA heading expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         I = NXTFLD(TEXT,80,LL,M1,M2)
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE('**Error** Count expected after HARMONICS DATA')
            CALL TWRITE(TEXT)
            STOP
         END IF
         NHARM = INTVAL(TEXT(M1:M2),ERR)
         IF (ERR) THEN
            CALL TWRITE('**Error** Invalid syntax for harmonics count')
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (NHARM.GT.0) THEN
            TEXT = ' '
            SAVTEX = ' '
            LL = 80
            MFLGS = 0
            DO 350 IREF = 1 , NHARM
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               IH = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('H',TEXT(M1:M2),IREF,2)
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               IK = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('K',TEXT(M1:M2),IREF,2)
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               IL = INTVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('L',TEXT(M1:M2),IREF,2)
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               BLAM = FLPVAL(TEXT(M1:M2),ERR)
               IF (ERR) CALL ITMERR('LAMBDA',TEXT(M1:M2),IREF,2)
               CALL CCPIBY(HARBUF(1),MHKL,-4)
               WRITE (JUN,REC=IREF) HARBUF
               CALL NXTITM(TEXT,SAVTEX,LL,M1,M2,KUN)
               IF (TEXT(M1:M2).NE.'*') THEN
                  CALL TWRITE('**Error** Harmonics separator * expected'
     +                        )
                  CALL TWRITE(TEXT(M1:M2))
                  STOP
               END IF
 350        CONTINUE
         END IF
         CLOSE (UNIT=IUN)
         CLOSE (UNIT=JUN)
         READ (KUN,6480,END=360) TEXT
         LL = 0
         I = NXTFLD(TEXT,80,LL,M1,M2)
         IF (I.EQ.0) THEN
            CALL TWRITE('**Error** END-OF-FILE marker expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         IF (TEXT(M1:M2).NE.'END-OF-FILE') THEN
            CALL TWRITE('**Error** END-OF-FILE marker expected')
            CALL TWRITE(TEXT)
            STOP
         END IF
         CLOSE (UNIT=KUN)
         CALL TWRITE('*File translation completed*')
      END IF
      STOP
C
C====== Error on reads
C
 360  CALL TWRITE('**Error** Premature end of file reading ascii file')
      STOP
C
C====== Format statements
C
 6010 FORMAT ('TITL')
 6020 FORMAT (A)
 6030 FORMAT ('CRYS ',A)
 6040 FORMAT ('FIDX ',6F12.4)
 6050 FORMAT ('FIDY ',6F12.4)
 6060 FORMAT ('OMEG ',6F12.4)
 6070 FORMAT ('CELL ',6F12.6)
 6080 FORMAT ('SYST ',4I4)
 6090 FORMAT ('RAST ',F10.3)
 6100 FORMAT ('IBOX ',5I4)
 6110 FORMAT ('PHIS ',3F10.3)
 6120 FORMAT ('LAMS ',3F10.3)
 6130 FORMAT ('DMIN ',F10.3)
 6140 FORMAT ('RADI ',F10.3)
 6150 FORMAT ('SPIN ',F10.3)
 6160 FORMAT ('XC_S ',6F12.5)
 6170 FORMAT ('YC_S ',6F12.5)
 6180 FORMAT ('WC_S ',6F12.5)
 6190 FORMAT ('DELT ',F12.4)
 6200 FORMAT ('TWIS ',6F12.5)
 6210 FORMAT ('TILT ',6F12.5)
 6220 FORMAT ('BULG ',6F12.5)
 6230 FORMAT ('CTOF ',F10.3)
 6240 FORMAT ('YSCA ',6F12.5)
 6250 FORMAT ('CRAT ',6F12.5)
 6260 FORMAT ('MINI ',I12)
 6270 FORMAT ('MULT ')
 6280 FORMAT (10I8)
 6290 FORMAT ('LAMH ')
 6300 FORMAT (8I8)
 6310 FORMAT ('VERS ',I4)
 6320 FORMAT ('PACK ',I8)
 6330 FORMAT ('NSPT ',5I8)
 6340 FORMAT ('NODH ')
 6350 FORMAT (6I8)
 6360 FORMAT ('INTF ',I8)
 6370 FORMAT (3I5,3G12.4,I3,3I2,4I5)
 6380 FORMAT (G12.4,I6,G12.4)
 6390 FORMAT (6I7,6I6)
 6400 FORMAT (6I7,6I6,' *')
 6410 FORMAT (3I5,3G12.4,I3,3I2,4I5,G12.4,I6,G12.4,24I8,' *')
 6420 FORMAT ('REFLECTION DATA',I7,' REFLECTIONS')
 6430 FORMAT ('END-OF-REFLECTION-DATA')
 6440 FORMAT ('HARMONICS DATA',I7,' REFLECTIONS')
 6450 FORMAT (3I5,G12.4,' *')
 6460 FORMAT (3I5,G12.4,' *')
 6470 FORMAT ('END-OF-FILE')
C
 6480 FORMAT (A)
      END
**==cellcx.f
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CELLCX        **
C*************************
C
C Purpose: Convert between expanded and contracted form of cell params
C
      SUBROUTINE CELLCX(MSYS,CELLC,CELLX,IT,ICTYP)
C
C PARAMETERS
C
C        MSYS (I)       CRYSTAL SYSTEM 1-7
C       CELLC (I OR O)  CONTRACTED FORM OF CELL PARAMETERS (1-6 VALS)
C       CELLX (O OR I)  EXPANDED FORM OF CELL PARAMETERS (6 VALUES)
C          IT (I)       =1 CONVERT FROM CONTRACTED TO EXPANDED
C                       =2 CONVERT FROM EXPANDED TO CONTRACTED
C       ICTYP (I)       CELL TYPE =1 REAL, =2 RECIPROCAL
C
C
      REAL CELLC(6),CELLX(6)
C
C-------------------------------------------------------------------------------
C
      IF (IT.EQ.1) THEN
         IF (MSYS.EQ.1) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = CELLC(4)
            CELLX(5) = CELLC(5)
            CELLX(6) = CELLC(6)
            RETURN
         ELSE IF (MSYS.EQ.2) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = 90.0
            CELLX(5) = CELLC(4)
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.3) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.4) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(2)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.5) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(2)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 120.0
            IF (ICTYP.EQ.2) CELLX(6) = 60.0
            RETURN
         ELSE IF (MSYS.EQ.6) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(1)
            CELLX(4) = CELLC(2)
            CELLX(5) = CELLC(2)
            CELLX(6) = CELLC(2)
            RETURN
         ELSE IF (MSYS.EQ.7) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(1)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         END IF
         RETURN
      END IF
      IF (IT.EQ.2) THEN
         DO 20 I = 1 , 6
            CELLC(I) = 0.0
 20      CONTINUE
         IF (MSYS.EQ.1) THEN
            DO 30 I = 1 , 6
               CELLC(I) = CELLX(I)
 30         CONTINUE
            RETURN
         ELSE IF (MSYS.EQ.2) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(2)
            CELLC(3) = CELLX(3)
            CELLC(4) = CELLX(5)
            RETURN
         ELSE IF (MSYS.EQ.3) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(2)
            CELLC(3) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.4) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.5) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.6) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(4)
            RETURN
         ELSE IF (MSYS.EQ.7) THEN
            CELLC(1) = CELLX(1)
            RETURN
         END IF
      END IF
      RETURN
      END
**==chkkey.f
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C***********************
C**      CHKKEY       **
C***********************
C
      SUBROUTINE CHKKEY(TEXT,KEY,IL,M2)
C
      CHARACTER*(*) TEXT
      CHARACTER*4 KEY
      INTEGER M2
C
C====== LOCALS
C
      INTEGER M1
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      IL = 0
      I = NXTFLD(TEXT,LEN(TEXT),IL,M1,M2)
      IF (I.LE.0) THEN
         WRITE (STR,6010) KEY
         CALL TWRITE(STR)
         CALL TWRITE(TEXT)
         STOP
      END IF
      IF (TEXT(M1:M1+3).NE.KEY) THEN
         WRITE (STR,6010) KEY
         CALL TWRITE(STR)
         CALL TWRITE(TEXT)
         STOP
      END IF
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('**Error** Keyword ''',A4,''' expected')
      END
**==nxtfld.f
C
C FUNCTION 'NXTFLD'
C =================
C
C GET NEXT FIELD FROM A CHARACTER STRING
C
      FUNCTION NXTFLD(TXT,MAXTXT,IL,M1,M2)
C
C PARAMETERS
C
C         TXT (I)   The input character string
C      MAXTXT (I)   The length of the character string to be searched
C          IL (I/O) The last character currently examined. This should
C                   be set to 0 for the first call
C          M1 (O)   The start of the new field (0 if none)
C          M2 (O)   The end of the field
C
C RETURN 0=blank field (no more left); >0 = no. of chars in the field
C
C SPECIFICATION STATEMENTS
C ========================
C
      CHARACTER*(*) TXT
C
C CODE
C ====
C
      NXTFLD = 0
      M1 = 0
      M2 = 0
 20   IL = IL + 1
      IF (IL.GT.MAXTXT) RETURN
      IF (TXT(IL:IL).EQ.' ') GO TO 20
      M1 = IL
 30   M2 = IL
      NXTFLD = NXTFLD + 1
      IL = IL + 1
      IF (IL.GT.MAXTXT) RETURN
      IF (TXT(IL:IL).NE.' ') GO TO 30
      RETURN
      END
**==nxtitm.f
C
C SUBROUTINE 'NXTITM'
C ===================
C
C GET NEXT FIELD FOR PROGRAM 'EXCHGE' READING NEXT RCORD WHEN NEEDED
C
      SUBROUTINE NXTITM(TXT,SAVTEX,IL,M1,M2,KUN)
C
C PARAMETERS
C
C         TXT (I/O) The input character string (80 chars)
C      SAVTEX (I/O) Previously read text buffer
C          IL (I/O) The last character currently examined.
C          M1 (O)   The start of the new field (0 if none)
C          M2 (O)   The end of the field
C         KUN (I)   Unit for reading next record if needed
C
C
C SPECIFICATION STATEMENTS
C ========================
C
      CHARACTER*(*) TXT
      CHARACTER*(*) SAVTEX
C
C CODE
C ====
C
 20   IL = IL + 1
      IF (IL.GT.80) THEN
         READ (KUN,6010,END=40) TXT
         SAVTEX = TXT
         IL = 0
         GO TO 20
      END IF
      IF (TXT(IL:IL).EQ.' ') GO TO 20
      M1 = IL
 30   M2 = IL
      IL = IL + 1
      IF (IL.GT.80) RETURN
      IF (TXT(IL:IL).NE.' ') GO TO 30
      RETURN
C
C ERROR
C -----
C
 40   CALL TWRITE('**Error** Premature end of file reading ascii data')
      CALL TWRITE('Last line read:')
      CALL TWRITE(SAVTEX)
      STOP
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (A)
      END
**==intval.f
C
C FUNCTION 'INTVAL'
C =================
C
C GET INTEGER VALUE FROM A CHARACTER STRING/SUBSTRING
C (ASSUMES NO LEADING/TRAILING BLANKS)
C
      FUNCTION INTVAL(STR,ERR)
C
C PARAMETERS
C
C       STR (I)  CHARACTER STRING CONTAINING THE INTEGER VALUE
C       ERR (O)  ERROR FLAG =.TRUE. syntax error, =.FALSE. OK
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*(*) STR
      LOGICAL ERR
C
C CODE
C ----
C
      ISIGN = 1
      LL = LEN(STR)
      INTVAL = 0
      ERR = .FALSE.
      DO 20 L = 1 , LL
         I = INDEX('0123456789+-',STR(L:L))
         IF (I.EQ.0) THEN
            ERR = .TRUE.
            INTVAL = 0
            RETURN
         END IF
         IF (I.LT.11) THEN
            INTVAL = 10*INTVAL + I - 1
         ELSE IF (L.NE.1) THEN
            ERR = .TRUE.
            INTVAL = 0
            RETURN
         ELSE
            IF (I.EQ.12) ISIGN = -1
         END IF
 20   CONTINUE
      INTVAL = ISIGN*INTVAL
      RETURN
      END
**==itmerr.f
C
C SUBROUTINE 'ITMERR'
C ===================
C
C ERROR MESSAGE FOR SYNTAX ERROR WHEN READING AN ITEM
C
      SUBROUTINE ITMERR(NAME,STR,IREF,ITYP)
C
C PARAMETERS
C
C        NAME (I)   Item name for error message
C         STR (I)   Invalid string found
C        IREF (I)   Reflection number
C        ITYP (I)   =1 reflection data, =2 harmonic data
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*(*) NAME,STR
      CHARACTER*120 TMP
C
C CODE
C ----
C
      IF (ITYP.EQ.1) THEN
         CALL TWRITE('**Error** Syntax error in reflection data')
      ELSE
         CALL TWRITE('**Error** Syntax error in harmonics data')
      END IF
      WRITE (TMP,6010) IREF
      CALL TWRITE(TMP(1:LENSTR(TMP)))
      WRITE (TMP,6020) NAME , STR
      CALL TWRITE(TMP(1:LENSTR(TMP)))
      STOP
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT ('Error is in reflection number',I7)
 6020 FORMAT ('Item name: ',A,'     Invalid value: ',A)
      END
