      PROGRAM NBSSEARCH
C
C                *** NBS*SEARCH ***
C
C        A PROGRAM TO SEARCH NBS CRYSTAL DATA
C               VERSION OF SPRING 1987
C
C
C        VICKY L. HIMES  AND  ALAN D. MIGHELL
C
C
C              NBS CRYSTAL DATA CENTER
C             REACTOR RADIATION DIVISION
C            NATIONAL BUREAU OF STANDARDS
C              GAITHERSBURG, MD   20899
C
C     COPYRIGHT 1987 BY THE U.S. SECRETARY OF COMMERCE ON BEHALF OF
C     THE UNITED STATES.
C
C 	I have made countless changes in the IO of this program not only
C	to accommodate the logic file but also to cut down the amount of
C       header information and to limit the printout to 80 characters.
C       I have introduced a few new variables, one of which IOUT is to
C       avoid header info.  A few parts of the program are avoided all
C       together -- there's code here that doesn't need to be here.
C       Searching the inorganic file separately from the organic file
C       is a waste.  Searching by direct lattice matching is apparently
C	not the best way; Alan has proposed using a matrix matching
C	technique.   All in all, this program should be rewritten, not
C	simply patched, for the next version.  RLH.
C	Instead of using pointers, the a values should be indexed; 
C	this would speed up the search considerably.
C
C
C
C
      CHARACTER ASRCH(5),IHI,IHO
      CHARACTER*5 AFCN,ALM
      CHARACTER*30 FILEX
      CHARACTER*12 USER
	INTEGER POINT,IPOINT
      COMMON /CONST1/ RADIAN
      COMMON /FCN1/ IFCN
      COMMON /PRINT1/ IPRRSS,IOUT
      COMMON /PROB1/ NTD,IPROB
      COMMON /PROB2/ IPCH,NUNK
      COMMON /TOLER1/ TOLE,TOLA,TOLV
	COMMON /POINT1/ POINT(100),IPOINT(100)
      COMMON /UNIT1/ IUNITA
      COMMON /UNIT2/ IUNITB
      COMMON /UNIT3/ IUNITC
      COMMON /UNIT4/ IUNITD
	COMMON /UNIT5/ IDIRECT,ICODEN,ITABLE,ISRCH
C**
      COMMON /CK01/ ICK011,ICK012,ICK013,ICK014
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
      DATA ALM/'LM   '/
      DATA IHI/'I'/, IHO/'O'/
C
C
C
C     --- OPENS, CLOSES :
C         IUNITC (= 7)  (ASSOCIATES FILENAMES: NBSI, NBSO)
C         IUNITD (=10)  (ASSOCIATED FILENAME:  NBS10)
C
C     --- INITIALIZE PROGRAM CONSTANTS
      RADIAN = 180.0/3.14159265
C
C     --- INITIALIZE VARIABLES
      ICTFCN = 0
      IERRIN = 0
      IHEAD1 = 0
      IHEAD2 = 0
      IPRRSS = 0
      ISRCHI = 0
      ISRCHO = 0
	IOUT=1
C
C	INITIAL POINTERS FOR THE INORGANIC FILE
C
	OPEN(UNIT=1,NAME='CD:POINTI.DAT',STATUS='OLD',ERR=9765,
	1 FORM='UNFORMATTED',ACCESS='SEQUENTIAL',READONLY,SHARED)
	READ (1) IPOINT,POINT
	CLOSE (UNIT=1)
C
C**
C
C	THE I/O FOR THIS VERSION OF SEARCH HAS BEEN ALTERED SO THAT
C	INPUT IS EXPECTED TO COME FROM A FILE NAMED 'SEARCH.INP' AND
C	OUTPUT IS TO BE PLACED IN 'SEARCH.OUT'.
C
	OPEN (UNIT=IUNITB,FILE='LATTICE.OUT',STATUS='NEW',
	1 FORM='FORMATTED')
	OPEN(UNIT=ICODEN,FILE='CD:CODENS.DAT',STATUS='OLD',ERR=9764,
	1 ACCESS='DIRECT',FORM='FORMATTED',RECL=80,READONLY,SHARED)
C**
C     --- FOR CHECKING ... READ OR INITIALIZE TEST PRINT/RUN CONTROL
C         VARIABLES
C     READ(IUNITA,1000) ICK011,ICK012,ICK013,ICK014,ICK015,
C    $    ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,ICK028,ICK029
C**
      ICK011 = 0
      ICK012 = 0
      ICK013 = 0
      ICK014 = 0
      ICK015 = 0
      ICK021 = 0
      ICK022 = 0
      ICK023 = 0
      ICK024 = 0
      ICK025 = 0
      ICK026 = 0
      ICK027 = 0
      ICK028 = 0
      ICK029 = 0
C**
C     --- WHEN NOT EXECUTING SPECIAL CHECK RUN, GO TO SECTION
C         OF CODE FOR NORMAL EXECUTION OF PROGRAM
      IF(ICK029.NE.1) GO TO 10
C**
C        --- THIS CHECK CODE ALLOWS FOR THE REDUCTION OF A LARGE
C            NUMBER OF CELLS PER RUN (UP TO 99999).  THE REDUCED
C            CELL, TRANSFORMATION MATRIX FROM THE INITIAL CELL TO
C            THE REDUCED CELL, AND THE PROBLEM NUMBER WILL BE
C            WRITTEN TO IUNITD.  IUNITD MUST BE PRE-ASSIGNED TO
C            THE COMPUTER RUN. THE PRINT OUT IS LIMITED TO THE
C            PROBLEM NUMBER FOLLOWED BY ANY WARNING AND/OR
C            ERROR MESSAGES.
C
C        --- INITIALIZE VARIABLES
         IFCN = 1
         IPCH = 0
         IPRRSS = 1
         NUNK = 0
C
C        --- READ NUMBER OF PROBLEMS
         READ(IUNITA,980) NTD
C
C        --- WRITE SPECIAL HEADING, NUMBER OF PROBLEMS
         IF (IOUT.EQ.0) CALL HEAD0
         CALL CKPT02(12)
C
C        --- CALCULATE REDUCED CELLS
         CALL REDUCE
         GO TO 800
   10 CONTINUE
C***********************************************************
C
C        MRL/PSU CHANGES
C        APRIL 17, 1987
C
C
      WRITE(6,60556)
60556 FORMAT(' NBS*SEARCH OF THE DATABASE "CRYSTAL DATA"'/
     1   10X,'PROGRAM 1987---FILE SIZE 115,000 ENTRIES'/
     1   10X,'USING THE ORIGINAL NBS*SEARCH CODE OF'/
     1   10X,'VICKY L. HIMES AND ALAN D. MIGHELL,'/
     1   10X,'WITH THE EXTENSIVE I/O CHANGES BY RICHARD HARLOW,'/
     1   10X,'AND FILE CHANGES AT MRL/PSU.'/
     1   10X,'LOCAL CHANGES BY GERALD G. JOHNSON JR.'/
     1   10X,'VAX VERSION SEPT 20, 1988'//)
      WRITE(6,70788)
70788 FORMAT(' AFTER THE NUMERICAL SEARCH IS COMPLETED, DO CHEMICAL'/
     1 10X,'SEARCHES. TO DO THIS USE THE MENU OPTION FOR MISC. SEARCH'/
     2 10X,'SCHEMES, AND PROCEED DIRECTLY TO "SELECTIONS"--DO NOT'/
     3 10X,'"CREATE/RESET RESULT FILE"--THE RESULTS FROM THE NUMERICAL'/
     4 10X,'SEARCH WILL HAVE BEEN STORED IN THE "LOGIC FILE".'//)
10557 WRITE(6,10556)
10556 FORMAT(' PLEASE ENTER THE NAME OF THE INPUT FILE',
     1   1X,'OF THE FORM *.LAT'/
     1   10X,'JUST ENTER THE ROOT PORTION, NOT THE EXTENSION.'/
     1   10X,'THE WORD "NOFILES", IF THERE ARE NOFILES, OR'/
     1   10X,'THE WORD "HELP" TO SEE A LIST OF POSSIBLE FILES   ',$)
      READ(5,10558) FILEX
10558 FORMAT(A18)
      IKEY=STR$UPCASE(FILEX,FILEX)
      IF(FILEX.EQ.'     ')   FILEX='HELP'
      IF(FILEX.EQ.'NOFILES') STOP 'PROGRAM ABORTED--START AGAIN'
      IF(FILEX.EQ.'HELP'   ) THEN
         IKEY=LIB$SPAWN('$ DIR *.LAT')
         GO TO 10557
      ENDIF
      OPEN(UNIT=IUNITA,READONLY,STATUS='OLD',ERR=10557,RECL=80,
     1   FILE=FILEX,DEFAULTFILE='.LAT',SHARED)
      WRITE(6,10061)
10061 FORMAT(' THERE COULD BE A 2-3 MINUTE WAIT HERE'/
     1  10X,'RELAX, WHILE THE COMPUTER DOES SOME WORK'//)
C
C     --- WRITE GENERAL HEADING FOR PROGRAM
      IF (IOUT.EQ.0) CALL HEAD0
C
C     --- STARTING POINT FOR EACH PROGRAM FUNCTION TO BE PROCESSED
   50 CONTINUE
      ICTFCN = ICTFCN + 1
C
C     --- READ PROGRAM CONTROL LINE
C         (TYPE OF PROGRAM FUNCTION, NUMBER OF PROBLEMS)
      READ(IUNITA,1100,END=800) AFCN, NTD
C
C     --- ASSIGN A VARIABLE (IFCN) TO INDICATE THE TYPE OF
C         PROGRAM FUNCTION
      IFCN = 0
      IF(AFCN.EQ.ALM)    IFCN = 1
C
C     --- CHECK FOR VALID PROGRAM FUNCTION (IF NOT VALID,
C         WRITE ERROR MESSAGE AND STOP EXECUTION OF PROGRAM)
      IF(IFCN.LT.1.OR.IFCN.GT.1) GO TO 700
C
C     --- GO TO SECTION OF CODE FOR SPECIFIED FUNCTION
      GO TO (100) IFCN
C
  100 CONTINUE
C
C
C     *** LM FUNCTION ***
C
C     --- IDENTIFY UNKNOWN CELLS BASED ON LATTICE
C         MATCHING WITH NBS CRYSTAL DATA
C
C**
      IF(ICK015.EQ.1) IHEAD1 = 0
C
C     --- READ LM PARAMETER LINE
      READ(IUNITA,1200) TOLE, TOLA, TOLV, ASRCH, IPRRSS
C
C     --- ASSIGN VARIABLES TO INDICATE WHICH 1-LINE DATABASES ARE
C         TO BE SEARCHED
      DO 110 I = 1,5
         IF(ASRCH(I).EQ.IHI) ISRCHI = 1
         IF(ASRCH(I).EQ.IHO) ISRCHO = 1
  110 CONTINUE
C
C     --- IF NO DATABASE SPECIFIED OR IF ILLEGAL DATABASE IS
C         SPECIFIED ONLY RSS CALCULATIONS WILL BE DONE
      IF(.NOT.(ISRCHI.EQ.0.AND.ISRCHO.EQ.0)) GO TO 112
         IPRRSS = 0
         GO TO 200
  112 CONTINUE
C
C     --- CHECK THAT THIS IS THE FIRST DATABASE SEARCH TO BE PROCESSED
      IF(IHEAD1.EQ.0) GO TO 130
C
C        --- ONLY ONE DATABASE SEARCH PER RUN IS ALLOWED ... SKIP
C            EXPECTED INPUT RECORDS AND PROCEED TO NEXT PROGRAM FUNCTION
         WRITE(IUNITB,1300)
         DO 120 I = 1,NTD
            READ(IUNITA,1400) TEMREC
  120    CONTINUE
         IPRRSS = 0
         ISRCHI = 0
         ISRCHO = 0
         GO TO 50
  130 CONTINUE
C
C
C     --- WRITE NUMBER OF INDEPENDENT PROBLEMS TO STUDY
      IF (IOUT.EQ.0) CALL OUTPT1(1)
C
C     --- OUTPUT FOR LATTICE MATCHING OF REDUCED CELLS
      CALL OUTPT1(2)
C
C     --- ALWAYS WRITE IUNITD, CONTROL WRITE OF RSS HEADING
      IPCH = 1
      IF(ICTFCN.GT.1) WRITE(IUNITB,5000)
      IF(IPRRSS.EQ.1) CALL HEAD2
C
C     --- CHECK NUMBER OF PROBLEMS INPUT ... IF NECESSARY, RESET TO 1
      IF(NTD.GE.1.AND.NTD.LE.20) GO TO 140
         IERRIN = NTD
         WRITE(IUNITB,1500)
         NTD = 1
  140 CONTINUE
C
C
C     --- INITIALIZE VARIABLE
      NUNK = 0
C
C     --- CALCULATE REDUCED AND DERIVATIVE CELLS
      OPEN(UNIT=IUNITD,FILE='NBS10',STATUS='NEW')
      CALL REDUCE
      CLOSE(IUNITD)
C
C     --- IDENTIFICATION OF REDUCED CELL(S) BASED ON LATTICE MATCHING
C         (FIRST PREPARE INPUT CELLS)
      CALL LMPRE
C
C     --- SEARCH INORGANIC 1-LINE DATABASE IF INDICATED
      IF(ISRCHI.EQ.0) GO TO 150
C
C        --- WRITE HEADING, THEN SEARCH DATABASE
	WRITE (6,888)
888	FORMAT (' SEARCHING THE INORGANIC DATA BASE -- ')
         WRITE(IUNITB,1600)
	ISRCH=1
         OPEN(UNIT=IUNITC,FILE='LATTICEI',STATUS='OLD',ERR=9763,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',RECL=32,READONLY,SHARED)
C	OPEN(UNIT=IDIRECT,FILE='CD:CRYSTI.DIRECT',STATUS='OLD',
C	1 ACCESS='DIRECT',FORM='FORMATTED',RECL=80,READONLY,SHARED)
	OPEN (UNIT=ITABLE,FILE='TABLE.INC',STATUS='NEW',
	1 FORM='UNFORMATTED')
         CALL LMSRCH(IMATCH)
	IF (IMATCH.GT.0) THEN
	WRITE (6,889)
889	FORMAT (' LOGIC TABLE HAS BEEN WRITTEN TO "TABLE.INC"'/)
	CLOSE (ITABLE)
	ELSE
	CLOSE(ITABLE,STATUS='DELETE')
	ENDIF
         CLOSE(IUNITC)
	CLOSE(IDIRECT)
  150 CONTINUE
C
C     --- SEARCH ORGANIC 1-LINE DATABASE IF INDICATED
      IF(ISRCHO.EQ.0) GO TO 160
C
C        --- WRITE HEADING
	WRITE (6,890)
890	FORMAT (/' SEARCHING THE ORGANIC DATA BASE -- ')
         WRITE(IUNITB,1700)
C
C        --- RESET VARIABLES, POINTERS FOR ORGANIC SEARCH
         CALL LMSETO
C
C        --- ORGANIC SEARCH
	ISRCH=2
         OPEN(UNIT=IUNITC,FILE='LATTICEO',STATUS='OLD',ERR=9762,
	1 ACCESS='DIRECT',FORM='UNFORMATTED',RECL=32,READONLY,SHARED)
C	OPEN(UNIT=IDIRECT,FILE='CD:CRYSTO.DIRECT',STATUS='OLD',
C	1 ACCESS='DIRECT',FORM='FORMATTED',RECL=80,READONLY,SHARED)
	OPEN (UNIT=ITABLE,FILE='TABLE.ORC',STATUS='NEW',
	1 FORM='UNFORMATTED')
         CALL LMSRCH(IMATCH)
	IF (IMATCH.GT.0) THEN
	WRITE (6,891)
891	FORMAT (' LOGIC TABLE HAS BEEN WRITTEN TO "TABLE.ORC"'/)
	CLOSE (ITABLE)
	ELSE
	CLOSE(ITABLE,STATUS='DELETE')
	ENDIF
         CLOSE(IUNITC)
	CLOSE(IDIRECT)
	CLOSE (ICODEN)
  160 CONTINUE
C
C     --- IF INPUT ERROR, SKIP EXPECTED INPUT RECORDS AND PROCEED TO
C         NEXT PROGRAM FUNCTION
      IF(IERRIN.EQ.0) GO TO 180
         DO 170 I = 1,IERRIN-1
            READ(IUNITA,1400) TEMREC
  170    CONTINUE
         IERRIN = 0
  180 CONTINUE
C
      IHEAD1 = IHEAD1 + 1
      IPRRSS = 0
      ISRCHI = 0
      ISRCHO = 0
      GO TO 50
C
  200 CONTINUE
C
C
C     *** RSS CALCULATIONS ***
C
C     --- (THIS SECTION OF CODE IS ENTERED IF A LEGAL DATABASE
C          IS NOT SPECIFIED)
C
C     --- NEVER WRITE IUNITD, CONTROL WRITE OF RSS HEADING
      IPCH = 0
      IF(ICTFCN.GT.1) WRITE(IUNITB,5000)
      IF(IHEAD2.EQ.0) CALL HEAD2
C
C     --- CHECK NUMBER OF PROBLEMS INPUT ... IF NECESSARY, RESET TO 1
      IF(NTD.GE.1.AND.NTD.LE.20) GO TO 210
         IERRIN = NTD
         WRITE(IUNITB,1500)
         NTD = 1
  210 CONTINUE
C
C     --- WRITE NUMBER OF INDEPENDENT PROBLEMS TO STUDY
      CALL OUTPT1(1)
C
C     --- CALCULATE REDUCED AND DERIVATIVE CELLS
      CALL REDUCE
C
C     --- IF INPUT ERROR, SKIP EXPECTED INPUT RECORDS AND PROCEED TO
C         NEXT PROGRAM FUNCTION
      IF(IERRIN.EQ.0) GO TO 230
         DO 220 I = 1,IERRIN-1
            READ(IUNITA,1400) TEMREC
  220    CONTINUE
         IERRIN = 0
  230 CONTINUE
C
      IHEAD2 = IHEAD2 + 1
      GO TO 50
C
C
  700 CONTINUE
C
C     --- ERROR IN SPECIFIED PROGRAM FUNCTION
      WRITE(IUNITB,4000)
  800 CONTINUE
      CALL WHO(USER)
      WRITE(IUNITB,40001) USER
40001 FORMAT(///' THIS JOB WAS RUN BY ',A12)
      CLOSE(UNIT=IUNITB)
      STOP 'END OF MODIFIED NIST LATTICE SEARCHING PROGRAM NBS*SEARCH'
9765  STOP 'OPEN ERROR ON CD:POINTI.DAT'
9764  STOP 'OPEN ERROR ON CODENS'
9763  STOP 'OPEN ERROR ON NBSI'
9762  STOP 'OPEN ERROR ON NBSO'
  980 FORMAT(5X,I5)
C**
C1000 FORMAT(5I1,5X,9I1,1X)
 1100 FORMAT(A5,3X,I2)
 1200 FORMAT(3F10.2,5A1,4X,I1)
 1300 FORMAT(1H1////1X,'INPUT ERROR ... Only one Database search per run
     $ is allowed.')
 1400 FORMAT(A80)
 1500 FORMAT(///1X,'INPUT ERROR ... Check columns 9-10 on Program Contro
     $l Line.'/1X,16X,'Number of independent problems set to 1.')
 1600 FORMAT(///,36X,'INORGANIC')
 1700 FORMAT(///,37X,'ORGANIC')
 4000 FORMAT(1H1////1X,'INPUT ERROR ... Invalid program function was spe
     $cified.')
 5000 FORMAT(1H1)
       END
      BLOCKDATA
C     SUB-PROGRAM 'BLOCKDATA' ...
C        INITIALIZES VARIABLES, POINTERS FOR SEARCHING INORGANIC
C        1-LINE DATABASE
C
C
      INTEGER POINT,IPOINT
      COMMON /DATA1/ IDATA1,IDATA2,IDATA3
C
C	REVISED DIMENSIONS OF POINT AND IPOINT FROM 61 TO 100
C	RLH
C
      COMMON /POINT1/ POINT(100),IPOINT(100)
      COMMON /SRCH1/ ISTART(900),NOGR(900)
      COMMON /UNIT1/ IUNITA
      COMMON /UNIT2/ IUNITB
      COMMON /UNIT3/ IUNITC
      COMMON /UNIT4/ IUNITD
	COMMON /UNIT5/ IDIRECT,ICODEN,ITABLE,ISRCH
C
C
      DATA IDATA1/61/, IDATA2/50/, IDATA3/24/
      DATA IUNITA/55/, IUNITB/4/, IUNITC/7/, IUNITD/10/
	DATA IDIRECT/2/,ICODEN/3/,ITABLE/11/

      DATA ISTART/900*0/, NOGR/900*0/
C
C
C	GET POINTERS FROM FILE POINTI (IN MAIN PROGRAM), NOT FROM FORTRAN CODE.
C
      END
      SUBROUTINE CENTER
      COMMON /CNTR1/ ICNTR1
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
C
C
C     SUBROUTINE 'CENTER' ...
C        FIND MATRIX TO TRANSFORM THE INPUT CELL TO A PRIMITIVE CELL
C        (I.E. MATRIX TO REMOVE CELL CENTERING)
C
C
C
C     --- (1/2/3/4/5/6/7)    (P OR RR/A/B/C/F/I/RH)
      GO TO (100,200,300,400,500,600,700) ICNTR1
C
  100 CONTINUE
C
C     --- PRIMITIVE LATTICE
      U1 = 1.0
      V1 = 0.0
      W1 = 0.0
      U2 = 0.0
      V2 = 1.0
      W2 = 0.0
      U3 = 0.0
      V3 = 0.0
      W3 = 1.0
      GO TO 800
  200 CONTINUE
C
C     --- A-CENTERED LATTICE
      U1 =  0.0
      V1 =  0.5
      W1 = -0.5
      U2 =  0.0
      V2 =  0.5
      W2 =  0.5
      U3 =  1.0
      V3 =  0.0
      W3 =  0.0
      GO TO 800
  300 CONTINUE
C
C     --- B-CENTERED LATTICE
      U1 = -0.5
      V1 =  0.0
      W1 =  0.5
      U2 =  0.5
      V2 =  0.0
      W2 =  0.5
      U3 =  0.0
      V3 =  1.0
      W3 =  0.0
      GO TO 800
  400 CONTINUE
C
C     --- C-CENTERED LATTICE
      U1 =  0.5
      V1 = -0.5
      W1 =  0.0
      U2 =  0.5
      V2 =  0.5
      W2 =  0.0
      U3 =  0.0
      V3 =  0.0
      W3 =  1.0
      GO TO 800
  500 CONTINUE
C
C     --- F-CENTERED LATTICE
      U1 = 0.5
      V1 = 0.5
      W1 = 0.0
      U2 = 0.0
      V2 = 0.5
      W2 = 0.5
      U3 = 0.5
      V3 = 0.0
      W3 = 0.5
      GO TO 800
  600 CONTINUE
C
C     --- I-CENTERED LATTICE
      U1 =  0.5
      V1 =  0.5
      W1 = -0.5
      U2 = -0.5
      V2 =  0.5
      W2 =  0.5
      U3 =  0.5
      V3 = -0.5
      W3 =  0.5
      GO TO 800
  700 CONTINUE
C
C     --- RHOMBOHEDRAL CELL SET ON HEXAGONAL AXES
      U1 =  1.0/3.0
      V1 = -1.0/3.0
      W1 = -1.0/3.0
      U2 = -2.0/3.0
      V2 = -1.0/3.0
      W2 = -1.0/3.0
      U3 =  1.0/3.0
      V3 =  2.0/3.0
      W3 = -1.0/3.0
  800 CONTINUE
C
C     --- WRITE MATRIX TO TRANSFORM THE INPUT CELL TO
C         A PRIMITIVE CELL OF THE LATTICE
      CALL OUTPT1(10)
      RETURN
      END
      SUBROUTINE CKPT02(IFLAG2)
      COMMON /DOTP/ S11,S22,S33,S23,S13,S12
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /PROB1/ NTD,IPROB
      COMMON /TYPE/ ITYPE
      COMMON /UNIT2/ IUNITB
C
C
C     SUBROUTINE 'CKPT02' ...
C        CHECK PRINT OUT FOR THE RSS CALCULATIONS
C
C
C
C     --- IF THE CALL ARGUMENT (IFLAG2) IS GREATER THAN OR EQUAL TO
C         31, IT MUST BE DECODED TO OBTAIN THE NUMBER OF THE SPECIAL
C         CONDITION AND THE 'CALL ARGUMENT' FOR THE OUTPUT
      ICOND = 0
      IF(IFLAG2.GE.31) ICOND = IFLAG2 - 30
      IF(IFLAG2.GE.31) IFLAG2 = 10
C
C     --- GO TO APPROPRIATE SECTION OF OUTPUT
      GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130) IFLAG2
   10 CONTINUE
C
C     *** CALLED FROM 'MNCOND'
C
C     --- WRITE CELL MATRIX AND TRANSFORMATION MATRIX AT BEGINNING OF
C         SUBROUTINE 'MNCOND'
      WRITE(IUNITB,1100) IFLAG2, S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
   20 CONTINUE
   30 CONTINUE
   40 CONTINUE
C
C     *** CALLED FROM 'MNCOND'
C
C     --- WRITE PRIOR TO CALLS TO 'SHORTV'
C         IFLAG2 = 2    ...   PRIOR TO FIRST CALLS
C         IFLAG2 = 3    ...   PRIOR TO SECOND CALLS
C         IFLAG2 = 4    ...   PRIOR TO THIRD CALLS
      WRITE(IUNITB,1100) IFLAG2
      GO TO 900
   50 CONTINUE
   60 CONTINUE
   70 CONTINUE
C
C     *** CALLED FROM 'MNCOND'
C
C     --- WRITE CELL MATRIX AND TRANSFORMATION MATRIX AT
C         INTERMEDIATE STAGES
C         IFLAG2 = 5 ... AFTER CELL EDGES A AND B HAVE BEEN INTERCHANGED
C         IFLAG2 = 6 ... AFTER CELL EDGES B AND C HAVE BEEN INTERCHANGED
C         IFLAG2 = 7 ... AFTER CALCULATING THE BODY DIAGONAL OF THE CELL
      WRITE(IUNITB,1100) IFLAG2, S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
   80 CONTINUE
C
C     *** CALLED FROM 'SHORTV'
C
C     --- WRITE CELL MATRIX AND TRANSFORMATION MATRIX AT END
C         OF SUBROUTINE 'SHORTV'
      WRITE(IUNITB,1200) S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
   90 CONTINUE
C
C     *** CALLED FROM 'NORMAL'
C
C     --- WRITE CELL TYPE, CELL MATRIX, TRANSFORMATION MATRIX
      WRITE(IUNITB,1300) ITYPE, S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
  100 CONTINUE
C
C     *** CALLED FROM 'SPCON2'
C
C     --- WRITE SPECIAL CONDITION NUMBER, CELL TYPE, CELL MATRIX,
C         TRANSFORMATION MATRIX
      WRITE(IUNITB,1400) ICOND, ITYPE, S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
  110 CONTINUE
C
C     *** CALLED FROM 'SPCON2'
C
C     --- WRITE CELL MATRIX AND TRANSFORMATION MATRIX AFTER THE
C         TRANSFORMATION TO SATISFY THE SPECIAL CONDITION HAS BEEN
C         APPLIED
      WRITE(IUNITB,1500) S11, S22, S33, S23, S13, S12,
     $                   U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
  120 CONTINUE
C
C     *** CALLED FROM 'MAIN' FOR SPECIAL CHECK RUN ONLY
C
C     --- WRITE HEADING FOR CHECK RUN, NUMBER OF PROBLEMS
      WRITE(IUNITB,2000)
      WRITE(IUNITB,2100) NTD
      GO TO 900
  130 CONTINUE
C
C     *** CALLED FROM 'OUTPT1' FOR CHECK RUN ONLY
C
C     --- WRITE PROBLEM NUMBER
      WRITE(IUNITB,2200) IPROB
  900 CONTINUE
      RETURN
 1100 FORMAT(1X,'MNCOND',I2,1X,6F12.6,3X,9F5.2)
 1200 FORMAT(1X,'SHORTV  ',1X,6F12.6,3X,9F5.2)
 1300 FORMAT(1X,'NORMAL',1X,I1,1X,6F12.6,3X,9F5.2)
 1400 FORMAT(1X,'SPCON2',2I1,1X,6F12.6,3X,9F5.2)
 1500 FORMAT(1X,'SPCON2  ',1X,6F12.6,3X,9F5.2)
 2000 FORMAT(///1X,'This mode of operation allows for the reduction of a
     $ large number'     /1X,'of cells (up to 99999) in a single run.  I
     $n this mode of operation,'     /1X,'the reduced cell, the transfor
     $mation matrix from the initial cell to'     /1X,'the reduced cell,
     $ and the problem number will be written on unit 10'     /1X,'(Form
     $at = 6F10.6,2X,9F7.2,2X,I5).  Unit 10 must be pre-assigned to the'
     $     /1X,'computer run.  The printed output is limited to the prob
     $lem number'     /1X,'followed by any warning and/or error messages
     $.')
 2100 FORMAT(//1X,'Number of cells to be reduced = ',I5//////)
 2200 FORMAT(1X,I5)
      END
      SUBROUTINE DERIV
      COMMON /DELTA1/ IRSS
      COMMON /DELTA3/ IDET,ILATNO
      COMMON /DELTA4/ IDERIV,IFINIS,IQMATF
      COMMON /INVER1/ UI1,VI1,WI1,UI2,VI2,WI2,UI3,VI3,WI3
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /QMAT/ ISQ11(519),ISQ12(519),ISQ13(519),
     $              ISQ22(519),ISQ23(519),ISQ33(519)
C
C
C     SUBROUTINE 'DERIV' ...
C        FIND MATRIX TO CALCULATE DERIVATIVE LATTICE
C
C
C
C     --- INITIALIZE VARIABLES FOR EACH NEW PROBLEM
      IF(IDERIV.NE.1) GO TO 100
         IDET = 0
         IFINIS = 0
         ILATNO = 0
  100 CONTINUE
C
C     --- INCREMENT DERIVATIVE LATTICE NUMBER, AND COUNT THE NUMBER
C         OF UPPER TRIANGULAR MATRICES SELECTED (IDERIV = IQMATF WHEN
C         LAST MATRIX IS SELECTED)
      ILATNO = ILATNO + 1
      IDERIV = IDERIV + 1
C
C     --- SELECT AN UPPER TRIANGULAR MATRIX
      U1 = ISQ11(IDERIV-1)
      V1 = ISQ12(IDERIV-1)
      W1 = ISQ13(IDERIV-1)
      U2 = 0.0
      V2 = ISQ22(IDERIV-1)
      W2 = ISQ23(IDERIV-1)
      U3 = 0.0
      V3 = 0.0
      W3 = ISQ33(IDERIV-1)
C
C     --- CALCULATE DETERMINANT FOR UPPER TRIANGULAR MATRIX
C         (SAVE PREVIOUS VALUE FOR LATER COMPARISON)
      IDPRE = IDET
      DET  = U1*V2*W3 + V1*W2*U3 + W1*U2*V3 - U3*V2*W1 - V3*W2*U1 -
     $       W3*U2*V1
      IDET = NINT(DET)
C
C     --- DO NOT CALCULATE THE TRANSPOSE OF THE INVERSE FOR THE UPPER
C         TRIANGULAR MATRIX WHEN SUPERCELLS ARE BEING CALCULATED
C         (WHEN BOTH SUPERCELL AND SUBCELL CALCULATIONS ARE TO BE
C         DONE, SUPERCELLS ARE CALCULATED FIRST)
      IF(IRSS.EQ.1.OR.IRSS.EQ.3) GO TO 300
C
C        --- CALCULATE THE TRANSPOSE OF THE INVERSE FOR AN UPPER
C            TRIANGULAR MATRIX (USED FOR CALCULATING SUBCELLS)
         CALL INVERS(0)
         U1 = UI1
         V1 = UI2
         W1 = UI3
         U2 = VI1
         V2 = VI2
         W2 = VI3
         U3 = WI1
         V3 = WI2
         W3 = WI3
  300 CONTINUE
C
C     --- CHECK FOR A CHANGE IN THE VALUE OF THE DETERMINANT OF
C         THE UPPER TRIANGULAR MATRIX ... ENABLES APPROPRIATE
C         SUB-HEADING TO BE WRITTEN
      IF(IDET.EQ.IDPRE) GO TO 400
C
C        --- CHANGE IN DELTA ENCOUNTERED ... WRITE SUB-HEADING FOR
C            DERIVATIVE LATTICES
         ILATNO = 1
         IF(IRSS.NE.2) CALL OUTPT1(7)
         IF(IRSS.EQ.2) CALL OUTPT1(8)
  400 CONTINUE
C
C     --- WRITE DERIVATIVE LATTICE NUMBER AND TRANSFORMATION MATRIX
C         TO DERIVATIVE CELL
      CALL OUTPT1(9)
      CALL OUTPT1(10)
C
C     --- ONLY WHEN THE LAST UPPER TRIANGULAR MATRIX HAS BEEN SELECTED,
C         INITIALIZE VARIABLES FOR THE NEXT PROBLEM, OR FOR THE SUBCELL
C         CALCULATIONS WHEN BOTH SUPERCELL AND SUBCELL CALCULATIONS ARE
C         ARE TO BE DONE
      IF(IDERIV-1.LT.IQMATF) GO TO 700
C
C        --- LAST UPPER TRIANGULAR MATRIX, CHECK IF FINISHED PROBLEM
         IF(IRSS.NE.3) IFINIS = 1
         IF(IRSS.NE.3) GO TO 700
C
C           --- FINISHED SUPERCELLS, INITIALIZE VARIABLES FOR SUBCELL
C               CALCULATION ON NEXT CALL TO SUBROUTINE 'DERIV'
            IRSS = 2
            IDET = 0
            IDERIV = 1
            ILATNO = 0
  700 CONTINUE
      RETURN
      END
      SUBROUTINE DETERM
      COMMON /FCN1/ IFCN
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /UNIT2/ IUNITB
C
C
C     SUBROUTINE 'DETERM' ...
C        CALCULATE THE DETERMINANT OF A 3 BY 3 MATRIX
C        TO CHECK FOR VALID INPUT MATRIX
C
C
C
C     --- INITIALIZE VARIABLES
      DET = 0
C
C     --- CALCULATE DETERMINANT
      DET = U1*V2*W3 + V1*W2*U3 + W1*U2*V3 - U3*V2*W1 - V3*W2*U1 -
     $      W3*U2*V1
C
C     --- CHECK VALUE OF DETERMINANT FOR ERROR OR WARNING
C         SITUATIONS (DIFFERENT ACTIONS ARE REQUIRED FOR
C         DIFFERENT PROGRAM FUNCTIONS)
      IF(.NOT.(IFCN.EQ.1)) GO TO 100
C
C        --- LM PROGRAM FUNCTION IS BEING EXECUTED
C
C        --- FOR ZERO OR NEGATIVE DETERMINANT, STOP PROGRAM
C            EXECUTION (SHOULD NOT OCCUR)
         IF(DET.LE.0.01) STOP
     $      '*DETERM* ERROR ... Determinant is zero or negative.'
C
C        --- FOR DETERMINANTS GREATER THAN 9, STOP PROGRAM
C            EXECUTION (SHOULD NOT OCCUR)
         IF(DET.GE.9.01) STOP
     $      '*DETERM* ERROR ... Determinant is greater than nine.'
         GO TO 400
  100 CONTINUE
C
C     --- STOP PROGRAM EXECUTION SINCE A VALID PROGRAM FUNCTION
C         HAS NOT BEEN ENCOUNTERED (SHOULD NOT OCCUR)
      STOP '*DETERM* ERROR ... Invalid progam function.'
  400 CONTINUE
      RETURN
      END
      SUBROUTINE DOT (X1,X2,X3,Y1,Y2,Y3,XI,YI,ZI,AR,BR,GR,DOTXY)
C
C
C     SUBROUTINE  'DOT' ...
C        CALCULATE DOT PRODUCT OF VECTORS X AND Y
C
C
C     --- VECTOR X = (X1A + X2B + X3C)
C         VECTOR Y = (Y1A + Y2B + Y3C) , WHERE (A,B,C) ARE (XI,YI,ZI)
      DOTXY = X1*Y1*(XI**2) + X2*Y2*(YI**2) + X3*Y3*(ZI**2) +
     $(X3*Y1+X1*Y3)*ZI*XI*COS(BR) + (X3*Y2+X2*Y3)*ZI*YI*COS(AR) +
     $(X1*Y2+X2*Y1)*XI*YI*COS(GR)
      RETURN
      END
      SUBROUTINE HEAD0
      COMMON /UNIT2/ IUNITB
C
C
C     SUBROUTINE 'HEAD0' ...
C        WRITE SHORT DESCRIPTION OF PROGRAM OUTPUT
C
C
C     --- WRITE HEADING FOR OUTPUT
      WRITE(IUNITB,1100)
      WRITE(IUNITB,1110)
      WRITE(IUNITB,1120)
      WRITE(IUNITB,1122)
      WRITE(IUNITB,1124)
      WRITE(IUNITB,1130)
      WRITE(IUNITB,1140)
      WRITE(IUNITB,1150)
      WRITE(IUNITB,1160)
      WRITE(IUNITB,2000)
      WRITE(IUNITB,1170)
      WRITE(IUNITB,2000)
      RETURN
 1100 FORMAT(1H1,////T45,'***  NBS*SEARCH  ***'/)
 1110 FORMAT(1X,T38,'A PROGRAM TO SEARCH NIST CRYSTAL DATA')
 1120 FORMAT(1X,T45,'Version of Spring, 1987'/)
 1122 FORMAT(1X,/T54,'by'//)
 1124 FORMAT(1X,T39,'Vicky L. Himes and Alan D. Mighell'/)
 1130 FORMAT(1X,T44,'NIST Crystal Data Center')
 1140 FORMAT(1X,T42,'National Institute of Standards and Technology')
 1150 FORMAT(1X,T42,'Reactor Radiation Division')
 1160 FORMAT(1X,T44,'Gaithersburg, MD  20899')
 1170 FORMAT(1X,T13,'*** Copyright 1987 by the U.S. Secretary of Commerc
     $e on behalf of the United States ***')
 2000 FORMAT(////)
      END
      SUBROUTINE HEAD2
      COMMON /UNIT2/ IUNITB
C
C
C     SUBROUTINE 'HEAD2' ...
C        WRITE SHORT DESCRIPTION OF PROGRAM OUTPUT
C        RSS CALCULATIONS (REDUCTION AND DERIVATIVE LATTICE)
C
C
C     --- WRITE HEADING FOR OUTPUT
      WRITE(IUNITB,1100)
      WRITE(IUNITB,1110)
      WRITE(IUNITB,1120)
      WRITE(IUNITB,1130)
      WRITE(IUNITB,1140)
      WRITE(IUNITB,1150)
      WRITE(IUNITB,1160)
      WRITE(IUNITB,1170)
      WRITE(IUNITB,1200)
      WRITE(IUNITB,1210)
      WRITE(IUNITB,1220)
      WRITE(IUNITB,1230)
      WRITE(IUNITB,1240)
      WRITE(IUNITB,1250)
      WRITE(IUNITB,1260)
      WRITE(IUNITB,1270)
      WRITE(IUNITB,2000)
      RETURN
 1100 FORMAT(2X,18x,'** REDUCTION AND DERIVATIVE LATTICE **'/)
 1110 FORMAT(2X,'These calculations fall into two categories:'/)
 1120 FORMAT(2X,' I. Reduction of an input cell.'/)
 1130 FORMAT(' CELL 1 = Input cell. This cell may be primitive'
	1 ' or centered (A,B,C,I,F,RR,RH).')
 1140 FORMAT(' CELL 2 = Reduced primitive cell of the lattice.')
 1150 FORMAT(' T 1    = A matrix that transforms CELL 1 to a'
	1 ' primitive cell of the lattice.')
 1160 FORMAT(' T 2    = A matrix that transforms CELL 1 to CELL 2.
     $'//)
 1170 FORMAT(2X,'II. Calculation and reduction of a series of'
	1 ' derivative supercells',/6x,'and/or subcells.',
	2 '  These derivative cells are calculated from the reduced'
	3 /,6x'cell of the lattice  (i.e. to carry out the Type II'
	4 '  calculation,'/6x,'the program first carries out the Type I'
	5 ' calculation).'/)
 1200 FORMAT(2X,'    CELL 1 = Reduced primitive cell (i.e. CELL 2 from P
     $art I).')
 1210 FORMAT(2X,'    CELL 2 = Reduced supercell or subcell.')
 1220 FORMAT(2X,'    T 1    = A matrix that transforms CELL 1 to a'
	1 /,15x'supercell or subcell of the lattice.')
 1230 FORMAT(2X,'    T 2    = A matrix that transforms CELL 1 to CELL 2.
     $'/)
 1240 FORMAT(2X,'For CELL 1 and CELL 2, the output parameters given are'
	1 /,'  a, b, c, alpha, beta, gamma, and volume with cell edges')
 1250 FORMAT('  in angstroms and angles in degrees.'/)
 1260 FORMAT('  The reduced cell matrix is of the form:  a.a  b.b  c.c')
 1270 FORMAT(42X,'b.c  a.c  a.b')
 2000 FORMAT(///)
      END
      SUBROUTINE INVERS(IPRINV)
      COMMON /INVER1/ UI1,VI1,WI1,UI2,VI2,WI2,UI3,VI3,WI3
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
C
C
C     SUBROUTINE 'INVERS' ...
C        CALCULATE THE INVERSE OF A 3 BY 3 MATRIX
C
C
C
C     --- CALCULATE DETERMINANT
      DET = U1*V2*W3 + V1*W2*U3 + W1*U2*V3 - U3*V2*W1 - V3*W2*U1 -
     $      W3*U2*V1
C
C     --- CALCULATE INVERSE
      UI1 =  (V2*W3 - V3*W2)/DET
      VI1 = -(V1*W3 - V3*W1)/DET
      WI1 =  (V1*W2 - V2*W1)/DET
      UI2 = -(U2*W3 - U3*W2)/DET
      VI2 =  (U1*W3 - U3*W1)/DET
      WI2 = -(U1*W2 - U2*W1)/DET
      UI3 =  (U2*V3 - U3*V2)/DET
      VI3 = -(U1*V3 - U3*V1)/DET
      WI3 =  (U1*V2 - U2*V1)/DET
C
C     --- PRINT OUT FOR INVERSE MATRIX
      IF(IPRINV.EQ.1) CALL OUTPT1(12)
      RETURN
      END
      SUBROUTINE LMPRE
      DIMENSION A0(900), B0(900), C0(900), ALPHA0(900), BETA0(900)
      DIMENSION GAMMA0(900), V0(900)
      DIMENSION IA0(900), IB0(900), IC0(900), IALPH0(900), IBETA0(900)
      DIMENSION IGAMM0(900), ISEQ0(900)
C
      COMMON /LMCELL/ AD(900),BD(900),CD(900),ALPHAD(900),BETAD(900),
     $                GAMMAD(900),VD(900),ISEQD(900)
      COMMON /MAX1/ IAMAX(900),IBMAX(900),ICMAX(900),IVMAX(900)
      COMMON /MAX2/ IALMAX(900),IBEMAX(900),IGAMAX(900)
      COMMON /MIN1/ IAMIN(900),IBMIN(900),ICMIN(900),IVMIN(900)
      COMMON /MIN2/ IALMIN(900),IBEMIN(900),IGAMIN(900)
      COMMON /PROB2/ IPCH,NUNK
      COMMON /PROB3/ IE
      COMMON /TOLER1/ TOLE,TOLA,TOLV
      COMMON /UNIT2/ IUNITB
      COMMON /UNIT4/ IUNITD
C**
      COMMON /CK01/ ICK011,ICK012,ICK013,ICK014
C
C
C     SUBROUTINE 'LMPRE' ...
C        PREPARES INPUT CELLS FOR LATTICE MATCHING
C        (READS, SEQUENCES AND SORTS CELLS, ELIMINATES DUPLICATE
C        CELLS, CALCULATES MINIMUM AND MAXIMUM VALUES OF A,B,C,V
C        AND ALPHA,BETA,GAMMA FOR A MATCH)
C
C
C     --- OPENS, READS, CLOSES:
C          IUNITD (=10)  (INPUT FILE OF UNKNOWNS,
C                         ASSOCIATED FILENAME : NBS10)
C
C
C
C     A0,B0,C0,ALPHA0,BETA0,GAMMA0,V0 = CELL PARAMETERS AND VOLUME FOR
C          UNKNOWN ENTRIES AS READ FROM INPUT UNIT IUNITD
C     IA0,IB0,IC0,IALPH0,IBETA0,IGAMM0 = ROUNDED OFF CELL PARAMETERS
C          FOR UNKNOWN ENTRIES (ARRAYS ARE SORTED AFTER ROUNDING
C          OFF AND ADDING SEQUENCE NUMBERS)
C     NUNK = NUMBER OF UNKNOWN ENTRIES READ
C     TOLE = TOLERANCES FOR CELL EDGES A, B, C (ANGSTROMS)
C     TOLA = TOLERANCES FOR CELL ANGLES ALPHA, BETA, GAMMA (DEGREES)
C     TOLV = TOLERANCE FOR VOLUME (PERCENTAGE OF ANGSTROMS**3)
C     ISEQ0,ISEQD = SEQUENCE NUMBER OF UNKNOWN ENTRY IN INPUT FILE (IUNITD)
C     IDELET = NUMBER OF DUPLICATE ENTRIES ELIMINATED
C     IE = NUMBER OF ENTRIES TO BE CHECKED AGAINST THE 1-LINE DATABASE
C          (DUPLICATES HAVE BEEN ELIMINATED)
C     AD,BD,CD,ALPHAD,BETAD,GAMMAD,VD = CELL PARAMETERS AND VOLUMES FOR
C           UNKNOWN ENTRIES (DUPLICATES HAVE BEEN ELIMINATED)
C     IAMIN,IBMIN,ICMIN,IVMIN = MINIMUM VALUE OF A,B,C,V FOR A MATCH
C     IALMIN,IBEMIN,IGAMIN    = MINIMUM VALUE OF ALPHA,BETA,GAMMA
C                               FOR A MATCH
C     IAMAX,IBMAX,ICMAX,IVMAX = MAXIMUM VALUE OF A,B,C,V FOR A MATCH
C     IALMAX,IBEMAX,IGAMAX    = MAXIMUM VALUE OF ALPHA,BETA,GAMMA
C                               FOR A MATCH
C
C
C
C     --- INITIALIZE VARIABLES
      IE = 1
      K0 = 0
      IDELET = 0
      IRSET1 = 0
      IRSET2 = 0
      IRSET3 = 0
C
C     --- IF NECESSARY, RESET NUMBER OF UNKNOWNS, TOLERANCES TO
C         MORE REASONABLE VALUES (ERROR/WARNING MESSAGES ARE
C         WRITTEN WITH SUMMARY DATA)
      IF(NUNK.LT.1.OR.NUNK.GT.900) IRSET1 = 1
      IF(NUNK.GT.900) NUNK = 900
C
      IF(.NOT.(TOLE.LT.0.02.OR.TOLA.LT.1.0.OR.TOLV.LT.5.0)) GO TO 20
         IRSET2 = 1
         IF(TOLE.LT.0.02) TOLE = 0.02
         IF(TOLA.LT.1.0)  TOLA = 1.0
         IF(TOLV.LT.5.0)  TOLV = 5.0
   20 CONTINUE
C
      IF(.NOT.(TOLE.GT.5.0.OR.TOLA.GT.60.1.OR.TOLV.GT.100.0)) GO TO 40
         IRSET3 = 1
         IF(TOLE.GT.5.0)    TOLE = 5.0
         IF(TOLA.GT.60.1)   TOLA = 60.1
         IF(TOLV.GT.100.0)  TOLV = 100.0
   40 CONTINUE
C
C     --- READ INPUT UNKNOWNS, ROUND OFF NUMBERS AND ADD SEQUENCE NUMBERS
C         (READS IUNITD)
      OPEN(UNIT=IUNITD,FILE='NBS10',STATUS='OLD')
C
C**   FOR CDC COMPUTER ONLY
C     REWIND IUNITD
      DO 100 I = 1,NUNK
         READ(IUNITD,1100) A0(I), B0(I), C0(I), ALPHA0(I), BETA0(I),
     $                GAMMA0(I), V0(I)
         IA0(I)    = NINT(A0(I)*1000)
         IB0(I)    = NINT(B0(I)*1000)
         IC0(I)    = NINT(C0(I)*1000)
         IALPH0(I) = NINT(ALPHA0(I)*100)
         IBETA0(I) = NINT(BETA0(I)*100)
         IGAMM0(I) = NINT(GAMMA0(I)*100)
         ISEQ0(I)  = I
  100 CONTINUE
C**
      IF(ICK014.NE.1) GO TO 160
C
C        --- FOR CHECKING, WRITE INPUT UNKNOWNS,
C            FOLLOWED BY WRITE OF INPUT UNKNOWNS AFTER ROUNDING
C            OFF AND SEQUENCE NUMBERS ADDED (BEFORE SORTING)
         WRITE(IUNITB,910)
         DO 120 I = 1,NUNK
            WRITE(IUNITB,920) A0(I), B0(I), C0(I), ALPHA0(I), BETA0(I),
     $                        GAMMA0(I), V0(I)
  120    CONTINUE
         WRITE(IUNITB,910)
         DO 140 I = 1,NUNK
            WRITE(IUNITB,940) IA0(I), IB0(I), IC0(I), IALPH0(I),
     $                        IBETA0(I), IGAMM0(I), ISEQ0(I)
  140    CONTINUE
  160 CONTINUE
C
C     --- SORT ROUNDED OFF CELLS ON A,B,C,ALPHA,BETA,GAMMA,SEQUENCE NUMBER
      CALL SORT1(IA0,IB0,IC0,IALPH0,IBETA0,IGAMM0,ISEQ0,NUNK)
C**
      IF(ICK014.NE.1) GO TO 200
C
C        --- FOR CHECKING, WRITE INPUT UNKNOWNS AFTER ROUNDING
C            OFF, ADDING SEQUENCE NUMBERS, SORTING
         WRITE(IUNITB,910)
         DO 180 I = 1,NUNK
            WRITE(IUNITB,940) IA0(I), IB0(I), IC0(I), IALPH0(I),
     $                        IBETA0(I), IGAMM0(I), ISEQ0(I)
  180    CONTINUE
  200 CONTINUE
C
C     --- WRITE FIRST ENTRY AND ASSIGN VALUES TO ARRAY TO BE
C         CHECKED AGAINST THE 1-LINE DATABASE (FIRST ENTRY IS
C         NEVER CONSIDERED A DUPLICATE ENTRY)
      K0 = ISEQ0(1)
      WRITE(IUNITB,1300)
      WRITE(IUNITB,1400)
      WRITE(IUNITB,1500) IE, ISEQ0(1), A0(K0), B0(K0), C0(K0),
     $                   ALPHA0(K0), BETA0(K0), GAMMA0(K0), V0(K0)
      AD(IE)     = A0(K0)
      BD(IE)     = B0(K0)
      CD(IE)     = C0(K0)
      ALPHAD(IE) = ALPHA0(K0)
      BETAD(IE)  = BETA0(K0)
      GAMMAD(IE) = GAMMA0(K0)
      VD(IE)     = V0(K0)
      ISEQD(IE)  = ISEQ0(1)
C
C     --- BUILD INPUT ARRAY OF CELLS WHICH IS TO BE CHECKED AGAINST
C         THE 1-LINE DATABASE FOR A MATCH
      DO 500 I = 2,NUNK
C
C        --- CHECK WHETHER A,B,C,ALPHA,BETA,GAMMA (ROUNDED OFF) ARE EQUAL
C            FOR TWO ADJACENT ENTRIES IN SORTED ARRAY OF UNKNOWNS
         IF(IC0(I).NE.IC0(I-1)) GO TO 300
         IF(IB0(I).NE.IB0(I-1).OR.IA0(I).NE.IA0(I-1)) GO TO 300
         IF(IALPH0(I).NE.IALPH0(I-1).OR.IBETA0(I).NE.IBETA0(I-1).OR.
     $      IGAMM0(I).NE.IGAMM0(I-1)) GO TO 300
C
C           --- HAVE A DUPLICATE ENTRY ... DO NOT INCLUDE IN ARRAY
C               TO BE CHECKED AGAINST THE 1-LINE DATABASE
            K0 = ISEQ0(I)
            WRITE(IUNITB,1600) ISEQ0(I), A0(K0), B0(K0), C0(K0),
     $                         ALPHA0(K0), BETA0(K0), GAMMA0(K0), V0(K0)
            IDELET = IDELET + 1
            GO TO 400
  300    CONTINUE
C
C        --- NOT A DUPLICATE ENTRY, ASSIGN VALUES TO ARRAYS TO BE
C            CHECKED AGAINST THE 1-LINE DATABASE
         IE = IE + 1
         K0 = ISEQ0(I)
         WRITE(IUNITB,1500) IE, ISEQ0(I), A0(K0), B0(K0), C0(K0),
     $                      ALPHA0(K0), BETA0(K0), GAMMA0(K0), V0(K0)
         AD(IE)     = A0(K0)
         BD(IE)     = B0(K0)
         CD(IE)     = C0(K0)
         ALPHAD(IE) = ALPHA0(K0)
         BETAD(IE)  = BETA0(K0)
         GAMMAD(IE) = GAMMA0(K0)
         VD(IE)     = V0(K0)
         ISEQD(IE)  = ISEQ0(I)
  400 CONTINUE
  500 CONTINUE
C
C     --- WRITE SUMMARY DATA FOR PREPARATION OF INPUT FILE OF UNKNOWNS
C         (AND, IF INDICATED, ANY ERROR/WARNING MESSAGES FOR THE
C         INPUT TOLERANCES, NUMBER OF CELLS TO BE CHECKED
C         AGAINST THE 1-LINE DATABASE)
      WRITE(IUNITB,1700)
      IF(IRSET1.EQ.1) WRITE(IUNITB,1720)
      IF(IRSET2.EQ.1) WRITE(IUNITB,1740)
      IF(IRSET3.EQ.1) WRITE(IUNITB,1760)
      WRITE(IUNITB,1800) NUNK, IDELET, IE, TOLE, TOLA, TOLV
C**
      IF(ICK014.NE.1) GO TO 540
C
C        --- FOR CHECKING, WRITE UNKNOWNS TO BE CHECKED AGAINST
C            THE 1-LINE DATABASE FOR A MATCH (AFTER DUPLICATES
C            HAVE BEEN ELIMINATED)
         WRITE(IUNITB,910)
         DO 520 I = 1,IE
            WRITE(IUNITB,920) AD(I), BD(I), CD(I), ALPHAD(I), BETAD(I),
     $                        GAMMAD(I), VD(I), ISEQD(I)
  520    CONTINUE
  540 CONTINUE
C
C     --- CALCULATE MINIMUM AND MAXIMUM VALUES FOR A,B,C,V
C         AND ALPHA, BETA, GAMMA
      DO 600 I = 1,IE
         TOLV1 = 0.01*TOLV*VD(I)
         IAMIN(I) = NINT((AD(I) - TOLE)*100)
         IBMIN(I) = NINT((BD(I) - TOLE)*100)
         ICMIN(I) = NINT((CD(I) - TOLE)*100)
         IALMIN(I) = NINT((ALPHAD(I) - TOLA)*10)
         IBEMIN(I) = NINT((BETAD(I)  - TOLA)*10)
         IGAMIN(I) = NINT((GAMMAD(I) - TOLA)*10)
         IVMIN(I) = NINT(VD(I) - TOLV1)
         IAMAX(I) = NINT((AD(I) + TOLE)*100)
         IBMAX(I) = NINT((BD(I) + TOLE)*100)
         ICMAX(I) = NINT((CD(I) + TOLE)*100)
         IALMAX(I) = NINT((ALPHAD(I) + TOLA)*10)
         IBEMAX(I) = NINT((BETAD(I)  + TOLA)*10)
         IGAMAX(I) = NINT((GAMMAD(I) + TOLA)*10)
         IVMAX(I) = NINT(VD(I) + TOLV1)
  600 CONTINUE
C
C     --- DELETE FILE
      CLOSE(UNIT=IUNITD,STATUS='DELETE')
  800 CONTINUE
      RETURN
  910 FORMAT(1H1)
  920 FORMAT(1X,6F10.5,F10.2,I10)
  940 FORMAT(1X,7I10)
 1100 FORMAT(6F10.5,F10.2,I10)
 1300 FORMAT(///,25X,'** LATTICE MATCHING **'//1X,11X,'Identification of
     $ unknown lattices using data from'/1X,11X,'the National Institute of
     $ Standards and Technology'
     $ /1x,11x,'using the CRYSTAL DATA file.'
     $ //1X,19X,'Vicky L. Himes and Alan D.
     $ Mighell'/////)
 1400 FORMAT(1X,27X,'***  UNKNOWNS  ***'/
     $1X,80(1H-)//,'  Search',T11,' Original',T24,'a',T33,'b'
     $,T42,'c',T49,'Alpha',T59,'Beta',T67,'Gamma',T77,'Vol'/' Sequence',
     $T11,' Sequence'/1X,80(1H-)/)
 1500 FORMAT(/1X,I5,I10,1X,3F9.3,3F9.2,F9.1)
 1600 FORMAT(/1X,' Delete ',2X,I5,1X,3F9.3,3F9.2,F9.1)
 1700 FORMAT(/1X,80(1H-)/)
 1720 FORMAT(1H1,'*LMPRE* ERROR ... Check number of unknowns generated (
     $input to unit 10).'//)
 1740 FORMAT(////1X,'*LMPRE* WARNING ... Input tolerances have been rese
     $t to minimum allowable values.  It is still'/1X,20X,
     $'likely that the reset tolerances are unacceptable since the known
     $ data in'/1X,20X,
     $'the Database may not be as accurate and/or as precise as the expe
     $rimental'/1X,20X,
     $'data input to the program.  Consult the manual for recommended va
     $lues.'//)
 1760 FORMAT(////1X,'*LMPRE* WARNING ... Input tolerances have been rese
     $t to maximum allowable values.'//)
 1800 FORMAT(////1X,'Original number of  unknowns  =',T35,I5/1X,
     $'Number of duplicate unknowns  =',T35,I5/1X,
     $'Number of unknowns for search =',T35,I5//1X,
     $'Tolerance for cell edges  =',1X,F10.2/1X,
     $'Tolerance for cell angles =',1X,F10.2/1X,
     $'Tolerance for cell volume =',1X,F10.2)
      END
      SUBROUTINE LMSETO
      INTEGER POINT,IPOINT
      COMMON /DATA1/ IDATA1,IDATA2,IDATA3
      COMMON /POINT1/ POINT(100),IPOINT(100)
      COMMON /SRCH1/ ISTART(900),NOGR(900)
C
C
C     SUBROUTINE 'LMSETO' ...
C        RESETS VARIABLES, POINTERS FOR ORGANIC SEARCH OF
C        1-LINE DATABASE
C
C
      IDATA1 = 58
C
C
C	I DELETED THE ORIGINAL POINTER INFORMATION FROM THIS SECTION
C	AND ADDED MY OWN CODE TO READ IN THE POINTERS.
C
	OPEN(UNIT=1,NAME='CD:POINTO.DAT',STATUS='OLD',ERR=9761,
	1 FORM='UNFORMATTED',ACCESS='SEQUENTIAL',READONLY,SHARED)
	READ (1) IPOINT,POINT
	CLOSE (UNIT=1)
C
      DO 100 I = 1,900
         NOGR(I) = 0
         ISTART(I) = 0
  100 CONTINUE
C
      RETURN
9761  STOP 'OPEN ERROR ON CD:POINTO.DAT'
      END
      SUBROUTINE LMSRCH(IMATCH)
      INTEGER POINT,IPOINT
	INTEGER*2 IAA(6),IAR(6),IAC(6),IVOLR
	INTEGER*4 TABLE(2000)
	BYTE RESLTS(128)
      DIMENSION KRECF(2000), KUNKNO(2000), KSEQNO(2000)
C
      COMMON /DATA1/ IDATA1,IDATA2,IDATA3
      COMMON /LMCELL/ AD(900),BD(900),CD(900),ALPHAD(900),BETAD(900),
     $                GAMMAD(900),VD(900),ISEQD(900)
      COMMON /MAX1/ IAMAX(900),IBMAX(900),ICMAX(900),IVMAX(900)
      COMMON /MAX2/ IALMAX(900),IBEMAX(900),IGAMAX(900)
      COMMON /MIN1/ IAMIN(900),IBMIN(900),ICMIN(900),IVMIN(900)
      COMMON /MIN2/ IALMIN(900),IBEMIN(900),IGAMIN(900)
      COMMON /POINT1/ POINT(100),IPOINT(100)
      COMMON /PROB3/ IE
      COMMON /SRCH1/ ISTART(900),NOGR(900)
      COMMON /UNIT2/ IUNITB
      COMMON /UNIT3/ IUNITC
	COMMON /UNIT5/ IDIRECT,ICODEN,ITABLE,ISRCH
C**
      COMMON /CK01/ ICK011,ICK012,ICK013,ICK014
C
C
C     SUBROUTINE 'LMSRCH' ...
C        SEARCHES FOR MATCHES IN SELECTED
C        REGIONS OF 1-LINE DIRECT ACCESS DATABASE;
C        WHEN APPROPRIATE, ENTRIES ARE TREATED AS SUB-GROUPS
C
C
C     --- READS:
C          IUNITC (=7) (1-LINE BINARY DATABASE)
C
C
C
C     ISEQD = SEQUENCE NUMBER OF UNKNOWN ENTRY IN INPUT FILE (IUNITD)
C     IE = NUMBER OF ENTRIES TO BE CHECKED AGAINST THE 1-LINE
C          DATABASE FOR A MATCH
C          (AFTER SEQUENCED, SORTED, DUPLICATE CELLS ELIMINATED)
C     AD,BD,CD,ALPHAD,BETAD,GAMMAD,VD = CELL PARAMETERS AND VOLUMES FOR
C           UNKNOWN ENTRIES (AFTER DUPLICATES HAVE BEEN ELIMINATED)
C     A1L,B1L,C1L,IV1L = CELL EDGES AND VOLUME READ FROM 1-LINE DATABASE
C     AL1L,BE1L,GA1L   = CELL ANGLES READ FROM 1-LINE DATABASE
C     IAMIN,IBMIN,ICMIN,IVMIN = MINIMUM VALUE OF A,B,C,V FOR A MATCH
C     IALMIN,IBEMIN,IGAMIN    = MINIMUM VALUE OF ALPHA,BETA,GAMMA
C                               FOR A MATCH
C     IAMAX,IBMAX,ICMAX,IVMAX = MAXIMUM VALUE OF A,B,C,V FOR A MATCH
C     IALMAX,IBEMAX,IGAMAX    = MAXIMUM VALUE OF ALPHA,BETA,GAMMA
C                               FOR A MATCH
C     POINT(I) = VALUE OF A AT RECORD NUMBER IPOINT(I)
C     IPOINT(I) = SEQUENCE NUMBER IN 1-LINE DATABASE
C     IRECNO = FOR EACH GROUP OF UNKNOWN ENTRIES, RECORD NUMBER TO START
C              SEARCHING FOR A MATCH
C     IMATCH = TOTAL NUMBER OF MATCHES FOUND FOR ENTIRE RUN
C     ISTART = FOR EACH UNKNOWN ENTRY, ENTRY NUMBER IN 1-LINE DATABASE
C              TO START SEARCHING FOR A MATCH
C     ISKIP = FOR EACH GROUP OF ENTRIES, NUMBER OF TIMES GROUPS OF X ENTRIES
C             ARE ELIMINATED FROM FINAL SCAN  (X=IDATA2)
C     IDSCAN = FOR EACH GROUP OF ENTRIES, NUMBER OF ENTRIES CHECKED WHEN
C              LOOKING FOR A MATCH IN THE 1-LINE DATABASE
C     IG = INPUT ENTRIES ARE DIVIDED INTO IG NUMBER OF GROUPS
C     NOGR = FOR EACH GROUP, NUMBER OF ENTRIES IN THE GROUP
C     INDEX1 = STARTING UNKNOWN NUMBER TO DEFINE A GROUP
C     INDEX2 = ENDING UNKNOWN NUMBER TO DEFINE A GROUP
C
C
C     --- INITIALIZE VARIABLES
      IMATCH = 0
	DO 10 I=1,2000
10	TABLE(I)=0
	IF (ISRCH.EQ.1) ISIZE=59613
	IF (ISRCH.EQ.2) ISIZE=56140
	NSIZE=ISIZE/32
	LAST=MOD(ISIZE,32)
	IF (LAST.NE.0) NSIZE=NSIZE+1
C
C     --- IF INPUT DATA IS NOT WITHIN RANGE OF A VALUES IN THE DATABASE,
C         NO MATCHES ARE POSSIBLE ... DO NOT READ FILE
      IF(IAMIN(1).GT.POINT(IDATA1).OR.IAMAX(IE).LT.POINT(1))
     $   WRITE(IUNITB,1000)
      IF(IAMIN(1).GT.POINT(IDATA1).OR.IAMAX(IE).LT.POINT(1)) GO TO 700
C
C     --- CALCULATE APPROXIMATE STARTING VALUES FOR EACH UNKNOWN
      DO 100 J = 1,IE
         K1 = 0
         DO 40 I = 1,IDATA1
            IF(IAMIN(J).LT.POINT(I)) K1 = I
            IF(IAMIN(J).LT.POINT(I)) GO TO 80
   40    CONTINUE
   80    CONTINUE
         IF(K1.EQ.1) ISTART(J) = 1
         IF(IAMIN(J).GE.POINT(IDATA1)) ISTART(J) = IPOINT(IDATA1-1)
         IF(K1.GT.1) ISTART(J) = IPOINT(K1-1)
  100 CONTINUE
C**
C     --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
      IF(ICK012.EQ.1) WRITE(IUNITB,740)
      IF(ICK012.EQ.1) WRITE(IUNITB,741) (I,IAMIN(I),IAMAX(I),ISTART(I),
     $   IVMIN(I),IVMAX(I),I=1,IE)
C
C     --- DEFINE GROUPS OF UNKNOWNS AND COUNT NUMBER OF GROUPS FORMED
      IG = 1
      NOGR(1) = 1
      DO 200 J = 1,IE-1
         IF(IAMAX(J).LT.IAMIN(J+1)) GO TO 180
            NOGR(IG) = NOGR(IG) + 1
            GO TO 200
  180    CONTINUE
         IG = IG + 1
         NOGR(IG) = 1
  200 CONTINUE
C**
C     --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
      IF(ICK011.EQ.1) WRITE(IUNITB,745) IG
      IF(ICK011.EQ.1) WRITE(IUNITB,746) (I,NOGR(I),I=1,IG)
C
C     --- START PROCEDURE TO FIND MATCHES WITH DATABASE ... EACH GROUP
C         OF UNKNOWN ENTRIES IS TREATED SEPARATELY
      INDEX2 = 0
      DO 500 J = 1,IG
         ISKIP  = 0
         IDSCAN = 0
         IX = INDEX2
         INDEX1 = IX + 1
         INDEX2 = IX + NOGR(J)
         IRECNO = ISTART(INDEX1)
C**
C        --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
         IF(ICK011.EQ.1) WRITE(IUNITB,755) J, INDEX1, INDEX2
C
C        --- PRE-SCAN OF 1-LINE DATABASE TO FIND STARTING RECORD NUMBER
C            CLOSE TO MINIMUM VALUE OF A FOR EACH GROUP ... READS EVERY
C            X-TH VALUE OF A IN 1-LINE DATABASE (X=IDATA2)
         DO 300 I = 1,IDATA3
            READ(IUNITC,REC=IRECNO) IAA,IAR,IAC,IVOLR
C**
            IA1L = IAR(1)
C           --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
            IF(ICK013.EQ.1) WRITE(IUNITB,760) I, ISKIP, IRECNO, IA1L
            IF(IAMIN(INDEX1).LE.IA1L) GO TO 340
               IRECNO = IRECNO + IDATA2
               IF(IRECNO.GE.IPOINT(IDATA1)) IRECNO = IPOINT(IDATA1)
               IF(IRECNO.GE.IPOINT(IDATA1)) GO TO 340
                  ISKIP = ISKIP + 1
  300    CONTINUE
  340    CONTINUE
         IRECNO = IRECNO - IDATA2
         IF(IRECNO.LT.1) IRECNO = 1
C**
C        --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
         IF(ICK012.EQ.1) WRITE(IUNITB,765) ISKIP, IRECNO
C
C        --- SEARCH SELECTED REGION OF 1-LINE DATABASE FOR A MATCH
C            WITHIN SPECIFIED TOLERANCES
  380    CONTINUE
         READ(IUNITC,REC=IRECNO) IAA,IAR,IAC,IVOLR
         IA1L = IAR(1)
         IB1L = IAR(2)
         IC1L = IAR(3)
         IAL1L = NINT(0.10*FLOAT(IAR(4)))
         IBE1L = NINT(0.10*FLOAT(IAR(5)))
         IGA1L = NINT(0.10*FLOAT(IAR(6)))
	IV1L=IVOLR
C
C        --- CHECK THAT VALUE OF A FROM 1-LINE DATABASE IS LESS THAN
C            MAXIMUM VALUE OF A IN GROUP ... IF NOT, STOP SEARCHING FOR
C            A MATCH
         IF(IA1L.GT.IAMAX(INDEX2)) GO TO 440
            IDSCAN = IDSCAN + 1
C
C           --- CHECK FOR A MATCH FOR EACH UNKNOWN ENTRY IN GROUP
            DO 400 K = INDEX1,INDEX2
               IF(IC1L.LT.ICMIN(K).OR.IC1L.GT.ICMAX(K).OR.
     $            IB1L.LT.IBMIN(K).OR.IB1L.GT.IBMAX(K).OR.
     $            IV1L.LT.IVMIN(K).OR.IV1L.GT.IVMAX(K).OR.
     $            IAL1L.LT.IALMIN(K).OR.IAL1L.GT.IALMAX(K).OR.
     $            IBE1L.LT.IBEMIN(K).OR.IBE1L.GT.IBEMAX(K).OR.
     $            IGA1L.LT.IGAMIN(K).OR.IGA1L.GT.IGAMAX(K).OR.
     $            IA1L.LT.IAMIN(K).OR.IA1L.GT.IAMAX(K)) GO TO 400
C
C                 --- HAVE A MATCH, ASSIGN ARRAYS SPECIFYING
C                     RECORD NUMBER (OF MATCH) IN THE 1-LINE
C                     DATABASE, UNKNOWN NUMBER (SEARCH SEQUENCE),
C                     AND ORIGINAL SEQUENCE NUMBER OF UNKNOWN
                  IMATCH = IMATCH + 1
                  IF(IMATCH.GT.2000) GO TO 510
                     KRECF(IMATCH)  = IRECNO
                     KUNKNO(IMATCH) = K
                     KSEQNO(IMATCH) = ISEQD(K)
  400       CONTINUE
            IRECNO = IRECNO + 1
            IF(IRECNO.GT.IPOINT(IDATA1)) GO TO 440
               GO TO 380
  440    CONTINUE
C**
C        --- FOR CHECKING, WRITE INTERMEDIATE VARIABLES
         IF(ICK011.EQ.1) WRITE(IUNITB,770) IDSCAN, IMATCH
  500 CONTINUE
  510 CONTINUE
C
C     --- CHECK NUMBER OF MATCHES FOUND
      IF(IMATCH.GT.0.AND.IMATCH.LE.2000) GO TO 530
         IF(IMATCH.LE.2000) GO TO 520
C
C           --- TOO MANY MATCHES GENERATED,
C               WRITE ERROR MESSAGE AND STOP PROGRAM EXECUTION
            WRITE(IUNITB,1200)
            STOP
  520    CONTINUE
C
C        --- NO MATCHES FOUND, WRITE MESSAGE AND CONTINUE
	WRITE (6,888) IMATCH
         WRITE(IUNITB,1300)
         GO TO 700
  530 CONTINUE
C**
      IF(ICK014.NE.1) GO TO 550
C
C        --- FOR CHECKING, WRITE ARRAYS WITH INDICES TO
C            MATCHES AND UNKNOWNS (BEFORE SORTING)
         WRITE(IUNITB,720)
         DO 540 I = 1,IMATCH
            WRITE(IUNITB,780) KRECF(I), KUNKNO(I), KSEQNO(I)
  540    CONTINUE
  550 CONTINUE
C
C     --- SORT ARRAYS WITH INDICES TO MATCHES AND UNKNOWNS
C         (FIRST SORT ON ORIGINAL SEQUENCE NUMBER, SECOND SORT
C         ON RECORD NUMBER OF MATCH FROM 1-LINE DATABASE, THIRD
C         SORT ON SEARCH SEQUENCE (UNKNOWN NUMBER FOR SEARCH))
C
C     --- THIRD SORT IS NOT REQUIRED
      CALL SORT2(KSEQNO,KRECF,KUNKNO,IMATCH)
C**
      IF(ICK014.NE.1) GO TO 570
C
C        --- FOR CHECKING, WRITE ARRAYS WITH INDICES TO MATCHES
C            AND UNKNOWNS (AFTER SORTING)
         WRITE(IUNITB,720)
         DO 560 I = 1,IMATCH
             WRITE(IUNITB,780) KRECF(I), KUNKNO(I), KSEQNO(I)
  560    CONTINUE
  570 CONTINUE
C
C     --- WRITE RESULTS AND SUMMARY DATA
      WRITE(IUNITB,1400)
      ISET1 = 0
      ISET2 = 1
      DO 600 I = 1,IMATCH
         IRECF  = KRECF(I)
         IUNKNO = KUNKNO(I)
         ISEQNO = KSEQNO(I)
C
         READ(IUNITC,REC=IRECF) RESLTS
         IF(ISEQNO.GT.ISET2) ISET1 = 0
         IF(ISET1.EQ.0) WRITE(IUNITB,1600) IUNKNO, ISEQD(IUNKNO),
     $      AD(IUNKNO), BD(IUNKNO), CD(IUNKNO), ALPHAD(IUNKNO),
     $      BETAD(IUNKNO), GAMMAD(IUNKNO), VD(IUNKNO)
C         WRITE(IUNITB,1700) RESLTS
C
C	I HAVE CREATED A SUBROUTINE TO WRITE OUT RESULTS IN A 80-COLUMN FORMAT
C
	CALL OUT80(RESLTS)
	IRECF=IRECF-1
	IWORD=1+IRECF/32
	IBITE=MOD(IRECF,32)
	TABLE(IWORD)=IBSET(TABLE(IWORD),IBITE)
C
         ISET1 = 1
         ISET2 = ISEQNO
  600 CONTINUE
	WRITE (ITABLE) ISIZE,NSIZE,(TABLE(N),N=1,NSIZE)
	WRITE (6,888) IMATCH
888	FORMAT (5X,' NUMBER OF MATCHES = 'I5)
      WRITE(IUNITB,1800)
  700 CONTINUE
      RETURN
  720 FORMAT(1H1)
  740 FORMAT(/1X,'UNK NUMBER',10X,'IAMIN',10X,'IAMAX',9X,'ISTART' ,11X,
     $'IVMIN',10X,'IVMAX'/)
  741 FORMAT(1X,I10,5X,I10,5X,I10,5X,I10,5X,I10,5X,I10)
  745 FORMAT(/1X,'745   NUMBER OF GROUPS = ',I10//1X,'GROUP NUMBER',5X,'
     $NUMBER IN GROUP')
  746 FORMAT(1X,I10,9X,I10)
  755 FORMAT(/1X,'755   Group number = ',I10,10X,'INDEX1 = ',I10,10X,'IN
     $DEX2 = ',I10)
  760 FORMAT(/1X,'760   I = ',I10,10X,'ISKIP = ',I10,10X,'IRECNO = ',I10
     $,10X,'IA1L = ',I8)
  765 FORMAT(/1X,'765   ISKIP = ',I10,10X,'IRECNO = ',I10)
  770 FORMAT(/1X,'Number of entries searched = ',I7,10X,'Number of match
     $es = ',I7)
  780 FORMAT(1X,3I10)
 1000 FORMAT(////1X,'** Input Data Not Within Range of Database ... No M
     $atches Possible **')
 1200 FORMAT(/////1X,'*LMSRCH* ERROR ... More than 2000 matches have bee
     $n found.'/1X,19X,'Input parameters and/or program limits must be c
     $hanged.')
 1300 FORMAT(//1X,'** NONE of Unknown Entries Matched Those in the Dat
     $abase **')
 1400 FORMAT(32X,'***  RESULTS  ***'/1X,
     $80(1H-)//,'  Search',T11,' Original',T24,'a',T33,'b'
     $,T42,'c',T49,'Alpha',T59,'Beta',T67,'Gamma',T77,'Vol'/' Sequence',
     $T11,' Sequence'/1X,80(1H-)/)
C 1500 FORMAT(A132)
 1600 FORMAT(/1X,I5,I10,1X,3F9.3,3F9.2,F9.1)
C 1700 FORMAT(1X,A132)
 1800 FORMAT(/1X,80(1H-)/)
      END
      SUBROUTINE MNCOND
      COMMON /DOTP/ S11,S22,S33,S23,S13,S12
      COMMON /MATR2/ U(9),T(9)
      COMMON /TYPE/ ITYPE
      COMMON /UNIT2/ IUNITB
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
      DATA PC1/0.00006/
C
C
C     SUBROUTINE 'MNCOND' ...
C        SATISFY MAIN CONDITIONS FOR REDUCTION
C        (THE THREE SHORTEST LATTICE TRANSLATIONS)
C
C
C
C     --- INITIALIZE VARIABLES
      ICT1 = 0
      ICT2 = 0
      ICT3 = 0
C
C
C      --- START CALCULATIONS TO SATISFY MAIN CONDITIONS
   50 CONTINUE
C**
C     --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE VARIABLES
      IF(ICK021.EQ.1) CALL CKPT02(1)
C
      A23 = ABS(S23)
      A13 = ABS(S13)
      A12 = ABS(S12)
C
C     --- PROTECTIVE CODE ... THIS CODE SHOULD BE ACTIVE ONLY WHEN
C         THE PROGRAM CONSTANT (PC1) IS INCORRECTLY SET FOR THE
C         SPECIFIC COMPUTER
      ICT1 = ICT1 + 1
      IF(ICT1.GT.21) WRITE(IUNITB,1000)
      IF(ICT1.GT.21) GO TO 300
C
C     --- CONTINUE WHEN HAVE THE SHORTEST VECTORS IN THE BC PLANE;
C         OTHERWISE, CALCULATE
      IF(.NOT.((2.0*A23-S22-PC1).GT.0.0.OR.(2.0*A23-S33-PC1).GT.0.0))
     $   GO TO 100
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT
         IF(ICK022.EQ.1) CALL CKPT02(2)
C
C        --- CALCULATE SHORTEST VECTORS IN BC PLANE,
C            UPDATE THE TOTAL TRANSFORMATION MATRIX AND APPLY
C            THE RESULTING MATRIX TO THE INPUT CELL
         CALL SHORTV(S22,S23,U(1),U(5),U(9),U(8))
         CALL MULTIP
         CALL TRANS(0)
         CALL SHORTV(S33,S23,U(1),U(5),U(9),U(6))
         CALL MULTIP
         CALL TRANS(0)
         GO TO 50
  100 CONTINUE
C
C     --- CONTINUE WHEN HAVE THE SHORTEST VECTORS IN THE AC PLANE;
C         OTHERWISE, CALCULATE
      IF(.NOT.((2.0*A13-S11-PC1).GT.0.0.OR.(2.0*A13-S33-PC1).GT.0.0))
     $   GO TO 200
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT
         IF(ICK022.EQ.1) CALL CKPT02(3)
C
C        --- CALCULATE SHORTEST VECTORS IN AC PLANE,
C            UPDATE THE TOTAL TRANSFORMATION MATRIX AND APPLY
C            THE RESULTING MATRIX TO THE INPUT CELL
         CALL SHORTV(S11,S13,U(1),U(5),U(9),U(7))
         CALL MULTIP
         CALL TRANS(0)
         CALL SHORTV(S33,S13,U(1),U(5),U(9),U(3))
         CALL MULTIP
         CALL TRANS(0)
         GO TO 50
  200 CONTINUE
C
C     --- CONTINUE WHEN HAVE THE SHORTEST VECTORS IN THE AB PLANE;
C         OTHERWISE, CALCULATE
      IF(.NOT.((2.0*A12-S11-PC1).GT.0.0.OR.(2.0*A12-S22-PC1).GT.0.0))
     $   GO TO 300
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT
         IF(ICK022.EQ.1) CALL CKPT02(4)
C
C        --- CALCULATE SHORTEST VECTORS IN AB PLANE,
C            UPDATE THE TOTAL TRANSFORMATION MATRIX AND APPLY
C            THE RESULTING MATRIX TO THE INPUT CELL
         CALL SHORTV(S11,S12,U(1),U(5),U(9),U(4))
         CALL MULTIP
         CALL TRANS(0)
         CALL SHORTV(S22,S12,U(1),U(5),U(9),U(2))
         CALL MULTIP
         CALL TRANS(0)
         GO TO 50
  300 CONTINUE
C
  400 CONTINUE
C
C     --- ARRANGE SO A IS <= TO B AND B IS <= TO C
C
C     --- PROTECTIVE CODE ... THIS CODE SHOULD BE ACTIVE ONLY WHEN
C         THE PROGRAM CONSTANT (PC1) IS INCORRECTLY SET FOR THE
C         SPECIFIC COMPUTER
      ICT2 = ICT2 + 1
      IF(ICT2.GT.11) WRITE(IUNITB,1100)
      IF(ICT2.GT.11) GO TO 500
C
C     --- CHECK THAT A IS <= TO B
      IF(S11.LE.(S22+PC1)) GO TO 420
C
C        --- INTERCHANGE VECTORS A AND B
         CALL SET
         U(2) =  1.0
         U(4) =  1.0
         U(9) = -1.0
         CALL MULTIP
         CALL TRANS(0)
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE
C            VARIABLES
         IF(ICK023.EQ.1) CALL CKPT02(5)
C
  420 CONTINUE
C
C     --- CHECK THAT B IS <= TO C
      IF(S22.LE.(S33+PC1)) GO TO 440
C
C        --- INTERCHANGE VECTORS B AND C
         CALL SET
         U(1) =  1.0
         U(6) =  1.0
         U(8) = -1.0
         CALL MULTIP
         CALL TRANS(0)
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE
C            VARIABLES
         IF(ICK023.EQ.1) CALL CKPT02(6)
  440 CONTINUE
C
C     --- CHECK THAT A IS <= TO B AND B IS <= TO C
      IF(.NOT.(S11.LE.(S22+PC1).AND.S22.LE.(S33+PC1))) GO TO 400
  500 CONTINUE
C
C     --- PUT CELL MATRIX IN NORMAL REPRESENTATION
      CALL NORMAL
      IF(ITYPE.EQ.1) GO TO 700
C
C        --- PROTECTIVE CODE ... THIS CODE SHOULD BE ACTIVE ONLY
C            WHEN THE PROGRAM CONSTANT (PC1) IS INCORRECTLY SET
C            FOR THE SPECIFIC COMPUTER
         ICT3 = ICT3 + 1
         IF(ICT3.GT.5) WRITE(IUNITB,1200)
         IF(ICT3.GT.5) GO TO  700
C
C           --- TYPE 2 CELL MATRIX ... CHECK PART 2 OF MAIN CONDITIONS
            TX1 = S11 + S22 + PC1
            TX2 = 2.0*(ABS(S23) + ABS(S13) + ABS(S12))
            IF(TX1.GE.TX2) GO TO 700
               CALL SET
               U(1) = 1.0
               U(5) = 1.0
               U(7) = 1.0
               U(8) = 1.0
               U(9) = 1.0
               CALL MULTIP
               CALL TRANS(0)
C**
C              --- FOR CHECKING, WRITE EXECUTION POINT AND
C                  INTERMEDIATE VARIABLES
               IF(ICK024.EQ.1) CALL CKPT02(7)
C
               ICT2 = 0
               GO TO 400
  700 CONTINUE
C
C     --- MAIN CONDITIONS SHOULD BE SATISFIED ...
C         RE-CHECK, WRITE WARNING IF NOT SATISFIED AND CONTINUE
      Q1 = 2.0*ABS(S23) - 2.0*PC1
      Q2 = 2.0*ABS(S13) - 2.0*PC1
      Q3 = 2.0*ABS(S12) - 2.0*PC1
      IF(.NOT.(S11.LE.(S22+2.0*PC1).AND.S22.LE.(S33+2.0*PC1).AND.Q1.LE.
     $   S22.AND.Q2.LE.S11.AND.Q3.LE.S11)) WRITE(IUNITB,1300)
      IF(ITYPE.EQ.1) GO TO 800
C
C        --- TYPE 2 CELL MATRIX (---), TEST EXTRA MAIN CONDITION
         TX1 = S11 + S22 + 2.0*PC1
         TX2 = 2.0*(ABS(S23) + ABS(S13) + ABS(S12))
         IF(TX1.LT.TX2) WRITE(IUNITB,1400)
  800 CONTINUE
      RETURN
 1000 FORMAT(/1X,'*MNCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error when determini
     $ing the shortest vectors in the BC, AC, AB planes.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
 1100 FORMAT(/1X,'*MNCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error when ordering
     $the cell edges so that a<=b<=c.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
 1200 FORMAT(/1X,'*MNCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error when checking
     $Part II of Main Conditions for a type II cell.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
 1300 FORMAT(/1X,'*MNCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error in the final c
     $heck of Part I of the Main Conditions.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
 1400 FORMAT(/1X,'*MNCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error in the final c
     $heck of Part II of the Main Conditions.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
      END
      SUBROUTINE MULTIP
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /MATR2/ U(9),T(9)
C
C
C     SUBROUTINE 'MULTIP' ...
C        MULTIPLY TWO 3X3 MATRICES
C        WHEN THIS SUBROUTINE IS CALLED, THE TOTAL TRANSFORMATION
C        MATRIX IS UPDATED
C
C
C
C     --- (PRODUCT MATRIX) = (U-MATRIX) (T-MATRIX)
      U1 = T(1)*U(1) + T(4)*U(2) + T(7)*U(3)
      V1 = T(2)*U(1) + T(5)*U(2) + T(8)*U(3)
      W1 = T(3)*U(1) + T(6)*U(2) + T(9)*U(3)
      U2 = T(1)*U(4) + T(4)*U(5) + T(7)*U(6)
      V2 = T(2)*U(4) + T(5)*U(5) + T(8)*U(6)
      W2 = T(3)*U(4) + T(6)*U(5) + T(9)*U(6)
      U3 = T(1)*U(7) + T(4)*U(8) + T(7)*U(9)
      V3 = T(2)*U(7) + T(5)*U(8) + T(8)*U(9)
      W3 = T(3)*U(7) + T(6)*U(8) + T(9)*U(9)
      RETURN
      END
      SUBROUTINE NORMAL
      COMMON /COSANG/ COSA,COSB,COSG
      COMMON /MATR2/ U(9),T(9)
      COMMON /TYPE/ ITYPE
      COMMON /VAR1/ VAR90
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
C
C
C     SUBROUTINE 'NORMAL' ...
C        PUT CELL MATRIX IN NORMAL REPRESENTATION
C
C
C     THE CELL IS SET AS A TYPE 1 OR TYPE 2 CELL ...
C     TYPE 1 CELL = (+++) ALL ANGLES LESS THAN 90 DEGREES
C                         ( COS(ANGLES) ARE ALL > THAN ZERO )
C     TYPE 2 CELL = (---) ALL ANGLES EQUAL TO OR GREATER THAN 90 DEGREES
C                         ( COS(ANGLES) ARE ALL <= TO ZERO )
C
C     IF NECESSARY, THIS SUBROUTINE CHANGES THE SIGNS ON THE UNSYMMETRIC
C     SCALARS (S23, S13, S12) SO THAT THEY ARE ALL POSITIVE, ALL
C     NEGATIVE, OR ZERO AND NEGATIVE.  ALSO, THE TOTAL TRANSFORMATION
C     MATRIX IS UPDATED.
C
C
C     --- INITIALIZE VARIABLES
      ITYPE = 0
C
      ACOSA = ABS(COSA)
      ACOSB = ABS(COSB)
      ACOSG = ABS(COSG)
C
C     --- VARIABLES ISGN-- INDICATE WHETHER THE UNSYMMETRICAL SCALARS
C         (S23, S13, S12) ARE ZERO, POSITIVE OR NEGATIVE (THIS CODE
C         USES THE COS(ANGLES) AS AN INDICATION OF THE SIGNS)
      ISGN23 = -1
      ISGN13 = -1
      ISGN12 = -1
      IF(COSA.GT.VAR90)  ISGN23 = 1
      IF(COSB.GT.VAR90)  ISGN13 = 1
      IF(COSG.GT.VAR90)  ISGN12 = 1
      IF(ACOSA.LE.VAR90) ISGN23 = 0
      IF(ACOSB.LE.VAR90) ISGN13 = 0
      IF(ACOSG.LE.VAR90) ISGN12 = 0
C
C     --- INITIALIZE MATRIX ARRAY U TO IDENTITY MATRIX
      CALL SET
      U(1) = 1.0
      U(5) = 1.0
      U(9) = 1.0
C
C     --- TYPE 1 CELL IF PRODUCT OF SIGNS OF UNSYMMETRICAL SCALARS IS +1
C         TYPE 2 CELL IF PRODUCT IS -1 OR 0
      IPROD = ISGN23*ISGN13*ISGN12
C
C     --- PUT THE CELL MATRIX IN NORMAL REPRESENTATION
      IF(IPROD.EQ.0.OR.IPROD.EQ.-1) GO TO 100
C
C        --- TYPE 1 CELL ... POSITIVE REDUCED FORM
C            SET UNSYMMETRICAL SCALARS TO BE POSITIVE (ALL ANGLES
C            LESS THAN 90 DEGREES)
         ITYPE = 1
C
C        --- UPDATE TRANSFORMATION MATRIX
         IF(ISGN23.EQ.-1) U(1) = -1.0
         IF(ISGN13.EQ.-1) U(5) = -1.0
         IF(ISGN12.EQ.-1) U(9) = -1.0
         GO TO 200
  100 CONTINUE
C
C     --- TYPE 2 CELL ... NEGATIVE REDUCED FORM
C         SET UNSYMMETRICAL SCALARS TO BE LESS THAN OR EQUAL TO ZERO
C         (ALL ANGLES >= 90 DEGREES)
      ITYPE = 2
C
C     --- UPDATE TRANSFORMATION MATRIX
      IF(ISGN23.EQ.1) U(1) = -1.0
      IF(ISGN13.EQ.1) U(5) = -1.0
      IF(ISGN12.EQ.1) U(9) = -1.0
C
C     --- HAVE ONE OR MORE 90 DEGREE ANGLES IF IPROD = 0
      IF(IPROD.NE.0) GO TO 200
C
C        --- CHECK WHETHER OR NOT MUST REVERSE DIRECTION OF ONE
C            ADDITIONAL VECTOR TO MAINTAIN A RIGHT-HANDED SYSTEM
         IREV23 = ISGN23
         IREV13 = ISGN13
         IREV12 = ISGN12
         IF(ISGN23.EQ.0) IREV23 = -1
         IF(ISGN13.EQ.0) IREV13 = -1
         IF(ISGN12.EQ.0) IREV12 = -1
         IPROD = IREV23*IREV13*IREV12
         IF(IPROD.EQ.-1) GO TO 200
C
C           --- MUST REVERSE DIRECTION OF ONE VECTOR TO MAINTAIN A
C               RIGHT-HANDED SYSTEM
            IF(ISGN23.EQ.0) U(1) = -1.0
            IF(ISGN23.EQ.0) GO TO 200
            IF(ISGN13.EQ.0) U(5) = -1.0
            IF(ISGN13.EQ.0) GO TO 200
            IF(ISGN12.EQ.0) U(9) = -1.0
  200 CONTINUE
C
C     --- UPDATE THE TOTAL TRANSFORMATION MATRIX AND APPLY THE
C         RESULTING MATRIX TO THE INPUT CELL.  TO UPDATE THE TOTAL
C         TRANSFORMATION MATRIX, THE PROGRAM PREMULTIPLIES THE
C         CURRENT MATRIX BY AN UPDATE MATRIX U.  IN THIS ROUTINE, U
C         MAY BE (-1 0 0 / 0 -1 0 / 0 0 1), (-1 0 0 / 0 1 0 / 0 0 -1)
C         OR (1 0 0 / 0 -1 0 / 0 0 -1).
      CALL MULTIP
      CALL TRANS(0)
C**
C     --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE VARIABLES
      IF(ICK025.EQ.1) CALL CKPT02(9)
C
C     --- STOP PROGRAM EXECUTION IF PROGRAM FAILS TO TYPE
C         CELL MATRIX (SHOULD NOT OCCUR)
      IF(ITYPE.EQ.0) STOP
     $  '*NORMAL* ERROR ... Failed to type cell matrix.'
      RETURN
      END
      SUBROUTINE OUTPT1(IFLAG1)
      COMMON /CELLI/ AI,BI,CI,ALPHI,BETI,GAMI,VOLI
      COMMON /CELLF/ AF,BF,CF,ALPHF,BETF,GAMF,VOLF
      COMMON /CNTR1/ ICNTR1
      COMMON /DELTA1/ IRSS
      COMMON /DELTA3/ IDET,ILATNO
      COMMON /DOTP/ S11,S22,S33,S23,S13,S12
      COMMON /INVER1/ UI1,VI1,WI1,UI2,VI2,WI2,UI3,VI3,WI3
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /PRINT1/ IPRRSS,IOUT
      COMMON /PROB1/ NTD,IPROB
      COMMON /UNIT2/ IUNITB
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
C
C
C     SUBROUTINE 'OUTPT1' ...
C          OUTPUT FOR PROGRAM
C
C
C
C**
C     --- WHEN NOT EXECUTING SPECIAL CHECK RUN, GO TO SECTION
C         OF CODE FOR NORMAL EXECUTION OF PROGRAM
      IF(ICK029.NE.1) GO TO 5
C
C        --- WRITE PROBLEM NUMBER IF INDICATED
         IF(IFLAG1.EQ.3) CALL CKPT02(13)
         GO TO 900
    5 CONTINUE
C
C     --- RETURN IF NO REDUCTION AND DERIVATIVE LATTICE OUTPUT
      IF(IPRRSS.EQ.0.AND.IFLAG1.GT.2) GO TO 900
C
C     --- GO TO APPROPRIATE SECTION OF OUTPUT (INDICATED BY IFLAG1)
      GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130)
     $ IFLAG1
   10 CONTINUE
C
C     *** CALLED FROM 'MAIN'
C
C     --- WRITE NUMBER OF INDEPENDENT PROBLEMS TO STUDY
      WRITE(IUNITB,1100)
      WRITE(IUNITB,1150) NTD
      GO TO 900
   20 CONTINUE
C
C     *** CALLED FROM 'MAIN'
C
C     --- WRITE FOR LATTICE MATCHING OF REDUCED CELLS
      WRITE(IUNITB,1200)
      GO TO 900
   30 CONTINUE
C
C     *** CALLED FROM 'REDUCE'
C
C     --- WRITE PROBLEM NUMBER
	IF (IOUT.GT.0) GO TO 900
      IF(IPROB.NE.1) WRITE(IUNITB,1300)
      WRITE(IUNITB,1350) IPROB
      GO TO 900
   40 CONTINUE
C
C     *** CALLED FROM 'READ'
C
C     --- HEADINGS PRODUCED BY PROBLEM SPECIFICATION AND CELL LINE
	IF (IOUT.GT.0) GO TO 900
      IF(IRSS.EQ.0) WRITE(IUNITB,1400)
      IF(IRSS.EQ.1) WRITE(IUNITB,1500)
      IF(IRSS.EQ.2) WRITE(IUNITB,1600)
      IF(IRSS.EQ.3) WRITE(IUNITB,1700)
      GO TO 900
   50 CONTINUE
C
C     *** CALLED FROM 'READ'
C
C     --- HEADING FOR CENTERING OF INPUT CELL
      IF(ICNTR1.EQ.0.OR.ICNTR1.EQ.1) WRITE(IUNITB,1800)
      IF(ICNTR1.EQ.2) WRITE(IUNITB,1900)
      IF(ICNTR1.EQ.3) WRITE(IUNITB,2000)
      IF(ICNTR1.EQ.4) WRITE(IUNITB,2100)
      IF(ICNTR1.EQ.5) WRITE(IUNITB,2200)
      IF(ICNTR1.EQ.6) WRITE(IUNITB,2300)
      IF(ICNTR1.EQ.7) WRITE(IUNITB,2400)
      GO TO 900
   60 CONTINUE
   70 CONTINUE
C
C     *** CALLED FROM 'DERIV'
C
C     --- HEADING FOR SUPERLATTICES
      WRITE(IUNITB,2500) IDET
      GO TO 900
   80 CONTINUE
C
C     *** CALLED FROM 'DERIV'
C
C     --- HEADING FOR SUBLATTICES
      WRITE(IUNITB,2600) IDET
      GO TO 900
   90 CONTINUE
C
C     *** CALLED FROM 'DERIV'
C
C     --- WRITE LATTICE NUMBER IF SUPERCELL OR SUBCELL
      IF(IRSS.EQ.1.OR.IRSS.EQ.3) WRITE(IUNITB,2700) ILATNO
      IF(IRSS.EQ.2) WRITE(IUNITB,2800) ILATNO
      GO TO 900
  100 CONTINUE
C
C     *** CALLED FROM 'CENTER' OR 'DERIV'
C
C     --- WRITE TRANSFORMATION MATRIX
      WRITE(IUNITB,2900) U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
  110 CONTINUE
C
C     *** CALLED FROM 'TRANS'
C
C     --- WRITE TRANSFORMATION MATRIX
      WRITE(IUNITB,3000) U1, V1, W1, U2, V2, W2, U3, V3, W3
      GO TO 900
  120 CONTINUE
C
C     *** CALLED FROM 'INVERS'
C
C     --- WRITE INVERSE MATRIX
      WRITE(IUNITB,3100) UI1, VI1, WI1, UI2, VI2, WI2,
     $      UI3, VI3, WI3
      GO TO 900
  130 CONTINUE
C
C     *** CALLED FROM 'TRANS'
C
C
C     --- WRITE INITIAL CELL, FINAL CELL AND CELL MATRIX
      WRITE(IUNITB,3300) AI, BI, CI, ALPHI, BETI, GAMI, VOLI
      WRITE(IUNITB,3400) AF, BF, CF, ALPHF, BETF, GAMF, VOLF
C     --- HEADING FOR CELL MATRIX
	WRITE (IUNITB,3200) S11,S22,S33,S23,S13,S12
      GO TO 900
C
  900 CONTINUE
      RETURN
 1100 FORMAT(////1X,10X,'REDUCTION AND DERIVATIVE LATTICE'///)
 1150 FORMAT(2X,'Number of independent problems to study = ',I2//)
 1200 FORMAT(//17X,'Lattice Matching of reduced cell(s) with'/15X,
     $'          NIST  CRYSTAL  DATA  '//)
 1300 FORMAT(1H1)
 1350 FORMAT(////10X,I3,'.  ')
 1400 FORMAT(1H+,16X,'REDUCTION'/)
 1500 FORMAT(1H+,16X,'SUPERLATTICES'/)
 1600 FORMAT(1H+,16X,'SUBLATTICES'/)
 1700 FORMAT(1H+,16X,'SUPERLATTICES for a given delta followed by SUBLAT
     $TICES for 1/delta'/)
 1800 FORMAT(//21X,'** Initial Cell is Primitive **'/)
 1900 FORMAT(//33X,'** Initial Cell is A-Centered **'/)
 2000 FORMAT(//33X,'** Initial Cell is B-Centered **'/)
 2100 FORMAT(//33X,'** Initial Cell is C-Centered **'/)
 2200 FORMAT(//33X,'** Initial Cell is F-Centered **'/)
 2300 FORMAT(//33X,'** Initial Cell is I-Centered **'/)
 2400 FORMAT(//32X,'** Initial Cell is RH-Centered **'/)
 2500 FORMAT(///2X,'Superlattices for Delta = ',I2)
 2600 FORMAT(///2X,'Sublattices for Delta = 1/',I2)
 2700 FORMAT(//24X,'***** Supercell ',I3,' *****'/)
 2800 FORMAT(//37X,'***** Subcell ',I3,' *****'/)
 2900 FORMAT(1X,'T 1=',4X,3F7.2,'/',3F7.2,'/',3F7.2)
 3000 FORMAT(1X,'T 2=',4X,3F7.2,'/',3F7.2,'/',3F7.2)
 3100 FORMAT(1X,'T 2 INV=',3F7.2,'/',3F7.2,'/',3F7.2)
 3200 FORMAT(/,28x,'** Cell Matrix **'//,21X,3F10.3,/,21X,3F10.3)
 3300 FORMAT(/1X,'CELL  1=',3F9.3,1X,3F8.2,4X,'V1=',F10.2)
 3400 FORMAT(1X,'CELL  2=',3F9.3,1X,3F8.2,4X,'V2=',F10.2)
      END
      SUBROUTINE QMATRI
      COMMON /DELTA2/ IDEL1,IDEL2
      COMMON /DELTA4/ IDERIV,IFINIS,IQMATF
      COMMON /QMAT/ ISQ11(519),ISQ12(519),ISQ13(519),
     $              ISQ22(519),ISQ23(519),ISQ33(519)
C
C
C     SUBROUTINE 'QMATRI' ...
C        UPPER TRIANGULAR MATRIX GENERATION FOR THE RANGE OF
C        DELTAS SUPPLIED
C
C
C
C     --- IDEL IS THE VALUE OF THE DETERMINANT AND IMATT IS THE TOTAL
C         NON-EQUIVALENT MATRICES CONSISTENT WITH A GIVEN IDEL
C     --- CALCULATE ALL THE UNIQUE MATRICES (IQMATF) CONSISTENT WITH
C         WITH A GIVEN DELTA (IDEL) AND STORE THEM IN THE ARRAYS.
C         EACH UNIQUE MATRIX IS IN THE FORM :
C               Q11     Q12     Q13
C               0       Q22     Q23
C               0       0       Q33
C
C     --- A TOTAL OF 519 UNIQUE MATRICES WILL BE GENERATED FOR
C         DELTAS 2 THROUGH 9 (I.E. 7+13+35+31+91+57+155+130 = 519).
C
      DO 300  IDEL = IDEL1,IDEL2
         DO 200 I = 1,IDEL
         DO 200 J = 1,IDEL
         DO 200 K = 1,IDEL
            IPROD = I*J*K
            IF(IPROD.NE.IDEL) GO TO 200
C
C              --- SET UP DIAGONAL ELEMENTS
               IQ11 = I
               IQ22 = J
               IQ33 = K
C
C              --- SET BOTTOM TRIANGULAR ELEMENTS EQUAL TO ZERO
               IQ21 = 0
               IQ31 = 0
               IQ32 = 0
C
C              --- SET TOP TRIANGULAR ELEMENTS EQUAL TO ZERO
               IQ12 = 0
               IQ13 = 0
               IQ23 = 0
C
C              --- GENERATE ALL MATRICES CONSISTENT WITH GIVEN DIAGONAL
               DO 100 II = 1,IDEL
               DO 100 JJ = 1,IDEL
               DO 100 KK = 1,IDEL
                  IQ12 = II - 1
                  IQ13 = JJ - 1
                  IQ23 = KK - 1
C
C                 --- THE VALUE OF EACH NON-DIAGONAL ELEMENT IS RESTRICTED
C                     TO BE LESS THAN THE DIAGONAL ELEMENT IN THE SAME
C                     COLUMN.  IN DOING SO, A UNIQUE UPPER TRIANGULAR
C                     MATRIX IS GENERATED FOR A GIVEN DELTA.
                  IF(.NOT.(IQ12.LT.IQ22.AND.IQ13.LT.IQ33.AND.IQ23.LT.
     $               IQ33)) GO TO 100
C
C                    --- MATRIX IS ACCEPTABLE
                     IQMATF = IQMATF + 1
C
C                    --- STOP PROGRAM EXECUTION IF TOO MANY UPPER
C                        TRIANGULAR MATRICES HAVE BEEN GENERATED
C                        (SHOULD NOT OCCUR)
                     IF(IQMATF.GT.519) STOP  '*QMATRI* ... Error in the
     $generation of upper triangular matrices.'
C
                     ISQ11(IQMATF) = IQ11
                     ISQ12(IQMATF) = IQ12
                     ISQ13(IQMATF) = IQ13
                     ISQ22(IQMATF) = IQ22
                     ISQ23(IQMATF) = IQ23
                     ISQ33(IQMATF) = IQ33
  100          CONTINUE
  200    CONTINUE
  300 CONTINUE
      RETURN
      END
      SUBROUTINE READ
      CHARACTER AHP,AHA,AHB,AHC,AHF,AHI,AHH,AHR,ACNTR1,ACNTR2
      COMMON /CELLI/ AI,BI,CI,ALPHI,BETI,GAMI,VOLI
      COMMON /CNTR1/ ICNTR1
      COMMON /DELTA1/ IRSS
      COMMON /DELTA2/ IDEL1,IDEL2
      COMMON /ERR1/ IERR1
      COMMON /UNIT1/ IUNITA
      COMMON /UNIT2/ IUNITB
      DATA AHP/'P'/, AHA/'A'/, AHB/'B'/, AHC/'C'/, AHF/'F'/, AHI/'I'/
      DATA AHR/'R'/, AHH/'H'/
C
C
C     SUBROUTINE 'READ' ...
C          READS AND INTERPRETS RSS CONTROL LINE FOR EACH PROBLEM
C
C
C
C     --- READ PROBLEM SPECIFICATIONS AND CELL PARAMETERS
C         (ON RSS CONTROL LINE)
      READ(IUNITA,1000) IRSS, IDEL1, IDEL2, ACNTR1, ACNTR2,
     $             AI, BI, CI, ALPHI, BETI, GAMI
C
C     --- IF NOT REDUCTION ONLY, CHECK AND, IF NECESSARY, RESET
C         SPECIFICATIONS FOR DERIVATIVE LATTICE CALCULATIONS
      IF(IRSS.EQ.0) GO TO 100
         IF(IRSS.GT.3.OR.IRSS.LT.0) WRITE(IUNITB,1100)
         IF(IRSS.GT.3.OR.IRSS.LT.0) IRSS = 0
         IF(IDEL1.GT.IDEL2.OR.IDEL1.LT.2.OR.IDEL2.GT.9)
     $      WRITE(IUNITB,1200)
         IF(IDEL1.GT.IDEL2.OR.IDEL1.LT.2.OR.IDEL2.GT.9) IRSS = 0
  100 CONTINUE
C
C     --- WRITE HEADINGS FOR RSS PROBLEM SPECIFICATIONS
      CALL OUTPT1(4)
C
C     --- ASSIGN VARIABLE (ICNTR1) TO INDICATE CENTERING OF INPUT CELL
      ICNTR1 = 0
      IF(ACNTR1.EQ.AHP)  ICNTR1 = 1
      IF(ACNTR1.EQ.AHA)  ICNTR1 = 2
      IF(ACNTR1.EQ.AHB)  ICNTR1 = 3
      IF(ACNTR1.EQ.AHC)  ICNTR1 = 4
      IF(ACNTR1.EQ.AHF)  ICNTR1 = 5
      IF(ACNTR1.EQ.AHI)  ICNTR1 = 6
      IF(ACNTR1.EQ.AHR.AND.ACNTR2.EQ.AHH)   ICNTR1 = 7
      IF(ACNTR1.EQ.AHR.AND.ACNTR2.EQ.AHR)   ICNTR1 = 1
      IF(ICNTR1.EQ.0) WRITE(IUNITB,1300)
      IF(ICNTR1.EQ.0) ICNTR1 = 1
C
C     --- WRITE HEADINGS FOR CENTERING OF INPUT CELL
      CALL OUTPT1(5)
C
C     --- FIND MATRIX TO TRANSFORM THE INPUT CELL TO
C         A PRIMITIVE CELL OF THE LATTICE
      CALL CENTER
C
C     --- CALCULATE THE VOLUME OF THE INPUT CELL
C         (AND CHECK FOR VALID INPUT DATA)
      CALL VOLUME(AI,BI,CI,ALPHI,BETI,GAMI,VOLI)
C
C     --- IF INPUT CELL HAS ILLEGAL CELL PARAMETER(S) AND/OR CELL VOLUME,
C         WRITE ERROR MESSAGE (ERROR FLAG IERR1 IS SET IN *VOLUME*)
      IF(IERR1.EQ.1) WRITE(IUNITB,1400)
      RETURN
 1000 FORMAT(I1,2X,2I1,3X,2A1,6F10.2)
 1100 FORMAT(/1X,'*READ* ERROR ... Check RSS Control Line, column 1.'
     $/1X,17X,'Only cell reduction calculations will be carried out.'//)
 1200 FORMAT(/1X,'*READ* ERROR ... Check RSS Control Line, columns 4-5.'
     $/1X,17X,'Only cell reduction calculations will be carried out.'//)
 1300 FORMAT(/1X, '*READ* WARNING ... Input centering symbol not legal (
     $i.e. P,A,B,C,I,F,RR,RH).',
     $/20X,'Program assumes that the input cell is primitive.')
 1400 FORMAT(/1X,'*READ* ERROR ... Input cell has illegal cell parameter
     $(s) and/or cell volume.'/)
      END
      SUBROUTINE REDUCE
      COMMON /CELLI/ AI,BI,CI,ALPHI,BETI,GAMI,VOLI
      COMMON /CELLF/ AF,BF,CF,ALPHF,BETF,GAMF,VOLF
      COMMON /DELTA1/ IRSS
      COMMON /DELTA4/ IDERIV,IFINIS,IQMATF
      COMMON /ERR1/ IERR1
      COMMON /PROB1/ NTD,IPROB
      COMMON /VAR1/ VAR90
C
C
C     SUBROUTINE 'REDUCE' ...
C        CONTROLS REDUCTION AND DERIVATIVE LATTICE CALCULATIONS
C
C
C
C     --- INITIALIZE VARIABLES
      IPROB = 1
C
  100 CONTINUE
C
C     --- BEGINNING OF LOOP TO PROCESS EACH INPUT CELL
C
C     --- WRITE PROBLEM NUMBER
      CALL OUTPT1(3)
C
C     --- INITIALIZE VARIABLES
      IDERIV = 0
      IQMATF = 0
      IFINIS = 0
C
C     --- READ AND INTERPRET RSS CONTROL LINE
C         (RSS PROBLEM SPECIFICATIONS, CELL CENTERING, CELL PARAMETERS)
      CALL READ
C
C     --- GO TO NEXT PROBLEM IF INPUT CELL HAS ILLEGAL CELL PARAMETER(S)
C         AND/OR CELL VOLUME (ERROR FLAG IERR1 IS SET IN *VOLUME*)
      IF(IERR1.EQ.1) GO TO 400
C
C        --- GENERATE UPPER TRIANGULAR MATRICES IF DERIVATIVE LATTICES
C            ARE TO BE CALCULATED
         IF(IRSS.NE.0) CALL QMATRI
C
  200    CONTINUE
C
C        --- STARTING POINT FOR REDUCTION CALCULATIONS
C
C        --- THIS STATEMENT DOES NOT APPLY TO REDUCTION-ONLY
C            CALCULATIONS ... GO TO NEXT THE PROBLEM IF ALL THE
C            DERIVATIVE LATTICES HAVE BEEN CALCULATED AND REDUCED
C            (IFINIS IS SET TO 1 IN DERIV AFTER THE LAST UPPER
C            TRIANGULAR MATRIX HAS BEEN SELECTED)
         IF(IFINIS.EQ.1) GO TO 400
C
C           --- FOR EACH INPUT CELL, REDUCE THE CELL AND, IF APPROPRIATE,
C               REDUCE ITS ASSOCIATED DERIVATIVE CELLS
            IF(IDERIV.GT.0) CALL DERIV
            CALL TRANS(0)
C
C           --- VAR90 DEFINES RANGE OF ANGLES TO BE CONSIDERED EQUAL
C               TO 90 DEGREES IN SUBROUTINE 'NORMAL'
            VAR90 = 0.000001
            CALL MNCOND
            VAR90 = 0.000349
            CALL NORMAL
            CALL SPCOND
            CALL TRANS(1)
C
C           --- IF DERIVATIVE LATTICES ARE NOT BEING CALCULATED,
C               GO TO NEXT PROBLEM
            IF(IRSS.EQ.0) GO TO 400
               IF(IDERIV.NE.0) GO TO 200
C
C              --- RESET INITIAL CELL TO BE THE REDUCED (PRIMITIVE) CELL
C                  OF THE LATTICE
               AI = AF
               BI = BF
               CI = CF
               ALPHI = ALPHF
               BETI  = BETF
               GAMI  = GAMF
               VOLI  = VOLF
C
C              --- FIRST UPPER TRIANGULAR MATRIX WILL BE SELECTED
C                  TO CALCULATE DERIVATIVE LATTICES
               IDERIV = 1
               GO TO 200
C
  400 CONTINUE
C
C     --- FINISHED RSS CALCULATIONS FOR A SINGLE PROBLEM,
C         PROCEED TO NEXT PROBLEM IF REQUIRED
      IPROB = IPROB + 1
      IF(IPROB.LE.NTD) GO TO 100
      RETURN
       END
      SUBROUTINE SET
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /MATR2/ U(9),T(9)
C
C
C     SUBROUTINE 'SET' ...
C        PREPARE TO UPDATE THE TOTAL TRANSFORMATION MATRIX
C        (U1,V1,W1,U2,V2,W2,U3,V3,W3) BY MATRIX MULTIPLICATION
C
C
C     --- SAVE THE CURRENT VALUES OF THE ELEMENTS FOR THE TOTAL
C         TRANSFORMATION MATRIX IN THE ARRAY T AND SET THE MATRIX
C         ELEMENTS IN THE UPDATE MATRIX U TO ZERO
      T(1) = U1
      T(2) = V1
      T(3) = W1
      T(4) = U2
      T(5) = V2
      T(6) = W2
      T(7) = U3
      T(8) = V3
      T(9) = W3
      DO 100 I = 1,9
         U(I) = 0.0
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SHORTV(SXX,SXY,ELEM1,ELEM5,ELEM9,ELEMX)
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
C
C
C     SUBROUTINE 'SHORTV' ...
C        FOR TWO VECTORS X AND Y, FIND THE SHORTEST Y' RELATIVE TO X
C
C
C**
C     --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE VARIABLES
      IF(ICK026.EQ.1) CALL CKPT02(8)
C
C     --- INITIALIZE VARIABLES
      AXY = ABS(SXY)
      XN = 0.0
      IF(SXY.LE.0.0) XN =  1.0
      IF(SXY.GT.0.0) XN = -1.0
      XN1 = 0.0
C
C     --- DETERMINE THE NUMBER OF VECTOR ADDITIONS OR SUBTRACTIONS
C         REQUIRED TO OBTAIN THE SHORTEST Y' RELATIVE TO X.  IF THE
C         INITIAL ANGLE IS < 90 DEGREES, VECTOR X IS SUBTRACTED XN1
C         TIMES, IF THE INITIAL ANGLE IS >= 90 DEGREES, VECTOR X IS
C         ADDED XN1 TIMES.
  100 CONTINUE
      RXY = ABS(SXY + XN*SXX)
      IF((RXY-AXY).GT.0.0) GO TO 160
         IF(SXY.GE.0.0) GO TO 120
            XN  = XN  + 1.0
            XN1 = XN1 + 1.0
            GO TO 140
  120    CONTINUE
         XN  = XN  - 1.0
         XN1 = XN1 - 1.0
  140    CONTINUE
         AXY = RXY
         GO TO 100
  160 CONTINUE
C
C     --- SET THE MATRIX ELEMENTS FOR THE MATRIX USED TO UPDATE
C         THE TOTAL TRANSFORMATION MATRIX (U)
      CALL SET
      ELEM1 = 1.0
      ELEM5 = 1.0
      ELEM9 = 1.0
      ELEMX = XN1
C
      RETURN
      END
      SUBROUTINE SORT1(A1,A2,A3,A4,A5,A6,A7,N)
      IMPLICIT INTEGER (A-Z)
      DIMENSION A1(*),A2(*),A3(*),A4(*),A5(*),A6(*),A7(*)
      DIMENSION INDEX(900)
C
C
C     A1, ... A7 = ARRAYS TO BE SORTED
C     N = LENGTH OF ARRAYS A1, ... A7
C     INDEX = ARRAY SPECIFYING ORDER OF INPUT ARRAYS AFTER SORT
C     Q = FLAG TO DETERMINE WHETHER OR NOT TO SORT ARRAY
C         IN THIS SUBROUTINE
C        Q = 0 ... SUBROUTINE SORTS ARRAYS (ALSO CALCULATES INDEX
C                  SPECIFYING HOW ARRAY WAS SORTED)
C        Q.NE.0 .. SUBROUTINE DOES NOT SORT ARRAYS BUT CALCULATES
C                  INDEX SPECIFYING HOW TO SORT
C
C     *** NOTE THAT THE VARIABLES INDEX AND Q MAY BE
C         INCLUDED IN THE CALL ARGUMENT
C
C
C
C
C     --- THIS SUBROUTINE RETURNS SORTED ARRAYS
      Q = 0
C
C     --- INITIALIZE VARIABLES
      DO 10 I = 1,N
         INDEX(I) = I
   10 CONTINUE
C
      M = N
C
C     --- BEGINNING OF CODE TO DETERMINE ORDER OF INPUT ARRAYS
C         AFTER SORTING
   20 CONTINUE
C
C     --- MUST HAVE AT LEAST 2 ITEMS TO SORT
      IF((M-2).LT.0) GO TO 60
         M = 2*(M/4) + 1
         K = N - M
         J = 1
C
   30    CONTINUE
         I = J
C
   40    CONTINUE
         IM = I + M
         II = INDEX(I)
         IIM = INDEX(IM)
         IF(A1(II).LT.A1(IIM)) GO TO 50
         IF(A1(II).GT.A1(IIM)) GO TO 45
         IF(A2(II).LT.A2(IIM)) GO TO 50
         IF(A2(II).GT.A2(IIM)) GO TO 45
         IF(A3(II).LT.A3(IIM)) GO TO 50
         IF(A3(II).GT.A3(IIM)) GO TO 45
         IF(A4(II).LT.A4(IIM)) GO TO 50
         IF(A4(II).GT.A4(IIM)) GO TO 45
         IF(A5(II).LT.A5(IIM)) GO TO 50
         IF(A5(II).GT.A5(IIM)) GO TO 45
         IF(A6(II).LT.A6(IIM)) GO TO 50
         IF(A6(II).GT.A6(IIM)) GO TO 45
         IF(A7(II).LE.A7(IIM)) GO TO 50
         IF(A7(II).GT.A7(IIM)) GO TO 45
   45    CONTINUE
            INDEX(I) = IIM
            INDEX(IM) = II
            I = I - M
            IF(I.GT.0) GO TO 40
C
   50    CONTINUE
         J = J + 1
         IF((K-J).LT.0) GO TO 20
            GO TO 30
C
   60 CONTINUE
C
C     --- BEGINNING OF CODE TO SORT THE ARRAYS (IF INDICATED)
      IF(Q.NE.0) GO TO 200
C
C     --- INDEX(A)=B MEANS THAT THE 'B'TH ENTRY BELONGS IN POSITION 'A'
      DO 80 I = 1,N
         IF(INDEX(I).EQ.0) GO TO 80
         IF((INDEX(I) - I).EQ.0) GO TO 80
            J = I
            TEMP1 = A1(I)
            TEMP2 = A2(I)
            TEMP3 = A3(I)
            TEMP4 = A4(I)
            TEMP5 = A5(I)
            TEMP6 = A6(I)
            TEMP7 = A7(I)
C
   70       CONTINUE
            K = INDEX(J)
            INDEX(J) = 0
            A1(J) = A1(K)
            A2(J) = A2(K)
            A3(J) = A3(K)
            A4(J) = A4(K)
            A5(J) = A5(K)
            A6(J) = A6(K)
            A7(J) = A7(K)
            J = K
            IF((INDEX(J) - I).NE.0) GO TO 70
               INDEX(J) = 0
               A1(J) = TEMP1
               A2(J) = TEMP2
               A3(J) = TEMP3
               A4(J) = TEMP4
               A5(J) = TEMP5
               A6(J) = TEMP6
               A7(J) = TEMP7
C
   80 CONTINUE
C
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SORT2(A1,A2,A3,N)
      IMPLICIT INTEGER (A-Z)
      DIMENSION A1(*),A2(*),A3(*),INDEX(2000)
C
C
C     THIS SUBROUTINE IS THE SAME AS SORT1 EXCEPT ONLY THREE
C       ARRAYS ARE SORTED
C
C
C     A1, A2, A3 = ARRAYS TO BE SORTED
C     N = LENGTH OF ARRAYS A1, A2, A3
C     INDEX = ARRAY SPECIFYING ORDER OF INPUT ARRAYS AFTER SORT
C     Q = FLAG TO DETERMINE WHETHER OR NOT TO SORT ARRAY
C         IN THIS SUBROUTINE
C        Q = 0 ... SUBROUTINE SORTS ARRAYS (ALSO CALCULATES INDEX
C                  SPECIFYING HOW ARRAY WAS SORTED)
C        Q.NE.0 .. SUBROUTINE DOES NOT SORT ARRAYS BUT CALCULATES
C                  INDEX SPECIFYING HOW TO SORT
C
C     *** NOTE THAT THE VARIABLES INDEX AND Q MAY BE
C         INCLUDED IN THE CALL ARGUMENT
C
C
C
C
C     --- THIS SUBROUTINE RETURNS SORTED ARRAYS
      Q = 0
C
C     --- INITIALIZE VARIABLES
      DO 10 I = 1,N
         INDEX(I) = I
   10 CONTINUE
C
      M = N
C
C     --- BEGINNING OF CODE TO DETERMINE ORDER OF INPUT ARRAYS
C         AFTER SORTING
   20 CONTINUE
C
C     --- MUST HAVE AT LEAST 2 ITEMS TO SORT
      IF((M-2).LT.0) GO TO 60
         M = 2*(M/4) + 1
         K = N - M
         J = 1
C
   30    CONTINUE
         I = J
C
   40    CONTINUE
         IM = I + M
         II = INDEX(I)
         IIM = INDEX(IM)
         IF(A1(II).LT.A1(IIM)) GO TO 50
         IF(A1(II).GT.A1(IIM)) GO TO 45
         IF(A2(II).LT.A2(IIM)) GO TO 50
         IF(A2(II).GT.A2(IIM)) GO TO 45
         IF(A3(II).LE.A3(IIM)) GO TO 50
         IF(A3(II).GT.A3(IIM)) GO TO 45
   45    CONTINUE
            INDEX(I) = IIM
            INDEX(IM) = II
            I = I - M
            IF(I.GT.0) GO TO 40
C
   50    CONTINUE
         J = J + 1
         IF((K-J).LT.0) GO TO 20
            GO TO 30
C
   60 CONTINUE
C
C     --- BEGINNING OF CODE TO SORT THE ARRAYS (IF INDICATED)
      IF(Q.NE.0) GO TO 200
C
C     --- INDEX(A)=B MEANS THAT THE 'B'TH ENTRY BELONGS IN POSITION 'A'
      DO 80 I = 1,N
         IF(INDEX(I).EQ.0) GO TO 80
         IF((INDEX(I) - I).EQ.0) GO TO 80
            J = I
            TEMP1 = A1(I)
            TEMP2 = A2(I)
            TEMP3 = A3(I)
C
   70       CONTINUE
            K = INDEX(J)
            INDEX(J) = 0
            A1(J) = A1(K)
            A2(J) = A2(K)
            A3(J) = A3(K)
            J = K
            IF((INDEX(J) - I).NE.0) GO TO 70
               INDEX(J) = 0
               A1(J) = TEMP1
               A2(J) = TEMP2
               A3(J) = TEMP3
   80 CONTINUE
C
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SPCOND
      COMMON /COSANG/ COSA,COSB,COSG
      COMMON /DOTP/ S11,S22,S33,S23,S13,S12
      COMMON /MATR2/ U(9),T(9)
      COMMON /TYPE/ ITYPE
      COMMON /UNIT2/ IUNITB
      COMMON /VAR1/ VAR90
      DATA PC1/0.00006/
C
C
C     SUBROUTINE 'SPCOND' ...
C        CHECK AND, IF NECESSARY, SATISFY SPECIAL CONDITIONS
C        FOR REDUCTION
C
C
C
C     --- INITIALIZE VARIABLES
      ICOUNT = 0
      DUM1 = 0.0
      DUM2 = 0.0
      DUM3 = 0.0
C
  100 CONTINUE
C
C     --- STARTING POINT TO CHECK, AND IF NECESSARY SATISFY, EACH
C         SPECIAL CONDITION
C
C     --- INITIALIZE VARIABLES
      CALL SET
      ISPFIX = 0
C
C     --- PROTECTIVE CODE ... THIS CODE SHOULD BE ACTIVE ONLY
C         WHEN THE PROGRAM CONSTANT (PC1) IS INCORRECTLY SET
C         FOR THE SPECIFIC COMPUTER
      ICOUNT = ICOUNT + 1
      IF(ICOUNT.LE.20) GO TO 200
         WRITE(IUNITB,1000)
         GO TO  600
  200 CONTINUE
C
C     --- CALCULATE TEMPORARY VARIABLES USED TO CHECK SPECIAL CONDITIONS
      TS1  = ABS(S11 - S22)/S11
      TS2  = ABS(S22 - S33)/S22
      TS3  = ABS(ABS(2.0*S23) - S22)/S22
      TS4  = ABS(ABS(2.0*S13) - S11)/S11
      TS5  = ABS(ABS(2.0*S12) - S11)/S11
      TEM1 = S11 + S22
      TEM2 = 2.0*(ABS(S23) + ABS(S13) + ABS(S12))
      TS6  = ABS(TEM1 - TEM2)/TEM1
      TS7  = 2.0*ABS(S13) + ABS(S12) + PC1
C
C
C     --- SPECIAL CONDITION (A) ...
C         TYPE 1 CELL - IF A.A = B.B THEN  B.C  <=  A.C
C         TYPE 2 CELL - IF A.A = B.B THEN /B.C/ <= /A.C/
      ICOND = 1
      CALL SPCON2(ICOND,TS1,ABS(S13)+PC1,S23,ISPFIX,U(2),U(4),U(9),
     $            DUM1,DUM2,DUM3)
      IF(ISPFIX.EQ.1) GO TO 100
C
C     --- SPECIAL CONDITION (B) ...
C         TYPE 1 CELL - IF B.B = C.C THEN  A.C  <=  A.B
C         TYPE 2 CELL - IF B.B = C.C THEN /A.C/ <= /A.B/
      ICOND = 2
      CALL SPCON2(ICOND,TS2,ABS(S12)+PC1,S13,ISPFIX,U(1),U(6),U(8),
     $            DUM1,DUM2,DUM3)
      IF(ISPFIX.EQ.1) GO TO 100
C
C     --- SPECIAL CONDITION (C) ...
C         TYPE 1 CELL - IF  B.C  = 1/2B.B THEN A.B <= 2A.C
C         TYPE 2 CELL - IF /B.C/ = 1/2B.B THEN A.B = 0
      ICOND = 3
      IF(ITYPE.EQ.1) CALL SPCON2(ICOND,TS3,2.0*S13+PC1,S12,ISPFIX,
     $                           U(1),U(5),U(8),U(9),DUM1,DUM2)
      IF(ITYPE.EQ.2) CALL SPCON2(ICOND,TS3,VAR90,COSG,ISPFIX,
     $                           U(5),U(8),U(9),U(1),DUM1,DUM2)
      IF(ISPFIX.EQ.1) GO TO 100
C
C     --- SPECIAL CONDITION (D) ...
C         TYPE 1 CELL - IF  A.C  = 1/2A.A THEN A.B <= 2B.C
C         TYPE 2 CELL - IF /A.C/ = 1/2A.A THEN A.B = 0
      ICOND = 4
      IF(ITYPE.EQ.1) CALL SPCON2(ICOND,TS4,2.0*S23+PC1,S12,ISPFIX,
     $                           U(1),U(5),U(7),U(9),DUM1,DUM2)
      IF(ITYPE.EQ.2) CALL SPCON2(ICOND,TS4,VAR90,COSG,ISPFIX,
     $                           U(1),U(7),U(9),U(5),DUM1,DUM2)
      IF(ISPFIX.EQ.1) GO TO 100
C
C     --- SPECIAL CONDITION (E) ...
C         TYPE 1 CELL - IF  A.B  = 1/2A.A THEN A.C <= 2B.C
C         TYPE 2 CELL - IF /A.B/ = 1/2A.A THEN A.C = 0
      ICOND = 5
      IF(ITYPE.EQ.1) CALL SPCON2(ICOND,TS5,2.0*S23+PC1,S13,ISPFIX,
     $                           U(1),U(4),U(9),U(5),DUM1,DUM2)
      IF(ITYPE.EQ.2) CALL SPCON2(ICOND,TS5,VAR90,COSB,ISPFIX,
     $                           U(1),U(4),U(5),U(9),DUM1,DUM2)
      IF(ISPFIX.EQ.1) GO TO 100
C
C     --- SPECIAL CONDITIONS (A)-(E) HAVE BEEN SATISFIED.
C         REDUCTION IS COMPLETE FOR A TYPE 1 CELL.
      IF(ITYPE.EQ.1) GO TO 600
C
C        --- SPECIAL CONDITION (F) ... APPLIES ONLY FOR TYPE 2 CELL
C            IF (/B.C/ + /A.C/ + /A.B/) = 1/2(A.A + B.B) ,
C            THEN A.A <= (2/A.C/ + A.B)
         ICOND = 6
         CALL SPCON2(ICOND,TS6,TS7,S11,ISPFIX,
     $              U(1),U(5),DUM1,U(7),U(8),U(9))
         IF(ISPFIX.EQ.1) GO TO 100
C
C
  600 CONTINUE
      RETURN
 1000 FORMAT(/1X,'*SPCOND* WARNING ... Cell may not be reduced - Check a
     $ll conditions for reduction.'/1X,21X,'Program error when satisfyin
     $g Special Conditions.'
     $/1X,21X,'The program constant (PC1) may be incorrectly set for thi
     $s computer.'/)
      END
      SUBROUTINE SPCON2(ICOND,EXP1,EXP2,EXP3,ISPFIX,ELE1,ELE2,ELE3,ELE4,
     $                  ELE5,ELE6)
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
      DATA PC2/0.0005/
C
C
C     SUBROUTINE 'SPCON2' ...
C        CHECK AND, IF NECESSARY, SATISFY SPECIAL CONDITIONS
C        FOR REDUCTION
C
C
C
C     --- WHEN A SPECIAL RELATIONSHIP IN THE CELL MATRIX OCCURS,
C         CHECK, AND IF NECESSARY SATISFY, THE SPECIAL CONDITION
      IF(EXP1.GT.PC2) GO TO 100
C**
C        --- FOR CHECKING, WRITE EXECUTION POINT, SPECIAL CONDITION
C            NUMBER, INTERMEDIATE VARIABLES
         IF(ICK027.EQ.1) CALL CKPT02(30+ICOND)
C
         IF(EXP2.GE.ABS(EXP3)) GO TO 100
C
C           --- FAILED ... NOW SATISFY SPECIAL CONDITION
            ELE1 = -1.0
            ELE2 = -1.0
            ELE3 = -1.0
            ELE4 =  1.0
            ELE5 =  1.0
            ELE6 =  1.0
C
C           --- UPDATE THE TOTAL TRANSFORMATION MATRIX AND
C               APPLY THE RESULTING MATRIX TO THE INPUT CELL
            CALL MULTIP
            CALL TRANS(0)
C**
C           --- FOR CHECKING, WRITE EXECUTION POINT AND INTERMEDIATE
C               VARIABLES
            IF(ICK028.EQ.1) CALL CKPT02(11)
C
            CALL NORMAL
            ISPFIX = 1
  100 CONTINUE
      RETURN
      END
      SUBROUTINE TRANS(IPRTRA)
      COMMON /CELLI/ AI,BI,CI,ALPHI,BETI,GAMI,VOLI
      COMMON /CELLF/ AF,BF,CF,ALPHF,BETF,GAMF,VOLF
      COMMON /CONST1/ RADIAN
      COMMON /COSANG/ COSA,COSB,COSG
      COMMON /DOTP/ S11,S22,S33,S23,S13,S12
      COMMON /MATR1/ U1,V1,W1,U2,V2,W2,U3,V3,W3
      COMMON /PROB2/ IPCH,NUNK
      COMMON /UNIT2/ IUNITB
      COMMON /UNIT4/ IUNITD
C**
      COMMON /CK02/ ICK021,ICK022,ICK023,ICK024,ICK025,ICK026,ICK027,
     $              ICK028,ICK029
C
C
C     SUBROUTINE 'TRANS' ...
C        TRANSFORM INITIAL CELL PARAMETERS
C
C     THE INITIAL CELL (AI,BI,CI,ALPHI,BETI,GAMI) IS TRANSFORMED BY
C     THE MATRIX (U1,V1,W1 / U2,V2,W2 / U3,V3,W3)
C
C
C     --- WRITES:
C         IUNITD (=10)  (REDUCED CELLS,
C                       ONLY WHEN EXECUTING LM PROGRAM FUNCTION
C                       AND SEARCHING 1-LINE DATABASE)
C
C
C
C     --- CALCULATE DETERMINANT AND CHECK FOR A VALID
C         TRANSFORMATION MATRIX. FOR THE LM PROGRAM FUNCTION, THE
C         PROGRAM EXECUTION IS STOPPED IN *DETERM* IF THE DETERMINANT
C         IS NOT GREATER THAN ZERO (SHOULD NOT OCCUR)
      CALL DETERM
C
      AR = ALPHI/RADIAN
      BR = BETI/RADIAN
      GR = GAMI/RADIAN
C
C     --- CALCULATE A
      CALL DOT (U1,V1,W1,U1,V1,W1,AI,BI,CI,AR,BR,GR,S11)
      AF = SQRT(S11)
C
C     --- CALCULATE B
      CALL DOT (U2,V2,W2,U2,V2,W2,AI,BI,CI,AR,BR,GR,S22)
      BF = SQRT(S22)
C
C     --- CALCULATE C
      CALL DOT (U3,V3,W3,U3,V3,W3,AI,BI,CI,AR,BR,GR,S33)
      CF = SQRT(S33)
C
C     --- CALCULATE ANGLE BETWEEN AF AND BF (GAMMA)
      CALL DOT (U1,V1,W1,U2,V2,W2,AI,BI,CI,AR,BR,GR,S12)
      COSG = S12/(AF*BF)
      GAMF = (ACOS(COSG))*RADIAN
C
C     --- CALCULATE ANGLE BETWEEN AF AND CF (BETA)
      CALL DOT (U1,V1,W1,U3,V3,W3,AI,BI,CI,AR,BR,GR,S13)
      COSB  = S13/(AF*CF)
      BETF = (ACOS(COSB))*RADIAN
C
C     --- CALCULATE ANGLE BETWEEN BF AND CF (ALPHA)
      CALL DOT (U2,V2,W2,U3,V3,W3,AI,BI,CI,AR,BR,GR,S23)
      COSA = S23/(BF*CF)
      ALPHF = (ACOS(COSA))*RADIAN
C
C     --- CALCULATE VOLUME
      VOLF = AF*BF*CF*SQRT(1.0 - COSG**2 - COSB**2 - COSA**2 +
     $       2.0*COSA*COSB*COSG)
C
      IF(IPRTRA.EQ.0) GO TO 400
C
C        --- WRITE OUTPUT
         CALL OUTPT1(11)
         CALL INVERS(1)
         CALL OUTPT1(13)
C
C        --- OPTIONAL WRITE OF REDUCED CELLS ON IUNITD
C            (ONLY FOR LATTICE MATCHING)
         IF(IPCH.EQ.1) WRITE(IUNITD,1100) AF, BF, CF, ALPHF,
     $      BETF, GAMF, VOLF
         IF(IPCH.EQ.1) NUNK = NUNK + 1
C**
C        --- ONLY FOR SPECIAL CHECK RUN, WRITE REDUCED CELL,
C            TRANSFORMATION MATRIX FROM INITIAL CELL TO REDUCED
C            CELL, PROBLEM SEQUENCE NUMBER ON IUNITD
         IF(ICK029.NE.1) GO TO 400
            NUNK = NUNK + 1
            WRITE(IUNITD,1200) AF,BF,CF,ALPHF,BETF,GAMF,
     $            U1,V1,W1,U2,V2,W2,U3,V3,W3, NUNK
  400 CONTINUE
      RETURN
 1100 FORMAT(6F10.5,F10.2)
C**
 1200 FORMAT(6F10.5,2X,9F7.2,2X,I5)
       END
      SUBROUTINE VOLUME(AX,BX,CX,ALPHX,BETX,GAMX,VOLX)
      COMMON /CONST1/ RADIAN
      COMMON /ERR1/ IERR1
      COMMON /UNIT2/ IUNITB
C
C
C     SUBROUTINE 'VOLUME' ...
C          CALCULATE CELL VOLUME - THESE CALCULATIONS
C          ARE ALSO USED TO CHECK FOR VALID INPUT DATA
C
C
C
C     --- INITIALIZE VARIABLES
      VOLX = 0.0
      IERR1 = 0
C
C     --- WHEN ONE OR MORE CELL EDGES ARE <= 0.01,
C         SET ERROR FLAG AND DO NOT CALCULATE VOLUME
      IF(AX.GT.0.01.AND.BX.GT.0.01.AND.CX.GT.0.01) GO TO 100
         IERR1 = 1
         GO TO 400
  100 CONTINUE
C
C     --- WHEN ONE OR MORE CELL ANGLES ARE <= 0.1 OR >=180.0,
C         SET ERROR FLAG AND DO NOT CALCULATE VOLUME
      IF(ALPHX.GT.0.1.AND.ALPHX.LT.180.0.AND.BETX.GT.0.1.AND.BETX.LT.
     $   180.0.AND.GAMX.GT.0.1.AND.GAMX.LT.180.0) GO TO 200
         IERR1 = 1
         GO TO 400
  200 CONTINUE
C
C      --- CALCULATE THE COSINES OF THE CELL ANGLES
      COS1 = COS(ALPHX/RADIAN)
      COS2 = COS(BETX/RADIAN)
      COS3 = COS(GAMX/RADIAN)
C
C     --- IF THE INTERMEDIATE EXPRESSION (TEM) IS GREATER THAN ZERO,
C         CALCULATE THE CELL VOLUME ... OTHERWISE, SET ERROR FLAG
C         SINCE DO NOT HAVE A LEGAL CELL
      TEM  = (1.0 - COS1**2 - COS2**2 - COS3**2 + 2.0*COS1*COS2*COS3)
      IF(TEM.GT.0.0) GO TO 300
         IERR1 = 1
         GO TO 400
  300 CONTINUE
      VOLX = AX*BX*CX*SQRT(TEM)
C
C     --- WRITE WARNING MESSAGE IF CALCULATED CELL VOLUME IS
C         EITHER VERY SMALL OR VERY LARGE
      IF(VOLX.LT.8.0.OR.VOLX.GT.50000.0) WRITE(IUNITB,1000)
  400 CONTINUE
      RETURN
 1000 FORMAT(/1X,'*VOLUME* WARNING ... Unusual cell volume has been calc
     $ulated.'/)
      END
	SUBROUTINE OUT80(RES)
C
C	TO OUTPUT THE NBSSEARCH MATCHES IN 80-COLUMN FORMAT

C	ITEMS USED TO READ IN ENCODED DATA
C

	BYTE RES(128),RESLTS(128)
	BYTE ASPEC,ORIENC,ZCODEC,DCODE,IX,OX,MX,AX,ELEM(47)
	BYTE ISYS,STRUC,SOUR,EDIT,RAD,METRIC,IR,YEAR,ISET
	INTEGER*2 IAA(6),IAR(6),IVOLR,IAC(6),NSPGC,ICARD,COMP,QUAL,IZC
	INTEGER*2 IDMA,IDXC,MAT
	DIMENSION AA(6),AR(6),AC(6)
	CHARACTER*2 QUALIT(9)
	CHARACTER*4 YR
	CHARACTER*5 ETC
	CHARACTER*6 CODEN
	CHARACTER*8 SPGC,RADIAT(5)
	CHARACTER*9 VOLPAG
	CHARACTER*12 SYSTEM(7)
	CHARACTER*13 STRUCT(3),CONDIT(3)
	CHARACTER*16 SOURCE(4)
	CHARACTER*68 JOURNL
	EQUIVALENCE (MAT,IR)

	COMMON /UNIT2/ IUNITB
	COMMON /UNIT5/ IDIRECT,ICODEN,ITABLE,ISRCH
	COMMON /LINE/ IAA,IAR,IAC,IVOLR,SPGC,NSPGC,IDMA,IDXC,
	1 CODEN,VOLPAG,YEAR,ISET,ICARD,IZC,COMP,MAT,NREC,ELEM
	EQUIVALENCE (IAA(1),RESLTS(1))
	DATA IDIRECT/2/,ICODEN/3/

	DATA ETC/' etc.'/
	DATA RADIAT/'No Info.','X-ray   ','Neutron ','Electron',
	1 'Gamma   '/
	DATA SYSTEM/'Triclinic   ','Monoclinic  ','Orthorhombic',
	1 'Tetragonal  ','Hexagonal   ','Rhombohedral','Cubic       '/
	DATA QUALIT/'A ','A-','B ','B-','C ','C-','D ','D-','F '/
	DATA SOURCE/'Not Specified   ','Single Crystal  ',
	1 'Powder Diffract.','Rietveld/Profile'/
	DATA STRUCT/'No Info.      ','Limited Info.','Determined   '/
	DATA CONDIT/'             ','High/Low Temp','High Pressure'/


C	CONVERT CODED ITEMS INTO PRINTABLE CHARACTERS


C	FOR REASONS I DONT UNDERSTAND, THE VAX COMPILER IS UNHAPPY ABOUT
C	EQUIVALENCING RESLTS(1) AND IAA(1) DIRECTLY.  IF THIS WERE A
C	PROGRAM INSTEAD OF A SUBROUTINE, THEN IT'S OK.  I DON'T HAVE
C	TIME TO SORT OUT THE COMPILER'S PROBLEM NOW -- I'VE CREATED A
C	DUMMY ARRAY, RES, TO GET THE INFO INTO THE ARRAY RESLTS.


	DO 5 I=1,128
5	RESLTS(I)=RES(I)

C	DECODE PACKED INFORMATION IN COMP AND MAT

	RAD = IBITS(COMP,0,3)
	SOUR = IBITS(COMP,3,2)
	SOUR=SOUR+1
	STRUC = IBITS(COMP,5,2)
	STRUC=STRUC+1
	ISYS = IBITS(COMP,7,3)
	QUAL = IBITS(COMP,10,4)
	EDIT = IBITS(COMP,14,2)
	EDIT=EDIT+1
	IX = IBITS(MAT,0,1)
	OX = IBITS(MAT,1,1)
	MX = IBITS(MAT,2,1)
	AX = IBITS(MAT,3,1)

C	CONVERT UNIT CELL PARAMETERS -- THOSE PARAMETERS WHICH SEEMED
C	OUT OF LINE AND WHICH WERE TOO BIG TO BE PACKED INTO AN INTEGER
C	ARE ASSIGNED 999.99.

	IVA=0
	IVC=0
	IVR=0
	DO 302 J=1,6
	AA(J)=0.01*IAA(J)
	AC(J)=0.01*IAC(J)
	AR(J)=0.01*IAR(J)
	IF (AA(J).EQ.-1.) THEN
	AA(J)=-999.99
	IVA=1
	ENDIF
	IF (AC(J).EQ.-1.) THEN
	AC(J)=-999.99
	IVC=1
	ENDIF
	IF (AR(J).EQ.-1.) THEN
	AR(J)=-999.99
	IVR=1
	ENDIF
302	CONTINUE
	IF (IVA.EQ.0) CALL VOLM (AA,VOLA)
	IF (IVA.EQ.1) VOLA=-9999.
	IF (IVC.EQ.0) CALL VOLM (AC,VOLC)
	IF (IVC.EQ.1) VOLC=-9999.
	VOLR=IVOLR
	IF (IVR.EQ.1) VOLR=-9999.

C	SET UP REFERENCE INFORMATION

	IF (YEAR.EQ.0) YR='    '
	IF (YEAR.LT.0) YR='9999'
	IF (YEAR.GT.0) THEN
	IYR=1900+YEAR
	ENCODE(4,304,YR) IYR
304	FORMAT (I4)
	ENDIF
	CALL MCODEN (CODEN,JOURNL)

C	TOTAL LENGTH OF REFERENCE CANNOT EXCEED 68 CHARACTERS IN PRINTED
C	TEXT.  SINCE I ALWAYS WANT THE PAGE AND DATE, I HAVE LIMITED THE
C	JOURNAL TITLE TO 53 CHARACTERS -- THIS MAY BE A PROBLEM.

	L = LENGTH(JOURNL,53)
	JOURNL(L+1:L+1)=' '
	JOURNL(L+2:L+10)=VOLPAG(1:9)
	JOURNL(L+11:L+11)=' '
	JOURNL(L+12:L+15)=YR(1:4)


C	GET OTHER ODDS AND ENDS

	DMA=0.001*IDMA
	DXC=0.001*IDXC
	ZC=0.01*IZC
	ASPEC=' '
	IF (NSPGC.LT.0) THEN
	NSPGC=-NSPGC
	ASPEC='*'
	ENDIF

C       GGJJ CHANGE AUG 11, 1988
        METRIC=' '
	IF (IR.LT.0) THEN
	IR=-IR
	METRIC='X'
	ENDIF


C	HANDLE CHEMISTRY?




C	WRITE OUT INFORMATION

	IF (ELEM(47).EQ.'*') WRITE(IUNITB,311) (ELEM(J),J=1,46),ETC,ZC
311	FORMAT (/' FORMULA:',3X,46A1,A,5X,'Z: 'F6.2)
	IF (ELEM(47).NE.'*') WRITE (IUNITB,312) ELEM,ZC
312	FORMAT (/' FORMULA:',3X,47A1,9X,'Z: 'F6.2)
	WRITE (IUNITB,315) AR,VOLR,IR
315	FORMAT (' REDUCED CELL:'6F8.2,F7.0,2X,'REDFM: 'I2)
        IF(QUAL.LT.1.OR.QUAL.GT.9) QUAL=9
	WRITE (IUNITB,320) AA,VOLA,QUALIT(QUAL)
320	FORMAT (' AUTHORS CELL:',6F8.2,F7.0,2X,'QLESD: 'A)
	WRITE (IUNITB,330) AC,VOLC,METRIC
330	FORMAT (' CRY-DAT CELL:',6F8.2,F7.0,2X,'METRIC: 'A1)
	IF (ASPEC.NE.'*') WRITE (IUNITB,335) SYSTEM(ISYS),
	1 SPGC,NSPGC,DMA,DXC
335	FORMAT (' SYSTEM: 'A,3X,'SP.GRP: 'A,3X,'NUMBER: 'I3,3X,
	1 'DM: 'F6.3,3X,'DX: 'F6.3)
	IF (ASPEC.EQ.'*') WRITE (IUNITB,336) SYSTEM(ISYS),
	1 SPGC,NSPGC,DMA,DXC
336	FORMAT (' SYSTEM: 'A,3X,'ASPECT: 'A,3X,'NUMBER: 'I3,3X,
	1 'DM: 'F6.3,3X,'DX: 'F6.3)
	WRITE (IUNITB,345) SOURCE(SOUR),STRUCT(STRUC),CONDIT(EDIT)
345	FORMAT (' SOURCE: 'A,3X,'STRUCTURE: 'A,3X,'CONDITIONS: 'A)
	WRITE (IUNITB,350) JOURNL
350	FORMAT (' JOURNAL:',3X,A68)
	WRITE (IUNITB,360) NREC
360	FORMAT (' RECORD: '3X,I7)


390	CONTINUE
400   CONTINUE
401   CONTINUE
C
C
C
	RETURN
      END




	SUBROUTINE VOLM(CELL,V)
C	****************************************************************

	DIMENSION CELL(6)
	DATA RAD/0.0174533/

	COSAL=COS(CELL(4)*RAD)
	COSBE=COS(CELL(5)*RAD)
	COSGA=COS(CELL(6)*RAD)
	COS2AL=COSAL*COSAL
	COS2BE=COSBE*COSBE
	COS2GA=COSGA*COSGA
	CTERM=2.0*COSAL*COSBE*COSGA
	STUFF=1.0-COS2AL-COS2BE-COS2GA+CTERM
	V=CELL(1)*CELL(2)*CELL(3)*SQRT(STUFF)
	RETURN
	END



	SUBROUTINE MCODEN (CODEN, JOURNL)
C **********************************************************************
C
C	MATCHES CODEN(A6) WITH REFERENCES IN THE CODEN FILE: ONEFILE.DAT
C
C
	IMPLICIT INTEGER (A-Z)
	COMMON /UNIT5/ IDIRECT,ICODEN,ITABLE,ISRCH
	CHARACTER*6	CODEN, INCDN
	CHARACTER*68	JOURNL

C
C	...READ CODEN-JOURNAL FILE UNTIL CODENS MATCH
	L = 1
	U = 1767

3000	IF(L .GT. U) GO TO 20
	M = (L + U)/2
	READ (ICODEN, 1200, REC=M) INCDN, JOURNL
1200	FORMAT(A6,1X,A54)
C
	IF(LGT(CODEN,INCDN)) THEN
	   L=M+1
	ELSE IF(LLT(CODEN,INCDN)) THEN
	   U=M-1
	ELSE
	   GO TO 9000
	ENDIF
	GO TO 3000


C
C-----END OF CODEN FILE FOUND WITHOUT MATCHING CODENS
C
20	JOURNL = '***misspelled or not in coden file***'
	GO TO 9000

9000	CONTINUE
	RETURN
	END




      FUNCTION LENGTH (STRING,MAXLEN)
C **********************************************************************
C
C          ROUTINE TO FIND THE LENGTH OF A CHARACTER STRING.
C          THE LENGTH IS DEFINED AS THE POSITION OF THE LAST
C          NON-BLANK CHARACTER.  LENGTH=0 IF STRING IS BLANK.
C
      IMPLICIT  INTEGER (A-Z)
      CHARACTER*1 STRING(MAXLEN)
C
      DO 400 I=MAXLEN,1,-1
      IF(STRING(I) .NE. ' ') THEN
         LENGTH = I
         RETURN
      ENDIF
400   CONTINUE

      LENGTH = 0
      RETURN
      END
