      PROGRAM LEPAGE
* **********************************************************************
*                                                                      *
*     PROGRAM TO DETERMINE THE METRICAL SYMMETRY OF A GIVEN LATTICE    *
*     =============================================================    *
*                                                                      *
*           PC/BASIC,  VERSION  22/04/85, UTRECHT, A.L. SPEK.          *
*                        UPDATE 26/09/85, 02/04/88, 09/05/88,          *
*                                                                      *
*     CONVERTED TO  FORTRAN V,                                         *
*                                                                      *
*                    VERSION 21/08/85, GRONINGEN, A. MEETSMA.          *
*                     UPDATE 31/10/85, 03/12/85, 04/05/87, 19/05/87.   *
*                                                                      *
*    INTERACTIVE VERSION (FREE FORMAT INPUT)    14/12/87.              *
*                        UPDATE 25/02/88.                              *
*     WITH SUB AND SUPER CELLS:     28/04/88, 11/05/88.                *
*                                                                      *
*     UNIX-VERSION - UTRECHT - 1991 - A.L. SPEK                        *
* **********************************************************************
*                                                                      *
*  G(3,3)     -  METRICAL MATRIX OF DIRECT CELL                        *
*  OR(3,3)    -  [T] = [OR] [U]; DIRECT SPACE ORTHOGONALILSATION       *
*  ROT(3,3)   -  [TAU] = [ROT][H]; RECIPROCAL SPACE ORTHOGONALISATION  *
*                (IN PROGRAM U AND H ARE IN(K,1-3) AND IN(J,1-3), RESP *
*  TM(3,3,127)-  TABLE WITH TRANSFORMATION MATRICES IN CELL REDUCTION  *
*             -  SUPER CELL AND SUB CELL LATTICES                      *
*  TMX(3,3,8) -   TABLE WITH TRANSFORMATION MATRICES SAVED             *
*             -  CENTERED TO PRIMITIVE CELL TRANSFORMATION             *
*  TP(3,3)    -  ACCUMALATED TRANSFORMATION                            *
*  TPS(3,3)   -  SAVED INPUT TO REDUCED CELL                           *
* **********************************************************************
*                                                                      *
*   TEST DATA IS GIVEN ON TAPE1.                                       *
*                                                                      *
*   INPUT CAN BE GIVEN ON TAPE2 OR/AND INTERACTIVE (TAPE5):            *
*       A, B, C, ALFA, BETA, GAMMA AND NR.                             *
*   -  NR IS A NUMBER CORRESPONDING WITH CELL TYPE:  1, 2, 3, 4, 5, 6, *
*      7, 8, FOR P, I, R, F, A, B, C AND X, RESPECTIVELY               *
*      IF TYPE X(=8), THEN THE NINE ELEMENTS OF TP(I,J) SHOULD         *
*      FOLLOW ON A --TRMX-- INSTRUCTION.                               *
*      IF B .EQ. A OR C .EQ. B THAN B AND/OR C MAY BE INPUT AS 0       *
*      IF ALFA, BETA, OR GAMMA .EQ. 90 DEGREE THEN INPUT MAY BE 0      *
*                                                                      *
*                                                                      *
*   -  A POSSIBLE HARDCOPY PRINT IS PROVIDED BY THE CCL PROCEDURE      *
* **********************************************************************
*                                                                      *
*      DEFAULT VALUES:                                                 *
*      --------------                                                  *
*   -  CRITICAL ANGLE:         2.5 DEGREE   (CRIT - OPTION)            *
*   -  CLASSIFICATION METRICAL: .LT. 0.01 DEGREE  (METR - OPTION)      *
*                                                                      *
* **********************************************************************
*                   ---   F I L E S   ---                              *
*                   =====================                              *
*    LI     TAPE1  - TEST CELLS              >>> LEPAGE_TST    (INPUT) *
*    LD     TAPE2  - INSTRUCTION INPUT FILE  >>> LEPAGE_INP    (INPUT) *
*    LG     TAPE5  - (TERMINAL) INPUT FILE                             *
*    LH     TAPE6  - (TERMINAL) OUTPUT FILE                   (OUTPUT) *
*    LP     TAPE7  - OUTPUT LISTING FILE     >>> LEPAGE_LIS   (OUTPUT) *
*                                                                      *
* ---------------------------------------------------------------------*
*                   ---  G L O S S A R Y  ---                          *
*                   =========================                          *
*                                                                      *
*                      P A R A M E T E R S                             *
* -------------------------------------------------------------------- *
*                                                                      *
*           0/1 = NO/YES                                               *
*                                                                      *
*  ISW(1) = 0/1          -  ON/OFF PRINT (HARD COPY LISTING)           *
*  ISW(2) = 0/1          -   /SUB LATTICES                             *
*  ISW(3) = 0/1          -   /SUPER LATTICES                           *
*  ISW(4) = 0/1          -   /LATT INPUT                               *
*  ISW(5) = 0/1          -   /MORE OUTPUT ON THE SCREEN                *
*  ISW(6) = 0/1          -   /CALCULATION DONE (CELL LISTING)          *
*  ISW(7) = 0/1          -   /CHANGE IN CRIT AND/OR MAXDM              *
*  ISW(8) = 0/1          -   /CELL INPUT                               *
*  ISW(9) = 0/1          -   /TEST-CELL                                *
*  ISW(10)= 0/1          -   /NOSCREEN OUTPUT (USEFULL IN CASE OF      *
*                                   SUB AND SUPER CELL.....            *
*                                                                      *
*                            ....FIRST VALUE IS DEFAULT (NO/YES)       *
*                                                                      *
* -------------------------------------------------------------------- *
*                                                                      *
* PAR(1)  =  CONVERSION DEGREE TO RADIAN                               *
* PAR(2)  =  CRITICAL ANGLE                                            *
* PAR(3)  =  CLASSIFICATION METRICAL                                   *
* PAR(4)  =                                                            *
* PAR(5)  =                                                            *
*                                                                      *
*                                                                      *
* LATT(1)  =  ORIGINALE LATTICE                                        *
* LATT(2)  =  REDUCED LATTICE                                          *
* LATT(3)  =  CONVENTIONAL LATTICE                                     *
* LATT(4)  =  TEST LATTICE                                             *
* LATT(5)  =                                                           *
*                                                                      *
* ==================================================================== *
*                                                                      *
*                 ---     M A I N  P R O G R A M     ---               *
*                                                                      *
      REAL AA(3,3), BB(3,3)
      LOGICAL TRS
      CHARACTER LATT*1, LAT*1, CHAR*1, VERSION*10, LOOPT*5, CDET*5
      COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET
      COMMON /TAPES/ LI, LD, LO, LF, LG, LH, LP
      COMMON /FR/ ICL(80), IFL(31,7), FN(31)
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
* *** TX(3,3): STORE THE [X]-MATRIX......
      EQUIVALENCE (TP(1,1),AA(1,1))
      DATA LI, LD, LO, LF, LG, LH, LP /1,2,3,4,5,6,7/
      VERSION = ' 20/10/89.'
* *** INITIALIZE DATA.....
      PAR(1) = ATAN(1.0)/45.0
      PAR(2) = 2.5
      PAR(3) = 0.01
* 0.01 DEGREE (DEFAULT) IS USED TO CLASSIFYING PSEUDO/METRICALLY!
      ISKP = 15
      NRS = ISKP + 1
      NRI = ISKP + 1
      NRSL = 1
      IDET = 1
      ITST = 42
      LATT(1) = 'P'
      LATT(2) = 'P'
      LOOPT = 'SUPER'
      CDET = '  DET'
      IAA = 0
      ITESTR = 0
      NR = 1
      NBCELL = 0
      TRS = .TRUE.
      OPEN(UNIT= LI,FILE='lepage.tst',STATUS='OLD',
     1 FORM='FORMATTED',ERR=5)
    5 CONTINUE
      OPEN (UNIT=LP,FILE='lepage.lis',STATUS='UNKNOWN')
      OPEN (UNIT=LD,FILE='lepage.inp',STATUS='UNKNOWN', ERR=1)
      GOTO 2
    1 WRITE (LH, 5000)
 5000 FORMAT (' ::FILE >>>  LEPAGE.INP  <<< NOT AVAILABLE, ',
     . 'INTERACTIVE INPUT ASSUMED.....', /)
    2 REWIND  (LI)
      REWIND  (LD)
      REWIND  (LP)
      DO 10 I=1,10
         ISW(I) = 0
   10 CONTINUE
      DO 20 I=1,3
         OCELL(I) = 10.0
         OCELL(I+3) = 90.0
   20 CONTINUE
      OCELL(7) = 1000.0
      DO 30 I=1,75
         ITLE(I) = ' '
   30 CONTINUE
      CALL LEPAG09
      DO 60 I=1,3
         DO 50 J=1,3
            DO 40 K=1,8
               TMX(I,J,K) = TM(I,J,K)
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
      ISW(7) = 1
* *** OUTPUT HEADER
      WRITE (LH,99977) VERSION
* *** OUTPUT HEADER TO LEPAGE_LIS......
      CALL LEPAG02(LP, VERSION)
* READ FIRST SPECIFIC INPUT FROM LEPAGE_INP
      LX = LD
   70 IF (LX.EQ.LG) WRITE (LH,99991)
      READ (LX,99999,ERR=80,END=80) ICL
      WRITE (LH,99998) ICL
      CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80)
      IF (KL.EQ.0 .AND. KN.EQ.0) GO TO 70
      IF (IFL(KL,1).EQ.1H=) GO TO 70
      N1 = IFL(1,1)
      N2 = IFL(1,2)
      N3 = IFL(1,3)
      N4 = IFL(1,4)
      IF (N1.EQ.1HM .AND. N2.EQ.1HA .AND. N3.EQ.1HN .AND. N4.EQ.1HU) GO
     1 TO 90
      IF (N1.EQ.1HH .AND. N2.EQ.1HE .AND. N3.EQ.1HL .AND. N4.EQ.1HP) GO
     1 TO 100
      IF (N1.EQ.1HT .AND. N2.EQ.1HI .AND. N3.EQ.1HT .AND. N4.EQ.1HL) GO
     1 TO 110
      IF (N1.EQ.1HC .AND. N2.EQ.1HR .AND. N3.EQ.1HI .AND. N4.EQ.1HT) GO
     1 TO 130
      IF (N1.EQ.1HM .AND. N2.EQ.1HE .AND. N3.EQ.1HT .AND. N4.EQ.1HR) GO
     1 TO 140
      IF (N1.EQ.1HS .AND. N2.EQ.1HU .AND. N3.EQ.1HB) GO TO 160
      IF (N1.EQ.1HS .AND. N2.EQ.1HU .AND. N3.EQ.1HP .AND. N4.EQ.1HE) GO
     1 TO 150
      IF (N1.EQ.1HC .AND. N2.EQ.1HE .AND. N3.EQ.1HL .AND. N4.EQ.1HL) GO
     1 TO 170
      IF (N1.EQ.1HD .AND. N2.EQ.1HA .AND. N3.EQ.1HT .AND. N4.EQ.1HA) GO
     1 TO 170
      IF (N1.EQ.1HL .AND. N2.EQ.1HA .AND. N3.EQ.1HT .AND. N4.EQ.1HT) GO
     1 TO 190
      IF (N1.EQ.1HT .AND. N2.EQ.1HR .AND. N3.EQ.1HA .AND. N4.EQ.1HN) GO
     1 TO 240
      IF (N1.EQ.1HN .AND. N2.EQ.1HO .AND. N3.EQ.1HS .AND. N4.EQ.1HC) GO
     1 TO 280
      IF (N1.EQ.1HT .AND. N2.EQ.1HR .AND. N3.EQ.1HM .AND. N4.EQ.1HX) GO
     1 TO 230
      IF (N1.EQ.1HP .AND. N2.EQ.1HR .AND. N3.EQ.1HI .AND. N4.EQ.1HN) GO
     1 TO 290
      IF (N1.EQ.1HM .AND. N2.EQ.1HO .AND. N3.EQ.1HR .AND. N4.EQ.1HE) GO
     1 TO 300
      IF (N1.EQ.1HT .AND. N2.EQ.1HE .AND. N3.EQ.1HS .AND. N4.EQ.1HT) GO
     1 TO 320
      IF (N1.EQ.1HC .AND. N2.EQ.1HA .AND. N3.EQ.1HL .AND. N4.EQ.1HC) GO
     1 TO 370
      IF (N1.EQ.1HL .AND. N2.EQ.1HI .AND. N3.EQ.1HS) GO TO 450
      IF (N1.EQ.1HE .AND. N2.EQ.1HN .AND. N3.EQ.1HD) GOTO 470
      IF (N1.EQ.1HQ .AND. N2.EQ.1HU .AND. N3.EQ.1HI .AND. N4.EQ.1HT) GO
     1 TO 470
      IF (N1.EQ.1HS .AND. N2.EQ.1HT .AND. N3.EQ.1HO) STOP
     1 ' -- FORCED STOP OF LEPAGE--'
      IF (LX.EQ.LG) WRITE (LH,99992)
      GO TO 70
* *** >>EOF<< ..........................................................
   80 CONTINUE
      IF (LX.EQ.LG) REWIND  (LG)
      IF (LX.EQ.LD) LX = LG
      GO TO 70
* *** MANUAL............................................................
   90 CONTINUE
      CALL LEPAG02(LH, VERSION)
      GO TO 70
* *** HELP..............................................................
  100 CONTINUE
      CALL LEPAG02(LH, VERSION)
      GO TO 70
* *** TITL..............................................................
  110 CONTINUE
      DO 120 I=6,81
         ITLE(I-5) = ICL(I)
  120 CONTINUE
      GO TO 70
* *** CRIT..............................................................
  130 CONTINUE
      PAR(2) = FN(1)
      IF (PAR(2).LE.0.0 .OR. PAR(2).GT.5.0) PAR(2) = 1.0
      ISW(7) = 1
      GO TO 70
* *** METR..............................................................
  140 CONTINUE
      PAR(3) = FN(1)
      IF (PAR(3).LE.0.0 .OR. PAR(3).GT.1.0) PAR(3) = 0.1
      ISW(7) = 1
      GO TO 70
* *** SUPER LATTICE.....................................................
  150 CONTINUE
      LOOPT = 'SUPER'
      CDET = '  DET'
      ISKP = 15
      NRI = ISKP + 1
      IDET = NINT(FN(1))
      IF (IDET.EQ.4) THEN
         NRS = 71
         NRSL = 56
      ELSE IF (IDET.EQ.3) THEN
         NRS = 36
         NRSL = 21
      ELSE IF (IDET.EQ.2) THEN
         NRS = 23
         NRSL = 8
      ELSE IF (IDET.EQ.1) THEN
         NRS = 16
         NRSL = 1
      ELSE
         IDET = 1
         NRS = 16
         NRSL = 1
      END IF
      ISW(2) = 0
      ISW(3) = 1
      GO TO 70
* *** SUB LATTICE.......................................................
  160 CONTINUE
      LOOPT = 'SUB  '
      CDET = '1/DET'
      ISKP = 71
      NRI = ISKP + 1
      IDET = NINT(FN(1))
      IF (IDET.EQ.4) THEN
         NRS = 127
         NRSL = 56
      ELSE IF (IDET.EQ.3) THEN
         NRS = 93
         NRSL = 21
      ELSE IF (IDET.EQ.2) THEN
         NRS = 79
         NRSL = 8
      ELSE IF (IDET.EQ.1) THEN
         NRS = 72
         NRSL = 1
      ELSE
         IDET = 1
         NRS = 72
         NRSL = 1
      END IF
      ISW(2) = 1
      ISW(3) = 0
      GO TO 70
* *** CELL/DATA.........................................................
  170 CONTINUE
      NR = 1
      WRITE (LH,99997)
      IF (KN.LT.6) GO TO 460
      DO 180 I=1,6
         OCELL(I) = FN(I)
  180 CONTINUE
      IF (OCELL(2).EQ.0.0) OCELL(2) = OCELL(1)
      IF (OCELL(3).EQ.0.0) OCELL(3) = OCELL(2)
      IF (OCELL(4).EQ.0.0) OCELL(4) = 90.0
      IF (OCELL(5).EQ.0.0) OCELL(5) = 90.0
      IF (OCELL(6).EQ.0.0) OCELL(6) = 90.0
      IF (OCELL(1).LT.0.01 .OR. OCELL(1).GT.150.0 .OR. OCELL(2).LT.0.01
     1 .OR. OCELL(2).GT.150.0 .OR. OCELL(3).LT.0.01 .OR.
     2 OCELL(3).GT.150.0 .OR. OCELL(4).GT.180.0 .OR. OCELL(5).GT.180.0
     3 .OR. OCELL(6).GT.180.0) THEN
         WRITE (LH,99996)
      ELSE
         OCELL(7) = VOLUME(OCELL)
         ISW(8) = 1
         IF (KN.GT.6)  NR = FN(7)
         IF (KL.GT.1) GO TO 200
         IF (NR.GT.0) GO TO 220
      END IF
      GO TO 70
* *** LATT..............................................................
  190 CONTINUE
      IF (KN.NE.0) THEN
         NR = NINT(FN(1))
         GO TO 220
      END IF
  200 WRITE (LATT(1) ,99990) IFL(2,1)
* LATTICES TYPE
      DO 210 IP=1,8
         NR = IP
         IF (LATT(1).EQ.LAT(IP)) GO TO 220
         IF ((IP.EQ.8) .AND. (LATT(1).NE.LAT(IP))) THEN
            WRITE (LH,99995)
            GO TO 70
         END IF
  210 CONTINUE
  220 ISW(4) = 1
      LATT(1) = LAT(NR)
      IF (NR.EQ.8) WRITE (LH,99987)
      GO TO 70
* *** TRMX..............................................................
  230 CONTINUE
      NR = 8
* *** TRAN..............................................................
  240 CONTINUE
      IF (KN.NE.9) GO TO 460
      K = 0
      DO 260 I=1,3
         DO 250 J=1,3
            K = K + 1
            TX(I,J) = FN(K)
            TP(I,J) = FN(K)
  250    CONTINUE
  260 CONTINUE
      CALL SMINV(AA, BB, DET)
      DO 270 LQ=6,7
         WRITE (LQ,99983) ((TP(I,J),J=1,3),(BB(I,J),J=1,3), I=1,2)
     1    , DET, (TP(3,J),J=1,3), (BB(3,J),J=1,3)
         IF (DET.LE.0.0) THEN
            IF (DET.LT.0.0) WRITE (LH,99986)
            IF (DET.EQ.0.0) WRITE (LH,99985)
            WRITE (LH,99984)
            GO TO 70
         END IF
  270 CONTINUE
      IF (NR.EQ.8) GO TO 70
      CALL METRIC(OCELL, G)
      CALL TRMETR(G, TP)
      CALL NEWCON(G, OCELL)
      WRITE (LH,99980)
      WRITE (LH,99979) LAT(1), (OCELL(I),I=1,7)
      GO TO 70
* ***  NO SCREEN  --   TOGGLE...........................................
  280 CONTINUE
      IPR = 10
      GO TO 310
* ***  HARD COPY  --   TOGGLE...........................................
  290 CONTINUE
      IPR = 1
      GO TO 310
* ***  MORE OUTPUT --  TOGGLE...........................................
  300 CONTINUE
      IPR = 5
  310 IF (KL.EQ.1) THEN
         ISW(IPR) = IABS(ISW(IPR)-1)
      ELSE
         IF (IFL(2,2).EQ.1HN) ISW(IPR) = 1
         IF (IFL(2,2).EQ.1HF) ISW(IPR) = 0
      END IF
      GO TO 70
* *** TEST..............................................................
  320 CONTINUE
      IF (ITESTR.GT.0) THEN
         IAA = ITESTR
         GO TO 330
      END IF
      IAA = NINT(FN(1))
      IF (IAA.LT.-2 .OR. IAA.GT.ITST) THEN
         WRITE (LH,99988)
         GO TO 70
      END IF
* ***    SEARCH, LOAD AND RUN TEST EXAMPLE
      IF (IAA.LE.0) THEN
         IAA = ITST
         ITESTR = ITST
         IF (IAA.EQ.-1) THEN
            IDET = 4
            NRS = 71
            NRSL = 56
            ISKP = 15
            NRI = ISKP + 1
            LOOPT = 'SUPER'
            CDET = '  DET'
         ELSE IF (IAA.EQ.-2) THEN
            IDET = 4
            NRS = 127
            NRSL = 56
            ISKP = 71
            NRI = ISKP + 1
            LOOPT = 'SUB  '
            CDET = '1/DET'
         ELSE
            IDET = 1
            NRS = 16
            NRSL = 1
            LOOPT = '     '
            CDET = '     '
         END IF
      END IF
  330 REWIND  (LI)
      IA = (IAA-1)*3
      DO 340 I=1,IA
         READ (LI,99999,ERR=460,END=460) ICL
  340 CONTINUE
      READ (LI,99999,ERR=460,END=460) ITLE
      READ (LI,99999,ERR=460,END=460) ICL
      CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80)
      DO 350 I=1,6
         OCELL(I) = FN(I)
  350 CONTINUE
      NR = NINT(FN(7))
      OCELL(7) = VOLUME(OCELL)
      READ (LI,99999,ERR=460,END=460) ICL
      CALL FRDA(ICL, IFL, FN, KL, KN, 6, 1, 80)
      DO 360 I=1,6
         TCELL(I) = FN(I)
  360 CONTINUE
      TCELL(7) = VOLUME(TCELL)
      LATT(4) = LAT(NINT(FN(7)))
      ISW(4) = 1
      ISW(8) = 1
      ISW(9) = 1
      IF (ITESTR.EQ.0) GO TO 70
* *** CALC..............................................................
  370 CONTINUE
      IF (ISW(7).EQ.1) WRITE (LP,99976) PAR(2), PAR(3)
      IF (NBCELL.NE.0) GO TO 380
  380 IF (ISW(8).EQ.0) WRITE (LH,99982)
      ISW(6) = 0
      NBCELL = NBCELL + 1
      DO 390 I=1,7
         CELL(I) = OCELL(I)
  390 CONTINUE
      LATT(1) = LAT(NR)
      DO 400 LQ=6,7
         WRITE (LQ,99981) NBCELL, (ITLE(I),I=1,75)
  400 CONTINUE
  410 CALL LEPAG01(TRS, NR)
      NRI = NRI + 1
      IF (NRI.LE.NRS) THEN
         DO 420 I=1,6
            CELL(I) = OCELL(I)
  420    CONTINUE
         IF (ISW(9).EQ.0) THEN
            WRITE (LH,99989)
            CHAR = 'Y'
            READ (LG,99999,ERR=430,END=430) CHAR
  430       IF (CHAR(1:1).EQ.'Y' .OR. char(1:).eq.'y') GOTO 410
         ELSE
            GO TO 410
         END IF
      END IF
      NRI = ISKP + 1
      IF (ITESTR.GT.0) THEN
         ITESTR = ITESTR - 1
         GO TO 320
      END IF
      ISW(6) = 1
      ISKP = 15
      NRS = ISKP + 1
      NRI = ISKP + 1
      NRSL = 1
      IDET = 1
      LATT(1) = 'P'
      LOOPT = 'SUPER'
      CDET = '  DET'
      IAA = 0
      DO 440 I=1,75
         ITLE(I) = ' '
  440 CONTINUE
      ISW(7) = 0
      WRITE (LH,99993) (NBCELL+1)
      GO TO 70
* *** LIST..............................................................
  450 CONTINUE
      WRITE (LH,99975) ISW(2), ISW(3), IDET, ISW(10), ISW(1), ISW(5),
     1 PAR(2), PAR(3)
      WRITE (LH,99980)
      WRITE (LH,99979) LAT(1), (OCELL(I),I=1,7)
      IF (ISW(6).NE.0) WRITE (LH,99978) LAT(3), (CELL(L),L=1,7)
      GO TO 70
* *** >>>MISTAKE<<< ....................................................
  460 CONTINUE
      WRITE (LH,99992)
      GO TO 70
* *** QUIT..............................................................
  470 CONTINUE
  490 CONTINUE
  500 STOP '  ---  LEPAGE DONE  ---'
99999 FORMAT (80A1)
99998 FORMAT (/' CONTROL CARD...', 80A1/)
99997 FORMAT (' INPUT OF LATTICE PARAMETERS TO BE CHECKED FOR METRICAL',
     1 ' SYMMETRY')
99996 FORMAT (' INPUT CELLPARAMETERS OUTSIDE THE LIMITS:'/'  ... 0 -- ',
     1 '150 ANGSTR. AND 0 -- 180 DEGREES ...')
99995 FORMAT ('   ---  SOMETHING WRONG WITH LATTICE TYPE  ---')
99994 FORMAT (' CELL ', 3(F9.5, 1X), 3(F9.4, 1X), I3)
99993 FORMAT (//'  .....GIVE INPUT ITEMS FOR THE NEXT CELL....',
     1 '  (NUMBER: ', I2, ')'//)
99992 FORMAT ('   >> UNKOWM KEYWORD (AND/OR WRONG INPUT DATA); IGNORED')
99991 FORMAT (' >>', $)
99990 FORMAT (1A1)
99989 FORMAT ('  .....CONTINUE (Y/N)? Y')
99988 FORMAT ('  "NO TEST DATA FOR THIS NUMBER!"')
99987 FORMAT (//'   =>  =>  =>  YOU SHOULD GIVE A SPECIAL MATRIX',
     1 ' [X] TO BE APPLIED TO THE', /,
     1 20X, '  INPUT CELL BEFORE CELL  REDUCTION PROCES!!!', //,
     2 '   =>  =>  =>  INSTR.: <TRMX>'//)
99986 FORMAT (//'  THE TRANSFORMATION CAUSED A CHANGE OF HANDEDNESS',
     1 ' OF THE COORDINATE SYSTEM!!')
99985 FORMAT (//'  THE NEW AXIS ARE COPLANAR!!')
99984 FORMAT ('  ------  TRY ANOTHER TRANSFORMATION MATRIX  ------')
99983 FORMAT (//'   THE NEW TRANSFORMATION MATRIX , THE INVERSE ',
     1 'AND THE DETERMINANT ARE RESP.:'//3X, '(A'')   (', 3F5.2,
     2 ') (A)', 4X, '(A)   (', 3F5.2, ') (A'')'/3X, '(B'') = (', 3F5.2,
     3 ') (B),', 3X, '(B) = (', 3F5.2, ') (B''),', 3X, 'DET. =',
     4 F6.2/3X, '(C'')   (', 3F5.2, ') (C)', 4X, '(C)   (', 3F5.2,
     5 ') (C'')')
99982 FORMAT (/' ERROR..... NOT YET GIVEN THE CELL CONSTANTS')
99981 FORMAT ('1'/'  CELL CONTROL NO.: ', I2/1X, 24(1H=)//'  FROM: ',
     1 75(A1)/)
99980 FORMAT (//14X, 'LATT', 4X, 'A', 7X, 'B', 7X, 'C', 7X, 'ALF', 5X,
     1 'BET', 5X, 'GAM', 6X, 'VOL'/1X, 75(1H-))
99979 FORMAT ('   INPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2)
99978 FORMAT ('  OUTPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2)
99977 FORMAT (//' * ', 67(1H=), ' *'/' *', 69(1H ), '*'/' *   ',
     1 '        M E T R I C A L   S Y M M E T R Y   P R O G R A M',
     2 '         *'/' *           = = = = = = = =   = = = = = = =',
     3 ' =   = = = = = = =         *'/' *', 69(1H ), '*'/' * ', 67(1H*),
     4 ' *'/' * ***** NOTICE *****  EXPERIMENTAL VERSION, MAY CONTAIN',
     5 ' ERRORS ****** *'/' * ', 67(1H*), ' *'/' * ', 67(1H ), ' *'/
     6 ' *', 68(1H ), ' *'/' *', 15X, '***** L E P A G E *****', 30X,
     7 ' *'/' *', 21X, '= = = = = =', 36X, ' *'///'    LEPAGE - ',
     8 'EXP. VERSION:', A10, '  -   TYPE <MANUAL> FOR HELP'/)
99976 FORMAT (//8X, '  THE CRITICAL VALUES USED ARE:'/6X, 39(1H=)/8X,
     1 'BETWEEN THE AXES  =>  ', F6.3, ' DEGREE'/8X, 'PSEUDO/METRICAL',
     2 '   =>  ', F6.3, ' DEGREE'/6X, 39(1H=)/)
99975 FORMAT (//'  ....FLAGS:  - SUB - SUPER - IDET - NOSCREEN - PRINT',
     1 ' - MORE -  CRIT -  METR -  '/16X, I2, 5X, I2, 6X, I2, 6X, I2,
     2 8X, I2, 6X, I2, 5X, F4.1, 4X, F4.3)
99972 FORMAT ( ' ......FILE OPEN ERROR ', /)
      END
      SUBROUTINE LEPAG01(TRS, NR)
      INTEGER DOT
      REAL MAXD, V(3), ORT(3,3), TAU(3)
      LOGICAL TRS, CHANGE
      CHARACTER LATT*1, LAT*1, LOOPT*5, CDET*5
      COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET
      COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
* ***  TRANSFORMATION MATRICES OF "DEPARTURE" USED IN CELL REDUCTION
      DO 30 I=1,3
         DO 20 J=1,3
            DO 10 K=1,8
               TM(I,J,K) = TMX(I,J,K)
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
      IF (NR.EQ.8) GO TO 70
      DO 60 J=1,3
         DO 50 K=1,3
            TP(J,K) = 0.0
            DO 40 I=1,3
               TP(J,K) = TP(J,K) + TM(J,I,NRI)*TM(I,K,NR+8)
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
* *** CALCULATE THE METRIC TENSOR.
   70 CALL METRIC(CELL, G)
* SAVE METRIC IN GI
      DO 90 I=1,3
         DO 80 J=1,3
            GI(I,J) = G(I,J)
   80    CONTINUE
   90 CONTINUE
      CELL(7) = VOLUME(CELL)
      DO 100 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 100
         WRITE (LQ,99999)
         WRITE (LQ,99998) LAT(NR), (CELL(L),L=1,7)
  100 CONTINUE
* TRANSFORM METRICAL MATRIX FOR INPUT CELL
      CALL TRMETR(G, TP)
* GET NEW CELL CONSTANTS FROM M (METRICAL MATRIX)
      CALL NEWCON(G, CELL)
      CELL(7) = VOLUME(CELL)
      DO 110 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 110
         WRITE (LQ,99997) LATT(2), (CELL(L),L=1,7)
  110 CONTINUE
* FIND REDUCED CELL
      CALL REDUCED(TRS, G, TM)
      CALL NEWCON(G, CELL)
      CELL(7) = VOLUME(CELL)
      DO 120 I=1,7
         RCELL(I) = CELL(I)
  120 CONTINUE
      DO 130 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 130
         WRITE (LQ,99996) LATT(2), (CELL(L),L=1,7), (TP(1,J),J=1,3),
     1    (TP(2,J),J=1,3), G(1,1), G(2,2), G(3,3), (TP(3,J),J=1,3),
     2    G(2,3), G(1,3), G(1,2)
  130 CONTINUE
* SAVE INPUT TO REDUCED CELL TRANSFORMATION MATRIX
      DO 150 I=1,3
         DO 140 J=1,3
            TPS(I,J) = TP(I,J)
  140    CONTINUE
  150 CONTINUE
* *** CALCULATE ORTHOGONALISATION MATRICES  (=> [OR])
      CALL ORTHOG(CELL, OR)
* *** CALCULATE THE TRANSPOSE OF OR (=> [ORT])
      CALL STRP(OR, ORT)
* *** CALCULATE THE INVERSE OF ORT (=> [ROT])
      CALL SMINV(ORT, ROT, DET)
* *** TRANSFORM U, V, W TO ORTHOGONAL COORDINATES.
      DO 180 K=1,37
         DO 160 I=1,3
            V(I) = FLOAT(IN(K,I))
  160    CONTINUE
         CALL SMATVEC(OR, V, T)
         DKW = 0.0
         DO 170 J=1,3
            TT(K,J) = T(J)
            TT(K,J+3) = T(J)*T(J)
            DKW = DKW + TT(K,J+3)
  170    CONTINUE
         TT(K,7) = T(1)*T(2)
         TT(K,8) = T(1)*T(3)
         TT(K,9) = T(2)*T(3)
         TT(K,10) = SQRT(ABS(DKW))
         TT(K,11) = K
  180 CONTINUE
* ORDER VECTOR LIST: SORT ON LENGTH:
* BUBLE SORT WITH SWAPPING OF THE SEQUENCE NUMBERS
*     -----    SEQUENCE NUMBER IN TT(K,11)!!    -----
  190 CHANGE = .FALSE.
      DO 200 K=1,36
         IF (TT(NINT(TT(K,11)),10).GT.TT(NINT(TT(K+1,11)),10)) THEN
            CALL REV(TT(K,11), TT(K+1,11))
            CHANGE = .TRUE.
         END IF
  200 CONTINUE
      IF (CHANGE) GO TO 190
      DO 210 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 210
         IF ((ISW(5).EQ.1 .AND. LQ.EQ.7) .OR. LQ.EQ.6) WRITE (LQ,99995)
  210 CONTINUE
      DO 230 I=1,12
         K = I + 12
         L = I + 24
         DO 220 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 220
            IF ((ISW(5).EQ.1 .AND. LQ.EQ.7) .OR. LQ.EQ.7) WRITE
     1       (LQ,99994) I, (IN(NINT(TT(I,11)), J), J=1,3),
     2       TT(NINT(TT(I,11)) , 10), K, (IN(NINT(TT(K,11)),J),J=1,3),
     3       TT(NINT(TT(K,11)),10),L,(IN(NINT(TT(L,11)),J),J=1,3),
     4       TT(NINT(TT(L,11)),10)
  220    CONTINUE
  230 CONTINUE
      I = 37
      DO 240 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 240
         IF ((ISW(5).EQ.1 .AND. LQ.EQ.6) .OR. LQ.EQ.7) WRITE (LQ,99993)
     1    I, (IN(NINT(TT(I,11)), J), J=1,3), TT(NINT(TT(I,11)),
     2    10)
  240 CONTINUE
* FIND 2-FOLD AXES
      ITEL = 0
      MAXD = 0.0
      DO 290 J=1,37
* TRANSFORM H,K,L, TO ORTHOGONAL COORDINATES
         DO 250 I=1,3
            V(I) = FLOAT(IN(J,I))
  250    CONTINUE
         CALL SMATVEC(ROT, V, TAU)
         TC(1) = TAU(2)*TAU(2) + TAU(3)*TAU(3)
         TC(2) = TAU(1)*TAU(1) + TAU(3)*TAU(3)
         TC(3) = TAU(1)*TAU(1) + TAU(2)*TAU(2)
         TC(4) = -2*TAU(1)*TAU(2)
         TC(5) = -2*TAU(1)*TAU(3)
         TC(6) = -2*TAU(2)*TAU(3)
         DO 280 K=1,37
            DOT = 0
            DO 260 N=1,3
               DOT = DOT + ABS(IN(J,N)*IN(K,N))
  260       CONTINUE
            IF (DOT.GE.3 .OR. DOT.LE.0) GO TO 280
            TAND = TT(K,4)*TC(1) + TT(K,5)*TC(2) + TT(K,6)*TC(3) +
     1       TT(K,7)*TC(4) + TT(K,8)*TC(5) + TT(K,9)*TC(6)
            IF (DOT.EQ.2) TAND = TAND/4.0
            TAND = ATAN(SQRT(ABS(TAND)))/PAR(1)
            IF (TAND.GT.PAR(2)) GO TO 280
* *** HANDLE TO MANY AXES CASE
            IF (ITEL.EQ.15) THEN
* *** FIRST RANK ACCORDING TO AXIAL LENGTH
               NS = 8
               CALL LEPAG08(AXES, NS, ITEL)
* *** AND RANK ACCORING TO TAND (ANGLE DEVIATION)
               NS = 7
               CALL LEPAG08(AXES, NS, ITEL)
               ITEL = 8
            END IF
            ITEL = ITEL + 1
            DO 270 I=1,3
               AXES(ITEL,I) = IN(K,I)
               AXES(ITEL,I+3) = IN(J,I)
               AXES(ITEL,I+9) = TT(K,I)/TT(K,10)
  270       CONTINUE
            AXES(ITEL,7) = TAND
            AXES(ITEL,8) = TT(K,10)
            AXES(ITEL,9) = DOT
            IF (TAND.GT.MAXD) MAXD = TAND
  280    CONTINUE
  290 CONTINUE
* ANALYSE RESULTS IN TERMS OF LATTICE TYPE AND TRANSFORMATION
      IF (ITEL.GT.9) THEN
* *** AVOID MORE THAN 9 AXES CASE; RANK ON TAND
         NS = 7
         CALL LEPAG08(AXES, NS, ITEL)
         ITEL = 9
      END IF
      NTEL = ITEL
      IF (ISW(5).EQ.1) WRITE (LH,99992) NTEL, MAXD
      WRITE (LP,99992) NTEL, MAXD
      ITELX = 0
  300 ISDET = 1
      IF (NRI.GT.(ISKP+1)) ISDET = 2
      IF (NRI.GT.(ISKP+8)) ISDET = 3
      IF (NRI.GT.(ISKP+21)) ISDET = 4
      NS = 7
* SORT ON TAND; THE LARGEST DELTAS ARE ELIMINATED IN THE NEXT PASSES
      CALL LEPAG08(AXES, NS, ITEL)
* RESTORE TRANSFORMATION MATRIX; INPUT TO REDUCED CELL
      DO 320 I=1,3
         DO 310 J=1,3
            TP(I,J) = TPS(I,J)
  310    CONTINUE
  320 CONTINUE
      ITEL = ITEL - ITELX
      IF (ITEL.LT.3) GO TO 350
  330 IF (MOD(ITEL,2).EQ.1) GO TO 340
      ITEL = ITEL - 1
      GO TO 330
  340 NS = 8
* SORT ON AXIAL LENGTH
*  => IN CASE OF TWO AXES: 'FIRST THE LARGEST DELTA'
      IF (ITEL.GT.2) CALL LEPAG08(AXES, NS, ITEL)
* CALCULATE INTERAXIAL ANGLES
  350 IF (ITEL.NE.0) CALL LEPAG05(ITEL, ANGMN, ANGM)
* ANALYSE RESULTS
      CALL LEPAG03(ITEL, NTEL, ANGM, ANGMN, MAXD)
      ITELX = 1
      IF ((ITEL.GT.0) .AND. (MAXD.GT.PAR(3))) GO TO 300
      RETURN
99999 FORMAT (//14X, 'LATT', 4X, 'A', 7X, 'B', 7X, 'C', 7X, 'ALF', 5X,
     1 'BET', 5X, 'GAM', 6X, 'VOL'/1X, 75(1H-))
99998 FORMAT ('   INPUT CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2)
99997 FORMAT ('   PRIM. CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2), F9.2)
99996 FORMAT ('   REDUC CELL', 4X, A1, 1X, 3(F8.3), 3(F8.2),
     1 F9.2////'   TRANFORMATION MATRIX:  INPUT TO REDUCED CELL', 9X,
     2 'NIGGLI MATRIX'/1X, 75(1H=)/'  (A'')   (', 3(F5.2), ') (A)',
     3 20X, '(A.A,B.B,C.C/B.C,A.C,A.B)'/'  (B'') = (', 3(F5.2),
     4 ') (B).', 17X, 3(F9.3)/'  (C'')   (', 3(F5.2), ') (C)', 18X,
     5 3(F9.3)//)
99995 FORMAT (/'   SORTED AXIAL LENGTH OF THE REDUCED CELL'/3X, 39(1H-)/
     1 )
99994 FORMAT (3(2X, I2, 2X, 3(I3), 2X, F7.3, 3X))
99993 FORMAT (56X, I2, 2X, 3(I3), 2X, F7.3)
99992 FORMAT (///2X, 75(1H=)/8X, '=>  =>  =>', 8X, 'FOUND ---', I2,
     1 ' --- POSSIBLE 2-FOLD AXES'/19X, ' MAX. DELTA:    ', F5.3/1X,
     2 75(1H=)/)
      END
* ***
      SUBROUTINE LEPAG02(LOUT, VERSION)
      CHARACTER VERSION*10, DATUM*10, TIJD*10
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
      CALL DATE(DATUM)
      CALL TIME(TIJD)
      IF (LOUT.LT.0) GO TO 10
      IF (LOUT.EQ.7) THEN
* OUTPUT HEADER.
         WRITE (LOUT,99999) (ITLE(I),I=1,75), DATUM, TIJD, VERSION
      ELSE
         WRITE (LOUT,99998) (ITLE(I),I=1,75), VERSION
      END IF
      WRITE (LOUT,99997)
      IF (LOUT.NE.7) GO TO 20
      WRITE (LOUT,99992)
   10 LOUT = IABS(LOUT)
      WRITE (LOUT,99996)
      WRITE (LOUT,99995)
      WRITE (LOUT,99994)
      IF (LOUT.EQ.6) WRITE (LOUT,99992)
      WRITE (LOUT,99993)
   20 CONTINUE
      RETURN
99999 FORMAT ('1', 4(/), 4X, 75A1/1X, 70(1H*)/' *', 68X, '*'/' *', 68X,
     1 '*'/' *', 68X, '*'/' *', 21X, '----   L E P A G E   ----', 22X,
     2 '*'/' *', 27X, ' = = = = = = ', 28X, '*'/' *', 68X, '*'/' *',
     3 68X, '*'/' *', 68X, '*'/' *', 21X, 25(1H=), 22X, '*'/' *', 21X,
     4 A10, 4X, A10, 23X, '*'/' *', 21X, 25(1H=), 22X, '*'/' *', 68X,
     5 '*'/2(' *', 68X, '*'/), ' *', 68X, '*'/' ', 69(1H*), '*'/' *',
     6 1X, 12(1H*, 1X), '   L E P A G E   ', 14(1H*, 1X)/' *', 69(1H*)/
     7 ' *', 68X, '*'/' *', 4X, 'PROGRAM TO DETERMINE THE METRICAL SY',
     8 'MMETRY OF A GIVEN LATTICE', 3X, '*'/' *', 68X, '*'/' *', 12X,
     9 'BASIC:', 12X, 'A.L. SPEK,  UTRECHT, JAN. 1985.', 7X, '*'/' *',
     * 8X, 'FORTRAN V:', 11X, 'A. MEETSMA, GRONINGEN, OCT. 1985.', 6X,
     1 '*'/' *', 68X, '*'/' *', 69(1H*)/' *', 68X, '*'/' *', 5X,
     2 '   LATTICE SYMMETRY DETERMINATION (VERSION', A10, ' - AM)', 5X,
     3 '*'/' *', 68X, '*'/' *', 69(1H*), 5(/)/8X, 'REFERENCES:'/6X,
     4 60(1H=)/8X, 'Y. LEPAGE, J. APPL.CRYST. (1982). 15, 255-259.'/8X,
     5 'W. CLEGG, ACTA CRYST. (1981). A37, 913-915.'/8X, 'I. KRIVY & ',
     6 'B. GRUBER, ACTA CRYST. (1976). A32, 297-298.'/8X, 'MIGHELL, J',
     7 '. APPL. CRYST. (1976). 9, 491-498.', 9X/6X, 60(1H=), 6(/), '1'//
     8 )
99998 FORMAT (4X, 75A1/' * ', 67(1H=), ' *'/' *', 69(1H ), '*'/' *   ',
     1 '    M E T R I C A L   S Y M M E T R Y   D E T E R M I',
     2 ' T I O N     *'/' *       = = = = = = = =   = = = = = = =',
     3 ' =   = = = = = = = = = = =     *'/' *', 69(1H ), '*'/' * ',
     4 67(1H*), ' *'/' * ***** NOTICE *****  EXPERIMENTAL VERSION, MA',
     5 'Y CONTAIN ERRORS ****** *'/' * ', 67(1H*), ' *'/' *', 50(1H ),
     6 'VERSION:', A10, ' *'/' *', 68(1H ), ' *'/' *', 15X, '***** L ',
     7 'E P A G E *****', 30X, ' *'/' *', 21X, '= = = = = =', 36X, ' *'/
     8 )
99997 FORMAT (/3X, 'KEYWORDS:', /,
     1  7X, '-  MANUAL    -   THIS MANUAL'/7X, '-  HELP   ',
     1 '   -   DESCRIPTION OF LEPAGE'/7X, '-  TITL      -   TITLE TEXT '
     2 /7X, '-  CRIT      -   CRITICAL ANGLE'/7X, '-  METR      -',
     3 '   ANGLE OF CLASSIFICATION METRICAL'/7X, '-  SUB       -   SE',
     4 'ARCH IN SUB-LATTICES'/7X, '-  SUPER     -   SEARCH IN SUP',
     5 'ER-LATTICES'/7X, '-  CELL/DATA -   CELL PARAMETERS: A, B,',
     6 ' C, ALF, BET AND GAM'/24X, ' (LATTYPE OR LATNR.)'/7X, '-  LAT',
     7 'T      -   LATTICE TYPE: P/I/R/F/A/B/C/X '/7X, '-  TEST',
     8 '      -   NUMBER OF TEST CELL FROM LEPAGE_LIS'/7X, '-  TRMX ',
     9 '     -   TRANSFORMATION MATRIX: T11, T12, T13, T21.....T23,',
     * ' T33'/7X, '-  TRAN      -   TRANSF. OF INPUT CELL: T11, T',
     1 '12, T13, T21.....T23, T33'/7X, '-  NOSCREEN  -   NO OUTPUT ',
     2 'ON THE SCREEN:   TOGGLE (OR WITH ON/OFF)'/7X,  '-  PRINT     ',
     3 '-   A HARD COPY OUTPUT:        TOGGLE (OR WITH ON/OFF)'/7X,
     4 '-  MORE      -   MORE OUTPUT ON THE SCREEN: TOGGLE (OR WI',
     5 'TH ON/OFF)'/7X, '-  LIST      -   LIST FLAGS AND (INPUT)-CELL'/
     6 7X, '-  CALC      -   START OF CALCULATION'/7X,  '-  QUIT/END',
     7 '  -   FINSH OF THE JOB'/7X,  '-  STOP      -   BREAK EXE',
     8 'CUTION PREMATURELY'//)
99996 FORMAT ('   ...THE PROGRAM LEPAGE ANALYSES A TRANSLATION ',
     1 'LATTICE AS SUPPLIED BY'/' THE USER [A,B,C,ALFA,BETA,GAMMA',
     2 ' AND LATTICE (P,A,B,C,F,R,I,X)] '/' FOR ITS  METRICAL ',
     3 'SYMMETRY [A = ANORTHIC, M = MONOCLINIC, O = ORTHORHOMBIC, '/
     4 ' T = TETRAGONAL, R = RHOMBOHEDRAL, H = HEXAGONAL, C = CUBI',
     5 'C] '/' AND CENTERING TYPE (P,A,B,C,F,R,I).'//' THE ALGORITH',
     6 'MS FOR THE CELL REDUCTION AND SYMMETRY DETERMINATION ARE'/
     7 ' BASED ON THOSE OF I.KRIVY & B. GRUBER (ACTA CRYST. (1976',
     8 '). A32, 297-298.)'/' AND Y. LE PAGE (J. APPL. CRYST. (1982).',
     9 ' 15, 255-259.) RESP..'//' THE ANALYSIS IN TERMS OF PSEUDO ',
     * 'OR METRIC SYMMETRY IS BASED ON'/' THE VALUE OF THE EXPERI',
     1 'MENTAL ERROR (USE <METR> - OPTION TO CHANGE THIS VALUE).')
99995 FORMAT (' ...THE PROGRAM SEARCHES FOR TWO-FOLD AXES  OF THE RE',
     1 'DUCED LATTICE WITH'/' THE PROPERTY  OF COINCIDING DIRECT AND',
     2 ' RECIPROCAL LATTICE VECTORS. '/' IN VIEW OF EXPERIMENTAL ',
     3 'ERROR, A SMALL ANGULAR RANGE OF COINCIDENCE '/' SHOULD ',
     4 'BE CONSIDERED (USE <CRIT> - OPTION TO CHANGETHIS VALUE).'/
     5 ' THE CORRESPONDING PARAMETER MAY BE SET TO A VALUE AS CRI',
     6 'TICAL AS THE ASSUMED '/' MAXIMUM EXPERIMENTAL ERROR OR TO',
     7 ' A SOMEWHAT HIGHER ANGLE TO CATCH CASES OF '/' PSEUDO-SYM',
     8 'METRY AND POSSIBLE TWINNING. (MAXIMUM ALLOWED VALUE = ',
     9 '5 DEGREES.)'/' THE SYMMETRY OF A CELL BASED ON COINCIDENCE ANG',
     * 'LES LESS THAN THE '/' EXP. ERROR IS MARKED AS METRICAL, O',
     1 'THERWISE PSEUDO. '/)
99994 FORMAT ('    >>>>>>>>>>FOM INDICATES THE POOREST FIT. (IN DEGR',
     1 'EES.)<<<<<<<<<<<<'//' THE PROGRAM CONTAINS THE DATA FOR A ',
     2 'NUMBER OF LATTICES THAT MAY BE CALLED'/' WITH THE <TEST>',
     3 ' - OPTION. ONE MAY BE CHOOSEN BY NR. (1-42).'/'   0 GIVES A ',
     4 'FULL TEST FOR ALL SETS'/'  -1 IN ADDITION LOOPS OVER ALL ',
     5 'SUPERCELLS AND'/'  -2 OVER ALL SUBCELLS.'//' USE <CELL> / <DA',
     6 'TA> - OPTION TO INPUT USER DATA'/' OPTIONALLY PRECEDED BY:',
     7 '  <CRIT>, <METR>, <SUB> OR <SUPER> SETTINGS.')
99993 FORMAT (/' THE <SUPER> - OPTION GENERATES TRANSFORMATION ',
     1 'MATRICES WITH DETERMINANT '/'  1, <=2, <=3 OR <=4 TO BE APPL',
     2 'IED TO THE PRIMITIVE CELL BEFORE REDUCTION, '/' IN ORDER ',
     3 'TO SEARCH FOR HIGHER SYMMETRY IN A SUPER-LATTICE. SIM',
     4 'ILARLY THE'/' <SUB> - OPTION MAY BE USED FOR THE SYMMETRY',
     5 ' SEARCH IN SUB-LATTICES.'/' OTHER TRANSFORMATIONS ARE POSSIBL',
     6 'E WITH THE [X]-MATRIX TO BE APPLIED TO'/' THE INPUT CELL',
     7 ' OF THE <CELL> / <DATA> - OPTION.'//'    <SUPER> :'/' THIS OP',
     8 'TION ALLOWS THE SEARCH FOR SYMMETRY IN SUPER CELLS (SEE'/
     9 ' MIGHELL, J. APPL. CRYST. 9, (1976). 491). THE PROGRAM CO',
     * 'NTAINS 7'/' MATRICES WITH DETERMINANT 2 AND 13 WITH DETER',
     1 'MINANT 3 AND 35 WITH'/' DETERMINANT 4 TO BE APPLIED ON THE PR',
     2 'IMITIVE CELL BEFORE REDUCTION.'//'    <SUB> :'/' THIS OPT',
     3 'ION ALLOWS THE SEARCH FOR SYMMETRY IN SUB CELLS (SEE'/' MIGHE',
     4 'LL, J. APPL. CRYST. 9, (1976). 491). THE PROGRAM CONTAINS 7'/
     5 ' MATRICES WITH DETERMINANT 1/2 AND 13 WITH DETERMINANT 1',
     6 '/3 AND 35 WITH'/' DETERMINANT 1/4 TO BE APPLIED ON THE PR',
     7 'IMITIVE CELL BEFORE REDUCTION.')
99992 FORMAT (///)
      END
* ***
      SUBROUTINE LEPAG03(ITEL, NTEL, ANGM, ANGMN, MAXD)
* ANALYSE OF THE RESULT
      REAL MAXD, AA(3,3), BB(3,3)
      CHARACTER LAT*1, LATT*1, LAT0*1, LOOPT*5, CDET*5, TESTOK*5
      CHARACTER SYST0*10, SYST*12
      COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET
      COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
      EQUIVALENCE (TM,AA)
      LATT(3) = 'P'
      MAXD = 0.0
      NR = 0
      IF (ITEL.LT.1) GO TO 20
      DO 10 JJ=1,ITEL
         IF (AXES(JJ,7).GT.MAXD) MAXD = AXES(JJ,7)
   10 CONTINUE
      GO TO (50, 50, 140, 570, 220, 570, 330, 570, 340) ITEL
* TRICLINIC
   20 SYST = 'TRICLINIC'
      LAT0 = 'A'
      DO 40 N1=1,3
         DO 30 N2=1,3
            VAL0 = 0
            IF (N1.EQ.N2) VAL0 = 1
            TM(N1,N2,1) = VAL0
   30    CONTINUE
   40 CONTINUE
      GO TO 370
* MONOCLINIC
   50 SYST = 'MONOCLINIC'
      LAT0 = 'M'
* *** MAKE THE 2-AXIS THE MONOCLINIC-B AXIS
      DO 60 N=1,3
         TM(2,N,1) = AXES(ITEL,N)
   60 CONTINUE
* *** LOOK FOR TWO ADDITIONAL SHORTEST VECTORS PERPENDICULAR
* ***   TO 2-AXIS.
      YDUM = COS(PAR(1)*(90-PAR(2)))
      D1 = 999.0
      DO 90 K=1,37
         DUM = (TT(K,1)*AXES(ITEL,10)+TT(K,2)*AXES(ITEL,11)+TT(K,3)*
     1    AXES(ITEL,12))/TT(K,10)
         IF (ABS(DUM).GT.YDUM) GO TO 90
         IF (TT(K,10).GE.D1) THEN
            IF (TT(K,10).GT.D2) GO TO 90
            I = 3
            D2 = TT(K,10)
         ELSE
            D2 = D1
            DO 70 N=1,3
               TM(3,N,1) = TM(1,N,1)
               CL(3,N) = CL(1,N)
   70       CONTINUE
            I = 1
            D1 = TT(K,10)
         END IF
         DO 80 N=1,3
            TM(I,N,1) = IN(K,N)
            CL(I,N) = TT(K,N)
   80    CONTINUE
   90 CONTINUE
* MAKE BETA > 90
      DUM = CL(1,1)*CL(3,1) + CL(1,2)*CL(3,2) + CL(1,3)*CL(3,3)
      IF (DUM.LT.0) GO TO 110
      DO 100 N=1,3
         TM(3,N,1) = -TM(3,N,1)
  100 CONTINUE
  110 CALL SMINV(AA, BB, DET)
      IF (DET.GT.0) GO TO 370
      DO 120 N=1,3
         TM(2,N,1) = -TM(2,N,1)
  120 CONTINUE
      GO TO 370
* ORTHORHOMBIC
  130 SYST = 'ORTHORHOMBIC'
      LAT0 = 'O'
      ZANG = 90
      GO TO 240
* RHOMBOHEDRAL
  140 SYST = 'RHOMB.(OBV.)'
      IF ((ANGM.GT.(120+PAR(2))) .OR. (ANGMN.LT.(120-PAR(2)))) GO TO 130
      LAT0 = 'H'
      DOT = 0.0
      K = 0
      DO 160 I3=1,3,2
         K = K + 1
         DO 150 J3=1,3
            TM(K,J3,1) = AXES(I3,J3)
            CL(K,J3) = AXES(I3,J3+9)
            IF (K.EQ.2) DOT = DOT + CL(1,J3)*CL(2,J3)
  150    CONTINUE
  160 CONTINUE
      IF (DOT.LT.0) GO TO 180
      DO 170 J3=1,3
         TM(2,J3,1) = -TM(2,J3,1)
         CL(2,J3) = -CL(2,J3)
  170 CONTINUE
* CALCULATE THIRD AXIS PERP TO 1 AND 2
  180 CRS1 = CL(1,2)*CL(2,3) - CL(1,3)*CL(2,2)
      CRS2 = CL(1,3)*CL(2,1) - CL(1,1)*CL(2,3)
      CRS3 = CL(1,1)*CL(2,2) - CL(1,2)*CL(2,1)
      TM(3,1,1) = CRS1*ROT(1,1) + CRS2*ROT(2,1) + CRS3*ROT(3,1)
      TM(3,2,1) = CRS1*ROT(1,2) + CRS2*ROT(2,2) + CRS3*ROT(3,2)
      TM(3,3,1) = CRS1*ROT(1,3) + CRS2*ROT(2,3) + CRS3*ROT(3,3)
      CALL SMINV(AA, BB, DET)
      DO 190 N=1,3
         TMDUM = TM(3,N,1)*3/DET
         TM(3,N,1) = NINT(TMDUM)
  190 CONTINUE
* TEST FOR OBVERSE SETTING
      LOOP = 0
  200 IF (LOOP.EQ.2) GO TO 530
* ONLY ONCE THROUGH THE  LOOP; IF TWICE THEN EXIT!!
      MODL = 3
      H(1) = 2
      H(2) = 1
      H(3) = 1
      CALL LEPAG07(MODL, H, TM, NUM)
      IF (NUM.EQ.0) GO TO 370
      DO 210 N=1,3
         TM(1,N,1) = -TM(1,N,1)
         TM(2,N,1) = -TM(2,N,1)
  210 CONTINUE
      LOOP = LOOP + 1
      GO TO 200
* TETRAGONAL
  220 SYST = 'TETRAGONAL'
      LAT0 = 'T'
* ENTRY POINT FOR HEXAGONAL
  230 ZANG = (ITEL+1)*15
* ENTRY POINT FOR  ORTHORHOMBIC
  240 N90 = ITEL - 1
      IOK = 0
      DO 250 I=1,ITEL
         IF (NINT(AXES(I,13)).NE.N90) GO TO 250
         IOK = 1
  250 CONTINUE
      IF (IOK.EQ.0) GO TO 530
      YDUM1 = COS((ZANG-PAR(2))*PAR(1))
      YDUM2 = COS((ZANG+PAR(2))*PAR(1))
      K = 0
      DO 300 I3=1,ITEL
         IF (NINT(AXES(I3,13)).LT.2) GO TO 530
         IF (ITEL.GT.3) GO TO 260
         K3 = I3
         GO TO 280
  260    IF (NINT(AXES(I3,13)).NE.N90) GO TO 270
         K3 = 3
         GO TO 280
  270    K = K + 1
         IF (K.GT.2) THEN
            K3 = 0
         ELSE
            K3 = K
         END IF
* SAVE THE AXIAL INDICES
  280    IF (K3.GT.0) THEN
            DO 290 J3=1,3
               TM(K3,J3,1) = AXES(I3,J3)
               CL(K3,J3) = AXES(I3,J3+9)
  290       CONTINUE
         END IF
  300 CONTINUE
      DUM = CL(1,1)*CL(2,1) + CL(1,2)*CL(2,2) + CL(1,3)*CL(2,3)
      IF (DUM.LT.0.0) GO TO 320
      DO 310 N=1,3
         TM(2,N,1) = -TM(2,N,1)
  310 CONTINUE
      DUM = -DUM
  320 IF ((DUM.GT.YDUM1) .OR. (DUM.LT.YDUM2)) GO TO 530
      GO TO 370
* HEXAGONAL
  330 SYST = 'HEXAGONAL'
      LAT0 = 'H'
      GO TO 230
* CUBIC
  340 SYST = 'CUBIC'
      LAT0 = 'C'
      K3 = 0
      N90 = 4
* *** LOAD THE THREE FOUR-FOLD AXES INDECES IN TM
      DO 360 I3=1,9
         IF (NINT(AXES(I3,13)).EQ.N90) THEN
            K3 = K3 + 1
            IF (K3.LE.3) THEN
               DO 350 J3=1,3
                  TM(K3,J3,1) = AXES(I3,J3)
  350          CONTINUE
            END IF
         END IF
  360 CONTINUE
      IF (K3.NE.3) GO TO 530
*****************************************************************
*  **************** F I N D  L A T T I C E  T Y P E  ***********
* **************************************************************
  370 CONTINUE
      CALL SMINV(AA, BB, DET)
      IF (DET.LT.0) THEN
         DO 380 N=1,3
            TM(3,N,1) = -TM(3,N,1)
  380    CONTINUE
      END IF
      IDET = NINT(ABS(DET))
      IF (IDET.NE.2) THEN
         IF (IDET.EQ.3) LATT(3) = 'R'
         IF (IDET.EQ.4) LATT(3) = 'F'
      ELSE
* TEST FOR A
         MODL = 2
         LATT(3) = 'A'
         H(1) = 0
         H(2) = 1
         H(3) = 1
         CALL LEPAG07(MODL, H, TM, NUM)
         IF (NUM.EQ.0) GO TO 390
* TEST FOR B
         LATT(3) = 'B'
         H(1) = 1
         H(2) = 0
         H(3) = 1
         CALL LEPAG07(MODL, H, TM, NUM)
         IF (NUM.EQ.0) GO TO 390
* TEST FOR C
         LATT(3) = 'C'
         H(1) = 1
         H(2) = 1
         H(3) = 0
         CALL LEPAG07(MODL, H, TM, NUM)
         IF (NUM.EQ.0) GO TO 390
* TEST FOR I
         LATT(3) = 'I'
         H(1) = 1
         H(2) = 1
         H(3) = 1
         CALL LEPAG07(MODL, H, TM, NUM)
         IF ((NUM.NE.0) .OR. (IDET.GT.4)) THEN
            WRITE (LH,99988)
            STOP 'STOPPED: "WRONG DETERMINANT!"'
         END IF
  390    CONTINUE
      END IF
************************************************************************
      IF ((ITEL.LT.3) .AND. (LATT(3).EQ.'A')) THEN
         DO 400 N=1,3
            CALL REV(TM(1,N,1), TM(3,N,1))
            TM(2,N,1) = -TM(2,N,1)
  400    CONTINUE
         LATT(3) = 'C'
      END IF
      IF ((ITEL.EQ.3) .AND. ((LATT(3).EQ.'A') .OR. (LATT(3).EQ.'B')))
     1 THEN
         IF (LATT(3).EQ.'A') THEN
            DO 410 N=1,3
               CALL REV(TM(1,N,1), TM(3,N,1))
               CALL REV(TM(1,N,1), TM(2,N,1))
  410       CONTINUE
         ELSE
            DO 420 N=1,3
               CALL REV(TM(2,N,1), TM(3,N,1))
               TM(1,N,1) = -TM(1,N,1)
  420       CONTINUE
         END IF
         LATT(3) = 'C'
      END IF
      IF (ITEL.GT.0) CALL LEPAG06(ITEL)
      L = 1
      CALL LEPAG04(L)
      CALL SMINV(TP, TG, DETM)
      SYST0 = 'METRICALLY'
      IF (MAXD.GT.PAR(3)) SYST0 = 'PSEUDO'
      IF (NR.EQ.8) THEN
         DO 430 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 430
            WRITE (LQ,99995) ((TX(I,J),J=1,3),I=1,3)
  430    CONTINUE
      END IF
      DO 440 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 440
         WRITE (LQ,99999)
         WRITE (LQ,99998) (TP(1,J),J=1,3), (TG(J,1),J=1,3), SYST0
         WRITE (LQ,99997) (TP(2,J),J=1,3), (TG(J,2),J=1,3), SYST
         WRITE (LQ,99996) (TP(3,J),J=1,3), (TG(J,3),J=1,3), MAXD
  440 CONTINUE
      DO 460 I3=1,3
         DO 450 J3=1,3
            G(I3,J3) = GI(I3,J3)
  450    CONTINUE
  460 CONTINUE
      CALL TRMETR(G, TP)
      CALL NEWCON(G, CELL)
      CELL(7) = VOLUME(CELL)
      DO 470 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 470
         WRITE (LQ,99994)
         WRITE (LQ,99993) LATT(1), (OCELL(J),J=1,7), LATT(2),
     1    (RCELL(I),I=1,7)
  470 CONTINUE
      TESTOK = '     '
      IF (ISW(9).NE.0) THEN
         TOK = 0.0
         DO 480 I=1,6
            TOK = TOK + ABS(CELL(I)-TCELL(I))
  480    CONTINUE
         IF (TOK.LT.0.5 .AND. LATT(3).EQ.LATT(4)) TESTOK = ' O.K.'
         DO 490 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 490
            WRITE (LQ,99992) LAT0, LATT(3), (CELL(J),J=1,7), TESTOK
  490    CONTINUE
      ELSE
         DO 500 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 500
            WRITE (LQ,99991) LAT0, LATT(3), (CELL(J),J=1,7)
  500    CONTINUE
      END IF
      IF (NRS.GT.(ISKP+1)) THEN
         NP = NRI - ISKP
         DO 510 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 510
            WRITE (LQ,99990) LOOPT, NP, ((TM(I,J,NRI),J=1,3),I=1,3),
     1       CDET, ISDET
  510    CONTINUE
      END IF
      IF (SYST0(1:1).EQ.'M') THEN
      DO 520 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 520
         WRITE (LQ,99989)
  520 CONTINUE
      END IF
      RETURN
  530 IF (ITEL.GT.0) CALL LEPAG06(ITEL)
      IF (ITEL.NE.NTEL) THEN
         IF (ITEL.EQ.(NTEL-1)) THEN
            DO 540 LQ=6,7
               IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 540
               WRITE (LQ,99987) SYST
  540       CONTINUE
         ELSE
            DO 550 LQ=6,7
               IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 550
               WRITE (LQ,99986) SYST
  550       CONTINUE
         END IF
      ELSE
         DO 560 LQ=6,7
            IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 560
            WRITE (LQ,99985) SYST
  560    CONTINUE
      END IF
      RETURN
  570 STOP ' WRONG "ITEL" NUMBER '
99999 FORMAT (//' === TRANSFORMATION MATRIX: INPUT (A,B,C) TO CON',
     1 'VENTIONAL CELL(A'', B'', C'') === '/1X, 77(1H=))
99998 FORMAT ('  (A'')   (', 3(F5.2), ') (A)   (X'')   (', 3(F5.2),
     1 ') (X)   ', 10(A))
99997 FORMAT ('  (B'') = (', 3(F5.2), ') (B).  (Y'') = (', 3(F5.2),
     1 ') (Y).  ', 21(A))
99996 FORMAT ('  (C'')   (', 3(F5.2), ') (C)   (Z'')   (', 3(F5.2),
     1 ') (Z)   FOM: ', F5.3/)
99995 FORMAT (' SPECIAL  [X] = (', 2(3F6.2, ' /'), 3F6.2, ')')
99994 FORMAT (/13X, 'LAT0', 1X, 'LATT', 3X, 'A', 7X, 'B', 7X, 'C', 7X,
     1 'ALFA', 4X, 'BET', 5X, 'GAM', 7X, 'VOL'/1X, 79(1H-))
99993 FORMAT ('  INPUT CELL   ', 5X, 1A1, 3(1X, F7.3), 3(2X, F6.2), 1X,
     1 F9.2/1X, ' REDUC CELL   ', 5X, 1A1, 3(1X, F7.3), 3(2X, F6.2),
     2 1X, F9.2)
99992 FORMAT ('  CONV. CELL   ', 1A, 4X, 1A, 3(1X, F7.3), 3(2X, F6.2),
     1 1X, F9.2/69X, 1A5/1X, 79(1H-))
99991 FORMAT ('  CONV. CELL   ', 1A, 4X, 1A, 3(1X, F7.3), 3(2X, F6.2),
     1 1X, F9.2/1X, 79(1H-))
99990 FORMAT (2X, A5, ' TRANSF:', I3, '  (', 2(3F5.1, '/'), 3F5.1, ') ',
     1 A5, ' = ', I2)
99989 FORMAT (1X, 79(1H=)/)
99988 FORMAT (//' THERE IS SOMETHING WRONG IN TYPE ANALYSIS')
99987 FORMAT (/'  AFTER DELETING THE LAGERST DELTA:', 2X, '=>  =>',
     1 '  NOT EVEN PSEUDO ', A12/)
99986 FORMAT (/'  AFTER DELETING THE TWO LAGERST DELTAS:', 2X, '=>  =',
     1 '>  NOT EVEN PSEUDO ', A12/)
99985 FORMAT (/11X, '=>  =>  =>  NOT EVEN PSEUDO ', A12/)
      END
* ***
      SUBROUTINE LEPAG04(L)
* ACCUMULATE TRANSFORMATIONS [TP(NEW)] = [TM(L)] * [TP(OLD)](3,3)
      COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
* FIRST COPY OLD [TP] INTO [TG]
      DO 20 I=1,3
         DO 10 J=1,3
            TG(I,J) = TP(I,J)
   10    CONTINUE
   20 CONTINUE
      DO 50 I=1,3
         DO 40 J=1,3
            TP(I,J) = 0
            DO 30 K=1,3
               TP(I,J) = TP(I,J) + TM(I,K,L)*TG(K,J)
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
      END
* ***
      SUBROUTINE LEPAG05(ITEL, ANGMN, ANGM)
* CALCULATE INTERAXIAL ANGLES
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
      ANGM = 0.0
      ANGMN = 180.0
      DO 20 I=1,ITEL
         AXES(I,13) = 0.0
         DO 10 J=1,ITEL
            ANG = 0.0
            AXES(I,J+13) = 0.0
            IF (I.EQ.J) GO TO 10
            ANG = AXES(I,10)*AXES(J,10) + AXES(I,11)*AXES(J,11) +
     1       AXES(I,12)*AXES(J,12)
            IF (ABS(ANG).LT..00001) THEN
               ANG = 90.0
            ELSE IF (ANG.GE.1.0) THEN
               ANG = 0
            ELSE
               ANG = ACOS(ANG)/PAR(1)
               IF (ANG.LT.0.0) ANG = ANG + 180.0
               IF (ANG.LT.90.0) ANG = 180.0 - ANG
            END IF
            IF (ANG.GT.ANGM) ANGM = ANG
            IF (ANG.LT.ANGMN) ANGMN = ANG
            AXES(I,J+13) = ANG
* SEACH 4- AND 6-AXES
            IF (((ANG+PAR(2)).GT.90) .AND. ((ANG-PAR(2)).LT.90))
     1       AXES(I,13) = AXES(I,13) + 1
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
* ***
      SUBROUTINE LEPAG06(ITEL)
      COMMON /TAPES/ LI, LD, LO, LF, LG, LP, LH
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
      DO 10 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 10
         WRITE (LQ,99999)
   10 CONTINUE
      DO 30 LQ=6,7
         IF (LQ.EQ.6 .AND. ISW(10).EQ.1) GO TO 30
         DO 20 I=1,ITEL
            WRITE (LQ,99998) I, AXES(I,8), NINT(AXES(I,13)) ,
     1       (NINT(AXES(I,K)), K=1,6), NINT(AXES(I,9)) ,
     2       AXES(I,7), (AXES(I,13+J),J=1,ITEL)
   20    CONTINUE
   30 CONTINUE
      RETURN
99999 FORMAT (///31X, 'POSSIBLE 2-FOLD AXES'/31X, 20(1H-)/29X, 'ROWS',
     1 16X, 'PRODUCTS'/' NR', 5X, 'D', 7X, 'N', 5X, 'DIRECT', 6X,
     2 'RECIPROCAL', 4X, 'DOT  DELTA', 9X, 'ANGLE BETWEEN TWO ',
     3 'DIRECT AXES '/1X, 125(1H-))
99998 FORMAT (1X, I2, 2X, F7.3, 3X, I2, 1X, 3I4, 2X, 3I4, 4X, I2, 4X,
     1 F5.3, 3X, 9(1X, F6.1))
      END
* ***
      SUBROUTINE LEPAG07(MODL, H, TM, NUM)
* TEST LATTICE TYPE
      DIMENSION H(3), TM(3,3,127)
      NUM = 0
      DO 20 J=1,3
         DM = 0.0
         DO 10 I=1,3
            DM = DM + H(I)*TM(I,J,1)
   10    CONTINUE
         NUM = NUM + MOD(NINT(ABS(DM)),MODL)
   20 CONTINUE
      RETURN
      END
* ***
      SUBROUTINE LEPAG08(AXES, NS, ITEL)
* BUBBLE SORT AXES
      REAL AXES(15,22)
      LOGICAL CHANGE
   10 CHANGE = .FALSE.
      DO 30 J=1,(ITEL-1)
         IF (AXES(J,NS).GT.AXES(J+1,NS)) THEN
            DO 20 I=1,13
               CALL REV(AXES(J,I), AXES(J+1,I))
   20       CONTINUE
            CHANGE = .TRUE.
         END IF
   30 CONTINUE
      IF (CHANGE) GO TO 10
      RETURN
      END
* ***
      SUBROUTINE LEPAG09
      CHARACTER LAT*1, LATT*1, LOOPT*5, CDET*5
      COMMON /CHARS/ LAT(8), LATT(5), LOOPT, CDET
      COMMON /LEPAG/ IN(37,3), AXES(15,22), TM(3,3,127), TMX(3,3,8),
     1 CL(3,5), TT(37,11), TP(3,3), TG(3,3), TPS(3,3), TX(3,3), G(3,3),
     2 GI(3,3), OR(3,3), ROT(3,3), T(3), H(3), TC(6), ISW(10), PAR(10),
     3 CELL(10), OCELL(10), RCELL(10), TCELL(10), ITLE(75), ISKP, NRS,
     4 NRI, NRSL, IDET, ISDET
* LATTICE TYPE
      DATA (LAT(I),I=1,8) /'P','I','R','F','A','B','C','X'/
* LIST OF THE 37 LATTICE VECTORS TO BE TESTED AS TENTATIVE TWO-AXES
      DATA ((IN(I,J),J=1,3),I=1,37) /0,0,1,0,1,-2,0,1,-1,0,1,0,0,1,1,0,
     1 1,2,0,2,-1,0,2,1,1,-2,-1,1,-2,0,1,-2,1,1,-1,-2,1,-1,-1,1,-1,0,1,
     2 -1,1,1,-1,2,1,0,-2,1,0,-1,1,0,0,1,0,1,1,0,2,1,1,-2,1,1,-1,1,1,0,
     3 1,1,1,1,1,2,1,2,-1,1,2,0,1,2,1,2,-1,-1,2,-1,0,2,-1,1,2,0,-1,2,0,
     4 1,2,1,-1,2,1,0,2,1,1/
* TABLE OF TRANSFORMATION MATRICES USED IN THE CELL REDUCTION
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=1,8) /0,1,0,1,0,0,0,0,-1,-1,0,0,
     1 0,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,1,0,0,0,
     2 1,1,0,0,0,1,0,0,0,1,1,0,0,0,1,0,0,0,1,1,0,0,0,1,0,1,1,1/
* CENTERED TO PRIMITIVE CELL TRANSFORMATION
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=9,15) /1.,0.,0.,0.,1.,0.,0.,0.,
     1 1.,1.,0.,0.,0.,1.,0.,0.5,0.5,0.5,.666667,.333333,.333333,
     2 -.333333,.333333,.333333,-.333333,-.666667,.333333,0.5,0.,0.5,.5,
     3 .5,0.,0.,.5,.5,1.,0.,0.,0.,1.,0.,0.,.5,.5,0.5,0.,.5,0.,1.,0.,0.,
     4 0.,1.,1.,0.,0.,.5,.5,0.,0.,0.,1./
* *** SUPERLAT1:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=16,16) /1,0,0,0,1,0,0,0,1/
* *** SUPERLAT2:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=17,23) /2.0,0.0,0.0,0.0,1.0,0.0,
     1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,
     2 1.0,0.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,2.0,0.0,
     3 0.0,0.0,1.0,0.0,1.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,2.0,
     4 1.0,1.0,0.0,0.0,1.0,1.0,1.0,0.0,1.0/
* * SUPERLAT3:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=24,36) /3.0,0.0,0.0,0.0,1.0,0.0,
     1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,3.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,
     2 1.0,0.0,0.0,0.0,3.0,1.0,-1.0,0.0,2.0,1.0,0.0,0.0,0.0,1.0,1.0,1.0,
     3 0.0,-2.0,1.0,0.0,0.0,0.0,1.0,-1.0,0.0,1.0,2.0,0.0,1.0,0.0,1.0,
     4 0.0,1.0,0.0,1.0,2.0,0.0,-1.0,0.0,1.0,0.0,0.0,1.0,-1.0,0.0,2.0,
     5 1.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,-2.0,1.0,1.0,0.0,0.0,2.0,1.0,1.0,
     6 1.0,1.0,0.0,0.0,2.0,1.0,1.0,2.0,1.0,-1.0,-1.0,0.0,2.0,0.0,1.0,
     7 1.0,1.0,2.0,1.0,0.0,1.0,2.0,1.0,0.0,1.0,1.0,1.0,1.0,2.0,0.0,0.0,
     8 2.0,1.0/
* * SUPERLAT4:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=37,54) /4.0,0.0,0.0,0.0,1.0,0.0,
     1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,4.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,
     2 1.0,0.0,0.0,0.0,4.0,4.0,0.0,0.0,3.0,1.0,0.0,0.0,0.0,1.0,4.0,0.0,
     3 0.0,1.0,1.0,0.0,0.0,0.0,1.0,4.0,0.0,0.0,0.0,1.0,0.0,3.0,0.0,1.0,
     4 4.0,0.0,0.0,0.0,1.0,0.0,1.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,3.0,0.0,
     5 0.0,4.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,4.0,4.0,0.0,0.0,2.0,1.0,
     6 0.0,0.0,0.0,1.0,4.0,0.0,0.0,0.0,1.0,0.0,2.0,0.0,1.0,1.0,0.0,0.0,
     7 0.0,2.0,1.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,2.0,0.0,0.0,0.0,1.0,2.0,
     8 0.0,0.0,0.0,1.0,0.0,1.0,0.0,2.0,1.0,0.0,0.0,0.0,1.0,2.0,0.0,0.0,
     9 4.0,2.0,2.0,0.0,0.0,1.0,1.0,1.0,0.0,1.0,1.0,1.0,0.0,0.0,1.0,1.0,
     * 2.0,0.0,2.0,1.0,1.0,0.0,0.0,2.0,2.0,1.0,0.0,1.0/
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=55,71) /1.0,2.0,1.0,1.0,1.0,2.0,
     1 2.0,1.0,1.0,3.0,1.0,0.0,1.0,1.0,1.0,2.0,0.0,1.0,4.0,0.0,0.0,1.0,
     2 1.0,0.0,2.0,0.0,1.0,2.0,1.0,0.0,1.0,1.0,1.0,3.0,0.0,1.0,4.0,0.0,
     3 0.0,2.0,1.0,0.0,1.0,0.0,1.0,1.0,1.0,1.0,0.0,1.0,3.0,1.0,0.0,2.0,
     4 2.0,0.0,0.0,0.0,1.0,1.0,1.0,0.0,2.0,2.0,1.0,0.0,0.0,1.0,1.0,2.0,
     5 0.0,1.0,1.0,2.0,0.0,0.0,2.0,1.0,1.0,0.0,1.0,1.0,1.0,0.0,0.0,1.0,
     6 2.0,1.0,0.0,2.0,2.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,1.0,2.0,0.0,0.0,
     7 0.0,1.0,0.0,0.0,0.0,2.0,1.0,0.0,0.0,0.0,2.0,0.0,0.0,0.0,2.0,2.0,
     8 0.0,0.0,0.0,1.0,1.0,0.0,0.0,2.0,2.0,0.0,0.0,0.0,2.0,0.0,1.0,0.0,
     9 1.0,2.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,2.0,2.0,0.0,0.0,1.0,1.0,1.0,
     * 0.0,0.0,2.0/
* *** SUBLAT1:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=72,72) /1,0,0,0,1,0,0,0,1/
* *** SUBLAT2:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=73,79) /0.5,0.0,0.0,0.0,1.0,0.0,
     1 0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,
     2 1.0,0.0,0.0,0.0,0.5,0.5,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.5,0.0,
     3 -0.5,0.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.5,
     4 0.5,0.5,0.5,-0.5,-0.5,0.5,0.5,0.5,-0.5,0.5/
* * SUBLAT3:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=80,92) /0.33333,0.0,0.0,0.0,1.0,
     1 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.33333,0.0,0.0,0.0,1.0,1.0,0.0,
     2 0.0,0.0,1.0,0.0,0.0,0.0,0.33333,0.33333,-0.66667,0.0,0.33333,
     3 0.33333,0.0,0.0,0.0,1.0,0.33333,0.66667,0.0,-0.33333,0.33333,0.0,
     4 0.0,0.0,1.0,-0.33333,0.0,0.66667,0.33333,0.0,0.33333,0.0,1.0,0.0,
     5 0.33333,0.0,0.66667,0.33333,0.0,-0.33333,0.0,1.0,0.0,0.0,0.33333,
     6 -0.66667,0.0,0.33333,0.33333,1.0,0.0,0.0,0.0,0.33333,0.66667,0.0,
     7 -0.33333,0.33333,1.0,0.0,0.0,0.33333,-0.33333,0.66667,0.33333,
     8 0.66667,-1.33333,-0.33333,0.33333,0.33333,-0.33333,0.33333,
     9 0.66667,-0.66667,-0.33333,1.33333,0.33333,-0.33333,0.33333,
     * -0.33333,0.66667,0.33333,0.66667,-1.33333,0.33333,0.33333,
     1 0.33333,-0.33333,0.66667,-0.33333,0.66667,0.33333,0.33333,
     2 -0.66667,-0.66667,0.33333,0.33333/
* * SUBLAT4:
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=93,109) /0.25,0.0,0.0,0.0,1.0,
     1 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.25,0.0,0.0,0.0,1.0,1.0,0.0,0.0,
     2 0.0,1.0,0.0,0.0,0.0,0.25,0.25,-0.75,0.0,0.0,1.0,0.0,0.0,0.0,1.0,
     3 0.25,-0.25,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.0,-0.75,0.0,1.0,
     4 0.0,0.0,0.0,1.0,0.25,0.0,-0.25,0.0,1.0,0.0,0.0,0.0,1.0,1.0,0.0,
     5 0.0,0.0,1.0,0.0,0.0,-0.75,0.25,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.25,
     6 0.25,0.25,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.0,-0.5,0.0,1.0,
     7 0.0,0.0,0.0,1.0,1.0,0.0,0.0,0.0,0.5,0.0,0.0,-0.25,0.5,0.5,-0.25,
     8 0.0,0.0,0.5,0.0,0.0,0.0,1.0,0.5,0.0,-0.25,0.0,1.0,0.0,0.0,0.0,
     9 0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,-0.5,0.25,0.25,0.25,-0.25,-0.5,
     * 0.5,0.5,0.5,-0.5,0.5,0.5,0.5,-0.5,-0.5,0.5,-0.25,-0.5,0.5,0.25/
      DATA (((TM(I,J,K),J=1,3),I=1,3),K=110,127) /0.5,0.5,-0.5,-0.25,
     1 0.25,0.25,0.5,-0.5,0.5,-0.25,0.75,-0.25,-0.25,-0.25,0.75,0.75,
     2 -0.25,-0.25,0.25,0.25,-0.5,-0.25,0.75,0.5,0.25,-0.75,0.5,0.25,
     3 -0.25,-0.5,0.0,1.0,0.0,0.0,0.0,1.0,0.25,0.5,-0.75,-0.25,0.5,0.75,
     4 0.25,-0.5,0.25,0.25,-0.5,-0.25,0.0,1.0,0.0,0.0,0.0,1.0,0.5,0.75,
     5 -0.25,-0.5,0.25,0.25,0.5,-0.75,0.25,0.5,0.25,-0.25,0.0,1.0,0.0,
     6 0.0,-0.5,0.5,0.25,0.5,-0.5,-0.25,0.5,0.5,0.25,-0.5,0.5,0.5,0.25,
     7 -0.5,-0.5,0.25,0.5,0.5,-0.25,0.5,0.5,-0.5,0.5,0.5,0.5,-0.5,-0.25,
     8 0.25,0.25,0.5,0.0,0.0,0.0,0.5,0.0,0.0,0.0,1.0,0.5,0.0,0.0,0.0,
     9 1.0,0.0,0.0,0.0,0.5,1.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0,0.5,0.5,0.0,
     * 0.0,0.0,1.0,0.0,0.0,-0.5,0.5,0.5,0.0,-0.5,0.0,0.5,0.0,0.0,0.0,
     1 1.0,0.5,-0.5,0.0,0.0,1.0,0.0,0.0,0.0,0.5,0.5,-0.5,0.0,0.0,1.0,
     2 0.0,0.0,-0.5,0.5/
      RETURN
      END
      SUBROUTINE FRDA(ICL, IFL, FN, KL, KN, NCHAR, IMIN, IMAX)
* **********************************************************************
*  *                                                                   *
*   THE FIRST INPUT LINE BEGINS WITH A KEYWORD IN THE FIRST NON-BLANK  *
*      COLUMN.                                                         *
*   CONCATENATION LINES BEGINS WITH A DOLLAR SIGN ($) IN THE FIRST     *
*      COLUMN (OR THE FOREGOING LINE ENDS WITH A EQUAL SIGN(=))        *
*   ALWAYS FIRST READ THE KEYWORD AND THEN ZERO, ONE OR MORE ITEM      *
*   FIELDS BELONGING TO THE KEYWORD.                                   *
*   IN IFL(II,NL) ONE WILL FIND THE FIRST NUMBER OF THE NUMERIC        *
*   FIELD BELONGING TO THE KEYWORD IN THE ARRAY ELEMENTS:              *
*                                         IFL(II,1) TOO IFL(II,NL-1).  *
*   =>  =>  THE TOTAL NUMERIC FIELDS BELONGING TO THE KEYWORD IS:      *
*   IFL((II+1),NL) - IFL(II,NL);  NOTE THIS CAN BE ZERO!!              *
*   IF  IFL((II+1),NL).EQ.0  THEN THE FIRST TERM IN THE AFORE NAMED    *
*   DIFFERENCE MUST BE REPLACED BY THE MAXIMUN NUMERIC FIELD           *
*           PLUS ONE ( = KN + 1 !!!!!!!)                               *
*   =>  BEGIN OF A LITERAL FIELD DEFINED BY A BLANK( ).                *
*   =>  END OF A LITERAL FIELD DEFINED BY A BLANK( ) OR A COMMA(,).    *
*   =>  BEGIN OR END OF A NUMERIC FIELD                                *
*                          DEFINED BY A BLANK( ), PLUS(+) OR MINUS(-). *
*  *                                                                   *
*   =>  =>  THE COMMA(,) 'BETWEEN' ITEMS ON THE INPUT LINE REACTS      *
*                                                AS A FIELD DELIMITER! *
*  *                                                                   *
* **********************************************************************
*           MODIFIED: 15 SEPT 1986 (A.M.)                              *
*                     24 FEBR 1987 (A.M.)                              *
*                      4 JULY 1989 (A.M.)                              *
*                                                                      *
      COMMON /CRSET/ INUM(11), ISMB(10), LETR(53)
      DIMENSION ICL(80), IFL(31,7), FN(31)
      DATA ICH, LH /1H ,6/
      DATA INUM /1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0,1H /
      DATA ISMB /1H ,1H+,1H-,1H.,1H(,1H),1H>,1H$,1H,,1H=/
      DATA LETR /1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,1HM,
     1 1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ,1H ,
     1 1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,1Hk,1Hl,1Hm,
     1 1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,1Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
* *
      IF (NCHAR.GT.6) NCHAR = 6
      DO 7 I=1,80
         N = ICL(I)
         DO 9 J=28,53
           IF (N.EQ.LETR(J)) ICL(I) = LETR(J-27)
  9      CONTINUE
  7   CONTINUE
      IF (ICL(1).EQ.ISMB(8)) GO TO 30
      IF (ICH.EQ.ISMB(10)) THEN
         I = 0
         KL = KL - 1
         GO TO 40
      END IF
      KN = 0
      KL = 0
      NL = NCHAR + 1
      I = IMIN - 1
      DO 20 II=1,31
         DO 10 JJ=1,NL-1
            IFL(II,JJ) = (1H )
   10    CONTINUE
         IFL(II,NL) = 0
         FN(II) = 0
   20 CONTINUE
      GO TO 40
   30 I = 1
* *
* **** START OF A NEW FIELD
* **** LOOK FOR A NON-BLANK COLUMN
* *
   40 A = 0.0
      IP = 0
      NP = 0
      L = 0
      S = 1.0
   50 I = I + 1
      IF (I.GT.IMAX) GO TO 110
      ICH = ICL(I)
      IF (L.EQ.0 .AND. ICH.EQ.ISMB(1)) GO TO 50
* *
* **** START OF A FIELD
* *
      L = L + 1
      DO 60 J=1,10
         IF (ICH.EQ.INUM(J)) GO TO 70
   60 CONTINUE
      IF (ICH.EQ.ISMB(4)) GO TO 80
      IF (ICH.EQ.ISMB(2)) GO TO 90
      IF (ICH.EQ.ISMB(3)) GO TO 100
      IF (L.GT.1) GO TO 120
* *
* **** START OF A LITERAL FIELD BY A CHARACTER WHICH IS OTHER THAN 0-9+-
      GO TO 130
*  **** NUMERIC FIELD FOUND
* *
   70 IF (J.EQ.10) J = 0
      IF (IP.EQ.1) NP = NP + 1
      A = 10.0*A + J
      GO TO 50
   80 IF (IP.EQ.1) GO TO 180
      IP = 1
      GO TO 50
   90 IF (L.GT.1) GO TO 120
      S = 1.0
      GO TO 50
  100 IF (L.GT.1) GO TO 120
      S = -1.0
      GO TO 50
  110 IF (L.GT.0) GO TO 120
      RETURN
* *
* **** END OF NUMERIC FIELD
* *
  120 IF (KL.EQ.0) GO TO 190
      A = S*A/10.0**NP
      KN = KN + 1
      IF (KN.GT.31) GO TO 200
      FN(KN) = A
      IF (ICH.EQ.ISMB(2) .OR. ICH.EQ.ISMB(3)) I = I - 1
      GO TO 40
* *
* **** LITERAL FIELD
* FIRST KEYWORD AND THEN EVENTUALLY THE NUMERIC FIELDS BELONGING TO IT
* *
  130 KL = KL + 1
      IF (KL.GT.31) GO TO 210
      IFL(KL,NL) = KN + 1
  140 IFL(KL,L) = ICH
      IF (ICH.EQ.ISMB(10)) RETURN
      L = L + 1
  150 I = I + 1
      IF (I.GT.IMAX) GO TO 160
      ICH = ICL(I)
      IF (ICH.EQ.ISMB(1) .OR. ICH.EQ.ISMB(9)) GO TO 160
      IF (L-NCHAR) 140, 140, 150
  160 DO 170 J=L,NCHAR
         IFL(KL,J) = ISMB(1)
  170 CONTINUE
      GO TO 40
* *
* **** FINISHED
* *
  180 CONTINUE
      WRITE (LH,99999) ICL
      STOP '- END NUMERIC FIELD BY A DOT -'
  190 CONTINUE
      WRITE (LH,99999) ICL
      STOP '--- NO BEGIN WITH A KEYWORD ---'
  200 CONTINUE
      WRITE (LH,99999) ICL
      STOP '--- TOO MUCH NUMERIC FIELDS ---'
  210 CONTINUE
      WRITE (LH,99999) ICL
      STOP '--- TOO MUCH LITERAL FIELDS ---'
99999 FORMAT (//'  THE FALSE LINE IS: '/2X, 17(1H=)//2X, 80A1///)
      END
* ***
      SUBROUTINE METRIC(C, G)
* CALCULATION METRIC TENSOR
* ***  A, B, C, ALF, BET, GAM IN [C(1)--C(6)]
      REAL C(10), G(3,3)
      DTR = ATAN(1.0)/45.0
      G(1,1) = C(1)*C(1)
      G(2,2) = C(2)*C(2)
      G(3,3) = C(3)*C(3)
      G(1,2) = C(1)*C(2)*COS(DTR*C(6))
      G(1,3) = C(1)*C(3)*COS(DTR*C(5))
      G(2,3) = C(2)*C(3)*COS(DTR*C(4))
      G(2,1) = G(1,2)
      G(3,1) = G(1,3)
      G(3,2) = G(2,3)
      RETURN
      END
* ***
      SUBROUTINE NEWCON(G, C)
* ***  A, B, C, ALF, BET, GAM IN [C(1)--C(6)]
* GET NEW A, B, C, ALF, BET, GAM FROM G
*  C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001.
      REAL C(10), G(3,3)
      DTR = ATAN(1.0)/45.0
      C(1) = SQRT(G(1,1))
      C(2) = SQRT(G(2,2))
      C(3) = SQRT(G(3,3))
      C(4) = ACOS(G(2,3)/(C(2)*C(3)))/DTR
      C(5) = ACOS(G(1,3)/(C(1)*C(3)))/DTR
      C(6) = ACOS(G(1,2)/(C(1)*C(2)))/DTR
      RETURN
      END
* ***
      SUBROUTINE ORTHOG(C, OR)
* ***  A, B, C, ALF, BET, GAM IN [C(1)--C(6)]
*  C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001.
      DIMENSION C(10), OR(3,3)
      DTR = ATAN(1.0)/45.0
      DO 20 I=1,3
         DO 10 J=1,3
            OR(I,J) = 0.0
   10    CONTINUE
   20 CONTINUE
* *** CALCULATION OF ORTHOGONALISATION MATRIX:
* *** NOW: J.D. DUNITZ, XRAY ANALYSIS AND STRUCTURE DETERMINATION OF
* ***      ORGANIC MOLECULES, CORNAL UNIV. PRESS, 1979, P236.
* *** WAS: REF. ROLLETT COMPUTING METHODS IN CRYSTALLOGRAPHY P.23
      SA = SIN(C(4)*DTR)
      SB = SIN(C(5)*DTR)
      SG = SIN(C(6)*DTR)
      CA = COS(C(4)*DTR)
      CB = COS(C(5)*DTR)
      CG = COS(C(6)*DTR)
      CASTAR = (CB*CG-CA)/(SB*SG)
      SASTAR = SQRT(1.0-CASTAR**2)
      OR(1,1) = C(1)
      OR(1,2) = C(2)*CG
      OR(1,3) = C(3)*CB
      OR(2,2) = C(2)*SG
      OR(2,3) = -C(3)*SB*CASTAR
      OR(3,3) = C(3)*SB*SASTAR
      C(7) = C(1)*C(2)*C(3)*SQRT(1.0-CA*CA-CB*CB-CG*CG+
     1         2.0*CA*CB*CG)
      C(8) = C(7)/(C(2)*C(3)*SA)
      C(9) = C(7)/(C(1)*C(3)*SB)
      C(10) = C(7)/(C(1)*C(2)*SG)
      RETURN
* ***
      END
      FUNCTION VOLUME(C)
* CALCULATE CELL-VOLUME FROM CELL-PARAMETERS
* ***  A, B, C, ALF, BET, GAM IN [C(1)--C(6)]
*  C(7) = VOLUME, C(8) = D100, C(9) = D010, C(10) = D001.
      REAL C(10)
      DTR = ATAN(1.0)/45.0
      CA = COS(C(4)*DTR)
      CB = COS(C(5)*DTR)
      CG = COS(C(6)*DTR)
      VOL = (1.-CA**2-CB**2-CG**2+2*CA*CB*CG)
      IF (VOL.LT.0.0) STOP 'CELL VOLUME IMAGINAIRE!!'
      VOLUME = C(1)*C(2)*C(3)*SQRT(VOL)
      RETURN
      END
* ***
      SUBROUTINE REDUCED(TRS, G, TM)
* CELL REDUCTION. SEE KRIVY   GRUBER, ACTA CRYST (1976), A32, 297-298.
      REAL  KSI, ETA, ZETA
      DIMENSION G(3,3), TM(3,3,8)
      LOGICAL TRS
      DATA LP, LG1 /6,7/
      KSI = ANINT(2.*G(2,3)*1000.)
      ETA = ANINT(2.*G(1,3)*1000.)
      ZETA = ANINT(2.*G(1,2)*1000.)
      A = ANINT(G(1,1)*1000.)
      B = ANINT(G(2,2)*1000.)
      C = ANINT(G(3,3)*1000.)
* REDUCTION STEP 1
 10   L = 1
      IF ((A.GT.B) .OR. ((A.EQ.B) .AND. (ABS(KSI).GT.ABS(ETA)))) THEN
         CALL REV(A, B)
         CALL REV(KSI, ETA)
         ETA = -ETA
         KSI = -KSI
         IF (TRS) CALL LEPAG04(L)
      END IF
* REDUCTION STEP 2
      L = 2
      IF ((B.GT.C) .OR. ((B.EQ.C) .AND. (ABS(ETA).GT.ABS(ZETA)))) THEN
         CALL REV(B, C)
         CALL REV(ETA, ZETA)
         ETA = -ETA
         ZETA = -ZETA
         IF (TRS) CALL LEPAG04(L)
         GO TO 10
      END IF
* REDUCTION STEP 3
      L = 3
      IF (KSI*ETA*ZETA.GT.0.0) THEN
         TM(1,1,3) = SIGN(1.0,KSI)
         TM(2,2,3) = SIGN(1.0,ETA)
         TM(3,3,3) = SIGN(1.0,ZETA)
         KSI = ABS(KSI)
         ETA = ABS(ETA)
         ZETA = ABS(ZETA)
         IF (TRS) CALL LEPAG04(L)
      ELSE
* REDUCTION STEP 4
      L = 4
         TM(1,1,4) = -(SIGN(1.0,KSI))
         TM(2,2,4) = -(SIGN(1.0,ETA))
         TM(3,3,4) = -(SIGN(1.0,ZETA))
         IF (KSI .EQ. 0.0)   TM(1,1,4)=TM(2,2,4)*TM(3,3,4)
         IF (ETA .EQ. 0.0)   TM(2,2,4)=TM(1,1,4)*TM(3,3,4)
         IF (ZETA .EQ. 0.0)   TM(3,3,4)=TM(1,1,4)*TM(2,2,4)
         KSI = -ABS(KSI)
         ETA = -ABS(ETA)
         ZETA = -ABS(ZETA)
         IF (TRS) CALL LEPAG04(L)
      END IF
* REDUCTION STEP 5
      L = 5
      IF ((ABS(KSI).GT.B) .OR. ((KSI.EQ.B) .AND. (2*ETA.LT.ZETA)) .OR.
     1 ((KSI.EQ.-B) .AND. (ZETA.LT.0.0))) THEN
         TM(3,2,5) = -(SIGN(1.0,KSI))
         C = B + C - ABS(KSI)
         ETA = ETA - ZETA*SIGN(1.0,KSI)
         KSI = KSI - 2.*B*SIGN(1.0,KSI)
         IF (TRS) CALL LEPAG04(L)
         GO TO 10
      END IF
* REDUCTION STEP 6
      L = 6
      IF ((ABS(ETA).GT.A) .OR. ((ETA.EQ.A) .AND. (2*KSI.LT.ZETA)) .OR.
     1 ((ETA.EQ.-A) .AND. (ZETA.LT.0.0))) THEN
         TM(3,1,6) = -SIGN(1.0,ETA)
         C = A + C - ABS(ETA)
         KSI = KSI - ZETA*SIGN(1.0,ETA)
         ETA = ETA - 2.*A*SIGN(1.0,ETA)
         IF (TRS) CALL LEPAG04(L)
         GO TO 10
      END IF
* REDUCTION STEP 7
      L = 7
      IF ((ABS(ZETA).GT.A) .OR. ((ZETA.EQ.A) .AND. (2*KSI.LT.ETA)) .OR.
     1 ((ZETA.EQ.-A) .AND. (ETA.LT.0.0))) THEN
         TM(2,1,7) = -SIGN(1.0,ZETA)
         B = A + B - ABS(ZETA)
         KSI = KSI - ETA*SIGN(1.0,ZETA)
         ZETA = ZETA - 2.*A*SIGN(1.0,ZETA)
         IF (TRS) CALL LEPAG04(L)
         GO TO 10
      END IF
* REDUCTION STEP 8
      L = 8
      IF ((KSI+ETA+ZETA+A+B.LT.0.0) .OR. ((KSI+ETA+ZETA+A+B.EQ.0.0)
     1 .AND. (2.*(A+ETA)+ZETA.GT.0.0))) THEN
         C = A + B + C + KSI + ETA + ZETA
         KSI = 2.*B + KSI + ZETA
         ETA = 2.*A + ETA + ZETA
         IF (TRS) CALL LEPAG04(L)
         GO TO 10
      END IF
* FINISHING OF THE REDUCTION PROCESS
      G(1,1) = A/1000.
      G(2,2) = B/1000.
      G(3,3) = C/1000.
      G(1,2) = ZETA/2000.
      G(1,3) = ETA/2000.
      G(2,3) = KSI/2000.
      G(3,2) = G(2,3)
      G(3,1) = G(1,3)
      G(2,1) = G(1,2)
      RETURN
99999 FORMAT (/1X, 6(F11.6))
      END
* ***
      SUBROUTINE TRMETR(G, TP)
* TRANSFORM METRICAL MATRIX
      DIMENSION G(3,3), R(3,3), TP(3,3)
      DO 30 I=1,3
         DO 20 J=1,3
            R(I,J) = 0.0
            DO 10 K=1,3
               R(I,J) = R(I,J) + G(I,K)*TP(J,K)
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
      DO 60 I=1,3
         DO 50 J=1,3
            G(I,J) = 0.0
            DO 40 K=1,3
               G(I,J) = G(I,J) + TP(I,K)*R(K,J)
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
      RETURN
      END
* ***
* ***
      SUBROUTINE REV(A, B)
* *** CHANGE VALUES OF A AND B
      C = A
      A = B
      B = C
      RETURN
      END
* ***
      SUBROUTINE SMATVEC(A, B, C)
      DIMENSION A(3,3), B(3), C(3)
      DO 20 I=1,3
         C(I) = 0.0
         DO 10 J=1,3
            C(I) = C(I) + A(I,J)*B(J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
* ***
      SUBROUTINE SMINV(A, B, DET)
* *** INVERTS ASYMMETRIC 3X3 MATRIX
      DIMENSION A(3,3), B(3,3)
      B(1,1) = A(2,2)*A(3,3) - A(3,2)*A(2,3)
      B(2,1) = A(2,1)*A(3,3) - A(3,1)*A(2,3)
      B(3,1) = A(2,1)*A(3,2) - A(3,1)*A(2,2)
      DET = A(1,1)*B(1,1) - A(1,2)*B(2,1) + A(1,3)*B(3,1)
      IF (DET) 10, 40, 10
   10 B(1,2) = A(1,2)*A(3,3) - A(3,2)*A(1,3)
      B(2,2) = A(1,1)*A(3,3) - A(3,1)*A(1,3)
      B(3,2) = A(1,1)*A(3,2) - A(3,1)*A(1,2)
      B(1,3) = A(1,2)*A(2,3) - A(2,2)*A(1,3)
      B(2,3) = A(1,1)*A(2,3) - A(2,1)*A(1,3)
      B(3,3) = A(1,1)*A(2,2) - A(2,1)*A(1,2)
* *** MULTIPLY B(I,J) ELEMENTS BY -1**(I+J). THIS CAN BE ACCOMPLISHED
* ***  BY MULTIPLYING M BY -1 SONSECUTIVE FASHION
      M = -1
      DO 30 I=1,3
         DO 20 J=1,3
            M = -M
            B(I,J) = FLOAT(M)*B(I,J)/DET
   20    CONTINUE
   30 CONTINUE
   40 CONTINUE
      RETURN
      END
* ***
      SUBROUTINE STRP(T, TR)
      DIMENSION T(3,3), TR(3,3)
      DO 20 I=1,3
         DO 10 J=1,3
            TR(J,I) = T(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
