      PROGRAM TRACER II
C
C     DESCRIPTION.   LATTICE TRANSFORMATION - CELL REDUCTION PROGRAM
C     AUTHOR,DATE.   S. L. LAWTON   (APRIL 1967)
C     LANGUAGE.      FORTRAN IV FOR IBM 7040
C
C     INPUT DATA
C
C  1. TITLE CARD -- FORMAT(14A4) -- ONE CARD.
C
C	   ANY ALPHANUMERIC INFORMATION DESCRIBING THE COMPOUND.  THIS
C	   WILL BE PRINTED BACK OUT AS A HEADING ON EACH PAGE OF OUTPUT.
C
C  2. CONTROL CARD -- FORMAT(I3,F7.3) -- ONE CARD.
C
C	COL. 1-3   INPUT =1 CELL PARAMETERS ON PARAMETER CARD ARE IN
C			    DIRECT SPACE
C			 =2 CELL PARAMETERS ON PARAMETER CARD ARE IN
C			    RECIPROCAL SPACE
C	COL. 4-10   DEL     ABSOLUTE VALUE OF THE LARGEST PERMISSIBLE
C			    DIFFERENCE BETWEEN ANY TWO OF THE SIX RE-
C			    DUCED CELL SCALAR PRODUCTS.  (FOR LATTICE
C			    PARAMETERS WITH E.S.D. OF 1 PART IN 10000 A.
C			    DEL = 0.10 IS SATISFACTORY.  IF ABOUT 1 PART
C			    IN 1000 A., DEL = 0.50 TO 1.00 MAY BE
C			    NECESSARY.)
C			    THIS FIELD IS IRRELAVENT IF NO CELL
C			    REDUCTION IS TO BE MADE.
C
C  3. PARAMETER CARD -- FORMAT(6F10.6) -- ONE CARD
C
C	COL. 1-10    A	    LATTICE PARAMETER A (OR A*)
C	COL.11-20    B	    LATTICE PARAMETER B (OR B*)
C	COL.21-30    C	    LATTICE PARAMETER C (OR C*)
C	COL.31-40  ALPHA    LATTICE PARAMETER ALPHA (OR ALPHA*)
C	COL.41-50  BETA     LATTICE PARAMETER BETA  (OR BETA*)
C	COL.51-60  GAMMA    LATTICE PARAMETER GAMMA (OR GAMMA*)
C	   (NOTE.  THE CELL EDGES ARE IN UNITS OF ANGSTROMS (IF INPUT=1)
C	   AND INVERSE ANGSTROMS (IF INPUT=2).	ALL ANGLES ARE IN
C	   DEGREES AND DECIMAL FRACTION.)
C
C  4. INSTRUCTION CARDS -- FORMAT(I3,2X,13A4).
C
C	   THESE CARDS FUNCTION AS THE COMMANDS TO THE PROGRAM IN TRANS-
C	   FORMING ONE CELL TO ANOTHER.  EACH CARD CONTAINS TWO ITEMS--
C	   AN INSTRUCTION NUMBER (NQ) AND THE BRAVAIS LATTICE
C	   DESCRIPTION OF THE CELL ON WHICH THE PROGRAM WILL OPERATE.
C	   AS MANY CARDS AS ARE NECESSARY MAY BE USED TO COMPLETE THE
C	   DESIRED SUCCESSIVE TRANSFORMATIONS FOR ANY ONE COMPOUND.
C	   THEIR ORDER SPECIFIES TO THE PROGRAM THE ORDER IN WHICH THE
C	   TRANSFORMATIONS ARE TO BE EXECUTED.	  THE LAST INSTRUCTION
C	   CARD FOR A PARTICULAR SEQUENCE OF TRANSFORMATIONS MUST HAVE
C	   NQ = 7 OR 8.  BOTH MAY NOT BE PRESENT AND NEITHER MAY PRECEDE
C	   ANY WITH NQ = 1,2,3,4,5 OR 6.  NQ = 7 TRIGGERS CELL REDUCTION
C	   AND NQ = 8 MERELY IDENTIFIES THE LAST CELL IN A SEQUENCE TO
C	   WHICH A TRANSFORMATION IS TO BE MADE WHEN NO CELL REDUCTION
C	   IS PERFORMED.  THUS, INSTRUCTION CARDS ARE READ UNTIL THE
C	   PROGRAM FINDS ONE WITH NQ = 7 OR 8.	INSTRUCTION CARDS WITH
C	   NQ.LE.6 MAY BE INTERMIXED.
C
C		 INSTR. CODE		    INSTRUCTION
C
C	COL. 3	    NQ = 1  TRANSFORM THIS CELL TO A NEW CELL USING A
C			    MATRIX SUPPLIED BY THE USER ON THE CORRE-
C			    SPONDING TRANSFORMATION CARD.
C		       = 2  THIS CELL IS A-CENTERED.  THE PROGRAM WILL
C			    TRANSFORM IT TO A PRIMITIVE CELL USING A
C			    MATRIX IN SUBROUTINE CENTER.
C		       = 3  THIS CELL IS B-CENTERED.  THE PROGRAM WILL
C			    TRANSFORM IT TO A PRIMITIVE CELL USING A
C			    MATRIX IN SUBROUTINE CENTER.
C		       = 4  THIS CELL IS C-CENTERED.  THE PROGRAM WILL
C			    TRANSFORM IT TO A PRIMITIVE CELL USING A
C			    MATRIX IN SUBROUTINE CENTER.
C		       = 5  THIS CELL IS BODY-CENTERED. THE PROGRAM WILL
C			    TRANSFORM IT TO A PRIMITIVE CELL USING A
C			    MATRIX IN SUBROUTINE CENTER.
C		       = 6  THIS CELL IS FACE-CENTERED. THE PROGRAM WILL
C			    TRANSFORM IT TO A PRIMITIVE CELL USING A
C			    MATRIX IN SUBROUTINE CENTER.
C		       = 7  TRANSFORM THIS CELL TO ITS REDUCED CELL AND
C			    THEN IDENTIFY AND GENERATE FROM IT THE UNIT
C			    CELL OF HIGHEST SYMMETRY AND ITS CORRESPOND-
C			    ING LATTICE PARAMETERS.  (ALL TRANSFORMATION
C			    MATRICES FOR THIS INSTRUCTION ARE GENERATED
C			    BY THE PROGRAM.)
C		       = 8  THIS IS A NON-EXECUTABLE INSTRUCTION NOTIFY-
C			    ING THE PROGRAM THAT NO TRANSFORMATION IS TO
C			    BE APPLIED TO THIS CELL.  THIS INSTRUCTION
C			    CARD MAY BE USED FOR ONE OF TWO PURPOSES.
C			    (A) TO CALCULATE THE INVERSE CELL DATA OF
C			    THE INPUT PARAMETERS, VOLUME AND SIN AND COS
C			    VALUES OF CELL ANGLES, OR (B) TO IDENTIFY
C			    THE NAME OF THE CELL TO WHICH THE PREVIOUS
C			    CELL IS TRANSFORMED WHEN THE PREVIOUS CELL
C			    IN A TRANSFORMATION SEQUENCE INVOLVES ANY
C			    ONE OF THE FOLLOWING INSTRUCTIONS--NQ=1,2,3,
C			    4,5 OR 6.
C
C	COL. 6-70  CELL     ANY ALPHANUMERIC INFORMATION DESCRIBING THE
C			    CELL, E.G., CRYSTAL SYSTEM AND LATTICE TYPE.
C			    LEFT JUSTIFY.  THIS WILL BE PRINTED BACK OUT
C			    AS A HEADING IN THE OUTPUT FOR IDENTIFICA-
C			    TION PURPOSES.
C
C  5. TRANSFORMATION CARDS -- FORMAT(9F8.5).
C
C	   EACH CARD CONTAINS A 3X3 TRANSFORMATION MATRIX (ONE PER CARD)
C	   TO BE USED BY THE PROGRAM FOR EACH INSTRUCTION CARD WITH NQ=1
C	   AND ARE ARRANGED IN THE SAME ORDER AS ARE THE INSTRUCTION
C	   CARDS (WITH NQ=1) WHICH WILL USE THEM.  IF NO INSTRUCTION
C	   CARDS ARE PRESENT WITH NQ=1, THESE TRANSFORMATION CARDS ARE
C	   OMITTED.
C	   (EXAMPLE.  INSTRUCTION CARD NO. 1 HAS NQ=1 AND CARD NO. 2
C	   HAS NQ=8.  INSTR. CARD NO. 1 CORRESP. TO CELL NO. 1 AND
C	   INSTR. CARD NO. 2 CORRESP. TO CELL NO. 2.  ONE MATRIX CARD
C	   IS THEREFORE SUPPLIED WHICH IS USED BY THE PROGRAM TO
C	   TRANSFORM CELL 1 TO CELL 2.)
C	   THE 3X3 MATRIX FOR VECTOR TRANSFORMATION OF UNIT CELL AXES
C	   IS DEFINED BY THE USUAL CONVENTION AS FOLLOWS
C		    NEWA = P(1,1)*A + P(1,2)*B + P(1,3)*C
C		    NEWB = P(2,1)*A + P(2,2)*B + P(2,3)*C
C		    NEWC = P(3,1)*A + P(3,2)*B + P(3,3)*C
C	   WHERE A,B,C,NEWA,NEWB,NEWC ARE VECTORS DESCRIBING THE OLD AND
C	   NEW CELL RESPECTIVELY.  THE ORDER OF PUNCHING IS P(1,1),
C	   P(1,2),P(1,3),P(2,1),P(2,2),P(2,3),P(3,1),P(3,2),P(3,3).
C
C  6.  STOPPER CARD -- 1 IN COL. 72
C
C	   ANY NUMBER OF SETS OF DATA MAY BE PROCESSED WITHOUT RELOADING
C	   THE PROGRAM.  EACH DATA SET CONSISTS OF ITEMS 1 - 5 ABOVE.
C
C     GLOSSARY OF SYMBOLS FOR MAIN PROGRAM AND SUBROUTINES RCELL,
C     LATCON, STORE, DIMEN, MATIN, MATOFC, CENTER
C
C     A 	 DIRECT CELL PARAMETER, A
C     AA	 A*A
C     AB	 A*B*COSGA = SCALAR PRODUCT OF A WITH B
C     ABSAB	 ABS(AB)
C     ABSBC	 ABS(BC)
C     ABSCA	 ABS(CA)
C     AL	 DIRECT CELL PARAMETER, ALPHA, IN RADIANS
C     ALPHA	 DIRECT CELL PARAMETER, ALPHA, IN DEGREES
C     ALS	 RECIPROCAL CELL PARAMETER, ALPHA-STAR, IN RADIANS
C     ALSTAR	 RECIPROCAL CELL PARAMETER, ALPHA-STAR, IN DEGREES
C     ANGLE(3)	 DIRECT CELL PARAMETERS ALPHA, BETA, GAMMA IN NEW CELL
C     AS	 RECIPROCAL CELL PARAMETER, A-STAR
C     AXIS(3)	 DIRECT CELL PARAMETERS A, B, C OF NEW CELL
C     B 	 DIRECT CELL PARAMETER, B
C     BB	 B*B
C     BC	 B*C*COSAL = SCALAR PRODUCT OF B WITH C
C     BE	 DIRECT CELL PARAMETER, BETA, IN RADIANS
C     BES	 RECIPROCAL CELL PARAMETER, BETA-STAR, IN RADIANS
C     BESTAR	 RECIPROCAL CELL PARAMETER, BETA-STAR, IN DEGREES
C     BET	 MODULUS OF TRANSF. MATRIX FOR CELL(N+1) TO CELL(N)
C     BETA	 DIRECT CELL PARAMETER, BETA, IN DEGREES
C     BS	 RECIPROCAL CELL PARAMETER, B-STAR
C     C 	 DIRECT CELL PARAMETER, C
C     CA	 C*A*COSBE = SCALAR PRODUCT OF C WITH A
C     CC	 C*C
C     CELL(12,12)   ANY ALPHANUMERIC INFORMATION DESCRIBING THE CELL
C     CSE(3)	 COSINE OF NEW ALPHA, BETA, GAMMA
C     COSAL	 COS(AL)
C     COSALS	 COS(ALS)
C     COSBE	 COS(BE)
C     COSBES	 COS(BES)
C     COSGA	 COS(GA)
C     COSGAS	 COS(GAS)
C     CS	 RECIPROCAL CELL PARAMETER, C-STAR
C     D(3)	 DIRECT CELL PARAMETERS A, B, C IN NEW ORIENTED CELL
C     DET	 MODULUS OF TRANSF. MATRIX FOR CELL(N) TO CELL(N+1)
C     DIS(6,12)  STORAGE LOCATIONS FOR A, B, C, ALPHA, BETA, GAMMA
C     GA	 DIRECT CELL PARAMETER, GAMMA, IN RADIANS
C     GAMMA	 DIRECT CELL PARAMETER, GAMMA, IN DEGREES
C     GAS	 RECIPROCAL CELL PARAMETER, GAMMA-STAR, IN RADIANS
C     GASTAR	 RECIPROCAL CELL PARAMETER, GAMMA-STAR, IN DEGREES
C     I 	 INDEX
C     IAXIS	 AXIS (VECTOR) HELD CONSTANT. 1=A, 2=B, 3=C
C     ICONT	 CONTINUATION/STOPPER CODE FOR NEXT JOB
C     ICYCLE	 NUMBER OF CYCLES IN REDUCED CELL ROUTINE
C     IHKL(12)	 CODE FOR PROGRAM SECTION
C     INPUT	 SPECIFICATION CODE FOR CELL PARAMETERS READ AT INPUT
C     IOUTPT	 PROGRAM SECTION NUMBER
C     IS	 CODE FOR USE IN SUBR. LATCON
C     ISIGN	 NUMBER OF ACUTE ANGLES IN REDUCED CELL
C     ISUM	 ITOTAL (+2, IF NQ(ITOTAL)=7)
C     ITL	 ITOTAL (+1, IF NQ(ITOTAL)=7)
C     ITOTAL	 TOTAL NUMBER OF CELL IDENTIFICATION CARDS READ IN
C     ITT	 SECTION IDENTIFICATION IN SUBR. TEST
C     J 	 INDEX
C     J1	 ITOTAL + 1
C     J2	 ITOTAL + 2
C     JA	 CODE FOR SHIFT IN A-AXIS.  JA=0 NO SHIFT, JA=1 SHIFT
C     JB	 CODE FOR SHIFT IN B-AXIS.  JB=0 NO SHIFT, JB=1 SHIFT
C     JB2	 INDEX
C     JC	 CODE FOR SHIFT IN C-AXIS.  JC=0 NO SHIFT, JC=1 SHIFT
C     JF	 JA + JB + JC
C     JJ	 INDEX
C     JL	 INDEX
C     K 	 INDEX
C     K2	 CODE FOR REDUCTION OF REMAINING TWO AXES
C     K4	 INDEX IDENT. FOR MATRIX IN SUBR. MATIN AND MATOFC
C     K8	 STORAGE FOR K
C     KK	 CODE FOR PARAMETERS IN CONVENTIONAL CELL. 1=A, 2=B, 3=C
C     KX	 INDEX
C     L 	 INDEX
C     L2	 INDEX
C     LINE	 PAGE CONTROL FOR OUTPUT
C     LL	 INDEX
C     LM	 INDEX
C     LOC	 ERROR IDENTIFICATION IN SUBROUTINE RCELL
C     M 	 INDEX
C     MA	 SECTION IDENTIFICATION IN SUBR. MATOFC
C     MATRIX	 NUMBER OF TRANSFORMATION CARDS READ IN
C     MAX	 LARGEST CELL PARAMETER READ AT INPUT. 1=A, 4=B, 7=C
C     MM(3,3,3)  MATRIX ELEMENTS (IN FIXED PT.) FOR CELL(N+1) TO CELL(N)
C     N(9)	 ELEMENTS OF DIRECT TRANSFORMATION MATRIX TO RED. CELL
C     NA(9)	 MATRIX ELEMENTS OF CELL(N) TO CELL(N+1) IN SUBR. RCELL
C     NB(9)	 MATRIX ELEMENTS OF CELL(1) TO CELL(N+1) IN SUBR. RCELL
C     NCHECK	 INDEX CONTROLLING REDUCTION OF CELL PARAMETER
C     NN(3,3,3)  MATRIX ELEMENTS (IN FIXED PT.) FOR CELL(N) TO CELL(N+1)
C     NQ(12)	 TRANSFORMATION INSTRUCTION CODE
C     NSTOP	 INDEX CONTROL. WHEN NSTOP = 3, REDUCTION CYCLE COMPLETE
C     NTEMP(9)	 TEMPORARY STORAGE LOCATION FOR MATRIX ELEMENTS
C     NTURN	 INDEX CONTROL
C     P(3,3,3)	 MATRIX ELEMENTS (IN FLOATING POINT)
C     PN	 INTEGER (FLOATING PT.)
C     Q(3,3,12)  MATRIX ELEMENTS (IN FLOATING POINT)
C     QMAX	 THE LARGER OF TWO CELL PARAMETERS
C     QQMAX	 THE LARGEST OF (ABSAB, ABSBC, ABSCA)
C     S(3,3,14)  MATRIX ELEMENTS (IN FLOAT PT.) FOR CELL(N+1) TO CELL(N)
C     SINAL	 SIN(AL)
C     SINALS	 SIN(ALS)
C     SINBE	 SIN(BE)
C     SINBES	 SIN(BES)
C     SINGA	 SIN(GA)
C     SINGAS	 SIN(GAS)
C     STORE	 TEMPORARY STORAGE LOCATION FOR NEW SCALAR PRODUCT
C     SUM	 BC + CA + AB
C     TITLE(14)  ALPHANUMERIC TITLE READ AT START OF PROGRAM
C     V 	 CELL VOLUME IN DIRECT SPACE
C     VS	 CELL VOLUME IN RECIPROCAL SPACE
C     W(3,3,12)  MATRIX ELEMENTS OF ORIGNAL CELL TO FINAL CELL
C     X 	 TEMPORARY LOCATION FOR CELL PARAMETER A, B OR C
C     XX	 X*X
C     XY	 TEMPORARY LOCATION FOR SCALAR PRODUCT AB, BC OR CA
C     XY2	 TEMPORARY LOCATION OF NEW SCALAR PRODUCT
C     Y 	 TEMPORARY LOCATION FOR CELL PARAMETER A, B OR C
C     YY	 Y*Y
C     YZ	 TEMPORARY LOCATION FOR SCALAR PRODUCT AB, BC OR CA
C     Z 	 TEMPORARY LOCATION FOR CELL PARAMETER A, B OR C
C     ZX	 TEMPORARY LOCATION FOR SCALAR PRODUCT AB, BC OR CA
C     ZX2	 TEMPORARY LOCATION OF NEW SCALAR PRODUCT
C     ZZ	 Z*Z
C
C     MAIN PROGRAM.  INPUT/OUTPUT ROUTINE AND CALLING PROGRAM FOR
C     INSTRUCTIONS NQ.
C
      DIMENSION TITLE(14),NQ(12),CELL(12, 6),P(3,3,12),IHKL(12),
     1 DIS(6,12),NN(3,3,3),MM(3,3,4),S(3,3,15),DET(15),BET(15)
      CHARACTER*1 ANS
      character*80 lineout
      COMMON /TESTZ/ITZ,INTERO
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
      COMMON SINAL,SINBE,SINGA,ALS,BES,GAS,SINALS,SINBES,SINGAS,COSALS,
     1 COSBES,COSGAS,AS,BS,CS,AL,BE,GA,ALSTAR,BESTAR,GASTAR,V,VS
      DATA BLNK/4H     /
C
C     INPUT AND OUTPUT UNIT SPECIFIERS
      IIN=5
      IOUT=5
C
C
C	   FORMAT STATEMENTS
C
 1000 FORMAT (14A4)
 1002 FORMAT (6F10.6)
 1003 FORMAT (I1,6A4)
 1004 FORMAT (9F8.0)
 1006 FORMAT (1H ,14A4)
 1009 FORMAT (1H-, 3X, 40H LATTICES USED AND GENERATED BY PROGRAM  / )
 1010 FORMAT (1H , 5X, 7H CELL (,I1,4H)   ,6A4)
 1011 FORMAT (1H , 5X, 7H CELL (,I1,16H)   REDUCED CELL)
 1012 FORMAT (1H , 5X, 7H CELL (,I1,43H)   REDUCED CELL (CONVENTIONAL OR
     1IENTATION))
 1018 FORMAT (1H-,/4X,25H TRANSFORMATION MATRICES / )
 1019 FORMAT (1H-,  5X, 7H CELL (,I1,11H) TO CELL (,I1,1H),
     1		    5X, 7H CELL (,I1,11H) TO CELL (,I1,1H) /  )
 1020 FORMAT (1H ,  5X, 3F7.2,	5X, 3F7.2 )
 1021 FORMAT (1H-,  5X, 19H CELL (1) TO CELL (,I1,1H),
     1		    5X,  7H CELL (,I1,13H) TO CELL (1) /)
 1023 FORMAT (1H0, 3X, 29H LATTICE PARAMETERS OF CELL (,I1,5H) -- /1H ,
     1 6A4)
 1024 FORMAT (1H0,  5X, 6H A  = F9.4,  4X, 10H ALPHA  = F10.4)
 1025 FORMAT (1H ,  5X, 6H B  = F9.4,  4X, 10H BETA   = F10.4)
 1026 FORMAT (1H ,  5X, 6H C  = F9.4,  4X, 10H GAMMA  = F10.4)
 1027 FORMAT (1H0,  5X, 6H A* = F9.6,  4X, 10H ALPHA* = F10.4)
 1028 FORMAT (1H ,  5X, 6H B* = F9.6,  4X, 10H BETA * = F10.4)
 1029 FORMAT (1H ,  5X, 6H C* = F9.6,  4X, 10H GAMMA* = F10.4)
 1030 FORMAT (1H0,  5X, 6H V  = F9.3)
 1031 FORMAT (1H ,  5X, 6H V* = F9.6, // )
 1032 FORMAT (1H-, 3X, 44H NATURAL TRIGONOMETRIC VALUES OF THE ANGLES )
 1033 FORMAT (1H , 15X, 7H ANGLE , 4X, 5H SIN , 5X, 5H COS )
 1034 FORMAT (1H0,  5X, 7H ALPHA , F10.4, 2F10.5)
 1035 FORMAT (1H ,  5X, 7H BETA  , F10.4, 2F10.5)
 1036 FORMAT (1H ,  5X, 7H GAMMA , F10.4, 2F10.5)
 1037 FORMAT (1H0,  5X, 7H ALPHA*, F10.4, 2F10.5)
 1038 FORMAT (1H ,  5X, 7H BETA *, F10.4, 2F10.5)
 1039 FORMAT (1H ,  5X, 7H GAMMA*, F10.4, 2F10.5)
 1040 FORMAT (1H0, 5X, 44H SCALARS CORRESPONDING TO THIS REDUCED CELL  )
 1041 FORMAT (1H-,  5X, 9H R(1,1) = F7.2, 5X, 9H R(2,2) = F7.2, 5X,
     1			9H R(3,3) = F7.2)
 1042 FORMAT (1H0,  5X, 9H R(2,3) = F7.2, 5X, 9H R(3,1) = F7.2, 5X,
     1			9H R(1,2) = F7.2)
 1043 FORMAT (1H-,  5X, 28H R(2,3) + R(3,1) + R(1,2)  =  F7.2)
 1044 FORMAT (1H ,  9X, 3I4, 14X, 3I4)
 1045 FORMAT (1H0, 3X, 29H LATTICE PARAMETERS OF CELL (,I1,1H)/44H  -- R
     1EDUCED CELL (CONVENTIONAL ORIENTATION))
 1046 FORMAT (1H , 10X, 6H MOD = F8.4, 10X, 6H MOD = F8.4 )
 1048 FORMAT (1H-, 3X, 29H LATTICE PARAMETERS OF CELL (,I1,17H) -- REDUC
     1ED CELL)
 1070 FORMAT (I1)
      WRITE(6,1267)
1267  FORMAT(' TRACER II - LATTICE TRANSFORMATION AND'/
     1  10X,'A CELL REDUCTION PROGRAM'/
     1  10X,'WRITTEN BY S. L. LAWTON AND R. A. JACOBSON'/
     1  10X,'U.S.A.E.C. AMES LABS REPORT IS-1141 AMES, IOWA.'/
     2  10X,'CONTRIBUTED TO THE MRL/PSU SYSTEM BY C. FORIS.'/
     3  10X,'VAX MODIFICATIONS BY GERALD G. JOHNSON JR.'/
     4  10X,'VAX VERSION JUN 25, 1987'//
     1  10X,'YOU MAY WANT TO COMPARE A KNOWN CELL WITH YOUR'/
     2  10X,'CELL, BY RUNNING THE KNOWN CELL THROUGH THIS CELL'/
     3  10X,'REDUCTION ROUTINE, TO SEE IF THE REDUCTED CELL IS'/
     4  10X,'THE SAME FOR BOTH CELLS.'//) 
40123 WRITE(6,40124)
40124 FORMAT(' DO YOU WANT TO SEE A LISTING OF THE PROGRAM'/
     1 10X,'DESCRIPTION AND INPUT INSTRUCTIONS (Y/[N]/E) ? '$)
      READ(5,40125) NCR,ANS
40125 FORMAT(Q,1A1)
      IF(NCR.EQ.0) ANS='N'
      KEY=STR$UPCASE(ANS,ANS)
      IF(ANS.EQ.'E') STOP 'JOB ABORTED--START AGAIN'
      IF(ANS.EQ.'Y') THEN
                     open(unit=48,status='old',readonly,shared,
     1                    file='helpfile')
                     do 3478 i=1,10000
                     read(48,3488,end=3489) lineout
3488                 format(a)
                     write(6,43488) lineout(1:79)
43488                format(1x,a)
3478                 continue
3489                 continue                  
                     GO TO 40123
      ENDIF
      IF(ANS.EQ.'N') GO TO 40126
      GO TO 40123
40126 CONTINUE
C
C	   INPUT
C
 1100 FORMAT(' ENTER TITLE   - CONTROL Z TO END RUN')
    1 TYPE 1100
      READ (IIN,1000,END=2020) (TITLE(I), I = 1,14)
    2 TYPE 1101
 1101 FORMAT(' ENTER CELL INDICATOR NUMBER = '/
     1  10X,'1 CELL PARAMETERS IN DIRECT SPACE'/
     2  10X,'2 CELL PARAMETERS IN RECIPROCAL SPACE'/
     3  10X,'ENTER YOUR VALUE [1]  ',$)
      READ (IIN,41070,ERR=2,END=2020) NCR,INPUT
41070 FORMAT(Q,I)
      IF(NCR.EQ.0) INPUT=1
      IF(INPUT.LT.1.OR.INPUT.GT.2) GO TO 2
41108 TYPE 1108
 1108 FORMAT (' ENTER LARGEST PERMISSIBLE DIFFERENCE = '/
     1   10X,'TYPICAL VALUES (0.01 TO 1.50) [0.10]  ',$)
      READ (IIN,71002,ERR=41108,END=2020) NCR,DEL
71002 FORMAT(Q,F10.2)
      IF(NCR.EQ.0) DEL =0.10
      IF(DEL.LE.0.0.OR.DEL.GT.1.0) GO TO 41108
41122 TYPE 1122
 1122 FORMAT (' SHORT OUTPUT ENTER A ZERO [0]'/
     1    10X,'FULL OUTPUT ENTER A ONE (1) '$)
      READ (IIN,51070,ERR=41122,END=2020) NCR,INTERO
51070 FORMAT(Q,I)
      IF(NCR.EQ.0) INTERM=0
      IF(INTERM.LT.0.OR.INTERMO.GT.1) GO TO 41122
 1102 FORMAT (' A            = '$)
 1112 FORMAT (' B [B=A]      = '$)
 1113 FORMAT (' C [C=A]      = '$)
 1114 FORMAT (' ALPHA [90.0] = '$)
 1115 FORMAT (' BETA  [90.0] = '$)
 1116 FORMAT (' GAMMA [90.0] = '$)
 1103 FORMAT (' AS = '$)
 1117 FORMAT (' BS = '$)
 1118 FORMAT (' CS = '$)
 1119 FORMAT (' ALSTAR = '$)
 1120 FORMAT (' BESTAR = '$)
 1121 FORMAT (' GASTAR = '$)
      GO TO (61, 62), INPUT
   61 TYPE 1102
      IS = 1
      READ (IIN,1002,ERR=61,END=2020) A
      IF(A.LT.2.0.OR.A.GT.100.0) GO TO 61
      TYPE 1112
      READ (IIN,41002,ERR=61,END=2020) NCR,B
41002 FORMAT(Q,F10.5)
      IF(NCR.EQ.0) B=A
      IF(B.LT.2.0.OR.B.GT.100.0) GO TO 61
      TYPE 1113
      READ (IIN,41002,ERR=61,END=2020) NCR,C
      IF(NCR.EQ.0) C=A
      IF(C.LT.2.0.OR.C.GT.100.0) GO TO 61
      TYPE 1114
      READ (IIN,41008,ERR=61,END=2020) NCR,ALPHA
41008 FORMAT(Q,F10.0)
      IF(NCR.EQ.0) ALPHA=90.0
      IF(ALPHA.LT.60.0.OR.ALPHA.GT.130.0)GO TO 61
      TYPE 1115
      READ (IIN,41008,ERR=61,END=2020) NCR,BETA
      IF(NCR.EQ.0) BETA=90.0
      IF(BETA.LT.60.0.OR.BETA.GT.130.0) GO TO 61
      TYPE 1116
      READ (IIN,41008,ERR=61,END=2020) NCR,GAMMA
      IF(NCR.EQ.0) GAMMA=90.0
      IF(GAMMA.LT.60.0.OR.GAMMA.GT.130.0)GO TO 61
      GO TO 70
   62 TYPE 1103
      READ (IIN,1002,ERR=62,END=2020) AS
      TYPE 1117
      READ (IIN,1002,ERR=62,END=2020) BS
      TYPE 1118
      READ (IIN,1002,ERR=62,END=2020) CS
      TYPE 1119
      READ (IIN,1002,ERR=62,END=2020) ALSTAR
      TYPE 1120
      READ (IIN,1002,ERR=62,END=2020) BESTAR
      TYPE 1121
      READ (IIN,1002,ERR=62,END=2020) GASTAR
      IS = 3
   70 ITOTAL = 0
      MATRIX = 0
41104 TYPE 1104
 1104 FORMAT('	    BRAVAIS LATTICE DESCRIPTIONS (I1,6A4)'/
     1  10X,'1 TRANSFORM THIS CELL'/
     2  10X,'2 THIS CELL IS A-CENTERED'/
     3  10X,'3 THIS CELL IS B-CENTERED'/
     4  10X,'4 THIS CELL IS C=CENTERED'/
     5  10X,'5 THIS CELL IS BODY-CENTERED'/
     6  10X,'6 THIS CELL IS FACE-CENTERED'/
     7  10X,'7 TRANSFORM THIS CELL TO ITS REDUCED CELL AND THEN'/
     8  15X,'IDENTIFY AND GENERATE FROM IT THE UNIT CELL OF HIGHEST'/
     9  15X,'SYMMETRY AND ITS CORRESPONDING LATTICE PARAMETERS'/
     1  10X,'8 THIS IS A NON-EXECUTABLE INSTRUCTION WHICH'/
     2  15X,'FOLLOWS INSTRUCTIONS 1,2,3,4,5, OR 6 [7]')   
   71 ITOTAL = ITOTAL + 1
      TYPE  1199
 1199 FORMAT(' NQ= [7] '$)
      READ (IIN,1003,END=2020,ERR=41104) NQ(ITOTAL), 
     1      (CELL(ITOTAL,I),I=1, 6)
      IF (NQ(ITOTAL).EQ.0) NQ(ITOTAL)=7
      IF (NQ(ITOTAL).EQ.1) GO TO 72
      GO TO 73
   72 MATRIX = MATRIX + 1
   73 I = NQ(ITOTAL)
      GO TO (71,71,71,71,71,71,74,75), I
   74 ISUM = ITOTAL + 2
      ITL = ITOTAL + 1
      GO TO 76
   75 ISUM = ITOTAL
      ITL = ITOTAL
   76 IF (MATRIX) 600, 600, 78
   78 TYPE 1106 , MATRIX
41101 TYPE 1107
 1106 FORMAT(' ENTER',I3,' LINES OF MATRIX ELEMENTS.'/
     1 10X,'THESE ARE REAL NUMBERS, SEPARATED BY COMMAS'/
     2 10X,'SUCH AS 1.,0.,0.,    0.,1.,0.,    0.,0.,1.')
 1107 FORMAT(' P(1,1,K)P(1,2,K)P(1,3,K)P(2,1,K)P(2,2,K)P(2,3,K)P(3,1,K)P
     1(3,2,K)P(3,3,K)'/)
      DO 83 K = 1,ITOTAL
      IF (NQ(K).NE.1) GO TO 83
      READ (IIN,1004,ERR=41101,END=2020)((P(I,J,K),J=1,3),I=1,3)
   83 CONTINUE
      K = 1
      K4 = 1
      CALL MATIN(K4)
C
C	   PRELIMINARY OUTPUT
C
  600 IOUTPT = 1
      ICYCLE = 0
      K = 1
      IHKL(1) = 1
      CALL LATCON(IS)
      CALL STORE
      IF (NQ(1).EQ.8) GO TO 742
      DO 660 I = 1,14
      IF (TITLE(I) .EQ. BLNK ) GO TO 64
  660 ITZ = I
   64 WRITE (IOUT,1006), (TITLE(I), I = 1,ITZ)
      WRITE (IOUT,1009)
      DO 13 J = 1,ITOTAL
   13 WRITE(IOUT,1010)J,(CELL(J,I),I=1, 6)
      IF (NQ(ITOTAL).EQ.7) GO TO 14
      GO TO 113
   14 J1 = ITOTAL + 1
      J2 = ITOTAL + 2
      WRITE(IOUT,1011)J1
      WRITE(IOUT,1012)J2
C
C	   CALL DESIRED TRANSFORMATION SUBROUTINE
C
  113 I = NQ(K)
      GO TO (5001,5000,5000,5000,5000,5000,5002), I
 5000 CALL CENTER(K,NQ,P)
      K4 = 1
      CALL MATIN(K4)
 5001 CALL DIMEN
      IS = 1
      CALL LATCON (IS)
      CALL STORE
      IF (K - 1) 64,64,63
   63 IF (ISUM - K) 41,41,113
 5002 CALL RCELL (IOUT)
   41 MA = 1
      CALL MATOFC(MA,K4,ITL)
C
C	   FINAL OUTPUT
C
   68 IOUTPT = 3
      IF (NQ(ITOTAL).EQ.8) GO TO 69
      LINE = 0
      ITT = 1
      CALL TEST(ITT,LINE,IOUT)
   69 IF (INTERO .EQ. 0 ) GO TO  755
      WRITE (IOUT,1018)
      K = 1
      IF (ISUM - 5) 798, 799, 799
  798 LINE = 2
      GO TO 800
  799 LINE = 3
  800 I = NQ(K)
      GO TO (750,750,750,750,750,750,751), I
  750 KX = K + 1
      L2=K
      WRITE(IOUT,1019) K,KX,KX,K
      WRITE (IOUT,1020) P(1,1,K),P(1,2,K),P(1,3,K), S(1,1,K),S(1,2,K),S(
     11,3,K)
      WRITE (IOUT,1020) P(2,1,K),P(2,2,K),P(2,3,K), S(2,1,K),S(2,2,K),S(
     12,3,K)
      WRITE (IOUT,1020) P(3,1,K),P(3,2,K),P(3,3,K), S(3,1,K),S(3,2,K),S(
     13,3,K)
      WRITE(IOUT,1046) DET(K),BET(K)
      GO TO 755
  751 L = 1
      KX = K + 1
      WRITE (IOUT,1019), K, KX, KX, K
      WRITE (IOUT,1044), NN(1,1,L),NN(1,2,L),NN(1,3,L),MM(1,1,L),
     1MM(1,2,L),  MM(1,3,L)
      WRITE (IOUT,1044), NN(2,1,L),NN(2,2,L),NN(2,3,L), MM(2,1,L),
     1MM(2,2,L),  MM(2,3,L)
      WRITE (IOUT,1044), NN(3,1,L),NN(3,2,L),NN(3,3,L), MM(3,1,L),
     1MM(3,2,L),  MM(3,3,L)
      WRITE (IOUT,1046), DET(K), BET(K)
      LINE = LINE + 1
      IF (LINE - 5) 752, 743, 743
  743 LINE = 1
      WRITE(IOUT, 1006), (TITLE(I), I = 1,ITZ)
  752 IF (INTERO .EQ. 0)   GO TO 755
      L = 2
      KX = K + 2
      WRITE (IOUT,1019), K, KX, KX, K
      WRITE (IOUT,1044), NN(1,1,L),NN(1,2,L),NN(1,3,L),MM(1,1,L),
     1MM(1,2,L),  MM(1,3,L)
      WRITE (IOUT,1044), NN(2,1,L),NN(2,2,L),NN(2,3,L), MM(2,1,L),
     1MM(2,2,L),  MM(2,3,L)
      WRITE (IOUT,1044), NN(3,1,L),NN(3,2,L),NN(3,3,L), MM(3,1,L),
     1MM(3,2,L),  MM(3,3,L)
      WRITE (IOUT,1046) DET(K+1), BET(K+1)
  755 LINE = LINE + 1
      IF (LINE - 5) 741, 740, 740
  740 LINE = 1
      WRITE(IOUT, 1006), (TITLE(I), I = 1,ITZ)
  741 K = K + 1
      IF (ITL - K) 753, 753, 800
  753 IF (ITL - 3) 754, 757, 757
  754 IF (NQ(1).EQ.7) GO TO 746
      GO TO 742
  757 IF (NQ(ITOTAL).EQ.8) GO TO 747
  746 ITT = 2
      CALL TEST(ITT,LINE,IOUT)
      IF (NQ(1).EQ.7) GO TO 758
  747 IF (INTERO .EQ. 0 ) GO TO 7581
      WRITE (IOUT,1021) ITL,ITL
      WRITE (IOUT,1020), P(1,1,L2),P(1,2,L2),P(1,3,L2), S(1,1,L2),
     1S(1,2,L2),  S(1,3,L2)
      WRITE (IOUT,1020), P(2,1,L2),P(2,2,L2),P(2,3,L2), S(2,1,L2),
     1S(2,2,L2),  S(2,3,L2)
      WRITE (IOUT,1020), P(3,1,L2),P(3,2,L2),P(3,3,L2), S(3,1,L2),
     1S(3,2,L2),  S(3,3,L2)
      WRITE (IOUT,1046), DET(L2), BET(L2)
 7581 IF (ICYCLE) 742,742,758
  758 K4 = 4
      JB2 = ITL - 1
      DO 7771 I = 1,3
      DO 7771 J = 1,3
 7771 P(I,J,JB2) = NN(I,J,2)
      MA = 2
      IF (NQ(1).EQ.7) L2 = 2
      IF (NQ(1).EQ.7) GO TO 762
      CALL MATOFC(MA,K4,ITL)
 7772 LINE = LINE + 1
      IF (LINE - 5) 761, 760, 760
  760 LINE = 1
      IF (INTERO .EQ. 0 ) GO TO 762
      WRITE(IOUT, 1006), (TITLE(I), I = 1,ITZ)
  761 WRITE (IOUT,1021), ISUM, ISUM
      WRITE (IOUT,1020), P(1,1,L2),P(1,2,L2),P(1,3,L2), S(1,1,L2),
     1S(1,2,L2),  S(1,3,L2)
      WRITE (IOUT,1020), P(2,1,L2),P(2,2,L2),P(2,3,L2), S(2,1,L2),
     1S(2,2,L2),  S(2,3,L2)
      WRITE (IOUT,1020), P(3,1,L2),P(3,2,L2),P(3,3,L2), S(3,1,L2),
     1S(3,2,L2),  S(3,3,L2)
      WRITE (IOUT,1046), DET(L2), BET(L2)
  762 ITT = 3
      CALL TEST(ITT,LINE,IOUT)
C
  742 J = 0
  756 J = J + 1
      WRITE(IOUT, 1006), (TITLE(I), I = 1,ITZ)
      IF (IHKL(J) - 2) 771,772,773
  771 WRITE (IOUT,1023), J, (CELL(J,I),I=1, 6)
      GO TO 774
  772 WRITE(IOUT, 1048), J
      GO TO 774
  773 WRITE (IOUT,1045), J
  774 A = DIS(1,J)
      B = DIS(2,J)
      C = DIS(3,J)
      ALPHA = DIS(4,J)
      BETA  = DIS(5,J)
      GAMMA = DIS(6,J)
      IS = 1
      CALL LATCON(IS)
  777 IF(INTERO .EQ. 0 .AND. IHKL(J) .GE. 2) GO TO 7773
      WRITE (IOUT,1024), A, ALPHA
      WRITE (IOUT,1025), B, BETA
      WRITE (IOUT,1026), C, GAMMA
      WRITE (IOUT,1027), AS, ALSTAR
      WRITE (IOUT,1028), BS, BESTAR
      WRITE (IOUT,1029), CS, GASTAR
      WRITE (IOUT,1030), V
      WRITE (IOUT,1031), VS
C
      WRITE (IOUT,1032)
      WRITE (IOUT,1033)
      WRITE (IOUT,1034), ALPHA, SINAL, COSAL
      WRITE (IOUT,1035), BETA,	SINBE, COSBE
      WRITE (IOUT,1036 )GAMMA, SINGA, COSGA
      WRITE(IOUT,1037) ALSTAR,SINALS,COSALS
      WRITE(IOUT,1038) BESTAR, SINBES, COSBES
      WRITE(IOUT,1039) GASTAR,SINGAS,COSGAS
C
 7773 IF (NQ(1).EQ.8) GO TO 1
      I = IHKL(J)
      GO TO (208, 871, 871, 1), I
C
  871 IF (INTERO .EQ. 0) GO TO 208
      WRITE (IOUT,1040)
      AA = A*A
      BB = B*B
      CC = C*C
      AB = A*B*COSGA
      BC = B*C*COSAL
      CA = C*A*COSBE
      SUM = AB + BC + CA
      WRITE(IOUT,1041)AA,BB,CC
      WRITE(IOUT,1042)BC,CA,AB
      WRITE(IOUT,1043)SUM
C
  208 IF (ISUM - J) 890, 890, 756
  890 IF (NQ(ITOTAL).EQ.8) GO TO 1
      ITT = 4
      J = JSUM
      IHKL(J) = 4
      CALL TEST(ITT,LINE,IOUT)
      IS = 1
      CALL LATCON(IS)
      GO TO 777
2020  CONTINUE
   89 STOP 'END OF TRAZER CODE'
      END
      SUBROUTINE RCELL (IOUT)
C
C     TRANSFORM GIVEN CELL TO REDUCED CELL.  CALLED WHEN INSTRUCTION
C     NQ = 7.
C
      DIMENSION N(9),NA(9),NB(9),D(3),ANGLE(3),NN(3,3,3),P(3,3,12),
     1 S(3,3,15),MM(3,3,4),IHKL(12),NTEMP(9)
      DIMENSION TITLE(14),DIS(6,12),DET(15),BET(15)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
      COMMON SINAL,SINBE,SINGA,ALS,BES,GAS,SINALS,SINBES,SINGAS,COSALS,
     1 COSBES,COSGAS,AS,BS,CS,AL,BE,GA,ALSTAR,BESTAR,GASTAR,V,VS
C
C	   PART 1.  TRANSFORMATION.
C
C
      K = K + 1
      IHKL(K) = 2
      ICYCLE = 1
      AB = A * B * COSGA
      BC = B * C * COSAL
      CA = C * A * COSBE
      DO 175 J = 1,9
      N(J) = 0
  175 NA(J) = 0
      N(1) = 1
      N(5) = 1
      N(9) = 1
      NA(1) = 1
      NA(5) = 1
      NA(9) = 1
  382 NSTOP = 1
      K2 = 0
      ABSAB = ABS(AB)
      ABSBC = ABS(BC)
      ABSCA = ABS(CA)
      QQMAX = AMAX1(ABSAB, ABSBC, ABSCA)
      IF (QQMAX - ABSAB) 176, 401, 176
  176 IF (QQMAX - ABSBC) 177, 404, 407
  177 LOC = 7
      GO TO 890
  401 QMAX = AMAX1(A,B)
      IF (QMAX - A) 84, 91, 92
  404 QMAX = AMAX1(B,C)
      IF (QMAX - B) 84, 93, 94
  407 QMAX = AMAX1(C,A)
      IF (QMAX - C) 84, 95, 96
   91 IAXIS = 2
      GO TO 1
   92 IAXIS = 1
      GO TO 4
   93 IAXIS = 3
      GO TO 4
   94 IAXIS = 2
      GO TO 7
   95 IAXIS = 1
      GO TO 7
   96 IAXIS = 3
      GO TO 1
C
    1 MAX = 1
      GO TO 10
    2 IAXIS = 1
      QMAX = AMAX1(B,C)
      IF (QMAX - B) 87, 101, 102
  101 K2 = 1
      GO TO 30
  102 K2 = 2
      GO TO 50
    3 IF (K2 - 1) 88, 121, 122
  121 IAXIS = 2
      GO TO 50
  122 IAXIS = 3
    4 MAX = 4
      GO TO 30
    5 IAXIS = 2
      QMAX = AMAX1(A,C)
      IF (QMAX - A) 87, 201, 202
  201 K2 = 1
      GO TO 10
  202 K2 = 2
      GO TO 50
    6 IF (K2 - 1) 88, 123, 124
  123 IAXIS = 1
      GO TO 50
  124 IAXIS = 3
      GO TO 10
C
    7 MAX = 7
      GO TO 50
    8 IAXIS = 3
      QMAX = AMAX1(A,B)
      IF (QMAX - A) 87, 301, 302
  301 K2 = 1
      GO TO 10
  302 K2 = 2
      GO TO 30
    9 IF (K2 - 1) 88, 125, 126
  125 IAXIS = 1
      GO TO 30
  126 IAXIS = 2
      GO TO 10
   84 LOC = 1
      GO TO 890
   87 LOC = 2
      GO TO 890
   88 LOC = 3
      GO TO 890
C
C	   REDUCTION OF A.   (QMAX = A)
C
   10 X  = A
      Y  = B
      Z  = C
      XY = AB
      YZ = BC
      ZX = CA
C
      NCHECK = 1
      GO TO (85, 11, 12), IAXIS
   11 I = 2
      GO TO 100
   12 I = 3
      GO TO 300
C
   15 A  = X
      B  = Y
      C  = Z
      AB = XY
      BC = YZ
      CA = ZX
C
      NCHECK = NCHECK - 1
      IF (NCHECK) 46, 17, 17
   17 IF (I - 2) 86, 12, 11
   46 MAX = MAX + 1
      NSTOP = NSTOP + 1
      IF (NSTOP - 3) 18, 18, 601
   18 GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9), MAX
C
C	   REDUCTION OF B.   (QMAX = B)
C
   30 X  = B
      Y  = C
      Z  = A
      XY = BC
      YZ = CA
      ZX = AB
C
      NCHECK = 1
      GO TO (32, 85, 31), IAXIS
   31 I = 6
      GO TO 100
   32 I = 4
      GO TO 300
C
   35 A  = Z
      B  = X
      C  = Y
      AB = ZX
      BC = XY
      CA = YZ
C
      NCHECK = NCHECK - 1
      IF (NCHECK) 46, 37, 37
   37 IF (I - 4) 86, 31, 32
C
C	   REDUCTION OF C.   (QMAX = C)
C
   50 X  = C
      Y  = A
      Z  = B
      XY = CA
      YZ = AB
      ZX = BC
C
      NCHECK = 1
      GO TO (51, 52, 85), IAXIS
   51 I = 7
      GO TO 100
   52 I = 8
      GO TO 300
C
   55 A  = Y
      B  = Z
      C  = X
      AB = YZ
      BC = ZX
      CA = XY
C
      NCHECK = NCHECK - 1
      IF (NCHECK) 46, 57, 57
   57 IF (I - 7) 86, 52, 51
C
   85 LOC = 4
      GO TO 890
   86 LOC = 5
      GO TO 890
C
C	   REDUCTION OF X.  ABSF(X.Y) GREATER THAN (Y**2)/2
C
  100 XX = X*X
      YY = Y*Y
      PN = 0.
      IF (ABS(XY) - 0.5*YY) 444, 444, 110
  110 IF (XY) 120, 444, 200
  120 XY2 = XY + PN*YY
      IF (XY2) 130, 150, 150
  130 SAVE = XY2
      PN = PN + 1.
      GO TO 110
  150 IF (ABS(XY2) - ABS(SAVE)) 143, 142, 142
  142 PN = PN - 1.
  143 NA(I) = PN
      X = SQRT(XX + 2.*PN*XY + PN*PN*YY)
      ZX = ZX + PN*YZ
  144 IF (ABS(XY2) - ABS(SAVE)) 160, 170, 170
  160 XY = XY2
      GO TO 520
  170 XY = SAVE
      GO TO 520
C
  200 XY2 = XY - PN*YY
      IF (XY2) 250, 250, 230
  230 SAVE = XY2
      PN = PN + 1.
      GO TO 200
  250 IF (ABS(XY2) - ABS(SAVE)) 243, 243, 242
  242 PN = PN - 1.
  243 NA(I) = -PN
      X = SQRT(XX - 2.*PN*XY + PN*PN*YY)
      ZX = ZX - PN*YZ
      GO TO 144
C
C	   REDUCTION OF X.  ABSF(Z.X) GREATER THAN (Z**2)/2
C
  300 XX = X*X
      ZZ = Z*Z
      PN = 0.
      IF  (ABS(ZX) - 0.5 * ZZ) 444, 444, 310
  310 IF (ZX) 320, 444, 400
  320 ZX2 = ZX + PN*ZZ
      IF (ZX2) 330, 350, 350
  330 SAVE = ZX2
      PN = PN + 1.
      GO TO 310
  350 IF (ABS(ZX2) - ABS(SAVE)) 343, 342, 342
  342 PN = PN - 1.
  343 NA(I) = PN
      X =  SQRT(XX + 2.*PN*ZX + PN*PN*ZZ)
      XY = XY + PN*YZ
  344 IF (ABS(ZX2) - ABS(SAVE)) 360, 370, 370
  360 ZX = ZX2
      GO TO 520
  370 ZX = SAVE
      GO TO 520
C
  400 ZX2 = ZX - PN*ZZ
      IF (ZX2) 450, 450, 430
  430 SAVE = ZX2
      PN = PN + 1.
      GO TO 400
  450 IF (ABS(ZX2) - ABS(SAVE)) 463, 463, 462
  462 PN = PN - 1.
  463 NA(I) = -PN
      X =  SQRT(XX - 2.*PN*ZX + PN*PN*ZZ)
      XY = XY - PN*YZ
      GO TO 344
C
  520 NB(1) = NA(1)*N(1) + NA(2)*N(4) + NA(3)*N(7)
      NB(2) = NA(1)*N(2) + NA(2)*N(5) + NA(3)*N(8)
      NB(3) = NA(1)*N(3) + NA(2)*N(6) + NA(3)*N(9)
      NB(4) = NA(4)*N(1) + NA(5)*N(4) + NA(6)*N(7)
      NB(5) = NA(4)*N(2) + NA(5)*N(5) + NA(6)*N(8)
      NB(6) = NA(4)*N(3) + NA(5)*N(6) + NA(6)*N(9)
      NB(7) = NA(7)*N(1) + NA(8)*N(4) + NA(9)*N(7)
      NB(8) = NA(7)*N(2) + NA(8)*N(5) + NA(9)*N(8)
      NB(9) = NA(7)*N(3) + NA(8)*N(6) + NA(9)*N(9)
      DO 521 J = 1,9
      N(J) = NB(J)
      IF (N(J)) 521, 540, 521
  540 N(J) = 0
  521 NA(J) = 0
      NA(1) = 1
      NA(5) = 1
      NA(9) = 1
  444 GO TO (601, 15, 15, 35, 601, 35, 55, 55, 601), I
C
C
C	   OUTPUT OF PART 1.	(REDUCED CELL)
C
C
  601 COSAL = BC / (B*C)
      COSBE = CA / (C*A)
      COSGA = AB / (A*B)
      AL = ACOS(COSAL)
      BE = ACOS(COSBE)
      GA = ACOS(COSGA)
      SINAL = SIN(AL)
      SINBE = SIN(BE)
      SINGA = SIN(GA)
      ALPHA = 57.295780 * AL
      BETA  = 57.295780 * BE
      GAMMA = 57.295780 * GA
      LL = 1
      GO TO 602
C
C	   A TEST IS NOW MADE TO DETERMINE IF THE CELL JUST OBTAINED
C     IS THE REDUCED CELL.  IF ONE OR MORE OF THE AXES CAN BE FURTHER
C     REDUCED, THE PROGRAM RETURNS TO STMNT 382 FOR ANOTHER CYCLE.
C
  501 IF  (ABS(AB) - 0.5 * A*A) 502, 502, 381
  502 IF  (ABS(AB) - 0.5 * B*B) 503, 503, 381
  503 IF  (ABS(BC) - 0.5 * B*B) 504, 504, 381
  504 IF  (ABS(BC) - 0.5 * C*C) 505, 505, 381
  505 IF  (ABS(CA) - 0.5 * C*C) 506, 506, 381
  506 IF  (ABS(CA) - 0.5 * A*A) 66, 66, 381
  381 ICYCLE = ICYCLE + 1
      GO TO 382
C
C
C	   PART 2.   TRANSFORMATION OF REDUCED CELL TO CONVENTIONAL
C     REDUCED CELL.  THE CONVENTION IS C LESS THAN A LESS THAN B,
C     WITH ALPHA, BETA OBTUSE.
C
C
   66 JA = 0
      JB = 0
      JC = 0
      K = K + 1
      IHKL(K) = 3
      NTURN = 1
      KK = 3
      IF (AMIN1(A,B,C) - A) 702, 611, 999
  611 JJ = 7
      M = -6
      GO TO 721
  702 IF (AMIN1(A,B,C) - B) 612, 613, 999
  612 JC = 1
      JJ = 7
      M = 0
      GO TO 723
  613 JJ = 7
      M = -3
      GO TO 722
  703 NTURN = 2
      KK = 2
      IF (AMAX1(A,B,C) - A) 999, 614, 704
  614 IF (AMIN1(A,B,C).EQ.A) GO TO 704
      JJ = 4
      M = -3
      GO TO 721
  704 IF (AMAX1(A,B,C) - B) 999, 615, 616
  615 JB = 1
      JJ = 4
      M = 0
      GO TO 722
  616 JJ = 4
      M = 3
      GO TO 723
  706 NTURN = 3
      KK = 1
      IF (D(2) - A) 710, 707, 710
  710 IF (D(2) - B) 999, 708, 709
  707 IF (AMIN1(B,C) - B) 622, 621, 999
  621 JJ = 1
      M = 6
      GO TO 723
  622 JJ = 1
      M = 3
      GO TO 722
  708 IF (AMIN1(A,C) - A) 623, 621, 999
  623 JA = 1
      JJ = 1
      M = 0
      GO TO 721
  709 IF (AMIN1(A,B) - A) 623, 622, 999
C
  999 LOC = 6
      GO TO 890
C
  721 D(KK) = A
      ANGLE (KK) = ALPHA
  664 JL = JJ + 2
      DO 665 L = JJ,JL
      LM = L + M
  665 NTEMP(L) = N(LM)
      GO TO (703, 706, 739), NTURN
  722 D(KK) = B
      ANGLE (KK) = BETA
      GO TO 664
  723 D(KK) = C
      ANGLE (KK) = GAMMA
      GO TO 664
C
  739 DO 730 I = 1,9
  730 N(I) = NTEMP(I)
      A = D(1)
      B = D(2)
      C = D(3)
      ALPHA = ANGLE(1)
      BETA  = ANGLE(2)
      GAMMA = ANGLE(3)
C
C	   THE FOLLOWING SECTION CHECKS TO MAKE SURE ALPHA AND BETA ARE
C     EACH EQUAL TO OR GREATER THAN 90 DEGREES.  IF ONE OR BOTH ARE
C     LESS THAN 90 DEGREES, THE PROPER ADJUSTMENTS ARE MADE.
C
  223 LL = 2
      ISIGS = 0
      IF (ALPHA - 90.0) 21, 801, 801
   21 ISIGS = ISIGS + 1
  801 IF (BETA - 90.0) 22, 802, 802
   22 ISIGS = ISIGS + 1
  802 IF (ISIGS - 1) 602, 69, 79
C
C     ISIGS = 1
C	   EITHER ALPHA OR BETA IS LESS THAN 90 DEGREES.  REDEFINE THAT
C	   ANGLE AS ITS SUPPLEMENT AND SET GAMMA = 180.0 - GAMMA.
C	   (TWO ANGLES MUST ALWAYS BE TRANSFORMED SIMULTANEOUSLY.)
C
   69 GAMMA = 180.0 - GAMMA
      DO 6661 I = 7,9
      N(I) = -N(I)
      IF (N(I)) 6661, 4441, 6661
 4441 N(I) = 0
 6661 CONTINUE
      IF (ALPHA - 90.0) 43, 44, 44
   43 ALPHA = 180.0 - ALPHA
      DO 6662 I = 1,3
      N(I) = -N(I)
      IF (N(I)) 6662, 4442, 6662
 4442 N(I) = 0
 6662 CONTINUE
      GO TO 602
   44 BETA = 180.0 - BETA
      DO 6663 I = 4,6
      N(I) = -N(I)
      IF (N(I)) 6663, 4443, 6663
 4443 N(I) = 0
 6663 CONTINUE
      GO TO 602
C
C     ISIGS = 2
C	   REDEFINE ALPHA AND BETA AS ITS OWN SUPPLEMENT AND REVERSE THE
C	   DIRECTIONS OF A AND B.
C
   79 ALPHA = 180.0 - ALPHA
      BETA = 180.0 - BETA
      DO 6664 I = 1,6
      N(I) = -N(I)
      IF (N(I)) 6664, 4444, 6664
 4444 N(I) = 0
 6664 CONTINUE
C
  602 GO TO (821, 831), LL
C
C	   A CHECK IS MADE TO DETERMINE IF THE SYSTEM HAS GONE FROM
C     RIGHT-HANDED TO LEFT-HANDED OR VICE VERSA.  IF JF = 1 THE SYSTEM
C     HAS REVERSED.  IF JF = 0 OR 3, IT HAS NOT REVERSED.
C
  831 JF = JA + JB + JC
      IF (JF - 1) 821, 832, 821
  832 DO 835 I = 1,9
      N(I) = -N(I)
      IF (N(I)) 835, 833, 835
  833 N(I) = 0
  835 CONTINUE
C
  821 K = K - 1
      L = 0
      DO 822 I = 1,3
      DO 822 J = 1,3
      L = L + 1
      NN(I,J,LL) = N(L)
  822 P(I,J,K) = N(L)
      K4 = 2
      CALL MATIN(K4)
      L = 0
      DO 823 I = 1,3
      DO 823 J = 1,3
      L = L + 1
  823 MM(I,J,LL) = S(I,J,K)
      K = K + 1
      IF (IHKL(K) - 2) 261,261,260
  260 IS = 1
      GO TO 262
  261 IS = 2
  262 CALL LATCON(IS)
      CALL STORE
      I = IHKL(K)
      IF (I.EQ.2) GO TO 501
      GO TO 41
C
  890 WRITE(IOUT,1000)LOC
 1000 FORMAT (1H-,/,51H AN ERROR HAS OCCURRED IN SUBROUTINE RCELL.   LOC
     1 = I2)
C
   41 RETURN
      END
      SUBROUTINE LATCON(IS)
C
C     CALCULATE CELL PARAMETER DATA IN DIRECT AND RECIPROCAL SPACE
C
      DIMENSION TITLE(14),P(3,3,12),IHKL(12),DIS(6,12),NN(3,3,3),
     1 MM(3,3,4),S(3,3,15),DET(15),BET(15)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
      COMMON SINAL,SINBE,SINGA,ALS,BES,GAS,SINALS,SINBES,SINGAS,COSALS,
     1 COSBES,COSGAS,AS,BS,CS,AL,BE,GA,ALSTAR,BESTAR,GASTAR,V,VS
C
      GO TO (71,81,72), IS
   71 SINAL = SIN(ALPHA * 0.01745329)
      SINBE = SIN(BETA	* 0.01745329)
      SINGA = SIN(GAMMA * 0.01745329)
      COSAL = COS(ALPHA * 0.01745329)
      COSBE = COS(BETA	* 0.01745329)
      COSGA = COS(GAMMA * 0.01745329)
   81 ALS =  ACOS((COSBE * COSGA - COSAL) / (SINBE * SINGA))
      BES =  ACOS((COSAL * COSGA - COSBE) / (SINAL * SINGA))
      GAS =  ACOS((COSAL * COSBE - COSGA) / (SINAL * SINBE))
      SINALS = SIN(ALS)
      SINBES = SIN(BES)
      SINGAS = SIN(GAS)
      COSALS = COS(ALS)
      COSBES = COS(BES)
      COSGAS = COS(GAS)
      AS = 1. / (A * SINBES * SINGA)
      BS = 1. / (B * SINALS * SINGA)
      CS = 1. / (C * SINALS * SINBE)
      ALSTAR = ALS * 57.295780
      BESTAR = BES * 57.295780
      GASTAR = GAS * 57.295780
      GO TO 99
C
   72 SINALS = SIN(ALSTAR * 0.01745329)
      SINBES = SIN(BESTAR * 0.01745329)
      SINGAS = SIN(GASTAR * 0.01745329)
      COSALS = COS(ALSTAR * 0.01745329)
      COSBES = COS(BESTAR * 0.01745329)
      COSGAS = COS(GASTAR * 0.01745329)
      AL =  ACOS((COSBES * COSGAS - COSALS) / (SINBES * SINGAS))
      BE =  ACOS((COSALS * COSGAS - COSBES) / (SINALS * SINGAS))
      GA =  ACOS((COSALS * COSBES - COSGAS) / (SINALS * SINBES))
      SINAL = SIN(AL)
      SINBE = SIN(BE)
      SINGA = SIN(GA)
      COSAL = COS(AL)
      COSBE = COS(BE)
      COSGA = COS(GA)
      A = 1. / (AS * SINBE * SINGAS)
      B = 1. / (BS * SINAL * SINGAS)
      C = 1. / (CS * SINAL * SINBES)
      ALPHA = AL * 57.295780
      BETA  = BE * 57.295780
      GAMMA = GA * 57.295780
C
   99 V  = A*B*C*SINAL*SINBE*SINGAS
      VS = 1./V
      RETURN
      END
      SUBROUTINE STORE
C
C     STORE CELL PARAMETERS INTO VARIABLE DIS(I,K)
C
      DIMENSION TITLE(14),DIS(6,12),IHKL(12)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
C
      DIS(1,K) = A
      DIS(2,K) = B
      DIS(3,K) = C
      DIS(4,K) = ALPHA
      DIS(5,K) = BETA
      DIS(6,K) = GAMMA
C
      RETURN
      END
      SUBROUTINE DIMEN
C
C     TRANSFORM GIVEN CELL (DEFINED BY VECTORS IN DIRECT SPACE) TO A
C     NEW CELL USING A VECTORIAL TRANSFORMATION MATRIX P(I,J,K).
C     CALLED IF NQ.LE.6.
C
      DIMENSION AXIS(3),CSE(3),ANGLE(3),P(3,3,12),TITLE(14),DIS(6,12),
     1		IHKL(12)
      DIMENSION S(3,3,15),DET(15),BET(15),NN(3,3,3),MM(3,3,4)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
C
C	   CALCULATION OF THE NEW A, B, C
C
      DO 117 I = 1,3
  117 AXIS(I) = SQRT((P(I,1,K)*A)**2 + (P(I,2,K)*B)**2 + (P(I,3,K)*C)**2
     1	       + 2.*(P(I,1,K)*P(I,2,K)*A*B*COSGA
     2	       +     P(I,1,K)*P(I,3,K)*A*C*COSBE
     3	       +     P(I,2,K)*P(I,3,K)*B*C*COSAL))
C
C	   CALCULATION OF THE NEW ALPHA, BETA, GAMMA
C
      J = 2
      L = 3
      DO 19 I = 1,3
      CSE(I) = (P(J,1,K)*P(L,1,K)*A*A + P(J,2,K)*P(L,2,K)*B*B
     1	       + P(J,3,K)*P(L,3,K)*C*C
     2	       + (P(J,1,K)*P(L,2,K) + P(J,2,K)*P(L,1,K))*A*B*COSGA
     3	       + (P(J,1,K)*P(L,3,K) + P(J,3,K)*P(L,1,K))*A*C*COSBE
     4	       + (P(J,2,K)*P(L,3,K) + P(J,3,K)*P(L,2,K))*B*C*COSAL)
     5	       / (AXIS(J)*AXIS(L))
      ANGLE(I) =  ACOS(CSE(I)) * 57.295780
      GO TO (115, 16, 19), I
  115 J = 1
      GO TO 19
   16 L = 2
   19 CONTINUE
      A = AXIS(1)
      B = AXIS(2)
      C = AXIS(3)
      ALPHA = ANGLE(1)
      BETA  = ANGLE(2)
      GAMMA = ANGLE(3)
C
      K = K + 1
      IHKL(K) = 1
      RETURN
      END
      SUBROUTINE MATIN(K4)
C
C     GENERATE MATRIX ELEMENTS OF INVERSE TRANSFORMATION MATRIX
C
      DIMENSION P(3,3,12),S(3,3,15),DET(15),BET(15),TITLE(14),DIS(6,12),
     1 NN(3,3,3),MM(3,3,4),IHKL(12)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
C
      GO TO (5552,5552,5553,5553), K4
 5552 L = K
      GO TO 5554
 5553 L = L2
 5554 DET(L) = P(1,1,L)*(P(2,2,L)*P(3,3,L) - P(3,2,L)*P(2,3,L))
     1	     - P(1,2,L)*(P(2,1,L)*P(3,3,L) - P(3,1,L)*P(2,3,L))
     2	     + P(1,3,L)*(P(2,1,L)*P(3,2,L) - P(3,1,L)*P(2,2,L))
      S(1,1,L) =  (P(2,2,L)*P(3,3,L) - P(3,2,L)*P(2,3,L)) / DET(L)
      S(1,2,L) = -(P(1,2,L)*P(3,3,L) - P(3,2,L)*P(1,3,L)) / DET(L)
      S(1,3,L) =  (P(1,2,L)*P(2,3,L) - P(2,2,L)*P(1,3,L)) / DET(L)
      S(2,1,L) = -(P(2,1,L)*P(3,3,L) - P(3,1,L)*P(2,3,L)) / DET(L)
      S(2,2,L) =  (P(1,1,L)*P(3,3,L) - P(3,1,L)*P(1,3,L)) / DET(L)
      S(2,3,L) = -(P(1,1,L)*P(2,3,L) - P(2,1,L)*P(1,3,L)) / DET(L)
      S(3,1,L) =  (P(2,1,L)*P(3,2,L) - P(3,1,L)*P(2,2,L)) / DET(L)
      S(3,2,L) = -(P(1,1,L)*P(3,2,L) - P(3,1,L)*P(1,2,L)) / DET(L)
      S(3,3,L) =  (P(1,1,L)*P(2,2,L) - P(2,1,L)*P(1,2,L)) / DET(L)
      DO 5555 I = 1,3
      DO 5555 J = 1,3
      IF (S(I,J,L)) 5555, 5559, 5555
 5559 S(I,J,L) = 0.0
 5555 CONTINUE
      BET(L) = 1./DET(L)
      IF (K4 - 1) 5558, 5556, 5558
 5556 IF (L - MATRIX) 5557, 5558, 5558
 5557 L = L + 1
      GO TO 5554
 5558 RETURN
      END
      SUBROUTINE MATOFC(MA,K4,ITL)
C
C     GENERATE MATRIX FOR VECTORIAL TRANSFORMATION OF LATTICE AXES OF
C     ORIGINAL CELL TO FINAL CELL WHEN BOTH CELLS ARE SEPARATED BY
C     INTERMEDIATE CELLS.  CALLED ONLY IF 3 OR MORE CELLS ARE INVOLVED
C     IN A SEQUENCE OF TRANSFORMATIONS.  IF A SERIES OF INSTRUCTIONS
C     ENDS WITH NQ = 8, MATOFC CALLED ONLY ONCE.  IF THE SERIES ENDS
C     WITH NQ = 7, MATOFC CALLED TWICE, ONCE FOR EACH OF THE TWO
C     ORIENTATIONS OF THE REDUCED CELL.  MATRIX OBTAINED BY MATRIX MULT.
C
      DIMENSION IHKL(12),Q(3,3,12),P(3,3,12),W(3,3,12)
      DIMENSION TITLE(14),DIS(6,12),S(3,3,15),DET(15),BET(15),
     1 NN(3,3,3),MM(3,3,4)
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
C
      GO TO (41,8881), MA
   41 IF (ITL - 3) 68,45,45
   45 K4 = 3
      K = K + 1
      IHKL(K) = 4
 8881 DO 8882 L = 1,ISUM
      DO 8882 J = 1,3
      DO 8882 I = 1,3
 8882 Q(I,J,L) = P(I,J,L)
      IF (K4 - 4) 56, 58, 58
   56 K8 = K
      GO TO 59
   58 K = K8
   59 IF (ICYCLE) 53, 53, 54
   53 K = K + 1
   54 L = K - 3
      M = K - 4
      LL = L
  104 DO 105 I = 1,3
      DO 105 J = 1,3
  105 W(I,J,L) = Q(I,1,L)*Q(1,J,M)+Q(I,2,L)*Q(2,J,M)+Q(I,3,L)*Q(3,J,M)
      IF (M - 1) 8890, 8890, 106
  106 DO 8883 I = 1,3
      DO 8883 J = 1,3
 8883 Q(I,J,L) = W(I,J,L)
      M = M - 1
      GO TO 104
 8890 IF (K4.EQ.3) GO TO 8892
 8891 L2 = L2 + 1
      GO TO 8893
 8892 L2 = ISUM
 8893 DO 8887 I = 1,3
      DO 8887 J = 1,3
      P(I,J,L2) = W(I,J,L)
      IF (P(I,J,L2)) 8887,201,8887
  201 P(I,J,L2) = 0.0
 8887 CONTINUE
      CALL MATIN(K4)
C
   68 RETURN
      END
      SUBROUTINE CENTER(K,NQ,P)
C
C     DEFINE MATRIX ELEMENTS FOR TRANSFORMATION OF AN A-, B-, C-, I- AND
C     F-CENTERED CELL TO A PRIMITIVE CELL
C
      DIMENSION NQ(12),P(3,3,12),E(9)
C
      J = NQ(K)
      DO 100 I = 1,9
      GO TO (11,12,13,14,15,16,17,18,19), I
C
   11 GO TO (9,5,3,4,5,4), J
   12 GO TO (9,3,3,4,3,4), J
   13 GO TO (9,3,1,3,3,3), J
   14 GO TO (9,3,3,1,3,3), J
   15 GO TO (9,4,5,3,5,4), J
   16 GO TO (9,4,3,3,3,4), J
   17 GO TO (9,3,4,3,4,4), J
   18 GO TO (9,1,3,3,4,3), J
   19 GO TO (9,3,4,5,4,4), J
C
    1 E(I) = -1.0
      GO TO 100
C   2 E(I) = -0.5
C     GO TO 100
    3 E(I) = 0.0
      GO TO 100
    4 E(I) = 0.5
      GO TO 100
    5 E(I) = 1.0
  100 CONTINUE
C
      L = 0
      DO 200 I = 1,3
      DO 200 J = 1,3
      L = L + 1
  200 P(I,J,K) = E(L)
C
    9 RETURN
      END
      SUBROUTINE TEST(ITT,LINE,IOUT)
C
C     ANALYZE SCALAR PRODUCTS OF REDUCED CELL (IN CONVENTIONAL ORIENTA-
C     TION C.LT.A.LT.B, ALPHA, BETA OBTUSE) FOR UNIT CELL OF HIGHEST
C     SYMMETRY.  MATRIX ELEMENTS EU(I) TAKEN FROM TABLE 3 OF - THE
C     REDUCED CELL AND ITS CRYSTALLOGRAPHIC APPLICATIONS, U.S.A.E.C.,
C     AMES LAB REPORT IS-1141, APRIL 1965, BY LAWTON AND JACOBSON.
C
C     GLOSSARY OF SYMBOLS.  REMAINING SYMBOLS DEFINED IN GLOSSARY
C     PRECEDING MAIN PROGRAM.
C
C     A2       CELL PARAMETER, A, IN NEW UNIT CELL
C     ABC      A*B*COS(GAMMA)
C     ACC      A*C*COS(BETA)
C     ALPHA2   CELL PARAMETER, ALPHA, IN NEW UNIT CELL
C     B2       CELL PARAMETER, B, IN NEW UNIT CELL
C     BCC      B*C*COS(ALPHA)
C     BETA2    CELL PARAMETER, BETA, IN NEW UNIT CELL
C     C2       CELL PARAMETER, C, IN NEW UNIT CELL
C     DEL      LARGEST EST. ERROR BETWEEN REDUCED CELL SCALAR PRODUCTS
C     DETEU    MODULUS OF MATRIX EU
C     DETEUI   MODULUS OF MATRIX EUI
C     DETFN    MODULUS OF MATRIX F
C     DETFNI   MODULUS OF MATRIX FI
C     EU(9)    MATRIX ELEM. FOR TRANSF. OF CONV. RED. CELL TO UNIT CELL
C     EUI(9)   INVERSE MATRIX ELEMENTS OF EU
C     F(9)     MATRIX ELEM. FOR TRANSF. OF ORIG. CELL TO UNIT CELL
C     FI(9)    INVERSE MATRIX ELEMENTS OF F
C     GAMMA2   CELL PARAMETER, GAMMA, IN NEW UNIT CELL
C     ISYM     CODE IDENTIFYING EQUIVALENCY AMONG SYMMETRICAL SCALARS
C     JSUM     ISUM + 1
C     JU       CODE IDENTIFYING SET OF UNSYMMETRICAL SCALAR PRODUCTS
C     JU12     CODE FOR AB IN TEST FOR ZERO ELEMENT
C     JU23     CODE FOR BC IN TEST FOR ZERO ELEMENT
C     JU31     CODE FOR CA IN TEST FOR ZERO ELEMENT
C     ITT      CODE SPECIFYING SECTIONS OF SUBROUTINE TEST
C
      DIMENSION TITLE(14),DIS(6,12),IHKL(12),P(3,3,12),S(3,3,15),
     1		DET(15),BET(15),NN(3,3,3),MM(3,3,4)
      DIMENSION EU(9),EUI(9),F(9),FI(9)
      COMMON /TESTZ/ITZ,INTERO
      COMMON A,B,C,ALPHA,BETA,GAMMA,COSAL,COSBE,COSGA,TITLE,DIS,K,IHKL
      COMMON DEL,ISUM,JSUM,P,S,DET,BET,L,L2,MATRIX,NN,MM,ICYCLE,IOUTPT
C
      GO TO (91,92,93,94), ITT
C
C	   TEST R(1,1), R(2,2), R(3,3)
C
   91 AA = A * A
      BB = B * B
      CC = C * C
      BC = B * C * COSAL
      CA = C * A * COSBE
      AB = A * B * COSGA
      JU23 = 0
      JU31 = 0
      JU12 = 0
      JU = 0
C
      IF (ABS(AA-BB) - DEL) 721,721,722
  721 IF (ABS((AA+BB)/2. - CC) - DEL) 723,723,724
  723 ISYM = 1
      GO TO 100
  724 ISYM = 2
      GO TO 100
  722 IF (ABS(AA-CC) - DEL) 725,725,726
  725 ISYM = 3
      GO TO 100
  726 IF (ABS(BB-CC) - DEL) 95,95,727
  727 ISYM = 4
C
C	   TEST R(2,3), R(3,1), R(1,2)
C
C	   1. TEST FOR ZERO ELEMENTS
C
  100 IF (ABS(ALPHA-90.0) - DEL) 102,102,101
  101 IF (ABS(BC) - DEL) 102,102,103
  102 JU23 = 1
  103 IF (ABS(BETA-90.0) - DEL) 105,105,104
  104 IF (ABS(CA) - DEL) 105,105,106
  105 JU31 = 1
  106 IF (ABS(GAMMA-90.0) - DEL) 108,108,107
  107 IF (ABS(AB) - DEL) 108,108,120
  108 JU12 = 1
C
  120 IF ((JU23+JU31+JU12).EQ.3) GO TO 130
      IF ((JU23+JU31).EQ.2) GO TO 140
      IF ((JU23+JU12).EQ.2) GO TO 150
      IF ((JU31+JU12).EQ.2) GO TO 160
      IF (JU23.EQ.1) GO TO 170
      IF (JU31.EQ.1) GO TO 180
      IF (JU12.EQ.1) GO TO 240
      GO TO 200
C
C	      R(2,3) = R(3,1) = R(1,2) = 0.0
C	      CUBIC(41), TETRAGONAL(31), TETRAGONAL(30) AND
C	      ORTHORHOMBIC(19)
C
  130 GO TO (11,11,11,11),ISYM
C
C	      R(2,3) = R(3,1) = 0.0
C	      HEXAGONAL(40A,B), ORTHORHOMBIC(24A,B), ORTHORHOMBIC(22A,B)
C	      AND MONOCLINIC(4A,B)
C
  140 IF (ABS(AB - AA/2.) - DEL) 141,141,142
  141 IF (ISYM.EQ.1) ISYM = 2
      GO TO (98,12,98,12), ISYM
  142 IF (ABS(AB + AA/2.) - DEL) 143,143,144
  143 IF (ISYM.EQ.1) ISYM = 2
      GO TO (98,13,98,13), ISYM
  144 IF (AB) 146,130,145
  145 IF (ISYM.EQ.1) ISYM = 4
      GO TO (98,14,98,14), ISYM
  146 IF (ISYM.EQ.1) ISYM = 4
      GO TO (98,15,98,15), ISYM
C
C	      R(2,3) = R(1,2) = 0.0
C	      HEXAGONAL(39), ORTHORHOMBIC(23), ORTHORHOMBIC(20) AND
C	      MONOCLINIC(5)
C
  150 IF (ABS(CA + AA/2.) - DEL) 151,151,152
  151 IF (ISYM.EQ.1) ISYM = 3
      GO TO (98,98,12,98), ISYM
  152 IF (ISYM.EQ.3) GO TO 13
      IF (ISYM.NE.4) GO TO 98
      IF (ABS(CA + CC/2.) - DEL) 16,16,17
C
C	      R(3,1) = R(1,2) = 0.0
C	      ORTHORHOMBIC(21), MONOCLINIC(3) AND HEXAGONAL(SPECIAL
C	      CASE)
C
  160 IF (ABS(BC + CC/2.) - DEL) 161,161,162
  161 GO TO (23,98,98,20), ISYM
  162 GO TO (98,98,98,21), ISYM
C
C
C	      R(2,3) = 0.0     MONOCLINIC(9A,B)
C
  170 IF (ISYM.NE.4) GO TO 98
      IF (ABS(CA+CC/2.) - DEL) 171,171,98
  171 IF (AB) 19,150,18
C
C	      R(3,1) = 0.0
C	      TETRAGONAL(32A,B), ORTHORHOMBIC(27A,B), MONOCLINIC(11A,B)
C	      AND MONOCLINIC(10A,B)
C
  180 IF (ISYM.NE.3) GO TO 183
      IF (ABS(BC+AA/2.) - DEL) 181,181,98
  181 IF (ABS(AB-AA/2.) - DEL) 14,14,182
  182 IF (ABS(AB+AA/2.) - DEL) 15,15,98
  183 IF (ISYM.NE.4) GO TO 98
      IF (ABS(BC+CC/2.) - DEL) 184,184,187
  184 IF (ABS(AB-AA/2.) - DEL) 22,22,185
  185 IF (ABS(AB+AA/2.) - DEL) 23,23,186
  186 IF (AB) 25,160,24
  187 IF (ABS(AB-AA/2.) - DEL) 26,26,188
  188 IF (ABS(AB+AA/2.) - DEL) 27,27,98
C
C	   2. TEST FOR CUBIC(42), TETRAGONAL(34A,B,C) AND
C	      ORTHORHOMBIC(25A,B,C).
C
  200 IF (ISYM.NE.1) GO TO 230
      IF (ABS(BC+CA+AB + AA) - DEL) 201,201,230
  201 IF (ABS(ABS(BC) - AA/3.) - DEL) 202,202,210
  202 IF (ABS(ABS(CA) - AA/3.) - DEL) 203,203,210
  203 IF (ABS(ABS(AB) - AA/3.) - DEL) 16,16,210
C
  210 IF (ABS(ABS(CA) - ABS(AB)) - DEL) 211,211,212
  211 IF (ABS(ABS(CA) - ABS((-AA-BC)/2.)) - DEL) 17,17,230
  212 IF (ABS(ABS(BC) - ABS(AB)) - DEL) 213,213,214
  213 IF (ABS(ABS(BC) - ABS(-AA-CA)/2.) - DEL) 18,18,230
  214 IF (ABS(ABS(BC) - ABS(CA)) - DEL) 215,215,220
  215 IF (ABS(ABS(BC) - ABS((-AA-AB)/2.)) - DEL) 19,19,230
C
  220 IF (ABS(ABS(BC) - ABS(-AA-CA-AB)) - DEL) 20,20,221
  221 IF (ABS(ABS(CA) - ABS(-AA-BC-AB)) - DEL) 21,21,222
  222 IF (ABS(ABS(AB) - ABS(-AA-BC-CA)) - DEL) 22,22,230
C
C	   3. TEST FOR R(2,3) = R(3,1)
C
  230 IF (ABS(ABS(BC) - ABS(CA)) - DEL) 231,231,270
  231 IF (ABS(BC+AA/2.) - DEL) 241,241,232
  232 IF (ABS(BC+CC/2.) - DEL) 250,250,233
  233 IF (ABS(BC+CC/3.) - DEL) 256,256,260
C
C	      R(2,3) = R(3,1) = -R(1,1)/2.
C	      CUBIC(43A,B) AND RHOMBOHEDRAL(35)
C
  240 GO TO (12,98,98,98), ISYM
  241 IF (ABS(AB-AA/2.) - DEL) 242,242,260
  242 GO TO (13,98,18,98), ISYM
C
C	      R(2,3) = R(3,1) = -R(3,3)/2.
C	      TETRAGONAL(33), ORTHORHOMBIC(29), ORTHORHOMBIC(26A,B)
C	      AND MONOCLINIC(8)
C
  250 IF (ABS(AB-CC/4.) - DEL) 251,251,252
  251 GO TO (98,16,98,28), ISYM
  252 IF (AB) 253,254,254
  253 IF (ISYM.EQ.2) GO TO 18
      GO TO 260
  254 GO TO (98,17,98,29), ISYM
C
C	      R(2,3) = R(3,1) = -R(3,3)/3.
C	      RHOMBOHEDRAL(38)
C
  256 IF (ISYM.NE.2) GO TO 260
      IF (ABS(ABS(AB) - ABS((-AA+CC/3.)/2.)) - DEL) 19,19,260
C
C	      R(2,3) = R(3,1) NOT NECESSARILY = R(1,2)
C	      RHOMBOHEDRAL(36), RHOMBOHEDRAL(37), MONOCLINIC(14)
C	      AND MONOCLINIC(15)
C
  260 IF (ABS(ABS(BC) - ABS(AB)) - DEL) 261,261,262
  261 IF (ISYM.NE.1) GO TO 262
      IF (AB) 15,98,14
  262 IF (ISYM.NE.2) GO TO 270
      IF (AB) 21,98,20
C
C	   4. TEST FOR ABS(R(2,3)) = ABS(R(1,2)).
C	      ORTHORHOMBIC(28), MONOCLINIC(12) AND MONOCLINIC(13)
C
  270 IF (ABS(ABS(BC) - ABS(AB)) - DEL) 271,271,280
  271 IF (ISYM.NE.3) GO TO 280
      IF (ABS(CA - (-AA - 2.*BC)) - DEL) 19,19,272
  272 IF (AB) 17,98,16
C
C	   5. TEST FOR REMAINING CELLS.
C
C	      MONOCLINIC(7)
C
  280 IF (ISYM.NE.3) GO TO 300
  290 IF (ABS(ABS(CA) - ABS(-AA-BC-AB)) - DEL) 20,20,300
C
C	      MONOCLINIC(16)
C
  300 GO TO (340,98,98,301), ISYM
  301 IF (ABS(BC + CC/2.) - DEL) 302,302,310
  302 IF (ABS(AB + CA/2.) - DEL) 30,30,310
C
C	      MONOCLINIC(17)
C
  310 IF (ABS(BC - CA/2.) - DEL) 311,311,320
  311 IF (ABS(AB - AA/2.) - DEL) 31,31,320
C
C	      MONOCLINIC(18)
C
  320 IF (ABS(AB + BC/2.) - DEL) 321,321,330
  321 IF (ABS(CA + CC/2.) - DEL) 32,32,330
C
C	      MONOCLINIC(6)
C
  330 IF (ABS(ABS(BC) - ABS((-CC - CA)/2.)) - DEL) 331,331,340
  331 IF (ABS(ABS(AB) - ABS((-AA - CA)/2.)) - DEL) 33,33,340
C
C	      TRICLINIC(1) AND TRICLINIC(2)
C
  340 ISYM = 4
      IF (AB) 35,34,34
C
   11 JU = 1
      GO TO 65
   12 JU = 2
      GO TO 65
   13 JU = 3
      GO TO 65
   14 JU = 4
      GO TO 65
   15 JU = 5
      GO TO 65
   16 JU = 6
      GO TO 65
   17 JU = 7
      GO TO 65
   18 JU = 8
      GO TO 65
   19 JU = 9
      GO TO 65
   20 JU = 10
      GO TO 65
   21 JU = 11
      GO TO 65
   22 JU = 12
      GO TO 65
   23 JU = 13
      GO TO 65
   24 JU = 14
      GO TO 65
   25 JU = 15
      GO TO 65
   26 JU = 16
      GO TO 65
   27 JU = 17
      GO TO 65
   28 JU = 18
      GO TO 65
   29 JU = 19
      GO TO 65
   30 JU = 20
      GO TO 65
   31 JU = 21
      GO TO 65
   32 JU = 22
      GO TO 65
   33 JU = 23
      GO TO 65
   34 JU = 24
      GO TO 65
   35 JU = 25
C
C	   TESTS COMPLETED.  NOW EXECUTE ASSIGNMENT OF MATRIX ELEMENTS
C     FOR TRANSFORMATION OF REDUCED CELL (IN CONVENTIONAL FORM) TO
C     UNIT CELL.
C
C
   65 DO 7 I = 1,9
      GO TO (66,67,68,69), ISYM
   66 GO TO (1001,1002,1003,1004,1005,1006,1007,1008,1009), I
   67 GO TO (1011,1012,1013,1014,1015,1016,1017,1018,1019), I
   68 GO TO (1021,1022,1023,1024,1025,1026,1027,1028,1029), I
   69 GO TO (1031,1032,1033,1034,1035,1036,1037,1038,1039), I
C
C	   ISYM = 1
C
CELL ORDER = 41,43A,43B,36,37,42,34A,34B,34C,25A,25B,25C,HEX(SPEC.CASE)
 1001 GO TO (1,1,1,4,1,1,1,1,4,1,4,1,4), JU
 1002 GO TO (4,5,1,1,4,1,4,1,1,1,1,4,1), JU
 1003 GO TO (4,4,1,4,4,4,1,4,1,4,1,1,4), JU
 1004 GO TO (4,1,1,1,4,4,1,4,1,4,1,1,4), JU
 1005 GO TO (1,1,5,4,1,1,1,1,4,1,4,1,4), JU
 1006 GO TO (4,4,5,4,4,1,4,1,1,1,1,4,1), JU
 1007 GO TO (4,1,5,4,4,1,4,1,1,1,1,4,1), JU
 1008 GO TO (4,1,1,4,4,4,1,4,1,4,1,1,4), JU
 1009 GO TO (1,2,5,5,1,1,1,1,4,1,4,1,4), JU
C
C	   ISYM = 2
C
CELL ORDER = 31,40A,40B,24A,24B,33,26A,26B,38,14,15
 1011 GO TO (1,1,1,5,1,1,1,1,1,1,1), JU
 1012 GO TO (4,4,4,1,1,5,1,5,1,1,1), JU
 1013 GO TO (4,4,4,4,4,4,1,4,1,4,4), JU
 1014 GO TO (4,5,4,1,5,1,5,1,5,5,5) ,JU
 1015 GO TO (1,1,1,1,1,1,1,1,4,1,1), JU
 1016 GO TO (4,4,4,4,4,1,4,1,4,4,4), JU
 1017 GO TO (4,4,4,4,4,4,4,4,4,4,4), JU
 1018 GO TO (4,4,4,4,4,4,4,4,5,4,4) ,JU
 1019 GO TO (1,1,1,1,1,1,1,1,4,1,1), JU
C
C	   ISYM = 3
C
CELL ORDER = 30,39,23,32A,32B,12,13,35,28,7
 1021 GO TO (4,4,1,5,4,5,1,4,5,1), JU
 1022 GO TO (4,4,4,4,4,4,4,1,4,4), JU
 1023 GO TO (1,1,1,4,1,1,1,1,1,5), JU
 1024 GO TO (1,1,1,4,1,1,1,4,1,1), JU
 1025 GO TO (4,4,4,4,4,4,4,1,2,4), JU
 1026 GO TO (4,4,5,1,4,1,5,4,1,1), JU
 1027 GO TO (4,4,4,5,1,4,4,5,5,5), JU
 1028 GO TO (1,1,1,2,2,1,1,1,4,5), JU
 1029 GO TO (4,4,4,1,1,4,4,4,5,4), JU
C
C	   ISYM = 4
C
CELL ORDER = 19,22A,22B,4A,4B,20,5,9A,9B,21,3,27A,27B,11A,11B,10A,10B,
C	     29,8,16,17,18,6,1,2
 1031 GO TO (1,1,1,5,1,4,4,2,2,4,4,5,1,4,4,5,1,2,6,4,1,4,1,1,1), JU
 1032 GO TO (4,4,4,4,4,4,4,4,4,4,4,4,4,2,2,2,2,4,4,4,4,4,4,4,4), JU
 1033 GO TO (4,4,4,4,4,1,1,1,1,1,1,4,4,1,1,4,4,1,5,1,4,1,1,4,4), JU
 1034 GO TO (4,5,5,4,4,6,4,4,4,4,1,5,1,4,4,5,1,4,4,4,5,2,1,4,4), JU
 1035 GO TO (1,2,6,4,4,4,1,4,4,6,4,2,2,4,4,4,4,2,4,2,2,4,2,1,1), JU
 1036 GO TO (4,4,4,1,5,5,4,1,1,5,4,1,1,1,1,4,4,1,1,1,4,1,1,4,4), JU
 1037 GO TO (4,4,4,4,4,4,1,4,4,1,4,4,4,5,1,4,4,4,1,1,4,4,4,4,4), JU
 1038 GO TO (4,4,4,1,1,1,4,5,1,4,1,4,4,4,4,4,4,4,5,4,4,1,4,4,4), JU
 1039 GO TO (1,1,1,4,4,4,4,4,4,4,4,1,1,4,4,1,1,1,4,4,1,4,5,1,1), JU
C
    1 EU(I) = 1
      GO TO 7
    2 EU(I) = 2
      GO TO 7
    3 EU(I) = 3
      GO TO 7
    4 EU(I) = 0
      GO TO 7
    5 EU(I) = -1
      GO TO 7
    6 EU(I) = -2
    7 CONTINUE
C
C	   GENERATE INVERSE TRANSFORMATION MATRIX OF EU
C
   50 DETEU = EU(1)*(EU(5)*EU(9)-EU(8)*EU(6)) - EU(2)*(EU(4)*EU(9)-
     1 EU(7)*EU(6)) + EU(3)*(EU(4)*EU(8)-EU(7)*EU(5))
C
      IF (DETEU) 51,96,54
   51 DETEU = -DETEU
      DO 53 I = 1,9
      IF (EU(I)) 52,53,52
   52 EU(I) = -EU(I)
   53 CONTINUE
C
   54 EUI(1) =	(EU(5)*EU(9) - EU(8)*EU(6)) / DETEU
      EUI(2) = -(EU(2)*EU(9) - EU(8)*EU(3)) / DETEU
      EUI(3) =	(EU(2)*EU(6) - EU(5)*EU(3)) / DETEU
      EUI(4) = -(EU(4)*EU(9) - EU(7)*EU(6)) / DETEU
      EUI(5) =	(EU(1)*EU(9) - EU(7)*EU(3)) / DETEU
      EUI(6) = -(EU(1)*EU(6) - EU(4)*EU(3)) / DETEU
      EUI(7) =	(EU(5)*EU(8) - EU(7)*EU(5)) / DETEU
      EUI(8) = -(EU(1)*EU(8) - EU(7)*EU(2)) / DETEU
      EUI(9) =	(EU(1)*EU(5) - EU(4)*EU(2)) / DETEU
      DETEUI = 1./DETEU
C
      DO 362 I = 1,9
      IF (EUI(I)) 362,361,362
  361 EUI(I) = 0.0
  362 CONTINUE
C
C	   CALCULATE THE NEW CELL PARAMETERS
C
      ABC = A*B*COSGA
      ACC = A*C*COSBE
      BCC = B*C*COSAL
      A2 = SQRT((EU(1)*A)**2 + (EU(2)*B)**2 + (EU(3)*C)**2
     1 + 2.*(EU(2)*EU(3)*BCC + EU(1)*EU(3)*ACC + EU(1)*EU(2)*ABC))
      B2 = SQRT((EU(4)*A)**2 + (EU(5)*B)**2 + (EU(6)*C)**2
     1 + 2.*(EU(5)*EU(6)*BCC + EU(4)*EU(6)*ACC + EU(4)*EU(5)*ABC))
      C2 = SQRT((EU(7)*A)**2 + (EU(8)*B)**2 + (EU(9)*C)**2
     1 + 2.*(EU(8)*EU(9)*BCC + EU(7)*EU(9)*ACC + EU(7)*EU(8)*ABC))
      ALPHA2 = 57.295780 *  ACOS((EU(4)*EU(7)*A*A + EU(5)*EU(8)*B*B
     1 + EU(6)*EU(9)*C*C + (EU(4)*EU(8)+EU(5)*EU(7))*ABC + (EU(4)*EU(9)
     2 +EU(6)*EU(7))*ACC + (EU(5)*EU(9)+EU(6)*EU(8))*BCC) / (B2*C2))
      BETA2  = 57.295780 *  ACOS((EU(1)*EU(7)*A*A + EU(2)*EU(8)*B*B
     1 + EU(3)*EU(9)*C*C + (EU(1)*EU(8)+EU(2)*EU(7))*ABC + (EU(1)*EU(9)
     2 +EU(3)*EU(7))*ACC + (EU(2)*EU(9)+EU(3)*EU(8))*BCC) / (A2*C2))
      GAMMA2 = 57.295780 *  ACOS((EU(1)*EU(4)*A*A + EU(2)*EU(5)*B*B
     1 + EU(3)*EU(6)*C*C + (EU(1)*EU(5)+EU(2)*EU(4))*ABC + (EU(1)*EU(6)
     2 +EU(3)*EU(4))*ACC + (EU(2)*EU(6)+EU(3)*EU(5))*BCC) / (A2*B2))
C
C	   OUTPUT RESULTS
C
      JSUM = ISUM + 1
      GO TO (401,402,403,404),ISYM
  401 GO TO (712,714,714,710,710,713,709,709,709,706,706,706,711), JU
  402 GO TO (708,711,711,705,705,709,706,706,710,703,703), JU
  403 GO TO (708,711,705,709,709,703,703,710,707,703), JU
  404 GO TO (704,705,705,702,702,705,702,703,703,705,702,706,706,703,
     1	 703,703,703,707,703,703,703,703,703,701,701), JU
  701 WRITE(IOUT,5001)JSUM
      GO TO 89
  702 WRITE (IOUT,5002), JSUM
      GO TO 89
  703 WRITE (IOUT,5003), JSUM
      GO TO 89
  704 WRITE (IOUT,5004), JSUM
      GO TO 89
  705 WRITE (IOUT,5005), JSUM
      GO TO 89
  706 WRITE (IOUT,5006), JSUM
      GO TO 89
  707 WRITE (IOUT,5007), JSUM
      GO TO 89
  708 WRITE (IOUT,5008), JSUM
      GO TO 89
  709 WRITE (IOUT,5009), JSUM
      GO TO 89
  710 WRITE (IOUT,5010), JSUM
      GO TO 89
  711 WRITE (IOUT,5011), JSUM
      GO TO 89
  712 WRITE (IOUT,5012), JSUM
      GO TO 89
  713 WRITE (IOUT,5013), JSUM
      GO TO 89
  714 WRITE (IOUT,5014), JSUM
      GO TO 89
 5001 FORMAT (1H ,5X,7H CELL (,I1,1H),24H   TRICLINIC (PRIMITIVE))
 5002 FORMAT (1H ,5X,7H CELL (,I1,1H),25H   MONOCLINIC (PRIMITIVE))
 5003 FORMAT (1H ,5X,7H CELL (,I1,1H),26H   MONOCLINIC (C-CENTERED))
 5004 FORMAT (1H ,5X,7H CELL (,I1,1H),27H   ORTHORHOMBIC (PRIMITIVE))
 5005 FORMAT (1H ,5X,7H CELL (,I1,1H),28H   ORTHORHOMBIC (C-CENTERED))
 5006 FORMAT (1H ,5X,7H CELL (,I1,1H),31H   ORTHORHOMBIC (BODY-CENTERED)
     1)
 5007 FORMAT (1H ,5X,7H CELL (,I1,1H),31H   ORTHORHOMBIC (FACE-CENTERED)
     1)
 5008 FORMAT (1H ,5X,7H CELL (,I1,1H),25H   TETRAGONAL (PRIMITIVE))
 5009 FORMAT (1H ,5X,7H CELL (,I1,1H),29H   TETRAGONAL (BODY-CENTERED))
 5010 FORMAT (1H ,5X,7H CELL (,I1,1H),27H   RHOMBOHEDRAL (PRIMITIVE))
 5011 FORMAT (1H ,5X,7H CELL (,I1,1H),24H   HEXAGONAL (PRIMITIVE))
 5012 FORMAT (1H ,5X,7H CELL (,I1,1H),20H   CUBIC (PRIMITIVE))
 5013 FORMAT (1H ,5X,7H CELL (,I1,1H),24H   CUBIC (BODY-CENTERED))
 5014 FORMAT (1H ,5X,7H CELL (,I1,1H),24H   CUBIC (FACE-CENTERED))
C
   92 IF (INTERO .EQ. 0) GO TO 89
      WRITE (IOUT,6019), ISUM,JSUM,JSUM,ISUM
      WRITE (IOUT,6020), EU(1),EU(2),EU(3),EUI(1),EUI(2),EUI(3),EU(4),
     1EU(5),
     2 EU(6),EUI(4),EUI(5),EUI(6),EU(7),EU(8),EU(9),EUI(7),EUI(8),EUI(9)
      WRITE (IOUT,6046), DETEU,DETEUI
      LINE = LINE + 1
      IF (LINE - 5) 89,730,730
  730 LINE = 1
      WRITE(IOUT, 4998), (TITLE(I), I = 1,ITZ)
      GO TO 89
C
C	   CALCULATE MATRIX ELEMENTS, F, FOR TRANSFORMATION OF ORIGINAL
C     CELL TO FINAL UNIT CELL
C
   93 F(1) = EU(1)*P(1,1,L2) + EU(2)*P(2,1,L2) + EU(3)*P(3,1,L2)
      F(2) = EU(1)*P(1,2,L2) + EU(2)*P(2,2,L2) + EU(3)*P(3,2,L2)
      F(3) = EU(1)*P(1,3,L2) + EU(2)*P(2,3,L2) + EU(3)*P(3,3,L2)
      F(4) = EU(4)*P(1,1,L2) + EU(5)*P(2,1,L2) + EU(6)*P(3,1,L2)
      F(5) = EU(4)*P(1,2,L2) + EU(5)*P(2,2,L2) + EU(6)*P(3,2,L2)
      F(6) = EU(4)*P(1,3,L2) + EU(5)*P(2,3,L2) + EU(6)*P(3,3,L2)
      F(7) = EU(7)*P(1,1,L2) + EU(8)*P(2,1,L2) + EU(9)*P(3,1,L2)
      F(8) = EU(7)*P(1,2,L2) + EU(8)*P(2,2,L2) + EU(9)*P(3,2,L2)
      F(9) = EU(7)*P(1,3,L2) + EU(8)*P(2,3,L2) + EU(9)*P(3,3,L2)
C
C	   GENERATE INVERSE TRANSFORMATION MATRIX OF F
C
      DETFN = F(1)*(F(5)*F(9)-F(8)*F(6)) - F(2)*(F(4)*F(9)-F(7)*F(6)) +
     1 F(3)*(F(4)*F(8)-F(7)*F(5))
      IF (DETFN.EQ.0.0) GO TO 97
      FI(1) =  (F(5)*F(9) - F(8)*F(6)) / DETFN
      FI(2) = -(F(2)*F(9) - F(8)*F(3)) / DETFN
      FI(3) =  (F(2)*F(6) - F(5)*F(3)) / DETFN
      FI(4) = -(F(4)*F(9) - F(7)*F(6)) / DETFN
      FI(5) =  (F(1)*F(9) - F(7)*F(3)) / DETFN
      FI(6) = -(F(1)*F(6) - F(4)*F(3)) / DETFN
      FI(7) =  (F(4)*F(8) - F(7)*F(5)) / DETFN
      FI(8) = -(F(1)*F(8) - F(7)*F(2)) / DETFN
      FI(9) =  (F(1)*F(5) - F(4)*F(2)) / DETFN
      DETFNI = 1./DETFN
C
      DO 366 I = 1,9
      IF (F(I)) 364,363,364
  363 F(I) = 0.0
  364 IF (FI(I)) 366,365,366
  365 FI(I) = 0.0
  366 CONTINUE
C
  731 LINE = LINE + 1
      IF (LINE - 5) 733,732,732
  732 LINE = 1
      IF (INTERO .EQ. 0 ) GO TO 89
      WRITE(IOUT, 4998), (TITLE(I), I = 1,ITZ)
  733 IF (INTERO .EQ. 0 ) GO TO 89
      WRITE(IOUT,6021)JSUM,JSUM
      WRITE (IOUT,6020), F(1),F(2),F(3),FI(1),FI(2),FI(3),F(4),F(5)
     1,F(6),FI(4),
     2 FI(5),FI(6),F(7),F(8),F(9),FI(7),FI(8),FI(9)
      WRITE (IOUT,6046), DETFN,DETFNI
      GO TO 89
 6019 FORMAT (1H-,  5X, 7H CELL (,I1,11H) TO CELL (,I1,1H),
     1		    5X, 7H CELL (,I1,11H) TO CELL (,I1,1H) /)
 6020 FORMAT (1H ,  4X, 3F7.2,	5X, 3F7.2 )
 6021 FORMAT (1H-,  5X, 19H CELL (1) TO CELL (,I1,1H),
     1		    5X,  7H CELL (,I1,13H) TO CELL (1) /)
 6046 FORMAT (1H ,10X,6H MOD = F8.4,10X,6H MOD = F8.4 )
C
   94 A = A2
      B = B2
      C = C2
      ALPHA = ALPHA2
      BETA  = BETA2
      GAMMA = GAMMA2
      WRITE(IOUT, 4998), (TITLE(I), I = 1,ITZ)
 4998 FORMAT (1H ,14A4/)
      GO TO (411,412,413,414),ISYM
  411 GO TO (812,814,814,810,810,813,809,809,809,806,806,806,811), JU
  412 GO TO (808,811,811,805,805,809,806,806,810,803,803), JU
  413 GO TO (808,811,805,809,809,803,803,810,807,803), JU
  414 GO TO (804,805,805,802,802,805,802,803,803,805,802,806,806,803,
     1	 803,803,803,807,803,803,803,803,803,801,801), JU
C
  801 WRITE (IOUT,6001), JSUM
      GO TO 910
  802 WRITE (IOUT,6002), JSUM
      GO TO 901
  803 WRITE (IOUT,6003) JSUM
      GO TO 901
  804 WRITE (IOUT,6004), JSUM
      GO TO 907
  805 WRITE (IOUT,6005), JSUM
      GO TO 907
  806 WRITE (IOUT,6006), JSUM
      GO TO 907
  807 WRITE (IOUT,6007), JSUM
      GO TO 907
  808 WRITE (IOUT,6008), JSUM
      GO TO 902
  809 WRITE (IOUT,6009), JSUM
      GO TO 902
  810 WRITE (IOUT,6010), JSUM
      GO TO 903
  811 WRITE (IOUT,6011), JSUM
      GO TO 904
  812 WRITE (IOUT,6012), JSUM
      GO TO 905
  813 WRITE (IOUT,6013), JSUM
      GO TO 905
  814 WRITE (IOUT,6014), JSUM
      GO TO 905
 6001 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 26H) -- TRICLINIC (PRIMITIVE))
 6002 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 27H) -- MONOCLINIC (PRIMITIVE))
 6003 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 28H) -- MONOCLINIC (C-CENTERED))
 6004 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 29H) -- ORTHORHOMBIC (PRIMITIVE))
 6005 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 30H) -- ORTHORHOMBIC (C-CENTERED))
 6006 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 33H) -- ORTHORHOMBIC (BODY-CENTERED))
 6007 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 33H) -- ORTHORHOMBIC (FACE-CENTERED))
 6008 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 27H) -- TETRAGONAL (PRIMITIVE))
 6009 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 31H) -- TETRAGONAL (BODY-CENTERED))
 6010 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 29H) -- RHOMBOHEDRAL (PRIMITIVE))
 6011 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 26H) -- HEXAGONAL (PRIMITIVE))
 6012 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 22H) -- CUBIC (PRIMITIVE))
 6013 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 26H) -- CUBIC (BODY-CENTERED))
 6014 FORMAT (1H-,3X,29H LATTICE PARAMETERS OF CELL (,I1,
     1 26H) -- CUBIC (FACE-CENTERED))
C
C	   RESET CELL EDGES AND CELL ANGLES AS PRESCRIBED BY SYMMETRY.
C     GO TO 901 (MONOCLINIC), 902 (TETRAGONAL), 903 (RHOMBOHEDRAL),
C     904 (HEXAGONAL), 905 (CUBIC), 907 (ORTHORHOMBIC).
C
  901 ALPHA = 90.0
      GO TO 909
  902 A = (A + B) / 2.
      GO TO 906
  903 A = (A + B + C) / 3.
      B = A
      C = A
      ALPHA = (ALPHA + BETA + GAMMA) / 3.
      GO TO 908
  904 A = (A + B) / 2.
      B = A
      ALPHA = 90.0
      BETA = 90.0
      GAMMA = 120.0
      GO TO 910
  905 A = (A + B + C) / 3.
      C = A
  906 B = A
  907 ALPHA = 90.0
  908 BETA  = ALPHA
  909 GAMMA = ALPHA
C
  910 WRITE (IOUT,6030), DEL
 6030 FORMAT(1H    ,	  67H CELL IS THE SUGGESTED UNIT CELL OF HIGHEST
     1 SYMMETRY BASED ON DEL = F4.2)
      WRITE(IOUT,6031)ISYM,JU
      INTERO = 1
 6031 FORMAT (1H ,4X,7H ISYM = I2,4X,5H JU = I3)
      IF (ABS(AA - BB) - DEL) 921,921,922
  921 IF (ABS((AA + BB)/2. - CC) - DEL) 923,923,924
  923 IF (JU.EQ.13) GO TO 931
      IF (ISYM.NE.1) GO TO 931
      GO TO 89
  924 IF (ISYM.NE.2) GO TO 932
      GO TO 89
  922 IF (ABS(AA - CC) - DEL) 925,925,89
  925 IF (ISYM.NE.3) GO TO 933
      GO TO 89
C
C	   SPECIAL PROGRAM MESSAGES
C
  931 WRITE (IOUT,6040), ISUM
 6040 FORMAT (1H0,4X,35H WARNING.  THE REDUCED CELL, CELL (,I1, 1H)/ 66H
     1 OF THIS UNIT CELL IS A SPECIAL CASE HAVING PARAMETERS
     2 A = B = C. )
      GO TO 89
  932 WRITE (IOUT,6041), ISUM
 6041 FORMAT (1H0,4X,35H WARNING.  THE REDUCED CELL, CELL (,I1, 1H)/ 62H,
     1 OF THIS UNIT CELL IS A SPECIAL CASE HAVING PARAMETERS A = B. )
      GO TO 89
  933 WRITE(IOUT,6042)ISUM
 6042 FORMAT (1H0,4X,35H WARNING.  THE REDUCED CELL, CELL (,I1, 1H)/ 62H,
     1 OF THIS UNIT CELL IS A SPECIAL CASE HAVING PARAMETERS A = C.  )
      GO TO 89
C
   95 WRITE (IOUT,7001)
 7001 FORMAT (1H0,		      71HTEST FOUND R(2,2) = R(3,3).NE.R
     1(1,1).  THIS RELATIONSHIP IS NOT ALLOWED /     72H UPON ENTRY INTO
     2 TEST SUBROUTINE AND INDICATES AN ERROR IN THE PROGRAM.
     3/ 21X,42H ISYM HAS BEEN SET TO 4 BEFORE CONTINUING. / )
      GO TO 727
C
   98 GO TO (725,727,727,503), ISYM
  503 WRITE (IOUT,7004)
 7004 FORMAT (1H0,    70H THIS REDUCED CELL CONTAINS ONE OR MORE INTERRE
     1LATED OR SPECIAL SCALAR /     71H PRODUCTS INCONSISTENT WITH THE U
     2NIQUE REDUCED CELLS OF TYPE ISYM	 4. / 10X,    56H IT WILL THEREF
     3ORE BE ARBITRARILY ASSIGNED AS TRICLINIC. / )
      GO TO 340
C
   96 JSUM = ISUM + 1
      WRITE(IOUT,7002)ISUM,JSUM
 7002 FORMAT (	 1H0,61H A VALUE OF MOD = 0.00 HAS BEEN CALCULATED IN SU
     1BROUTINE TEST/'FOR THE MATRIX OF CELL ('I1,11H) TO CELL (,I1,1H)/)
      GO TO 89
   97 I = 1
      WRITE (IOUT,7002) I,JSUM
      GO TO 731
  89   RETURN
      END
