       PROGRAM LSQ90
C      ############################################################
C      #                                                          #
C      #                          MAIN                            #
C      #                                                          #
C      ############################################################
C*********************************************************************
C
C      FILENAME: LSQ90
C		FOR THE HTML*LSQ PROGRAM PACKAGE
C
C		WRITTEN: SUMMER 1982
C
C  ORIGINALY FROM THE GEOLOGICAL SURVEY BY APPLEMAN, HANDWERKER AND
C  EVANS
C
C  	C. R. Hubbard AND S. Ledderman		Summer 	1982
C
C  	Updated for CDC BY   M. K. Pagoaga    	Summer 	1985
C
C  	Updated for VAX BY   R. P. Sokol    	Summer 	1990
C
C	Updated for Vax BY   S.F. Alexander	Oct.	1990
C
C	Purpose:	LSQ90 a component of the HTML*LSQ Program Package,
C			has several functions. (1) Indexes the observed
C			lines based on a trial cell and space group
C			(2) Refines the trial cell (3) Calculates figures-
C			of-merit (4) Updates PKN file with new cell and
C			hkl's, and (5) Calculates allowed lines given a cell
C			and space group
C
C	Contact:	Camden R. Hubbard
C			HTML: Oak Ridge National Laboratory
C			Bdlg 4515, MS 6064
C			P.O. Box 2008
C			Oak Ridge, TN 37831-6064
C			(615)-574-4472
C
C************************************************************************
C
C  INPUT-OUTPUT UNIT NUMBERS ARE SET IN SUBROUTINE BLOCK5
C
C  NTOUT IS FOR THE TERMINAL OR FILE OUTPUT (USER SPECIFIED)
C  NTIN  IS FOR THE TERMINAL INPUTS OR CARD INPUT IF BATCH MODE
C  NTEXT IS CONNECTED TO FILE  CRYEXTN VIA AN OPEN STATEMENT
C        IN THIS MAIN ROUTINE (JUST BEFORE LABEL 12).
C  IOPKS IS CONNECTED TO THE USERS PKS FILE IN SUBROUTINE PKREAD
C
C***********************************************************************
C
C  ****POSSIBLE NONSTANDARD ITEMS****
C
C  1. SUBROUTINE DATIM.  CALLS SYSTEM DATE TIME ROUTINE. 
C
C  2. LOGICAL UNIT NUMBER ASSIGNMENTS (SEE ABOVE AND SUBROUTINE BLOCK5)
C
C  3. FILE NAME FOR THE HKL EXTINCTION CONDITION FILE WE CALL CRYEXTN
C     SEE OPEN STATEMENT JUST BEFORE LABEL 12 BELOW.
C
C  4. FILE NAME FOR THE PKS FILE WHICH HAS THE FORM  A#####.PKN
C     SEE OPEN STATEMENT IN SUBROUTINE PKREAD
C
C***************************************************************************
C
C
C            ROUTINES USED ONLY FOR PKS FILE INPUT AND OUTPUT
C
C
C   PKREAD---RDPKS
C
C   FNINPK---SRMTCH---PMATCH
C
C   UPDPKS
C
C  THE ROUTINES PKREAD,UPDPKS AND FNINPK CAN BE REPLACED BY DUMMY ROUTINES
C  IF THE PKFILE INPUT OPTION IS NEVER TO BE USED
C
C  IF THESE SUBROUTINES ARE REPLACED BY DUMMY ROUTINES THEN ALSO
C  COMMENT OUT THE "PEAK FILE PARAMETERS" TO ELIMINATE ARRAY
C  STORAGE OF ITEMS REQUIRED ONLY BY THESE ROUTINES.
C
C----------------------------------------------------------
      PARAMETER (MAXOBS=200, MAXGEN=1000, MAXPKS=300)
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKJ/TOLMN,TOLMX
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/CBLKC/FLAG(MAXOBS)
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/CPPCON/IALF12
      COMMON/EDITR/IED1(6)
      COMMON/LSQRD/CARD,ITEST
      COMMON/IERRS/IWARN,IERR
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/PKNAME/PCLNAM
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/SWFG/DEGRAD
      COMMON/UNQ/IFA,IFB,IFC,IRH
C-------------------------------------------------------------
C  PEAK FILE PARAMETERS
C
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/PKFIL/NAME,CRSYS,TMTMMX,TMTMMN
      COMMON/REFPRM/NRGRF,NRCPP,NRCBER,NRCGRP,NRGNT,IREV
      COMMON/TEMPRT/NTMMS,AVTMP,SDTMPR,TMPRMX,TMPRMN
C
      CHARACTER*7 PCLNAM
      CHARACTER*4 TMTMMX,TMTMMN
      CHARACTER*1 CRSYS
      CHARACTER*40 NAME
      CHARACTER*6 NPFLG
C
C  END OF PEAK FILE PARAMETRS.
C-------------------------------------------------------------
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, ITEST, IALF12,ICOND(10)
      CHARACTER*5 CSC,ICRYST
      CHARACTER*3 ICLASS(10)
      CHARACTER*80 IHEAD
      CHARACTER*80 CARD
      CHARACTER*1 IED1,IBLANK,ICENT
      CHARACTER*2 FLAG
      CHARACTER*5 WTLABL(3)
      CHARACTER OUTFIL*80
      CHARACTER*1 RESP  
      CHARACTER*60 PATH, FLNAME
      DIMENSION JCLASS(27),JCOND(27),XO(3)
      LOGICAL GOOD,RGOOD,SYSEXT,DONE
      REAL TEMP(3)
      DATA (ICLASS(L),L=1,10)/'HKL','HHL','0KL','H0L','HK0','HH0','H00',
     * '0K0','00L','HLL'/,(ICOND(L),L=1,10)/'   H+K','   H+L','   K+L',
     * ' H+K+L','-H+K+L','     H','     K','     L','  2H+L','  H+2L'/,
     * (JCLASS(L),L=1,27)/6*1,4*2,3*3,3*4,3*5,6,7,8,9,4*10/,(JCOND(L),
     * L=1,27)/1,2,3,0,4,5,6,8,2,9,7,8,3,6,8,2,6,7,1,6,6,7,8,6,8,2,10/
      DATA IBLANK/' '/
      DATA WTLABL/'INPUT','UNIT ','HESS'''/
C
C-----INITIALIZE AND OPEN EXTINCTION FILE
C
      DEGRAD = 57.295779
C-----NERRT IS THE NUMBER OF PROBLEM SETS WITH ERRORS
      NERRT=0
C-----SEMULT IS THE MULTIPLIER OF THE STANDARD ERROR TO SET TOL OF CYCLE
      SEMULT = 2.0
C
C     ************************************************************
C
C     THIS SECTION MAY BE MACHINE SPECIFIC, ON SOME MACHINES THE OPEN
C     STATEMENT IS A NO-OP.
C     THE FILE READ HERE, NTEXT, THE EXTINCTION FLAGS SHOULD BE
C     ATTACHED TO UNIT 14 TO BE READ AT THIS POINT.
C
C-----OPEN FILE CRYEXTN AND ATTACH LOGICAL UNIT NUMBER NTEXT
C-----THIS FILE IS THE HKL EXTINCTION FLAGS ORDERED BY SPACE GROUP  	
C
C	AT HTML THE FILE IS ON LOGICAL DISK POWD: IN DIRECTORY
C	[PUBLIC.EXE.LSQ.HTML]
C
      PATH = 'POWD:[PUBLIC.EXE.LSQ.HTML]'
      FLNAME = PATH(1:26) // 'CRYEXTN.CDS'
C
      PRINT*
      OPEN (UNIT = NTEXT, ERR = 900,
     * FILE = FLNAME ,READONLY, STATUS = 'OLD')
C
C     ************************************************************
C
      WRITE(*, 12)
 12   FORMAT(1H1,34X,'*** LSQ90 ***'/
     * 4X, 'A VERSION OF THE GEOLOGICAL SURVEY LATTICE PARAMETER',
     * ' LEAST SQUARES PROGRAM'/
     * 30X, ' OCTOBER 1990 REVISION '/
     * 22X, 'CAMDEN R. HUBBARD AND ROBERT P. SOKOL' /
     * 26X,'OAK RIDGE NATIONAL LABORATORY' /
     * 34X, 'P.O. BOX 2008'/ 29X, 'OAK RIDGE, TN 37831-6064' /
     & 34X, '(615) 574-4472')
C
C-----TOP OF PROGRAM FOR EACH PROBLEM SET
C
 10   CONTINUE
      WRITE (*, 14)
 14   FORMAT ('1', 'ENTER ONE OF THE FOLLOWING CODES (A6):'//
     * ' ','DEMAND  (INTERACTIVE MODE INPUT)'/
     * ' ','PKFILE  (PKN FILE INPUT MODE) **= <CR>, default = PKFILE'/
     * ' ','TITLE   (BATCH MODE INPUT VIA FORMATTED CARDS)'/
     * ' ','FINISH  (TERMINATE RUN)'/)
C
C-----INITIALIZE FOR EACH SET
C
      INPK=0
      IDOLSQ = 0
      DO I = 1, MAXOBS, 1
	INTN(I) = 0
	INTED(I) = IBLANK
	IHED(I) = IBLANK
      END DO
      IED1(2) = IBLANK
      SPGI = IBLANK
      SPGIN= IBLANK
      SPGIA= IBLANK
      DO I = 1, 7, 1
	ERRI(I) = 0.0
      END DO
      IJOB = 1
      IERR = 0
      IWARN= 0
      THTMX = 0.0
      TOLMN = 0.0
      TOLMX = 0.0
      NCYC = 0
C
C-----READ CARD INTO BUFFER
C
      READ (*, 1105) ITEST
 1105 FORMAT (A6)
C
C-----CHECK IF FINISH
C
      IF (ITEST .EQ. ' ') ITEST = 'PKFILE'
      IF (ITEST .EQ. IALF(5)) THEN 
        GOTO 990
      ENDIF
C
C-----CHOOSE SCREEN OR FILE MODE
C
 8769 PRINT*
      PRINT*, 'WOULD YOU LIKE SCREEN OR FILE OUTPUT?' 
      PRINT*, '  ENTER AN ''S'' FOR SCREEN OR AN ''F'' FOR FILE:'
      PRINT*, '  (DEFAULT = SCREEN)'
      READ(*, 9812, ERR=8770) RESP
 9812 FORMAT(A1)
      IF ((RESP .EQ. 'S') .OR. (RESP .EQ. ' ')) THEN
        NTOUT = 5
      ELSEIF (RESP .EQ. 'F') THEN
        NTOUT = 12
 8315   PRINT*,'ENTER AN OUTPUT FILENAME:'
        READ(*, 8320, ERR=8330) OUTFIL
 8320   FORMAT(A80)
        OPEN(12, FILE=OUTFIL, ERR=8331, STATUS='NEW')
      ELSE
 8770   PRINT*,'INVALID RESPONSE.  PLEASE TRY AGAIN.'
        GOTO 8769
      ENDIF
C
C-----CHECK IF DEMAND RUN
C
 1110 CONTINUE
      IF (ITEST .NE. IALF(10)) GO TO 1150
C
C-----DEMAND MODE RUN, CALL DMREAD
C
      CALL DMREAD
      GOTO 1500
C
C-----CHECK IF BATCH RUN
C
 1150 IF (ITEST .NE. IALF(1)) GO TO 1200
C
C-----BATCH TYPE RUN
C
      CALL BHREAD
C
C-----CLOSE REFLECTIONS FILE
C
      CLOSE(NTIN)
      GO TO 1500
C
C-----CHECK IF PKS RUN 
C 
 1200 IF (ITEST .NE. IALF(11)) GO TO 1250
      CALL PKREAD
      INPK=1
      GO TO 1500
C
C-----CHECK IF FINISH
C
 1250 CONTINUE
      IF (ITEST .NE. IALF(5)) GO TO 1350
      WRITE (*, 1260)
 1260 FORMAT ('0', 'JOB DONE')
      GO TO 990
C
C-----ILLEGAL CARD TO START SET
C
 1350 CONTINUE
      WRITE(NTOUT, 1360) ITEST
 1360 FORMAT (' ', '**ERROR**COLUMNS 1-6 OF FIRST CARD READ SHOULD BE '/
     *' ','"DEMAND OR PKFILE OR TITLE OR FINISH" NOT "',A6,'"')
C
C-----SEARCH FOR BATCH, DEMAND, PKS, OR END CARD
C
 1370 CONTINUE
      READ (*, 1105) ITEST, CARD
      IF ((ITEST .EQ. IALF(1)) .OR. (ITEST .EQ. IALF(10))
     * .OR. (ITEST .EQ. IALF(11)) .OR. (ITEST .EQ. IALF(5))) GO TO 1110
      GO TO 1370
C
C-----START PROCESSING SET
C
 1500 CONTINUE
C
C-----CHECK IF DATA READ WAS GOOD, IF NOT START NEW SET
C
      IF (.NOT. (RGOOD)) GO TO 10
C
C-----PRINT HEADING FOR THE PROBLEM
C
      WRITE (NTOUT, 455) IHEAD
 455  FORMAT ('0' / '0', 'TITLE OF SET: ' / 1X, A80 //)
      WRITE (NTOUT, 475) ICRYST
 475  FORMAT (' ', 'CRYSTAL SYSTEM = ', A5 / )
      IF(.NOT.SYSEXT) WRITE (NTOUT, 465) SPGI
 465  FORMAT (' ', 'SPACE GROUP = ', 3X, A8)
C
C-----SET ICRS AND IRH (SEE NBS*AIDS80 FOR DEFINITION)
C
 25   IF (ICRYST .EQ. CSC(1)) ICRS = ITCRS(7)
      IF (ICRYST .EQ. CSC(2)) ICRS = ITCRS(4)
      IF (ICRYST .EQ. CSC(3)) ICRS = ITCRS(3)
      IF (ICRYST .EQ. CSC(4)) ICRS = ITCRS(2)
      IF (ICRYST .EQ. CSC(5)) THEN
         ICRS = ITCRS(6)
         IRH  = 0
      END IF
      IF (ICRYST .EQ. CSC(6)) ICRS = ITCRS(1)
      IF (ICRYST .EQ. CSC(7)) ICRS = ITCRS(5)
      IF (ICRYST .EQ. CSC(8)) THEN
         ICRS = ITCRS(6)
         IRH = 1
      END IF
C
C-----CHECK THAT INPUT CELL IS REASONABLE.  USE SYMMETRY TO
C-----SET THE CONSTRAINED PARAMETERS.
C
      AI = AO(1)
      BI = AO(2)
      CI = AO(3)
      ALPHI = IDG(1) + FMN(1) / 60.0
      BETI = IDG(2) + FMN(2) / 60.0
      GAMI = IDG(3) + FMN(3) / 60.0
      CALL CELLCK(GOOD)
      IF (.NOT. GOOD) GO TO 10
C
C-----RESET ANY CHANGES MADE BY CELLCK
C
      AO(1) = AI
      AO(2) = BI
      AO(3) = CI
      IDG(1) = INT(ALPHI)
      FMN(1) = 60.0 * (ALPHI - REAL(IDG(1)))
      IDG(2) = INT(BETI)
      FMN(2) = 60.0 * (BETI - REAL(IDG(2)))
      IDG(3) = INT(GAMI)
      FMN(3) = 60.0 * (GAMI - REAL(IDG(3)))
      DO 35 L=1,3
 35   ALO(L) = REAL(IDG(L))*60.0 + FMN(L)
C
C-----CALL PRMCHK TO SET UP HKL GENERATION CONTROL VARIABLES ITYP + JTYP
C
      CALL PRMCHK(ICRS,NLSQV,ITYP,JTYP)
C
C-----IF SYSTEMATIC EXTINCTION CONDITIONS WERE INPUT EXPLICITLY SKIP
C-----ELSE USE SPACE GROUP, ASPECT OR CENTERING SYMBOL TO GENERATE
C-----THE EXTINCTION CONDITIONS AUTOMATICALLY
C
      IF (SYSEXT) GO TO 21
C
C-----IF RHOMBOHEDRAL SYSTEM ON RHOMBOHEDRAL AXES THEN EXTINCTIONS MUST
C-----BE INPUT EXPLICITLY WITH SYSEXT CARD
C
      IF (ICRYST.EQ.CSC(5)) THEN
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,26)   
          ENDIF
          WRITE(NTOUT,26)
 26      FORMAT('0','**WARNING**EXTINCTION CONDITIONS FOR RHOMBOHEDRAL',
     *   ' LATTICE NOT IN FILE**WARNING**'/ ' ',11X,
     *   'YOU MAY WISH TO EXPLICITLY INPUT THEM USING SYSEXT CARD')
         IWARN = IWARN + 1
         GOTO 21
      END IF
      CALL CHKSPG
      IPASS = 1
      CALL SPG(SPGI,SPGIN,SPGIA,ICRS, IPASS)
C
C-----TEST THAT THE INPUT SPACE GROUP WAS IN THE FILE FROM NBS*AIDS80
C
      IF (SPGIN.EQ.'  0 ') THEN
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,27) SPGI
          ENDIF
          WRITE(NTOUT,27) SPGI
 27      FORMAT('0','**WARNING** INPUT SPACE GROUP "',A8,'" WAS NOT IN',
     *   ' THE FILE **WARNING**')
         IWARN=IWARN+1
         IF(SPGI(1:1).EQ.' ') GOTO 21
      END IF
C-----SEARCH FILE CRYST*EXTNS FOR THE EXTINCTION CONDITION FLAGS
      CALL FINDEX
C
C-----SET IOP, JOP AND NOPT EXTINCTION CONDITION VARIABLES
C
 21   CONTINUE
      CALL OPSET
C
C-----TEST THAT INPUT HKL ARE ALLOWED
C
      CALL HKLES
 45   IALF12=IALF(ITHT+6)
      IMN=((NLSQV+3)*NLSQV)/2
      DO 55 L=1,3
      AD(L)=AO(L)
      ALS(L)=ALO(L)
      ARAD=0.00029088821*ALO(L)
      CSA(L)=COS(ARAD)
 55   SNA(L)=SIN(ARAD)
      CALL RSCMP
      DO 60 L=1,3
      UO(L)=U(L)
 60   XO(L)=X(L)
      VRO=VR
      VCO=VC
      WRITE(NTOUT,122)
 122  FORMAT(1H0,17X,1HA,8X,1HB,8X,1HC,6X,5HALPHA,5X,4HBETA,6X,
     * 5HGAMMA,5X,6HVOLUME)
      PRINT*
      DO 6 I=1,3
          AR(I)=3437.7468*(1.5707963-ATAN2(U(I),SQRT(1.0-U(I)**2)))            
          TEMP(I) = AR(I) / 60.0
 6    CONTINUE
      WRITE(NTOUT,64) (X(I),I=1,3),(TEMP(I),I=1,3),VR
 64   FORMAT(11H RECIP CELL,2X,3(F8.5,1X),1X,F8.4,2X,F8.4,2X,
     & F8.4,1X,E11.4)
      PRINT*
      DO 5  L=1,3
          TEMP(L) = ALS(L) / 60.0
 5    CONTINUE
      WRITE(NTOUT,7) (AD(L),L=1,3),(TEMP(L),L=1,3),VC
 7    FORMAT (' ', 'DIRECT CELL', 3(F9.5),2X,F8.4,2X,F8.4,2X,
     & F8.4, 1X, E11.4)
      CALL SORT
      IF(NUMOBS.EQ.0) GOTO 42
C
C-----CALC THEMX AND DMIN
C-----ADD 0.5 DEG THETA TO OBSTH(MAX) TO ASSURE THAT ALL HKL ARE GENERAT
C
      THEMO = OBSTH(NUMOBS) + 0.5
      THEMX = AMAX1(THEMX, THEMO)
 42   IF (THEMX .LT. 0.01 .OR. THEMX .GT. 90.0) THEMX = 89.0
      DMIN = 0.5*PWL/SIN(THEMX/57.296)
C
C-----CALCULATE THE APPROXIMATE NUMBER OF REFLECTIONS TO BE GENERATED
C-----FOR THIS LATTICE AND CRYSTAL SYSTEM.
C-----# IN SPHERE = (4/3)*PI*VC/DMIN**3
C----- FUDGE FACTOR  IS USED TO COMPENSATE FOR ZONE REFLECTIONS
C-----MULTPL IS THE GENERAL REFLECTION MULTIPLICITY FOR THE CRYSTAL SYSTEM
C
C     ANORTHIC = TRICLINIC
      MULTPL = 2
C-----MONOCLINIC
      IF (ICRS .EQ. ITCRS(2)) MULTPL = 4
C-----ORTHORHOMBIC
      IF (ICRS .EQ. ITCRS(3)) MULTPL = 8
C-----TETRAGONAL
      IF (ICRS .EQ. ITCRS(4)) MULTPL = 16
C-----HEXAGONAL
      IF (ICRS .EQ. ITCRS(5)) MULTPL = 24
C-----RHOMBOHEDRAL
      IF (ICRS .EQ. ITCRS(6) .AND. IRH .EQ. 1) MULTPL = 24
      IF (ICRS .EQ. ITCRS(6) .AND. IRH .EQ. 0) MULTPL =  8
C-----CUBIC
      IF (ICRS .EQ. ITCRS(7)) MULTPL = 48
C-----MODIFY MULTPL FOR CENTERING
      ICENT = SPGI(1:1)
C-----A, B, C, I-CENTERING
      IF(ICENT.EQ.ITSG(2).OR.ICENT.EQ.ITSG(3).OR.ICENT.EQ.ITSG(4).OR.
     * ICENT.EQ.ITSG(6)) MULTPL = 2*MULTPL
C-----F CENTERING
      IF(ICENT.EQ.ITSG(5)) MULTPL = 4*MULTPL
      DLIM = (1.333*3.14156*VC/(MULTPL*MAXGEN))**0.333
      IF(DMIN.GT.DLIM) GOTO 330
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,320) MAXGEN
      ENDIF
      WRITE(NTOUT,320) MAXGEN
 320  FORMAT('0','**MESSAGE**D/HKL-GENERATION LIMITED TO',I5,' REFLECTI
     *ONS - 2THETA(MAX) DECREASED' )
      DMIN = DLIM
      THEMX = THETA(0.5*PWL,DLIM)
 330  ANGLE=THEMX+THEMX
      IF (IDOLSQ .EQ. 1) WRITE(NTOUT,334) 2*THTMX,
     * NCYC,2*TOLMN,2*TOLMX,2*THEMX,DMIN
 334  FORMAT(24H02-THETA ANGLES  THTMX =,F6.1,8H  NCYC =,I2 / 
     * 9H  TOLMN =,F7.4,9H  TOLMX =,F7.4 /
     * 9H  THEMX =,F6.1,8H  DMIN =,F10.6)
      IF((IXPD.EQ.0) .AND. (IDOLSQ .EQ. 0)) WRITE(NTOUT,345) ANGLE,DMIN
 345  FORMAT(1H0,10X,13H2-THETA(MAX)=,F6.2,4X,7HD(MIN)=,F9.6)
      IF(IPHKL.NE.0) WRITE(NTOUT,340) IPHKL 
 340  FORMAT('0','PRINTING OF HKL, 2-THETA TABLE AFTER EACH',
     * ' CYCLE OMITTED.  (IPHKL = ', I2, ')')
      IF(IXPD.EQ.1) WRITE(NTOUT,341)
 341  FORMAT('0','PRINTING OF FINAL HKL TABLE OMITTED. (IXPD=1)')
      IF(NOINDX.EQ.1) WRITE(NTOUT,342)
 342  FORMAT('0','AUTO INDEXING TO BE USED.  ALL INPUT LINES',
     * ' CONSIDERED UNINDEXED')
      WRITE(NTOUT,343) WTLABL(IWTYP+1)
 343  FORMAT('0',A5,' WEIGHTS TO BE USED')
      IF(IWCYC.NE.0) WRITE(NTOUT,344) IWCYC
 344  FORMAT(' ','AND RESET TO UNIT WEIGHTS AFTER',I2,' CYCLES')
      IF(IXPD.EQ.0) WRITE(NTOUT,346) NOPT
 346  FORMAT(1H0,I2,' CONDITIONS FOR NON-EXTINCTION CALLED FOR ',
     *'CLASS CONDITION(S)')
      IF(NOPT .LT. 1) GO TO 361
      DO 360  L=1,NOPT
      J= JOP(L)
      I= JCLASS(J)
      K= JCOND(J)
      IF(K.GE.1 .AND. K.LE.10) GOTO 350
      IF(IXPD.EQ.0) WRITE(NTOUT,348) IOP(J), IOP(J), IOP(J)
 348  FORMAT(1H ,11X,12HHKL     H+K=,I1,6HN,H+L=,I1,6HN,K+L=,I1,1HN)
      GOTO 360
 350  IF(IXPD.EQ.0) WRITE(NTOUT,352) ICLASS(I),ICOND(K),IOP(J)
 352  FORMAT(1H ,20X,A4,1X,A6,1H=,I1,1HN)
 360  CONTINUE
 361  CONTINUE
 79   CALL HKLGEN
      CALL SORTD(NR,DCM,IHG)
      CALL SKWEZE
      TOL=TOLMX
      ICYCLE=0
      IF(IDOLSQ.EQ.0) GOTO 150
C
C-----BEGIN MAIN BODY OF ITERATIVE LEAST SQUARES ANALYSIS
C
 80   CALL SLCR
      IF (NUMOBS .LT. NLSQV) GO TO 92
      MMN=NUMCYC-NLSQV
      IF (MMN) 90,99,94
 90   IF ((ICYCLE.GE.10).OR.(ICYCLE.GT.NCYC.AND.TOL.LE.TOLMN))GO TO 92
      TOL=0.5*TOL
      IF (TOL .LT. TOLMN) TOL=TOLMN
      NCYC=0
      GO TO 80
 92   WRITE(NTOUT,93)
 93   FORMAT(12H0NO SOLUTION)
      GO TO 150
 94   J=NLSQV+1
      K=J
      DO 98 I=1,NLSQV
      AA(I)=A(K)
      J=J-1
 98   K=K+J
C
C-----SOLVE LS EQUATION
C
 99   CALL PDSQRT(A,NLSQV,B,IERR)
      IF (IERR .EQ. 0) GO TO 104
      WRITE(NTOUT,100) IERR
 100  FORMAT(38H0SINGULAR NORMAL EQUATION MATRIX - ROW,I2,
     * 36H LINEARLY DEPENDENT ON PREVIOUS ROWS)
      GO TO 90
C
C-----COMPUTE CORRECTIONS TO RECIPRICAL CELL PARAMETERS
C
 104  CALL COORD
      DO 120 J=1,3
          X(J)=X(J)+CR(J)
          U(J)=U(J)+CR(J+3)
          IF (X(J)) 106,106,109
 106  WRITE(NTOUT,108) J
 108  FORMAT(40H0CORRECTED VALUE OF RECIPROCAL CELL EDGE,I2,
     * 27H LESS THAN OR EQUAL TO ZERO)
      GO TO 114
 109  IF (ABS(U(J))-1.0) 120,110,110
 110  WRITE(NTOUT,112) J
 112  FORMAT(42H0CORRECTED VALUE OF RECIPROCAL CELL COSINE,I2,
     * 40H EQUALS OR EXCEEDS 1.0 IN ABSOLUTE VALUE)
 114  DO 116 K=1,J
      X(K)=X(K)-CR(K)
 116  U(K)=U(K)-CR(K+3)
      GO TO 90
 120  CONTINUE
C
C-----COMPUTE NEW CELL PARAMETERS
C
      CALL CMPNUP
      IF (MMN .GT. 0) GO TO 130
      TOL=0.5*TOL
      GO TO 140
 130  DO 134 I=1,NLSQV
 134  SUM=SUM-AA(I)*B(I)
      IF (SUM .LT. 0.0) SUM=0.0
      THTSE=SQRT(SUM/REAL(MMN))
      TOL=SEMULT*THTSE
 140  IF (TOL .LT. TOLMN) TOL=TOLMN
      IF (TOL .GT. TOLMX) TOL=TOLMX
      IF (ICYCLE .LE. NCYC) GO TO 160
      CRMAX=0.0
      DO 146 I=1,NLSQV
 146  IF (ABS( B(I)) .GT. CRMAX) CRMAX=ABS( B(I))
      IF (CRMAX .GE. 0.5E-6) GO TO 152
 149  IF (MMN .GT. 0) CALL SESUB
      DONE = .TRUE.
      CALL OUTPUT(DONE)
 150  IF( INPK .EQ. 0 ) CALL FNLST
       IF( INPK .EQ. 1 ) CALL FNINPK
      IF(IDOLSQ.EQ.1) CALL COMPAR
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,151) IWARN,IERR
      ENDIF
      WRITE(NTOUT,151) IWARN,IERR 
 151  FORMAT('0 *****TOTAL NUMBER OF WARNINGS=',I3, ' *****'/,
     *       '  *****TOTAL NUMBER OF ERRORS  =',I3, ' *****',/)
      IF(IERR.NE.0) NERRT = NERRT + 1
       IF( INPK .EQ. 1 ) CALL UPDPKS
      GO TO 10
 152  IF (ICYCLE .LT. 10) GO TO 160
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,154)
      ENDIF
      WRITE(NTOUT,154)
 154  FORMAT(28H0NOT CONVERGENT IN 10 CYCLES, ' ',
     * '**MESSAGE**FINAL LIST USES CELL PARAMETERS FROM CYCLE 9')
      GO TO 149
 160  CONTINUE
      DONE = .FALSE.
      CALL OUTPUT(DONE)
      CALL RCMPD
      CALL SORTD(NR,DCM,IHG)
      GO TO 80
C
C-----ERROR IN OPENING CRYEXTN FILE
C
 900  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 910) NTEXT
      ENDIF
      WRITE(NTOUT, 910) NTEXT
 910  FORMAT (' ', '**ERROR**ERROR OCCURED IN ASSIGNING EXTINCTION',
     * ' FILE TO UNIT ', I3, ' EXECUTION STOPPED**')
C
C-----WRITE SUMMARY OF ENTIRE RUN IN TERMS OF DECKS WITH ERRORS
C
 990  IF (NTOUT .EQ. 12) THEN
          WRITE(*,991) NERRT
      ENDIF
      WRITE(NTOUT,991) NERRT
 991  FORMAT(1H0,'##### TOTAL DECKS WITH ERRORS =',I3,' #####')
C
      CLOSE(UNIT=NTEXT)
      CLOSE(12)
      STOP
C
C-----ERROR READING OUTPUT FILENAME
C     
 8330 PRINT*,'ERROR READING OUTPUT FILENAME.  PLEASE TRY AGAIN.'
      GOTO 8315
C
C-----ERROR OPENING SPECIFIED OUTPUT FILE
C
 8331 PRINT*,'UNABLE TO OPEN THE SPECIFIED FILE.  PLEASE TRY AGAIN.'
      GOTO 8315
C
      END
      SUBROUTINE BADHKL(NUMDO, ISTART)
C      ############################################################
C      #                                                          #
C      #                          BADHKL                          #
C      #                                                          #
C      ############################################################
C
C-----CHECK IF DOBS-D CALC OF AUTHOR ASSIGNED HKL GREATER THAN 10*TOLTH
C-----AND IF SO LET PROGRAM REASSIGN HKL'S IF CAN
C
      PARAMETER (MAXOBS=200)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/IERRS/IWARN,IERR
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/FLAG(MAXOBS)
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*2 FLAG
      LOGICAL HEADNG
      DATA HEADNG /.TRUE./
C
C-----LOOP FOR ALL HKL'S
C
      DO 200 I = ISTART, NUMDO + ISTART - 1, 1
C
C-----SKIP IF NOT MARKED INDEXED
C
      IF ((IHED(I) .NE. ITIH(1)) .AND. (IHED(I) .NE. ITIH(2)) .AND.
     * (IHED(I) .NE. ITIH(3)) .AND. (IHED(I) .NE. ITIH(7))) GO TO 200
C
C-----SKIP IF NOT FLAGGED AS ' R'
C
      IF(FLAG(I).NE.' R') GOTO 200
C
C-----SKIP IF DELTA THETA < 10*TOLTH
C
      THCLC = THETA(CONST,DLST(I))
      DIFF = ABS (OBSTH(I) - THCLC)
      IF (DIFF .LE. (10.0 * TOLTH)) GO TO 200
C
C-----HKL'S POSSIBLY WRONG WRITE MESSAGE, FLAG, AND ZERO OUT HKL'S
C
      DIFF = DIFF * 2.0
      A = OBSTH(I) * 2.0
      IF(HEADNG) THEN 
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,49)
          ENDIF
          WRITE(NTOUT,49)
      ENDIF
 49   FORMAT('0','**WARNING** DELTA 2-THETA EXCEEDS 10*TOL.  LINE ',
     * 'MARKED AS UNINDEXED**WARNING**')
      HEADNG = .FALSE.
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 50) (IH(I,J), J = 1, 3), A, DIFF
      ENDIF
      WRITE(NTOUT, 50) (IH(I,J), J = 1, 3), A, DIFF
 50   FORMAT(' ','** BAD HKL=',3I4,' 2-THETA=',F7.3,
     * ' DELTA 2-THETA=', F7.3,' SET TO UNINDEXED**')
      IWARN = IWARN + 1
      IHED(I) = ITIH(4)
      DO 100 J = 1, 3, 1
      IH(I,J) = 0
 100  CONTINUE
 200  CONTINUE
      RETURN
      END
      SUBROUTINE BHREAD
C      ############################################################
C      #                                                          #
C      #                          BHREAD                          #
C      #                                                          #
C      ############################################################
C
C-----SUBROUTINE TO SIMULATE OLD BATCH READING OF LEAST SQUARE PROGRAM
C
      PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/LSQRD/CARD,ITEST
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN,TOLMX
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      LOGICAL RGOOD,SYSEXT,HGOOD
      CHARACTER*6 ITEST,IALF
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*80 CARD
      CHARACTER*80 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER FILNAM*80
C
C-----INITIALIZE
C
      RGOOD = .TRUE.
      NUMCRD = 2
      IDOLSQ = 0
      HKLED = ' '
C
C-----REQUEST DATA FILENAME, OPEN THE SPECIFIED FILE
C
 8898 PRINT*,'ENTER THE NAME OF THE REFLECTION DATA FILE.'
      READ (*, 8800) FILNAM
 8800 FORMAT (A80)
      OPEN (NTIN, FILE=FILNAM, ERR=8899, STATUS='OLD')
      READ (NTIN, 7000) ITEST, CARD
 7000 FORMAT (A6, A72)     
C
C-----REMOVE HEADING FROM CARD, AND ECHO
C
      IHEAD(1:80) = CARD(1:74)//'      '
C
C-----READ PARAM CARD
C
      READ (NTIN, 100) ITEST, CARD
 100  FORMAT (A6, A72)
C
C-----CHECK IF CELL ANGLES ENTERED IN DEGREES AND MINUTES
C
      IF (ITEST .EQ. IALF(2)) GO TO 200
C
C-----CHECK IF CELL ANGLES ENTERED IN DEGREES AND FRACTIONS
C
      IF (ITEST .EQ. IALF(9)) GO TO 250
C
C-----BAD CARD TYPE, WRITE ERROR MESSAGE AND LOOK FOR FINISH
C-----OR NEW TITLE CARD
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 150) NUMCRD, IALF(2), IALF(9), ITEST
      ENDIF
      WRITE(NTOUT, 150) NUMCRD, IALF(2), IALF(9), ITEST
 150  FORMAT (' ', '**ERROR**BAD CARD (#', I3, ') SHOULD BE ''', A6,
     * ''' OR ''', A6, ''' AND NOT ''', A6, 1H')
 155  CONTINUE
      READ (NTIN, 100) ITEST, CARD
      IF ((ITEST .NE. IALF(1)) .AND. (ITEST .NE. IALF(5))) GO TO 155
C
C-----NEW TITLE CARD OR START OVER, SET READ FLAG BAD
C
      RGOOD = .FALSE.
      RETURN
C
C-----READ PARAM CARD IN DEG. AND MIN.
C
 200  CONTINUE
      READ (CARD, FMT = 210, ERR = 900) (AO(I), I = 1,3),
     * (IDG(I), FMN(I), I = 1,3), ITHT, THTMX, NCYC, TOLMN, TOLMX, IPHKL
     * ,IXPD,NOINDX,RESOLV
 210  FORMAT (3F9.6, 3(I3, F5.3), I1, F3.0, I1, 2F5.4, 3I1, F5.3)
      GO TO 300
C
C-----READ CARD WITH DEG AND FRACTIONS, AND CONVERT TO DEGREES AND MIN
C
 250  CONTINUE
      READ (CARD, FMT = 260, ERR = 900) (AO(I), I = 1,3),
     * (ALO(I), I = 1,3), ITHT, THTMX, NCYC, TOLMN, TOLMX, IPHKL
     * ,IXPD,NOINDX,RESOLV
 260  FORMAT (3F9.6, 3F8.3, I1, F3.0, I1, 2F5.4, 3I1, F5.3)
      DO 270 I = 1, 3
      IDG(I) = INT(ALO(I))
      FMN(I) = 60.0 * (ALO(I) - REAL(IDG(I)))
 270  CONTINUE
C
C-----READ SYSEXT OR SPACEG CARD
C
 300  CONTINUE
      NUMCRD = NUMCRD + 1
      READ (NTIN, 100) ITEST, CARD
C
C-----SEE IF OLD TYPE SYSEXT CARD
C
      IF (ITEST .EQ. IALF(3)) GO TO 400
C
C-----SEE IF NEW SPACEG CARD
C
      IF (ITEST .EQ. IALF(12)) GO TO 450
C
C-----NOT EXPECTED CARD, FLAG AND SEARCH FOR FINISH OR TITLE CARD
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 150) NUMCRD, IALF(3), IALF(12), ITEST
      ENDIF
      WRITE(NTOUT, 150) NUMCRD, IALF(3), IALF(12), ITEST
      GO TO 155
C
C-----OLD SYSEXT CARD, ADD DEFAULT FOR SPGI(1)
C
 400  CONTINUE
      READ (CARD, FMT = 410, ERR = 900) ICRYST, THEMX, PWL,
     * (IOP(I), I = 1,27), PWL2, IWTYP, IWCYC
 410  FORMAT (A5, F3.0, F6.5, 27I1, 2X, F11.6, 2I2)
      SYSEXT = .TRUE.
      GO TO 470
C
C-----NEW SPACEG CARD, SET FLAG
C
 450  CONTINUE
      READ (CARD, FMT = 460, ERR = 900) ICRYST, THEMX, PWL,
     * SPGI, PWL2, IWTYP, IWCYC
 460  FORMAT (A5, F3.0, F6.5, 2X, A8, 3X, 16X, F11.6, 2I2)
      SYSEXT = .FALSE.
C
C-----SEE IF NEED TO SET DEFAULT VALUE
C
 470  CONTINUE
      ITHT=MOD(ITHT,2)
      IF (ITHT.NE.0) GO TO 50
      THTMX=0.5*THTMX
      TOLMN=0.5*TOLMN
      RESOLV = 0.5 * RESOLV
      TOLMX=0.5*TOLMX
      THEMX=0.5*THEMX
 50   IF (THTMX.LE.0.0) THTMX=20.0
      IF (NCYC.LT.1) NCYC=2
      IF (TOLMN.LE.0.0) TOLMN=0.015
      IF (TOLMX.LE.TOLMN) TOLMX=5.0*TOLMN
C
C  REVISION 23 FEB 1982 CRH. ADDED 2ND FIELD FOR PWL INPUT
C                            TEST HERE IF NON ZERO
       IF(PWL2.GT.0.1) PWL=PWL2
      IF  (PWL.LE.0.0) PWL=1.5405981
C
C-----CHECK THAT ICRYST IS LEGAL
C
      DO 480 I = 1, 8, 1
      IF (ICRYST .EQ. CSC(I)) GO TO 500
 480  CONTINUE
C
C-----NOT LEGAL, FLAG AND SKIP GROUP
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 490) ICRYST, NUMCRD
      ENDIF
      WRITE(NTOUT, 490) ICRYST, NUMCRD
 490  FORMAT (' ', '**ERROR**CRYSTAL SYSTEM = ''', A5, ''' ON SYSEXT',
     * '(CARD # ', I2, ') IS ILLEGAL, SET SKIPPED')
      RGOOD = .FALSE.
      RETURN
C
C-----READ REFLECTION CARDS
C
 500  CONTINUE
      NUMOBS = 0
 510  CONTINUE
      NUMCRD = NUMCRD + 1
      READ (NTIN, 100) ITEST, CARD
C
C-----CHECK IF HIT END CARD
C
      IF (ITEST .EQ. IALF(4)) GO TO 999
      IF ((ITEST .NE. IALF(7)) .AND. (ITEST .NE. IALF(13))) GO TO 985
      READ (CARD,FMT = 520,ERR = 950,END = 970) (IHA(I),I = 1,3),
     * D, WLC, OBS, WT
 520  FORMAT (3I5, F9.6, F8.6, 2F9.5)
      CALL FRCHEK(NUMCRD)
C
C-----CHECK IF CARD WAS GOOD, SKIP IF NOT AND READ NEW CARD
C
      IF (.NOT. (HGOOD)) GO TO 510
C
C-----ROUTINE TO STORE AND DO COMPUTATIONS ON REFLECTION CARD
C
      CALL PRCHKL(NUMCRD)
C
C-----CHECK IF MAXOBS (OR GREATER) REFLECTIONS
C
      IF (NUMOBS .GE. MAXOBS) GO TO 600
      GO TO 510
C
C-----> 200 REFLECTIONS, PRINT MESSAGE AND READ TILL FIND
C-----END CARD (IE, FINISH THIS SET OF INPUT)
 600  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,610) MAXOBS,MAXOBS
      ENDIF
      WRITE(NTOUT,610) MAXOBS,MAXOBS
 610  FORMAT('0','**WARNING**MORE THAN',I4,' REFLECTION INPUT.',
     * ' ONLY THE FIRST',I4,' TO BE USED')
      READ (NTIN, 620) ITEST
 620  FORMAT (A6)
      IF (ITEST .NE. IALF(4)) GO TO 600
      RETURN
C
C-----ERROR IN FORMAT OF CARD, SET NOT PROCESSED
C
 900  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 910) ITEST, NUMCRD, CARD
      ENDIF
      WRITE(NTOUT, 910) ITEST, NUMCRD, CARD
 910  FORMAT (' ', '**ERROR**''', A6, '''(CARD #', I3,
     * ') HAS A FORMAT ERROR, SET NOT PROCESSED, CARD READ:' /
     * ' ', A72)
      RGOOD = .FALSE.
      RETURN
C
C-----ERROR IN FORMAT OF REFLECTION CARD, CARD SKIPPED
C-----BUT PROCESSING CONTINUES
C
 950  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 960) NUMCRD, CARD
      ENDIF
      WRITE(NTOUT, 960) NUMCRD, CARD
 960  FORMAT (' ', '**ERROR**', 'CARD #', I3,
     * '-NOT USED (REFLECTION)  HAS A FORMAT ERROR. CARD READ:',/
     * ' ', A72)
      GO TO 510
C
C-----EOF HIT WHILE READING HKL'S
C
 970  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 975)
      ENDIF
      WRITE(NTOUT, 975)
 975  FORMAT (' ', '**ERROR**END OF FILE HIT WHILE READING REFLECTION ',
     * 'CARDS, ASSUMED END OF DATA')
      GO TO 999
C
C-----BAD TITLE FOR REFLECTION CARD
C
 985  CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 990) NUMCRD, IALF(7), IALF(13), ITEST
      ENDIF
      WRITE(NTOUT, 990) NUMCRD, IALF(7), IALF(13), ITEST
 990  FORMAT (' ', '**ERROR**CARD #', I3, '-NOT USED (REFLECTION) ',
     * 'SHOULD BE ''', A6, ''' OR ''', A6, ''' AND NOT ''', A6, 1H')
      GO TO 510
 999  IF(NUMOBS.GT.0) IDOLSQ = 1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,9999) NUMOBS
      ENDIF
      WRITE(NTOUT,9999) NUMOBS
 9999 FORMAT('0','CARD READING COMPLETED.',I5,' REFLECTIONS READ')
      RETURN
 8899 PRINT*,'UNABLE TO OPEN THE SPECIFIED FILE.  PLEASE TRY AGAIN.'
      GOTO 8898
      END
      BLOCK DATA
C      ############################################################
C      #                                                          #
C      #                      BLOCK DATA                          #
C      #                                                          #
C      ############################################################
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      CHARACTER*6 IALF
      CHARACTER*5 CSC
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      DATA ((IFI(I,J) ,J=1,27),I=1,2)/6*0,4*1,3*4,3*5,3*6,1,
     * 5,4,4,4*2,19*0,3*6,5,4*0/,((IFJ(I,J),J=1,27),I=1,3)/1,2,3,1,4,5,
     * 6,8,2,9,7,8,3,6,8,2,6,7,1,6,6,7,8,6,8,2,10,3*0,2,26*0,3,23*0/,
     * ((IHKL(I,J),J=1,3),I=1,6)/1,-1,0,0,1,-1,1,0,-1,1,0,0,0,1,0,0,0,1/
     * ,((JHKL(I,J),J=1,3),I=1,10)/1,1,0,1,0,1,0,1,1,1,1,1,-1,1,1,1,0,0,
     * 0,1,0,0,0,1,2,0,1,1,0,2/
      DATA (IALF(I),I=1,13)/'TITLE ','PARAM ','SYSEXT','END   ',
     * 'FINISH','2-    ','      ',' R    ','PARAMD','DEMAND',
     * 'PKFILE', 'SPACEG','HKL   '/
      DATA (CSC(I),I=1,8)/'CUBIC','TETRA','ORTHO','MONOC',
     * 'RHOMB','TRICL','HEXAG','HEXAR'/
      DATA NTIN/11/,NTEXT/14/,IOPKS/20/,IOSCR/21/
C-----TEST CHARACTERS FOR CRYSTAL SYSTEM ICRS
      DATA  ITCRS/'A', 'M', 'O', 'T', 'H', 'R', 'C', 'X'/
C-----TEST CHARACTERS FOR HKL EDITORIAL MARKS IHED
      DATA  ITIH/' ', 'M', '+', 'U', '*', 'N', 'E'/
C-----TEST CHARACTERS FOR SPACE GROUP SYMBOL SPGI(1:1)
      DATA  ITSG/'P', 'A', 'B', 'C', 'F', 'I', 'R'/
C-----TEST CHARACTERS FOR GENERAL EDITORIAL MARKS', IED1', IED2', IED3.
      DATA  ITED/' ', 'E', 'G', 'T'/
      END
      SUBROUTINE CELLCK(GOOD)
C      ############################################################
C      #                                                          #
C      #                          CELLCK                          #
C      #                                                          #
C      ############################################################
C*************************************************************************
C
C  APPLY SYMMETRY CONSTRAINTS ON CELL PARAMETER INPUT  AND
C  CHECK FOR INCONSISTENT INPUT.
C
C************************************************************************
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/SWFG/DEGRAD
      COMMON/UNQ/IFA,IFB,IFC,IRH
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/IERRS/IWARN,IERR
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      LOGICAL GOOD
C
C-----INITIALIZE FLAGS
C
      IFA=0
      IFB=0
      IFC=0
      IRH=0
C
C-----COMPLETE CELL ANGLES, ERRORS
C-----SET FLAGS FOR ANGLES NOT INPUT. =0 FOR INPUT, =1 FOR ABSENT
C
      IF(ALPHI.GT. 0.1) GO TO 10
C-----ALPHA NOT INPUT. SET ALPHA TO 90.0 AND ERROR TO 0.0
      IFA=1
      ALPHI=90.0
      ERRI(4)=0
 10   IF(BETI .GT. 0.1) GO TO 20
C-----BETA  NOT INPUT. SET BETA  TO 90.0 AND ERROR TO 0.0
      IFB=1
      BETI=90.0
      ERRI(5)=0
 20   IF(GAMI .GT. 0.1) GO TO 22
C-----GAMMA NOT INPUT.  SET GAMMA TO 90.0 AND ERROR TO 0.0
      IFC=1
      GAMI=90.0
      ERRI(6)=0
C
C-----IFSUM WILL INDICATE THE NUMBER OF ANGLE ABSENT ON INPUT
C
 22   IFSUM = IFA + IFB + IFC 
C
C-----FOR RHOBOHEDRAL SYSTEM DETERMINE IF ON HEXAGONAL AXES (IRH=1)
C-----                            OR IF ON RHOMBOHEDRAL AXES (IRH=0)
C
      IF(ICRS.NE.ITCRS(6).OR. CI.LT.1.0) GOTO 23
      IF(BI.EQ.AI .AND. CI.EQ.AI) GOTO 23
C-----IT IS RHOMBOHEDRAL ON HEXAGONAL AXES. TEMPORARILY SET ICRS='H'
      ICRS =ITCRS(5)
      IRH=1
      GOTO 29
C
C-----TEST IF TRICLINIC. IF IT IS THEN 3 ANGLES MUST BE INPUT
C
 23   IF(ICRS.NE.ITCRS(1)) GOTO 25
      IF(IFSUM.EQ.0) GOTO 32
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,24)
      ENDIF
      WRITE(NTOUT,24)
 24   FORMAT(1H ,57H**ERROR**ALL 3 ANGLES MUST BE ENTERED IN TRICLINIC S
     *YSTEM )
      IERR=IERR+1
      GOTO 32
C
C-----TEST IF MONOCLINIC. IF SO ONLY ONE ANGLE SHOULD BE INPUT
C
 25   IF(ICRS.NE.ITCRS(2)) GOTO 27
      IF(IFSUM.EQ.2) GOTO 32
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,26)
      ENDIF
      WRITE(NTOUT,26)
 26   FORMAT(1H ,'**ERROR**FOR MONOCLINIC TWO ANGLES MUST BE ',
     *'INPUT AS BLANKS.', ' PROGRAM ASSUMING B-UNIQUE')
      IFA=1
      IFB=0
      IFC=1
      IERR=IERR+1
      GOTO 32
C
C-----TEST IF RHOMBOHEDRAL ON R-AXES. IF SO ONLY ALPHA SHOULD BE INPUT
C
 27   IF(ICRS.NE.ITCRS(6)) GOTO 29
      IF(IFSUM.EQ.2 .AND. IFA.EQ.0) GOTO 32
      IF(IJOB.NE.1.AND.IFA.EQ.0.AND.BETI.EQ.ALPHI.AND.GAMI.EQ.ALPHI)
     * GOTO 32
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,28)
      ENDIF
      WRITE(NTOUT,28)
 28   FORMAT(1H ,74H**ERROR**ONLY ANGLE ALPHA SHOULD BE INPUT FOR RHOBOH
     *EDRAL SYSTEM ON R-AXES)
      IERR=IERR+1
      GOTO 32
C
C-----MUST BE ORTHO, TETRAGONAL, HEXAGONAL, CUBIC OR RHOMB ON H-AXES
C-----TEST THAT NO ANGLE WAS INPUT
C
 29   IF(IFSUM.EQ.3) GOTO 32
      IF(IJOB.NE.1.AND.ALPHI.EQ.90.0.AND.BETI.EQ.90.0.AND.
     + (GAMI.EQ.90.0.OR.GAMI.EQ.120.0)) GOTO 32
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,30) ICRS
      ENDIF
      WRITE(NTOUT,30) ICRS
 30   FORMAT(1H ,52H**ERROR**NO ANGLES SHOULD BE INPUT IN CRYSTAL SYSTEM
     * , ' ', A1)
      IERR=IERR+1
C
C-----FOR TETRAGONAL, HEXAGONAL, RHOMBOREDRAL AND CUBIC  SET  BI=AI
C
 32   IF(ICRS.NE.ITCRS(5) .AND. ICRS.NE.ITCRS(4) .AND. ICRS.NE.ITCRS(7)
     * .AND. ICRS.NE.ITCRS(6)) GOTO 48
      IF(BI.LT.0.1) GOTO 34
      IF(IJOB.NE.1 .AND. BI.EQ.AI) GOTO 35
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,33)
      ENDIF
      WRITE(NTOUT,33)
 33   FORMAT(1H ,43H**ERROR**CELL PARAMETER 'B' SHOULD BE BLANK )
      IERR=IERR+1
 34   BI=AI
 35   ERRI(2)=ERRI(1)
C
C-----FOR CUBIC AND RHOMBOHERDRAL R-AXES SET CI = AI
C
      IF (ICRS.NE.ITCRS(6).AND.ICRS.NE.ITCRS(7)) GOTO 42
      IF(CI.LT.0.1) GOTO 38
      IF(IJOB.NE.1 .AND. CI.EQ.AI) GOTO 39
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,37)
      ENDIF
      WRITE(NTOUT,37)
 37   FORMAT(1H ,43H**ERROR**CELL PARAMETER 'C' SHOULD BE BLANK )
      IERR=IERR+1
 38   CI=AI
 39   ERRI(3)=ERRI(1)
      GOTO 46
C
C-----IF HEXAGONAL SET GAMMA
C
 42   IF (ICRS.NE.ITCRS(5)) GOTO 46
      GAMI=120.0
      ERRI(6)=0
      GOTO 48
C
C-----IF RHOMBOHEDRAL ON R-AXES THE SET EQUIVALENCES
C
 46   IF(ICRS.NE.ITCRS(6)) GO TO 48
      BETI=ALPHI
      GAMI=ALPHI
      ERRI(5)=ERRI(4)
      ERRI(6)=ERRI(4)
C
C-----IF RHOMBOHEDRAL ON HEXAGONAL AXES THEN RESET ICRS TO 'R'
C
 48   IF(IRH.EQ.1) ICRS=ITCRS(6)
C
C-----CHECK INITIAL CELL PARAMETERS FOR REASONABLE MAGNITUDES
C
      IF(AI.LE.30.0 .AND. BI.LE.30.0 .AND. CI.LE.30.0) GOTO 51
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,50)
      ENDIF
      WRITE(NTOUT,50)
 50   FORMAT(1H ,32H**WARNING**AI,BI AND/OR CI > 30A )
      IWARN=IWARN+1
 51   IF(AI.GE. 3.0 .AND. BI.GE. 3.0 .AND. CI.GE. 3.0)  GOTO 53
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,52)
      ENDIF
      WRITE(NTOUT,52)
 52   FORMAT(1H ,32H**WARNING**AI,BI AND/OR CI <  3A )
      IWARN=IWARN+1
 53   IF(ALPHI.LE.140.0 .AND. BETI.LE.140.0 .AND. GAMI.LE.140.0) GOTO 55
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,54)
      ENDIF
      WRITE(NTOUT,54)
 54   FORMAT(1H ,43H**WARNING**ALPHI,BETI AND/OR GAMI > 140 DEG )
      IWARN=IWARN+1
 55   IF(ALPHI.GE. 50.0 .AND. BETI.GE. 50.0 .AND. GAMI.GE. 50.0) GOTO 57
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,56)
      ENDIF
      WRITE(NTOUT,56)
      IWARN=IWARN+1
 56   FORMAT(1H ,43H**WARNING**ALPHI,BETI AND/OR GAMI <  50 DEG )
 57   IF(ALPHI.GT.179.9 .OR. BETI.GT.179.9 .OR. GAMI.GT.179.9) GOTO 60
C
C-----TEST FOR A VALID CELL - THAT IS THE THREE VECTORS ARE NOT COPLANAR
C
      GOOD=.TRUE.
      COS1 = COS(ALPHI/DEGRAD)
      COS2 = COS(BETI/DEGRAD)
      COS3 = COS(GAMI/DEGRAD)
      TEM = (1.0-COS1**2-COS2**2-COS3**2+2.0*(COS1*COS2*COS3))
      IF(TEM.GT.0.0001) GOTO 80
 60   IF (NTOUT .EQ. 12) THEN
          WRITE(*,62)
      ENDIF
      WRITE(NTOUT,62)
      IERR=IERR+1 
 62   FORMAT(1H ,'**ERROR**CELL PARAMETERS DO NOT DEFINE A VALID CELL',
     * ' **ERROR**')
      GOOD = .FALSE.
      RETURN
C
C-----CALCULATE THE INITIAL CELL VOLUME
C
 80   VI = AI*BI*CI*SQRT(TEM)
      IF(VI .LT. 1.0) GOTO 60
      RETURN
      END
      SUBROUTINE CHKEXT(IH,IK,IL,JEXT)
C      ############################################################
C      #                                                          #
C      #                          CHKEXT                          #
C      #                                                          #
C      ############################################################
C CHECKS MILLER INDICES IH,IK,IL FOR EXTINCTIONS - JEXT SET TO 1
C IF CURRENT REFLECTION NOT ACCEPTABLE, JEXT SET TO 0 IF IT IS
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      JEXT=0
      DO 22 I=1,NOPT
      L=JOP(I)
      IDIV=IOP(L)
      DO 10 J=1,2
      IFIJ=IFI(J,L)
      IF (IFIJ.LT.1.OR.IFIJ.GT.6) GO TO 12
      IANS=IH*IHKL(IFIJ,1)+IK*IHKL(IFIJ,2)+IL*IHKL(IFIJ,3)
      IF (IANS.NE.0) GO TO 22
 10   CONTINUE
 12   DO 20 K=1,3
      IFJK=IFJ(K,L)
      IF (IFJK.LT.1.OR.IFJK.GT.10) GO TO 22
      IARG=JHKL(IFJK,1)*IH+JHKL(IFJK,2)*IK+JHKL(IFJK,3)*IL
      IF (MOD(IARG,IDIV).EQ.0) GO TO 20
      JEXT=1
      GO TO 24
 20   CONTINUE
 22   CONTINUE
 24   RETURN
      END
      SUBROUTINE CHKSPG
C      ############################################################
C      #                                                          #
C      #                          CHKSPG                          #
C      #                                                          #
C      ############################################################
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/IERRS/IWARN,IERR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/UNQ/IFA,IFB,IFC,IRH
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 L
C-----FOR RHOMBOHEDRAL IF ISG(1)=' ' THEN SET IT TO 'R'
      IF(SPGI(1:1).EQ.ITED(1).AND.ICRS.EQ.ITCRS(6)) SPGI(1:1)=ITSG(7)
C
C-----FIRST PHASE. IS ISG(1) AN ALLOWED SYMBOL?
C-----USE L=ISG(1) FOR LATTICE CENTERING
C
      L=SPGI(1:1)
      IF(L.EQ.ITED(1)) GOTO 20
      DO 10 I=1,7
      IF(ITSG(I).EQ.L) GOTO 20
 10   CONTINUE
      IERR=IERR+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,11) L
      ENDIF
      WRITE(NTOUT,11) L
 11   FORMAT(' ',  '**ERROR** SPACE GROUP CENTERING SYMBOL "',A1,
     * '" IS NOT ALLOWED' /' ',10X,   'CELL CENTERING "P" ASSUMED' )
      SPGI(1:1)=ITED(1)
C
C-----SECOND PHASE. IS ICRS AN ALLOWED SYMBOL?
C
 20   DO 30 I=1,7
      IF(ICRS.EQ.ITCRS(I)) GOTO 40
 30   CONTINUE
      IERR=IERR+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,31) ICRS
      ENDIF
      WRITE(NTOUT,31) ICRS
 31   FORMAT(' ','**ERROR** CRYSTAL SYSTEM "',A1,'" IS NOT ALLOWED'/
     * ' ',10X, 'ANORTHIC SYSTEM ASSUMED' )
C-----SET TO ANORTHIC INORDER TO PERMIT TRIAL EXECUTION
      ICRS=ITCRS(1)
      I=1
C-----IF CENTERING IS ABSENT THEN NO FURTHER CHECKING IS POSSIBLE
 40   IF(L.EQ.ITED(1).AND.ICRS.NE.ITCRS(6)) GOTO 200
C
C-----THIRD PHASE. CHECK FOR CONSISTENT LATTICE CENTERING AND CRYSTAL
C-----SYSTEM
C
C-----BRANCH ON CODE FOR CRYSTAL SYSTEM
      GOTO(50,70,90,110,130,150,170),I
C-----ANORTHIC P,A,B,C,F,I ALLOWED
 50   IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----MONOCLINIC P,A,B,C,F,I ALLOWED
 70   IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----ORTHORHOMBIC P,A,B,C,F,I ALLOWED
 90   IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----TETRAGONAL P,C,F,I ALLOWED
 110  IF(L.EQ.ITSG(2).OR.L.EQ.ITSG(3).OR.L.EQ.ITSG(7)) GOTO 190
      IF(L.NE.ITSG(4).AND.L.NE.ITSG(5))  GOTO 200
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,111)
      ENDIF
      WRITE(NTOUT,111)
      IWARN=IWARN+1
 111  FORMAT(' ','**WARNING**UNUSUAL TETRAGONAL CENTERING INPUT')
      GOTO 200
C-----HEXAGONAL P ALLOWED
 130  IF(L.NE.ITSG(1)) GOTO 190
      GOTO 200
C-----RHOMBOHEDRAL  R-AXES R,F,I ALLOWED; H-AXES R ALLOWED
 150  IF(L.EQ.ITED(1)) SPGI(1:1)=ITSG(7)
      IF(IRH.EQ.1) GOTO 160
C-----R-AXES
      IF(L.EQ.ITSG(7)) GOTO 200
      IF(L.NE.ITSG(5).AND.L.NE.ITSG(6)) GOTO 190
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,151)
      ENDIF
      WRITE(NTOUT,151)
 151  FORMAT(' ','**WARNING**UNUSUAL RHOMBOHEDRAL CENTERING INPUT')
      IWARN=IWARN+1
      GOTO 200
C-----H-AXES
 160  IF(L.NE.ITSG(7)) GOTO 190
      GOTO 200
C-----CUBIC  P,F,I ALLOWED
 170  IF(L.NE.ITSG(1).AND.L.NE.ITSG(5).AND.L.NE.ITSG(6)) GOTO 190
      GOTO 200
C
C-----LATTICE CENTERING (ISG(1)) NOT ALLOWED IN SYSTEM ICRS
C
 190  IERR=IERR+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,192) L, ICRS
      ENDIF
      WRITE(NTOUT,192) L, ICRS
 192  FORMAT(' ','**ERROR**INPUT CELL CENTERING "',A1,'"  IS NOT ALLOWED
     * IN CRYSTAL SYSTEM "',A1,'"')
      SPGI(1:1)=ITSG(1)
      IF(ICRS.EQ.ITCRS(6)) SPGI(1:1)=ITSG(7)
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,194) SPGI(1:1)
      ENDIF
      WRITE(NTOUT,194) SPGI(1:1)
 194  FORMAT(' ',9X,'CENTERING SET TO "',A1,'"  TO PERMIT EXECUTION')
 200  RETURN
      END
      SUBROUTINE CMPNUP
C      ############################################################
C      #                                                          #
C      #                          CMPNUP                          #
C      #                                                          #
C      ############################################################
C COMPUTES DIRECT CELL PARAMETERS FROM CORRECTED RECIPROCAL CELL
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/OUTHLD/TCR(3)
      DO 9 J=1,3
      UO(J)=AR(J)
      W(J)=SQRT(1.0-U(J)**2)
      AR(J)=3437.7468*(1.5707963-ATAN2(U(J),W(J)))
      UO(J)=AR(J)-UO(J)
C
C-----STORE VALUE OF UO FOR LATER OUTPUT
C
      TCR(J) = CR(J)
 9    CONTINUE
      VRO=VR
      VR=SQRT(1.0-U(1)**2-U(2)**2-U(3)**2+2.0*U(1)*U(2)*U(3))*X(1)*X(2)
     & *X(3)
      DO 20 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      AO(I)=AD(I)
      AD(I)=X(J)*X(K)*W(I)/VR
      ALO(I)=ALS(I)
      IF (ITYP .GT. 5) GO TO 18
      IF (I .EQ. 2 .AND. ITYP .EQ. 4) GO TO 18
      IF (I .EQ. 3 .AND. ITYP .EQ. 2) GO TO 18
      CSA(I)=0.0
      GO TO 19
 18   CSA(I)=(U(J)*U(K)-U(I))/(W(J)*W(K))
 19   ALS(I)=3437.7468*(1.5707963-ATAN2(CSA(I),SQRT(1.0-CSA(I)**2)))
 20   CONTINUE
      VCO=VC
      VC=1.0/VR
      RETURN
      END
      SUBROUTINE COMPAR
C      ############################################################
C      #                                                          #
C      #                          COMPAR                          #
C      #                                                          #
C      ############################################################
C*********************************************************************
C
C---COMPARES AUTHOR'S INDEXING WITH THEORETICAL VALUES FROM HIS CELL.ALL
C-----CALCULATIONS PERFORMED IN 2-THETA, BUT RESULTS ARE GIVEN IN THETA
C-----IF THETA WAS GIVEN AS INPUT. WARNING IF OBS. -  CALC. DIFFERENCE
C-----IN ANGLES IS ABOVE TOLERANCE. AVERAGE FIT IS ALSO PRINTED.
C
C-----SUBROUTINE COMPAR RECHECKS THIS AT END OF DO 40 LOOP.
C
C*********************************************************************
      PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/SWFG/DEGRAD
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/IERRS/IWARN,IERR
      COMMON/QUAL/SDELTA(MAXOBS)
	COMMON RELINT(MAXOBS)
      DIMENSION NH(3)
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF12
C
C-----TEST IF 2 LINES HAVE THE SAME HKL VALUES
C
      M1=NUMOBS-1
      DO 200 I=1,M1
C
C-----SKIP UNINDEXED LINES AND KNOWN IMPURITY LINES
C
      IF(IHED(I).EQ.ITIH(4) .OR. IHED(I).EQ.ITIH(5)) GOTO 200
      I1=I+1
      DO 98 J=I1,NUMOBS
      DO 90 K=1,3
      IF(IH(I,K).NE.IH(J,K)) GOTO 98
 90   CONTINUE
      IERR=IERR+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,92) DSP(I),DSP(J)
      ENDIF
      WRITE(NTOUT,92) DSP(I),DSP(J)
 92   FORMAT(1H ,30H**ERROR**LINES WITH D-SPACING=, F8.4, 4H AND, F8.4,
     *30H HAVE IDENTICAL HKL'S**ERROR** )
C-----TEST WHICH FITS BETTER. ASSIGN THE OTHER AS UNINDEXED.
      DCOMP = DCM(IOC(I))
      DIFFI = ABS(DSP(I)-DCOMP)
      DIFFJ = ABS(DSP(J)-DCOMP)
      IJUNDX = I
      IF(DIFFJ.GT.DIFFI) IJUNDX = J
      IHED(IJUNDX) ='U'
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,96) 2*OBSTH(IJUNDX),DSP(IJUNDX)
      ENDIF
      WRITE(NTOUT,96) 2*OBSTH(IJUNDX),DSP(IJUNDX)
 96   FORMAT(' ',9X,'LINE WITH THETA=',F8.3,'  D-SPACING=',F8.4,
     * ' ASSIGNED AS UNINDEXED')
 98   CONTINUE
 200  CONTINUE
C-----ARRAY OF SIGNED DELTA 2-THETAS
C-----REJECTION CRITERIA (DEGREES 2-THETA)
      TEST2T=0.2
C
C-----INITIALIZE THE OVERALL PATTERN QUALITY COUNTERS
C        NAVG = NUMBER OF SPACE GROUP ALLOWED INDEXED LINES
C        AVG  = AVERAGE ABS(DELTA 2-THETA)
C        NRES = # OF RESOLVABLE THEORETICAL LINES OUT TO THEMX
C        IHDG = USED TO CONTROL PRINTING OF HEADINGS
C        NUNIQU = # OF UNIQUE LINES OBSERVED
C        NPLUS = # OF DELTA(2-THETA) > +0.02
C        MINUS = # OF DELTA(2-THETA) < -0.02
C        SAVG  = SUM OF DELTA(2-THETA).  SHOULD BE APPROX. ZERO IF DATA
C                IS FREE FROM SYSTEMATIC ERRORS
      AVG=0.0
      NAVG = 0
      IHDG=0
      NRES = 0
      CONST = 0.5*PWL
      NUNIQU = 1
      NPLUS=0
      MINUS=0
      SAVG =0.0
C
C-----SET UP FOR FIGURE-OF-MERIT (M20) CALCULATION
C-----  SEE DEWOLF, J APPL CRYST (1968) 1,108.
C        NUM20= 20 OR # OF UNIQUE AND INDEXED LINES IN PATTERN IF <20
C        I20  = ARRAY INDEX FOR THE NUM20'TH LINE
C        DLIM = D-SPACING OF THE NUM20'TH LINE
C        ERRQ, ERRQR = SUM ABS(DELTA-Q))
C        NERRQ, NERRQR = # IN SUMS
C             MULTIPLY INDEXED LINES IN AVERAGES
C             SUFFIX R INDICATES OMMISION OF LINES WITH (DELTA 2-THETA)
C             >TEST2T
C        N20  = # OF THEORETICAL LINES OUT TO DLIM
C        NUM20R= NUM20- # OF REJECTED LINES(>TEST2T)
C        JX20 = # OF UNINDEXED LINES OUT TO DLIM
C
      ERRQ=0.0
      ERRQR=0.0
      I20 = 0
      NUM20 = 0
      NERRQ=0
      NERRQR=0
      JX20 = 0
C
C-----SET UP FOR SMITH-SNYDER FIGURE OF MERIT
C        IFN,IFNR = 30 OR # OF UNIQUE AND INDEXED LINES IN  PATTERN <30
C        MFN  = ARRAY INDEX FOR THE IFN'TH LINE
C        FLIM = D-SPACING OF THE IFN'TH LINE
C        FAV, FAVR = SUM ABS(DELTA 2-THETA)
C        NFAV, NFAVR = # IN SUMS
C        NFN  = # OF THEORETICAL LINES OUT TO FLIM
C        FN2  = FAV/NFAV  (= AVERAGE MAGNITUDE OF DELTA 2-THETA)
C        FN1 = MERIT FUNCTION (=<DEL 2T>*IFN/NFN)
      IFN = 0
      FAV = 0.0
      FAVR = 0.0
      MFN = 0
      NFAV = 0
      NFAVR=0
C
C-----DETERMINE IFN,NFN AND NUM20,I20
C
      DO 40 I=1,NUMOBS
C-----SKIP OVER LINES NOT INDEXED, KNOWN IMPURITY OR SPACE GROUP EXT
      IF(IHED(I).EQ.ITIH(4).OR.IHED(I).EQ.ITIH(5).OR.IHED(I).EQ.ITIH(6))
     * GOTO 40
      IFN = IFN + 1
      NUM20 = NUM20 + 1
      IF(I.EQ.1) GOTO 40
      DLIM = DSP(I-1)
C-----TEST IF THIS IS A NEW LINE
      IF((DLIM-DSP(I)).GT.0.00001) GOTO 2
      NUM20=NUM20-1
      IFN = IFN -1
 2    IF(NUM20 .LE. 20) I20=I
      IF(IFN.LE.30) MFN=I
      IF(IFN.EQ.30) GOTO 41
 40   CONTINUE
      IF(I20.NE.0) GOTO 41
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,3)
      ENDIF
      WRITE(NTOUT,3)
 3    FORMAT(1H0,69H**ERROR**COMPAR CALLED, BUT THERE ARE NO INDEXED REF
     *LECTIONS**ERROR** )
      RETURN
C-----SHIFT DLIM TO ALLOW FOR POTENTIAL MEASUREMENT ERROR
 41   TEMP=OBSTH(I20)+0.05
      DLIM=CONST/SIN(TEMP/DEGRAD)
      TEMP=OBSTH(MFN)+0.05
      FLIM=CONST/SIN(TEMP/DEGRAD)
      Q20 = 1.0/(DLIM*DLIM)
      IF(NUM20.GT.20) NUM20=20
      NUM20R=NUM20
      IFNR = IFN
C
C-----CALCULATE THE DEWOLF X(20) VALUE.  COUNT THE NUMBER
C-----OF UNINDEXED AND SPACE GROUP EXTINCT LINES OUT TO I20
C
      DO 42 I=1,I20
      IF(IHED(I).EQ.ITIH(4) .OR. IHED(I).EQ.ITIH(6)) JX20=JX20+1
 42   CONTINUE
C
C-----LOOP OVER THE THEORETICAL LINES TO DETERMINE
C----- THE THEORETICALLY POSSIBLE NUMBER OF LINES NFN AND N20
C        EXACT COINCIDENCE WAS ELIMINATED BY THE HKL GENERATION ROUTINE
C        IN MOST CASES. A KNOWN EXCEPTION IS SPGR PA3.
C
      IF (RESOLV .LT. 0.001) RESOLV = 1.5 * TOLTH
      THETAL=THETA(CONST,DCM(1))
      N20=1
      NFN = 1
      NRES=1
      DO 5 I=2,NR
      DCALC = DCM(I)
      THETAC = THETA(CONST,DCALC)
      IF((THETAC-THETAL).GT.RESOLV) NRES=NRES+1
      IF((THETAC-THETAL).LT.0.0001) GOTO 4
      IF(DCALC.GT.DLIM) N20=N20+1
      IF(DCALC .GT. FLIM) NFN = NFN + 1
 4    THETAL=THETAC
 5    CONTINUE
C
C-----SET TOL TO BE USERS INDICATED TOLERANCE FOR 2-THETA SCALE
C
      TOL = 2.0*TOLTH
C
C-----BEGIN LOOP OVER INDEXED REFLECTIONS
C-----FOR FIGURE OF MERRIT CALCULATIONS DETERMINE THE AVERAGE
C-----ERROR IN 2-THETA AND IN Q
C-----LIST REFLECTIONS(INDEXED) WHICH EXCEED A PRESET ERROR (TOLTH)
C-----SAVE THE SIGNED DIFFERENCES FOR A STATISTICAL TEST ON NON
C-----RANDOMNESS
C
      DLAST = 99.9999
      DO 50 I=1,NUMOBS
C-----COUNT THE NUMBER OF UNIQUE OBSERVED LINES
      IF(I.EQ.1) GOTO 11
      IF((DLAST-DSP(I)).LT.0.00001) GOTO 11
      NUNIQU=NUNIQU+1
 11   DLAST=DSP(I)
C-----SKIP UNINDEXED, KNOWN IMPURITY AND SPACE GROUP EXTINC LINES
      IF(IHED(I).EQ.ITIH(4).OR.IHED(I).EQ.ITIH(5).OR.IHED(I).EQ.ITIH(6))
     * GOTO 50
      DO 10  J=1,3
      NH(J)=IH(I,J)
 10   CONTINUE
      CALL QCOMP(NH,Z,Q)
      DCALC= 1.0/SQRT(Q)
      QOBS=1.0/(DSP(I)*DSP(I))
      IF(I.GT.I20) GOTO 12
      ERRQ = ERRQ + ABS(Q-QOBS)
      NERRQ = NERRQ+1
 12   CONTINUE
C-----CALC THETAC.    (LAMBDA=PWL)
      THETAC=THETA(CONST,DCALC)
      THOBS=OBSTH(I)
C-----CONVERT FROM THETA TO 2-THETA
      THETAC=THETAC+THETAC
      THOBS=THOBS+THOBS
C
C-----CALCULATE THE DIFFERENCE IN 2-THETA AND MAGNITUDE OF DIFFERENCE
C
 20   SDIFF = THETAC-THOBS
      DIFF = ABS(SDIFF)
C-----SUM OF AVERAGE MAGNITUDE ERROR IN 2-THETA (ENTIRE PATTERN)
      AVG = AVG + DIFF
      NAVG=NAVG+1
C-----SUM OF ERRORS IN 2-THETA AND NUMBER OF '+' AND '-'
C-----DEVIATIONS GREATER THAN +0.02 OR LESS THAN -0.02
      SAVG=SAVG + SDIFF
      IF(SDIFF.GT.0.02) NPLUS=NPLUS+1
      IF(SDIFF.LT.-0.02)MINUS=MINUS+1
C-----STORE DELTA 2-THETA FOR LATER TEST FOR RANDOM DISTRIBUTION
      SDELTA(NAVG) = SDIFF
C-----NUM20R  IS NUMBER OF ACCEPTABLE OBSERVATIONS:(OBS-CALC).LT. 0.2DEG
      IF(I.GT.I20) GOTO 22
      IF(DIFF.GT.TEST2T) NUM20R = NUM20R-1
      IF(DIFF.GT.TEST2T) GOTO 22
      ERRQR=ERRQR + ABS(Q-QOBS)
      NERRQR=NERRQR+1
C-----SUM OF AVERAGE MAGNITUDE ERROR IN 2-THETA (I<MFN) 
 22   IF(I .GT. MFN) GO TO 30
      FAV = FAV + DIFF
      NFAV=NFAV+1
      IF(DIFF.GT.TEST2T) IFNR = IFNR-1
      IF(DIFF.GT.TEST2T) GOTO 30
      FAVR = FAVR + DIFF
      NFAVR = NFAVR + 1
 30   CONTINUE
C
C-----COMPARE ANGLES. LIST THOSE THAT DON'T SATISFY USER'S INPUT TOL.
C
      IF(DIFF.LT.TOL) GOTO 50
      SWT = SW(I)*SW(I)
C---IF THE USER INDICATED THETA, PERFORM CONVERSION BACK AGAIN
      IF(ITHT .EQ. 0) GO TO 23
      TOL=TOL/2.0
      THOBS=THOBS/2.0
      THETAC=THETAC/2.0
      SDIFF=SDIFF/2.0
 23   IF(IHDG .EQ.1) GOTO 24
      WRITE(NTOUT,1) TOL,IALF12(1:2),IALF12(1:2)
 1    FORMAT(1H0,43HSUMMARY OF REFLECTIONS EXCEEDING TOLERANCE=,F6.2/
     * 1H0,5X, 6HD CALC, 3X, 5HD OBS, 2X,6HRELINT,2X,9X,7HH  K  L,3X,A2,
     * 5HTHOBS, 1X, A2, 5HTHCLC, 3X,4HDIFF, 3X, 2HWT)
      IHDG=1
C 24   WRITE(NTOUT,25)DCALC,DSP(I),IHED(I),INTN(I),INTED(I),
C     *(NH(L),L=1,3), THOBS,  THETAC, SDIFF, SWT
 24   WRITE(NTOUT,25)DCALC,DSP(I),IHED(I),RELINT(I),INTED(I),
     *(NH(L),L=1,3), THOBS,  THETAC, SDIFF, SWT
 25   FORMAT(1H ,3X,2F8.4,A1,1X,F5.1,A1,9X,3I3,2X,2F8.3,F7.3,F6.2)
 50   CONTINUE
C
C-----SUMMARIZE COMPARISON
C
      AVG=AVG/REAL(NAVG)
      SAVG=SAVG/REAL(NAVG)
      NOIND =NUMOBS-NAVG
C
C-----TEST THE TABLE OF DELTA 2-THETA FOR PRESENCE OF NON-RANDOM
C-----VARIABILITY USING THE TEST OF L.C. YOUNG, "ON RANDOMNESS IN
C-----ORDERED SEQUENCES", ANNALS OF MATHETATICAL STATISTICS, VOL XII,
C-----NO. 3, SEPT 1941.
C
C-----NOTE: THEORETICALLY THE AVERAGE VALUE OF THE DEVIATION SHOULD
C-----BE ZERO.  THUS IN THE DENOMINATOR OF YOUNG'S EQUATION FOR C,
C-----X BAR IS TAKEN AS 0.0    THIS ENABLES DETECTION OF A CONSTANT
C-----SYSTEMATIC ERROR TO ALSO BE DETECTED BY C/SIGMA
C
      C = 0.0
      IF(NAVG.LT.8) GOTO 60
      XNUM = 0.0
      XDEN = 0.0
      C = 0.0
      DO 54 I=1,NAVG
      IF(I.EQ.1) GOTO 52
      DD = SDELTA(I) - SDELTA(I-1)
      XNUM = XNUM +DD*DD
 52   DD = SDELTA(I)
      XDEN = XDEN + DD*DD
 54   CONTINUE
C-----CALCULATE EXPECTED SIGMA OF DISTRIBUTION
      DD = REAL(NAVG-2)/REAL((NAVG-1)*(NAVG+1))
      DD = SQRT(DD)
C-----CALCULATE YOUNG'S C/SIGMA
      C = 1.0 - XNUM/(2.0*XDEN)
      C = C/DD
C-----CHANGE RESOLVE TO DEGREEES 2-THETA
 60   RESOLV = 2.0*RESOLV
      WRITE(NTOUT,61) RESOLV, NR, NRES,NUNIQU, NUMOBS, NAVG, NOIND
 61   FORMAT(1H0,38HREFLECTION SUMMARY FOR ENTIRE PATTERN:/
     * 1H ,21HESTIMATED RESOLUTION=,F5.3,13H DEG. 2-THETA/
     * 1H0,5X,23HTHEORETICAL # OF LINES=, I4/
     * 1H ,5X,23HTHEORETICAL RESOLVABLE=,I4/
     * 1H ,5X,22HUNIQUE OBSERVED LINES=,I5/
     * 1H0,5X,18HTOTAL LINES INPUT=,I6/
     * 1H ,5X,17HNUMBER   INDEXED=,I7/
     * 1H ,5X,17HNUMBER UNINDEXED=,I7)
      WRITE(NTOUT,62) SAVG,NPLUS,MINUS
 62   FORMAT(1H0,33H********FOR INDEXED LINES********/
     * 1H0, 5X, 27HAVERAGE 2-THETA DIFFERENCE=, F6.3/
     * 1H , 5X, 29H# WITH DIFF > +0.02(2-THETA)=,I4/
     * 1H , 5X, 29H# WITH DIFF < -0.02(2-THETA)=,I4)
C-----TEST FOR IMBALANCE IN THE NUMBER OF + AND - SIGNS
      NTEST=NAVG/5
      IF(NTEST.LT.5) NTEST=5
      IF(IABS(NPLUS-MINUS).LT.NTEST) GOTO 64
      IWARN=IWARN+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,63)
      ENDIF
      WRITE(NTOUT,63)
 63   FORMAT(1H ,58H**WARNING**IMBALANCE IN NUMBER OF + AND - SIGNS**WAR
     *NING**)
 64   IF(NAVG.GE.8) WRITE(NTOUT,65) C
 65   FORMAT(1H0, 5X, 32HC/SIGMA (NON-RANDOM ERROR TEST)=,F5.2)
C
C-----TEST FOR NONRANDOMNESS AT 99% AND 95% CONFIDENCE LEVEL
C-----USING YOUNG'S STATISTICAL TEST
C
      IF(C .LT. 1.6447) GOTO 67
      IWARN = IWARN + 1
      ICONF = 95
      IF(C.GT.2.3262) ICONF = 99
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,66) ICONF
      ENDIF
      WRITE(NTOUT,66) ICONF
 66   FORMAT(1H , 45H**WARNING**SYSTEMATIC ERRORS INDICATED AT THE, I3,
     *31H% SIGNIFICANCE LEVEL**WARNING**)
C
C-----CALCULATE AVERAGE ERROR IN Q AND THE FIGURE OF MERIT (M20)
C
 67   ERRQ = ERRQ/REAL(NERRQ)
      XM20=Q20/(2.0*ERRQ*REAL(N20))
      WRITE(NTOUT,68) NUM20,XM20,DLIM,N20,NUM20,JX20
 68   FORMAT(1H0,5X,2HM(,I2,3H) =,F6.2,13H   (DLIMIT = ,F6.4,
     * 14H, # POSSIBLE = , I3, 1H)/
     * 1H ,5X, 2HX(, I2, 3H) =, I3)
      IF (XM20 .LT. 10.0) THEN
          IWARN=IWARN+1
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,69) NUM20
          ENDIF
          WRITE(NTOUT,69) NUM20
 69      FORMAT(' ','**WARNING M(', I2, ') < 10 INDICATES THAT THE ',
     *   'CELL IS SUSPECT**WARNING**' )
      END IF
      IF (JX20.GE.2) THEN
          IWARN = IWARN + 1
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,70) NUM20
          ENDIF
          WRITE(NTOUT,70) NUM20
 70      FORMAT(' ','**WARNING** X(',I2, ') >=2 INDICATES THAT THE ',
     *   'CELL IS SUSPECT**WARNING**')
      END IF
C
C-----CALCULATE THE AVERAGE ABS(DELTA 2-THETA) AND F(N)
C
      FN2 = FAV/REAL(NFAV)
      FN1 = REAL(IFN) / (FN2 * REAL(NFN))
      WRITE(NTOUT,72)IFN,FN1,FN2,NFN
 72   FORMAT(1H0,5X,
     & 2HF(, I2,3H) =, F6.2, 18H (DELTA 2 THETA = ,F6.4,
     & 15H, # POSSIBLE =  , I3, 1H)//)
      IF(NUM20R .EQ. NUM20) GOTO 80
      WRITE(NTOUT,76)
 76   FORMAT(1H0, 39HFIGURES-OF-MERIT(REJECTING DIFF.GT.0.2))
      ERRQR = ERRQR/REAL(NERRQR)
      XM20R = Q20/(2.0*ERRQR*REAL(N20))
      WRITE(NTOUT,68) NUM20R, XM20R, DLIM,N20
 80   IF(NFAVR.EQ.NFAV) GO TO 100
      IF(IHDG.EQ.0) WRITE(NTOUT,76)
      FN2R = FAVR/NFAVR
      FN1R = REAL(IFNR)/(FN2R*REAL(NFN))
      WRITE(NTOUT,72) IFNR, FN1R, FN2R, NFN
 100  RETURN
      END
      SUBROUTINE COORD
C      ############################################################
C      #                                                          #
C      #                          COORD                           #
C      #                                                          #
C      ############################################################
C COMPUTES CORRECTIONS TO RECIPROCAL CELL ELEMENTS
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      GO TO (10,20,30,40,50,60,70),ITYP
 10   DO 15 J=1,3
      CR(J)=B(1)
 15   CR(J+3)=0.0
      GO TO 80
 20   DO 25 J=1,2
 25   CR(J)=B(1)
      CR(3)=B(2)
      DO 28 J=4,6
 28   CR(J)=0.0
      GO TO 80
 30   DO 35 J=1,3
      CR(J)=B(J)
 35   CR(J+3)=0.0
      GO TO 80
 40   DO 45 J=1,3
 45   CR(J)=B(J)
      CR(4)=0.0
      CR(5)=B(4)
      CR(6)=0.0
      GO TO 80
 50   DO 52 J=1,2
 52   CR(J)=B(1)
      CR(3)=B(2)
      DO 55 J=4,6
 55   CR(J)=0.0
      GO TO 80
 60   DO 65 J=1,6
 65   CR(J)=B(J)
      GO TO 80
 70   DO 75 J=1,3
      CR(J)=B(1)
 75   CR(J+3)=B(2)
 80   RETURN
      END
      SUBROUTINE DATIM (DAT,TIM)
C      ############################################################
C      #                                                          #
C      #                          DATIM                           #
C      #                                                          #
C      ############################################################
C******************************************************************
C
C  SUBROUTINE TO CALL VAX SPECIFIC  DATE - TIME  ROUTINES
C
C  ARGUMENTS FOR VAX SYSTEM:
C            DAT   CHAR*9  CURRENT DATE (E.G. 31-JAN-90)
C            TIM   CHAR*8  CURRENT TIME (E.G. 13:56:03)
C
C******************************************************************
      CHARACTER DAT*9, TIM*8
C-----CALL VAX'S ASCII FORTRAN DATE ROUTINE
      CALL DATE(DAT)
C-----CALL VAX'S ASCII FORTRAN TIME ROUTINE
      CALL TIME(TIM)
C
C******************************************************************
C
C  SUBROUTINE TO CALL YOUR SYSTEM SPECIFIC  DATE - TIME  ROUTINES
C
C  ARGUMENTS FOR UNIVAC SYSTEM
C            DAT   CHAR*8  CURRENT DATE (E.G. 01/31/83)
C            TIM   CHAR*8  CURRENT TIME (E.G. 13:56:03)
C
C******************************************************************
C     CHARACTER*8 DAT,TIM
C     CALL UNIVAC'S ASCII FORTRAN DATE/TIME ROUTINE
C     CALL ADATE(DAT,TIM)
C     CONVERT 6 CHARACTER PACKED FORMAT TO 8 CHARACTER FORMAT
C     DAT(7:8) = DAT(5:6)
C     DAT(6:6) = '/'
C     DAT(4:5) = DAT(3:4)
C     DAT(3:3) = '/'
C     TIM(7:8) = TIM(5:6)
C     TIM(6:6) = ':'
C     TIM(4:5) = TIM(3:4)
C     TIM(3:3) = ':'
C
C******************************************************************
C
C  SUBROUTINE TO CALL CDC SYSTEM SPECIFIC  DATE - TIME  ROUTINES
C
C  ARGUMENTS FOR A CDC SYSTEM
C            DAT   CHAR*8  CURRENT DATE (E.G. DD/MM/YY)
C            TIM   CHAR*8  CURRENT TIME (E.G. HH:MM:SS)
C
C******************************************************************
C     CHARACTER*10 CDCMCY,CHCMCS
C     CHARACTER*8  DAT,TIM
C
C     CALL THE DATE ROUTINE
C     CALL DATE(CDCMCY)
C     DAT(1:8)=CDCMCY(8:9)//'/'//CDCMCY(5:6)//'/'//CDCMCY(2:3)
C
C     CALL THE TIME ROUTINE
C     CALL TIME(CHCMCS)
C     TIM(1:8)=CHCMCS(2:3)//':'//CHCMCS(5:6)//':'//CHCMCS(8:9)
C******************************************************************
      RETURN
      END
      SUBROUTINE DLQOT
C      ############################################################
C      #                                                          #
C      #                          DLQOT                           #
C      #                                                          #
C      ############################################################
C COMPUTES PARTIAL DERIVATIVES OF RECIPROCAL OF D SQUARED
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/SCRT/E(7),NH(3)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      DO 15 J=1,3
      K=MOD(J,3)+1
      L=MOD(K,3)+1
      B(J)=FAC*(X(J)*NH(J)**2+NH(J)*NH(L)*X(L)*U(K)+NH(J)*NH(K)*X(K)*
     * U(L))
 15   B(J+3)=FAC*NH(K)*NH(L)*X(K)*X(L)
      RETURN
      END
      SUBROUTINE DMREAD
C      ############################################################
C      #                                                          #
C      #                          DMREAD                          #
C      #                                                          #
C      ############################################################
C
C-----INTERACTIVE MODE (DEMAND) INPUT OF REQUIRED PARAMETERS
C
      PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN,TOLMX
      COMMON/IERRS/IWARN,IERR
      COMMON/RDGOOD/RGOOD,SYSEXT
      LOGICAL HGOOD,RGOOD,SYSEXT
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*6 IALF
      CHARACTER*80 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 YES
      CHARACTER*7 LABEL(3)
      DATA LABEL/'THETA  ','2-THETA','D-VALUE'/
C
C-----INITIALIZE
C
      SYSEXT = .FALSE.
      RGOOD  = .TRUE.
      HKLED = ' '
      ITHT = 2
      NUMOBS = 0
      PWL = 1.5405981
      OBS = 0.0
      D   = 0.0
      DO 2 I=1,3,1
      AO(I) = 0.0
      ALO(I)=0.0
 2    CONTINUE
C
C-----ENTER HEADING FOR THIS PROBLEM
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,10)
      ENDIF
      WRITE(NTOUT,10)
 10   FORMAT('0','ENTER HEADING (A80)')
      READ(*,20) IHEAD
 20   FORMAT(A80)
C
C-----CRYSTAL SYSTEM INPUT - CHARACTER*5 LABEL
C
 28   IF (NTOUT .EQ. 12) THEN
          WRITE(*,30) (CSC(I),I=1,8)
      ENDIF
      WRITE(NTOUT,30) (CSC(I),I=1,8)
 30   FORMAT('0','ENTER CRYSTAL SYSTEM CODE (A5):'/
     * ' ','   ALLOWED CODES:',8(A5,2X))
      READ(*,34) ICRYST 
 34   FORMAT(A5)
      DO 40 I=1,8,1
      IF( ICRYST.NE.CSC(I)) GOTO 40
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,38) CSC(I)
      ENDIF
      WRITE(NTOUT,38) CSC(I)
 38   FORMAT('0','BEGIN LATTICE PARAMETER INPUT FOR CRYSTAL SYSTEM ',A5)
      GOTO 60
 40   CONTINUE
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,50) ICRYST
      ENDIF
      WRITE(NTOUT,50) ICRYST
 50   FORMAT('0','INVALID CODE ',A5,' ENTERED')
      GOTO 28
C
C-----ENTER LATTICE PARAMETERS AS REQUIRED BY CRYSTAL SYSTEM
C
 60   IF (NTOUT .EQ. 12) THEN
          WRITE(*,62)
      ENDIF
      WRITE(NTOUT,62)
 62   FORMAT('0','ENTER A')
      READ(*,*) AO(1)
C
C-----IF CUBIC THEN LATTICE PARAMETER INPUT IS COMPLETE
C
      IF(CSC(1).EQ.ICRYST) GOTO 400
C
C-----IF TETRAG, RHOMB HEXAG, OR HEXAR THEN B=A AND SKIP B INPUT
C
      IF(ICRYST.EQ.CSC(2)) GOTO 80
      IF(ICRYST.EQ.CSC(5)) GOTO 100
      IF(ICRYST.EQ.CSC(7)) GOTO 80
      IF(ICRYST.EQ.CSC(8)) GOTO 80
C
C-----INPUT OF B LATTICE PARAMETER
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,70)
      ENDIF
      WRITE(NTOUT,70)
 70   FORMAT('0','ENTER B')
      READ(*,*) AO(2)
C
C-----ENTER C LATTICE PARAMETER
C
 80   IF (NTOUT .EQ. 12) THEN
          WRITE(*,82)
      ENDIF
      WRITE(NTOUT,82)
 82   FORMAT('0','ENTER C')
      READ(*,*) AO(3)
C
C-----IF TETRAGONAL, HEXAGONAL, RHOMBOHEDRAL ON H-AXES, OR ORTHORHOMBIC
C-----THEN ALL LATTICE PARMETERS HAVE BEEN INPUT
C
      IF(ICRYST.EQ.CSC(2)) GOTO 400
      IF(ICRYST.EQ.CSC(7)) GOTO 400
      IF(ICRYST.EQ.CSC(8)) GOTO 400
      IF(ICRYST.EQ.CSC(3)) GOTO 400
C
C-----IF MONOCLINIC THEN SKIP TO BETA INPUT
C
      IF(ICRYST.EQ.CSC(4)) GOTO 120
C
C-----ENTER ALPHA LATTICE PARAMETER
C
 100  IF (NTOUT .EQ. 12) THEN
          WRITE(*,102)
      ENDIF
      WRITE(NTOUT,102)
 102  FORMAT('0','ENTER ALPHA')
      READ(*,*) ALO(1)
C
C-----TEST IF RHOMBOHERDAL, IF SO DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(5)) GOTO 400
C
C-----ENTER BETA
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,122)
      ENDIF
 120  WRITE(NTOUT,122)
 122  FORMAT('0','ENTER BETA')
      READ(*,*) ALO(2)
C
C-----IF MONOCLINIC B-UNIQUE THEN DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(4)) GOTO 400
C
C-----ENTER GAMMA ANGLE
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,142)
      ENDIF
      WRITE(NTOUT,142)
 142  FORMAT('0','ENTER GAMMA')
      READ(*,*) ALO(3)
C
C-----SET TO IDG AND FMN AS REQUIRED BY GEOLOGICAL SURVEY CODE
C
 400  DO 410 I = 1,3,1
      IDG(I) = INT(ALO(I))
      FMN(I) = 60.0*(ALO(I) - REAL(IDG(I)))
 410  CONTINUE
C
C-----NOW TO REQUEST LEAST-SQUARES CONTROL PARAMETERS
C 
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,501)
      ENDIF
 500  WRITE(NTOUT,501)
 501  FORMAT('0','ENTER PARAMETER INPUT FLAG: 1=THETA, 2=2-THETA,',
     * ' 3=D-SPACING')
      ITHT = 2
      READ(*,*) ITHT
      IF(ITHT.LT.1 .OR. ITHT.GT.3) GOTO 500
      ITYPE=ITHT
      IF(ITYPE.GE.2) ITHT = 0
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,502)
      ENDIF
      WRITE(NTOUT,502)
 502  FORMAT('0','IS A LEAST SQUARES TO BE DONE? (Y/N)')
      READ(*,504) YES
 504  FORMAT(A1)
      IF (YES.EQ.'Y') THEN
          IDOLSQ=1
          IF (NTOUT .EQ. 12) THEN
              WRITE(*,530)
          ENDIF
          WRITE(NTOUT,530)
 530     FORMAT('0','ENTER: NCYC, THTMX, TOLMN, TOLMX AND RESOLV'/
     *    '0 DEFAULTS ARE: 2, 40., 0.03, 0.15, 0.075 (DEGREES 2-THETA')
         READ(*,*) NCYC,THTMX,TOLMN,TOLMX,RESOLV
         IF(THTMX.LT.0.01) THTMX=40.
         IF(TOLMN.LT.0.01) TOLMN=0.03
         IF(TOLMX.LT.0.01) TOLMX=0.15
         IF(RESOLV.LT.0.01) RESOLV=0.075
         IF (NCYC .EQ.0)   NCYC = 2
         IF (NTOUT .EQ. 12) THEN
             WRITE(*,540)
         ENDIF
         WRITE(NTOUT,540)
 540     FORMAT('0','ENTER IWTYP,IWCYC (DEFAULTS ARE 0,0)')
         READ(*,*) IWTYP,IWCYC
      END IF
C
C-----ENTER D-GENERATION CONTROL PARAMETERS
C
      INDX = ITYPE
      IF(ITYPE.GT.2) INDX = 2
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,602) LABEL(INDX)
      ENDIF
      WRITE(NTOUT,602) LABEL(INDX)
 602  FORMAT('0','ENTER: ',A7,'-MAX, IPHKL, IXPD, PWL2',
     * ' DEFAULTS ARE: 179.9, 0, 0, 1.540598')
      READ(*,*) THEMX, IPHKL,  IXPD, PWL2
      IF(THEMX.LE.0.01) THEMX=179.9
      IF(PWL2.GT.0.01) PWL = PWL2
C
C-----ENTER THE SPACE GROUP, ASPECT SYMBOL OR CENTERING SYMBOL
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,702)
      ENDIF
      WRITE(NTOUT,702)
 702  FORMAT('0','ENTER SPACE GROUP, ASPECT OR CENTERING SYMBOL.'/
     * ' ',' FIRST CHARACTER CAPITOL, OTHERS LOWER CASE (A8)')
      READ(*,704) SPGI
 704  FORMAT(A8)
C
C-----IF NOT LEAST SQUARES RUN THEN SKIP REFLECTION INPUT
C
      NUMCRD=0
      ITHT = MOD(ITHT,2)
      IF(IDOLSQ.EQ.0) GOTO 900
C
C-----ENTER OBSERVED 2-THETA OR D-VALUE, HKL, WEIGHT AND ALT LAMBDA
C
 805  IF (NTOUT .EQ. 12) THEN
          WRITE(*,806) LABEL(ITYPE)
      ENDIF
      WRITE(NTOUT,806) LABEL(ITYPE)
 806  FORMAT('0','ENTER ',A7,', H, K, L, WEIGHT, ALT LAMBDA (0.0=END)')
 810  NUMCRD = NUMCRD + 1
      WLC = 0.0
      WT  = 0.0
      V   = 0.0
      IHA(1)= 0
      IHA(2)= 0
      IHA(3)= 0
      READ(*,*) V,(IHA(I),I=1,3),WT,WLC
      IF(V.LT.0.01) GOTO 900
      IF(ITYPE.NE.3) THEN
         OBS = V
      ELSE
         D = V
      END IF
      CALL FRCHEK(NUMCRD)
      IF(.NOT. HGOOD) GOTO 805
      CALL PRCHKL(NUMCRD)
      IF(NUMOBS.LE.MAXOBS) GOTO 810
C
C-----MORE THAN MAXOBS REFLECTIONS
C
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,820) MAXOBS,MAXOBS
      ENDIF
      WRITE(NTOUT,820) MAXOBS,MAXOBS
 820  FORMAT('0','**WARNING** MORE THAN',I4,' REFLECTIONS INPUT.',
     * ' ONLY THE FIRST',I4,' TO BE USED')
      IWARN = IWARN + 1
C
C-----DMREAD INPUT COMPLETED
C
 900  IF(ITHT.EQ.0) THEN
      THTMX = THTMX/2
      TOLMN = TOLMN/2
      RESOLV= RESOLV/2
      TOLMX = TOLMX/2
      THEMX = THEMX/2
      END IF
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,992) NUMOBS
      ENDIF
 990  WRITE(NTOUT,992) NUMOBS
 992  FORMAT('0','DEMAND INPUT COMPLETED.', I5,' REFLECTIONS READ')
      RETURN
      END
      SUBROUTINE FINDEX
C      ############################################################
C      #                                                          #
C      #                          FINDEX                          #
C      #                                                          #
C      ############################################################
C**************************************************************************
C
C----THIS SUBROUTINE USES THE SPACE GROUP NUMBER AND ORIENTATION
C-----TO SET UP THE EXTINCTION CODES FOR HKL GENERATION
C
C-----A CENTERING SYMBOL BY ITSELF ALSO SETS UP THE APPROPRIATE EXT CODES
C
C-----FILE CRYST*EXTNCT  IS READ SEQUENTIALLY.  CODE TESTS FOR A
C     MATCH OF SPACE GROUP NUMBER AND ORIENTATION CODE.
C     SEE NBS TECH NOTE 1141 FOR THE SPACE GROUP, NUMBER AND CODES.
C
C-----THE SPACE GROUP NUMBER AND ORIENTATION IS DERIVED FROM THE
C     INPUT SPACE GROUP SYMBOL IN SUBROUTINE SPG
C
C******************************************************************
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/EDITR/IED1(6)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/IERRS/IWARN,IERR
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*1 IED1
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*4 IHBB0B,NSG
      DIMENSION ITEMP(27)
      DATA IHBB0B/'  0 '/
      DO 10 I=1,27
 10   IOP(I)=0
      IF(SPGIN.EQ.IHBB0B) GOTO 219
      REWIND NTEXT
C-----READ FILE OF EXTINCTION CODES WITH SPACE GROUP # AND ORIENTATION
 100  READ (NTEXT,110,END=200) (ITEMP(I),I=1,27),NSG
 110  FORMAT (20X,27I1,29X,A4)
      IF (NSG .NE. SPGIN) GO TO 100
C-----LOCATED THE CORRECT SPACE GROUP AND ORIENTATION
C-----SAVE THE EXTINCTION CODES
      DO 120 I=1,27
 120  IOP(I)=ITEMP(I)
      RETURN
C-----END OF FILE LOCATED WITHOUT FINDING SPACE GROUP
C------AND ORIENTATION OF AUTHORS
 200  IERR=IERR+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,210) SPGIN
      ENDIF
      WRITE(NTOUT,210) SPGIN
 210  FORMAT(1H0,52H**ERROR**NO ENTRY IN EXTINCTION FILE FOR SPACE GROUP
     *, A4)
C
C-----CHECK IF MORE THAN A CENTERING SYMBOL WAS INPUT
C
 219  IF(SPGI(2:2).EQ.ITED(1))GO TO 225
      IWARN=IWARN+1
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,222) SPGI
      ENDIF
      WRITE(NTOUT,222) SPGI
 222  FORMAT(' ','**WARNING**YOU SHOULD INPUT EXTINCTIONS EXPLICITLY FOR
     * SPACE GROUP ',A8,'**WARNING**'/
     * ' ',11X,'ONLY CONDITIONS FOR LATTICE CENTERING GENERATED')
C
C-----SPACE GROUP SYMBOL IS NOT IN FILE.  IS THERE A CENTERING SYMBOL?
C-----(RHOMBOHEDRAL CENTERING ON HEXAGONAL CELL CODE IS SET
C----- IN SUBROUTINE OPSET)
C
 225  IF(SPGI(1:1).EQ.ITSG(1)) GOTO 999
C
C-----SET UP CODE FOR 'A' CENTERING
C
      IF(SPGI(1:1).NE.ITSG(2)) GOTO 226
      IOP(3)=2
      GOTO 999
C
C
C-----SET UP CODE FOR 'B' CENTERING
 226  IF(SPGI(1:1).NE.ITSG(3)) GOTO 230
      IOP(2)=2
      GOTO 999
C
C-----SET UP CODE FOR 'C' CENTERING
C
 230  IF(SPGI(1:1).NE.ITSG(4)) GOTO 240
      IOP(1)=2
      GOTO 999
C
C-----SET UP CODE FOR 'F' CENTERING
C
 240  IF(SPGI(1:1).NE.ITSG(5) .OR. IED1(2).EQ.ITCRS(6)) GOTO 250
      IOP(4)=2
      GOTO 999
C
C-----SET UP CODE FOR 'I' CENTERING
C
 250  IF(SPGI(1:1).NE.ITSG(6) .OR. IED1(2).EQ.ITCRS(6)) GOTO 999
      IOP(5)=2
 999  RETURN
      END
      SUBROUTINE FNINPK
C      ############################################################
C      #                                                          #
C      #                          FNINPK                          #
C      #                                                          #
C      ############################################################
C*************************************************************************
C
C FNINPK  FINAL RESULTS OF REFINEMENT FOR INPUT FROM PKS FILE
C         MODIFIED FROM FNLST
C  N P PYRROS ,9-10-82
C
C***************************************************************************
      PARAMETER (MAXOBS=200, MAXGEN=1000, MAXPKS=300)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      COMMON/CBLKG/IHEAD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/FLAG(MAXOBS)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CCONTR/ ID0
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
C-------------------------------------------------------------
C  PEAK FILE PARAMETERS
C
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/PKFIL/NAME,CRSYS,TMTMMX,TMTMMN
      COMMON/TEMPRT/NTMMS,AVTMP,SDTMPR,TMPRMX,TMPRMN
	COMMON RELINT(MAXPKS)
      CHARACTER*4 TMTMMX,TMTMMN
      CHARACTER*1 CRSYS
      CHARACTER*40 NAME
      CHARACTER*6 NPFLG
C
C  END OF PEAK FILE PARAMETRS.
C-------------------------------------------------------------
      DIMENSION NH(3), JH(3), IAH(3)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, IALF12
      CHARACTER*2 FLAG
      CHARACTER*80 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 IHC
      CHARACTER DAT*9, TIM*8
      DATA IHC/'C'/
C
C-------------------------------------------------------
C
      I2=0
          IPKSQ=1
      IFIRST=0
      IF(NUMOBS.LT.1) GOTO 10
      I2=  IOC(1)
 10   IGP=1
C-----IHP IS ARRAY INDEX TO THE GENERATED HKL
C-----IGP IS ARRAY INDEX FOR AUTHORS HKL
      IHP=1
C
C WRITE HEADING FOR THE FINAL LEASTING
C
      IF (IXPD .EQ. 0) WRITE(NTOUT, 9)
 9    FORMAT ('1')
C     CALL VAX'S DATE TIME ROUTINES AND LIST EACH
          CALL DATIM(DAT,TIM)
      IF ((IXPD .EQ. 0) .AND. (IDOLSQ .EQ. 1)) WRITE(NTOUT, 11) IHEAD,
     * NAME, DAT, TIM,
     * WL(1), ICRYST, SPGI, 2*TOLTH
 11   FORMAT (' ','TITLE OF SET: ' / 1X, A80 /
     *' ','INPUT PKS FILE: ',A40 / ' EXECUTION  ON, DATE: ',A9,
     *' TIME: ',A8 /
     * ' ', 'LAMBDA = ',F10.7/
     * ' ','CRYSTAL SYSTEM = ',A5,4X,'SPACE GROUP = ',A8/
     * ' ','"R" AND "M" REJECTION CRITERIA: TOL=',F5.3,' DEG 2-THETA')
          WRITE(NTOUT,1020) 2*THTSE
 1020 FORMAT(' ','2THETA STANDARD ERROR UNIT WEIGHTS = ',F8.5)
      WRITE(NTOUT,1070) AVTMP,SDTMPR,TMPRMX,TMTMMX,TMPRMN,TMTMMN
 1070 FORMAT(' AVERAGE TEMPERATURE =',F6.1,' C, SIGMA=',F6.1,/,
     *9X,'TEMPERATURE MAXIMUM=',F6.1,' AT ',A4,' H',/,
     *9X,'TEMPERATURE MINIMUM=',F6.1,' AT ',A4,' H')
C
C	80 COLUMN MODE
C
      WRITE(NTOUT,16)
 16   FORMAT(1H0,29X,7H<AUTHS>,2X,7H<PROGM>,5X,4HCORR,4X,4HCALC,
     & 4X,4HDIFF,1X,5HFINAL,1X,'SEQ')
      WRITE(NTOUT, 18) (IALF12(1:1), I=1,3)
 18   FORMAT(1H,3H  N,2X,6HD CALC,3X,5HD OBS,2X,6HRELINT,2X,7HH  K  L,
     & 2X,7HH  K  L,4X,A1,5HTHETA,2X,A1,5HTHETA,2X,A1,5HTHETA,2X,2HWT,
     & 2X,'NUM')
C
C	132 COLUMN MODE
C
C       WRITE(NTOUT,16)
C 16    FORMAT(1H0,27X,9H<AUTHORS>,4X,9H<PROGRAM>,5X,4HCORR,4X,4HCALC,
C     * 4X,4HDIFF,1X,5HFINAL,2X,'SEQ',5X,'I',6X,'I',14X,'RAW',
C     * 5X,'CORR',3X,'DIFF')
C       WRITE(NTOUT,18) (IALF12(1:1), I=1,6)
C 18    FORMAT(1H ,3H  N,2X,6HD CALC,2X,5HD OBS,3X,3HINT,3X,9HH   K   L,
C     * 4X,9HH   K   L,4X,A1,5HTHETA,2X,A1,5HTHETA,1X,A1,5HTHETA,3X,2HWT,
C     * 3X,'NUM',3X,'PEAK',4X,'SIG',3X,'FLAGS',1X,2(2X,A1,'THETA'),
C     * 1X,A1,'THETA')
C
C                      END HEADING
C
C
 20   IF (IHP .LE. NR) GO TO 22
      IF (IGP .GT. NUMOBS) GO TO 99
      GO TO 40
 22   DO 24 L=1,3
 24   NH(L) = IHG(IHP,L)
      D=DCM(IHP)
      IF (IHP .EQ. I2) GO TO 40
      THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      CALL SRMTCH(IPKSQ,IHP,IGP,NH)
 32   IHP=IHP+1
      GO TO 20
 40   DO 42 L=1,3
 42   JH(L) = IH(IGP,L)
      DOBS=DSP(IGP)
      THOBS=OBSTH(IGP)
      DF=DLST(IGP)
      SWT = SW(IGP)*SW(IGP)
C
C-----IS OBSERVED D-SPACING BEYOND THE LIMIT OF GENERATION. IF SO
C-----CALCULATED D-CALC DIRECTLY AS IT IS NOT STORED IN DLST( )
C
      IF(DOBS.GE.DMIN) GOTO 50
      IFIRST=IFIRST+1
      IF(IFIRST.EQ.1 .AND. IXPD.EQ.0) WRITE(NTOUT,44) 
 44   FORMAT(1H ,58H**BEGIN LISTING INPUT REFLECTIONS BEYOND HKL/D-GEN R
     *ANGE**)
C-----TEST IF UNINDEXED, KNOWN IMPURITY OR SPACE GROUP EXTINCT
      IF(IHED(IGP).EQ.ITIH(4).OR.IHED(IGP).EQ.ITIH(5).OR.
     * IHED(IGP).EQ.ITIH(6)) GOTO 48
      DO 46 I=1,3
 46   IAH(I) = IH(IGP,I)
      CALL QCOMP(IAH,Z,Q)
      DF=1.0/SQRT(Q)
      GO TO 50
C-----UNINDEXED REFLECTION BEYOND GENERATION RANGE; SET THCLC, DIFF,
C-----ETC TO VERY LARGE NUMBERS SO THAT ASTERISKS ARE PRINTED
 48   THCLC=1.0E+10
      DIFF=1.0E+10
      DF=1.0E+10
      NH(1)=99999
      NH(2)=99999
      NH(3)=99999
      IF(ITHT.EQ.0) THOBS=THOBS+THOBS
      GO TO 54
 50   THCLC=THETA(0.5*PWL,DF)
      DIFF=THCLC-THOBS
      IF (ITHT .NE. 0) GO TO 54
      THCLC=THCLC+THCLC
      THOBS=THOBS+THOBS
      DIFF=DIFF+DIFF
C-----TEST IF INDEXED
 54   IF(IHED(IGP).NE.ITIH(4) .AND. IHED(IGP).NE.ITIH(5) .AND.
     * IHED(IGP).NE.ITIH(6)) GOTO 70
C-----UNINDEXED OBSERVATION OR SPACE GROUP EXTINCT OR KNOWN IMPURITY
      IF(IHED(IGP).EQ.ITIH(5)) GOTO 60
C
C-----STORE H,K,L(PROGRAM) OF NEAREST LINE AND MARK WITH EDITORIAL 'C'
C-----ONLY IF DIFF<0.30 DEG 2-THETA
C
      IF(ABS(DIFF).GT.0.30) GOTO 60
      IH(IGP,1) = NH(1)
      IH(IGP,2) = NH(2)
      IH(IGP,3) = NH(3)
C-----MARK REFLECTION AS COMPUTER ASSIGNED HKL (MARK IS 'C')
      IHED(IGP)=IHC
      JH(1)=NH(1)
      JH(2)=NH(2)
      JH(3)=NH(3)
      GOTO 70
C
C-----OUTPUT NEXT GENERATED LINE WHICH DOES NOT INDEX ANY AUTHORS LINES
C
 60   IPKSQ=NPKSQ(IGP)
C
C	80 COLUMN MODE
C 
      WRITE(NTOUT,58) IHP,DF,DOBS,IHED(IGP), RELINT(IPKSQ),
     * INTED(IGP),(NH(L),L=1,3),FLAG(IGP),THOBS,THCLC, DIFF, SWT,
     * IPKSQ
 58   FORMAT(1H,I3,2F8.4,A1,1X,F5.1,A1,9X,3I3,A2,2F8.3,F7.3,F6.2,I4)
C
C	132 COLUMN MODE
C
C      WRITE(NTOUT,58) IHP,DF,DOBS,IHED(IGP),
C     * INTED(IGP),(NH(L),L=1,3),FLAG(IGP),THOBS,THCLC, DIFF, SWT,
C     *IPKSQ,PKPRM(3,IPKSQ),PKPRM(4,IPKSQ),NPFLG(IPKSQ),PKPRM(1,IPKSQ)
C 58   FORMAT(1H ,I3,2F8.4,A1,3X,A1,13X,3I4,A2,2F8.3,F7.3,F6.2,I5,
C     * F8.1,F6.1,2X,A6,F9.3)
 62   IGP=IGP+1
      IF (IGP-NUMOBS) 64,64,68
 64   IF (  IOC(IGP)  .EQ. I2) GO TO 40
      I2=  IOC(IGP)
      GO TO 32
 68   I2=0
      GO TO 32
C-----AUTHORS  OR EDITER INDEXED REFLECTION PRINTED HERE
 70   THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      IF (IGP .LT. 2) GO TO 75
      IF (  IOC(IGP-1)  .NE. I2) GO TO 75
C
C	80 COLUMN MODE
C
 73   IPKSQ=NPKSQ(IGP)
      WRITE(NTOUT,74)DF,DOBS,IHED(IGP),RELINT(IPKSQ),INTED(IGP),
     * (JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT,
     * IPKSQ
 74   FORMAT(1H ,3H***,2F8.4,A1,1X,F5.1,A1,3I3,9X,A2,2F8.3,F7.3,F6.2,
     * I4)
C
C	132 COLUMN MODE
C
C      WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INTED(IGP),
C     *(JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT,
C     *IPKSQ,PKPRM(3,IPKSQ),PKPRM(4,IPKSQ),NPFLG(IPKSQ),PKPRM(1,IPKSQ)
C 74   FORMAT(1H ,3H***,2F8.4,A1,3X,A1,3I4,13X,A2,2F8.3,F7.3,F6.2,
C     *I5,F8.1,F6.1,2X,A6,F9.3)
      GO TO 62
 75   IF (JH(1) .EQ. NH(1) .AND. JH(2) .EQ. NH(2) .AND.
     *JH(3) .EQ. NH(3)) GO TO 82
C
C-----CHECK IF MATCHES -H,-K,-L
C
      IF(JH(1).EQ.-NH(1) .AND. JH(2).EQ.-NH(2) .AND.
     *JH(3) .EQ.-NH(3)) GO TO 82
C
C-----IF HEX OR TET TEST IF THE H**2 + K**2 ARE EQUAL AND IF L'S ARE EQUAL
C
      IF ((ICRS .EQ. ITCRS(4) .OR. ICRS .EQ. ITCRS(5)) .AND.
     * (JH(1)*JH(1)+JH(2)*JH(2)) .EQ. (NH(1)*NH(1)+
     * NH(2)*NH(2)) .AND. JH(3) .EQ. NH(3)) GO TO 82
C
C-----IF CUBIC TEST IF THE H**2 + K**2 + L**2 ARE EQUAL
C
      IF (ICRS .EQ. ITCRS(7) .AND. (JH(1)*JH(1) + JH(2)*JH(2)
     * + JH(3)*JH(3)) .EQ. (NH(1)*NH(1) + NH(2)*NH(2) +
     * NH(3)*NH(3))) GO TO 82
C
C-----AUTHOR AND GENERATED HKL DO NOT MATCH PRINT THE
C-----ONE WITH LARGEST D FIRST
C
      IF (DLST(IGP)-D) 76,76,80
 76   CALL SRMTCH(IPKSQ,IHP,IGP,NH)
      GO TO 73
 80   IPKSQ=NPKSQ(IGP)
C
C	80 COLUMN MODE
C
      WRITE(NTOUT,74)DF,DOBS,IHED(IGP),RELINT(IPKSQ),INTED(IGP),
     *(JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT,
     *IPKSQ
C
C	132 COLUMN MODE
C
C      WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INTED(IGP),
C     *(JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT,
C     *IPKSQ,PKPRM(3,IPKSQ),PKPRM(4,IPKSQ),NPFLG(IPKSQ),PKPRM(1,IPKSQ)
      CALL SRMTCH(IPKSQ,IHP,IGP,NH)
      GO TO 62
C
C-----PRINT BOTH AUTHORS AND GENERATED ON SAME LINE
C
 82   IPKSQ=NPKSQ(IGP)
C
C	80 COLUMN MODE
C
      IF (IXPD .EQ. 0) WRITE (NTOUT, 84) IHP, DF, DOBS, IHED(IGP),
     *RELINT(IPKSQ),INTED(IGP),(JH(L),L = 1, 3),(NH(L),L = 1, 3),
     & FLAG(IGP),THOBS, THCLC, DIFF, SWT,IPKSQ
 84   FORMAT (1H , I3, 2F8.4, A1,1X,F5.1,A1,3I3,3I3, A2,
     * 2F8.3, F7.3,F6.2, I4)
C
C	132 COLUMN MODE
C
C      IF (IXPD .EQ. 0) WRITE (NTOUT, 84) IHP, DF, DOBS, IHED(IGP),
C     * INTED(IGP),(JH(L),L = 1, 3), (NH(L), L = 1, 3), FLAG(IGP),
C     *THOBS, THCLC, DIFF, SWT,
C     *IPKSQ,PKPRM(3,IPKSQ),PKPRM(4,IPKSQ),NPFLG(IPKSQ),PKPRM(1,IPKSQ)
C 84   FORMAT (1H , I3, 2F8.4, A1,3X,A1, 3I4, 1X, 3I4, A2
C     *, 2F8.3, F7.3,F6.2,
C     *I5,F8.1,F6.1,2X,A6,F9.3)
      GO TO 62
 99   RETURN
      END
      SUBROUTINE FNLST
C      ############################################################
C      #                                                          #
C      #                          FNLST                           #
C      #                                                          #
C      ############################################################
C*************************************************************************
C
C CALLED FROM SUBROUTINE SLCR
C LISTS THEORETICAL REFLECTIONS IN DESCENDING ORDER FOR D-SPACING
C
C***************************************************************************
      PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      COMMON/CBLKG/IHEAD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/FLAG(MAXOBS)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CCONTR/ ID0
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      DIMENSION NH(3), JH(3), IAH(3)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, IALF12
      CHARACTER*2 FLAG
      CHARACTER*80 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 IHC
      CHARACTER DAT*9, TIM*8
      DATA IHC/'C'/
C
C-----CALL SUBROUTINE DATIM WHICH GETS CURRENT DATE AND TIME FROM SYSTEM
C
      CALL DATIM(DAT,TIM)
      I2=0
      IFIRST=0
      IF(NUMOBS.LT.1) GOTO 10
      I2=IABS(IOC(1))
 10   IGP=1
C-----IHP IS ARRAY INDEX TO THE GENERATED HKL
C-----IGP IS ARRAY INDEX FOR AUTHORS HKL
      IHP=1
      IF (IXPD .EQ. 0) WRITE (NTOUT, 9)
 9    FORMAT ('1')
      IF ((IXPD .EQ. 0) .AND. (IDOLSQ .EQ. 1)) WRITE (NTOUT, 11) IHEAD,
     * DAT,TIM,WL(1),ICRYST,SPGI,2*TOLTH,2*THTSE
 11   FORMAT (' ','TITLE OF SET: ' / 1X,A80 / ' ',
     *  'EXECUTION ON: DATE=', A9,2X, 'TIME=',A8/ ' ', 'LAMBDA = ',
     * F10.7/ ' ','CRYSTAL SYSTEM = ',A5,4X,'SPACE GROUP = ',A8/
     * ' ','"R" AND "M" REJECTION CRITERIA: TOL=',F5.3,' DEG 2-THETA'/
     * ' ','2-THETA STANDARD ERROR UNIT WEIGHTS = ',F8.5)
C
C	80 COLUMN MODE
C
C      IF(IXPD.EQ.0) WRITE(NTOUT,16)
C 16   FORMAT(1H0,29X,7H<AUTHS>,2X,7H<PROGM>,5X,4H OBS,4X,4HCALC,
C     * 4X,4HDIFF,1X,5HFINAL)
C      IF(IXPD.EQ.0) WRITE(NTOUT,18) IALF12(1:1),IALF12(1:1),IALF12(1:1)
C 18   FORMAT(1H ,3H  N,2X,6HD CALC,3X,5HD OBS,2X,3HINT,2X,7HH  K  L,
C     * 2X,7HH  K  L,4X,A1,5HTHETA,2X,A1,5HTHETA,2X,A1,5HTHETA,2X,2HWT)
C
C	80 COLUMN MODE ALSO
C
      IF(IXPD.EQ.0) WRITE(NTOUT,16)
 16   FORMAT(1H0,27X,9H<AUTHORS>,4X,9H<PROGRAM>,5X,3HOBS,5X,4HCALC,
     * 3X,4HDIFF,2X,5HFINAL)
      IF(IXPD.EQ.0) WRITE(NTOUT,18) IALF12(1:1),IALF12(1:1),IALF12(1:1)
 18   FORMAT(1H ,3H  N,2X,6HD CALC,2X,5HD OBS,3X,3HINT,3X,9HH   K   L,
     * 4X,9HH   K   L,4X,A1,5HTHETA,2X,A1,5HTHETA,1X,A1,5HTHETA,2X,2HWT)
 20   IF (IHP .LE. NR) GO TO 22
      IF (IGP .GT. NUMOBS) GO TO 99
      GO TO 40
 22   DO 24 L=1,3
 24   NH(L) = IHG(IHP,L)
      D=DCM(IHP)
      IF (IHP .EQ. I2) GO TO 40
      THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
C 30   FORMAT(1H ,I3,F8.4,27X,3I3, 9X,F9.3)
 30   FORMAT(1H ,I3,F8.4,26X,3I4, 9X,F9.3)
 32   IHP=IHP+1
      GO TO 20
 40   DO 42 L=1,3
 42   JH(L) = IH(IGP,L)
      DOBS=DSP(IGP)
      THOBS=OBSTH(IGP)
      DF=DLST(IGP)
      SWT = SW(IGP)*SW(IGP)
C
C-----IS OBSERVED D-SPACING BEYOND THE LIMIT OF GENERATION. IF SO
C-----CALCULATED D-CALC DIRECTLY AS IT IS NOT STORED IN DLST( )
C
      IF(DOBS.GE.DMIN) GOTO 50
      IFIRST=IFIRST+1
      IF(IFIRST.EQ.1 .AND. IXPD.EQ.0) WRITE(NTOUT,44)
 44   FORMAT(1H ,58H**BEGIN LISTING INPUT REFLECTIONS BEYOND HKL/D-GEN R
     *ANGE**)
C-----TEST IF UNINDEXED, KNOWN IMPURITY OR SPACE GROUP EXTINCT
      IF(IHED(IGP).EQ.ITIH(4).OR.IHED(IGP).EQ.ITIH(5).OR.
     * IHED(IGP).EQ.ITIH(6)) GOTO 48
      DO 46 I=1,3
 46   IAH(I) = IH(IGP,I)
      CALL QCOMP(IAH,Z,Q)
      DF=1.0/SQRT(Q)
      GO TO 50
C-----UNINDEXED REFLECTION BEYOND GENERATION RANGE; SET THCLC, DIFF,
C-----ETC TO VERY LARGE NUMBERS SO THAT ASTERISKS ARE PRINTED
 48   THCLC=1.0E+10
      DIFF=1.0E+10
      DF=1.0E+10
      NH(1)=99999
      NH(2)=99999
      NH(3)=99999
      IF(ITHT.EQ.0) THOBS=THOBS+THOBS
      GO TO 54
 50   THCLC=THETA(0.5*PWL,DF)
      DIFF=THCLC-THOBS
      IF (ITHT .NE. 0) GO TO 54
      THCLC=THCLC+THCLC
      THOBS=THOBS+THOBS
      DIFF=DIFF+DIFF
C-----TEST IF INDEXED
 54   IF(IHED(IGP).NE.ITIH(4) .AND. IHED(IGP).NE.ITIH(5) .AND.
     * IHED(IGP).NE.ITIH(6)) GOTO 70
C-----UNINDEXED OBSERVATION OR SPACE GROUP EXTINCT OR KNOWN IMPURITY
      IF(IHED(IGP).EQ.ITIH(5)) GOTO 60
C
C-----STORE H,K,L(PROGRAM) OF NEAREST LINE AND MARK WITH EDITORIAL 'C'
C-----ONLY IF DIFF<0.30 DEG 2-THETA
C
      IF(ABS(DIFF).GT.0.30) GOTO 60
      IH(IGP,1) = NH(1)
      IH(IGP,2) = NH(2)
      IH(IGP,3) = NH(3)
C-----MARK REFLECTION AS COMPUTER ASSIGNED HKL (MARK IS 'C')
      IHED(IGP)=IHC
      JH(1)=NH(1)
      JH(2)=NH(2)
      JH(3)=NH(3)
      GOTO 70
C
C-----OUTPUT NEXT GENERATED LINE WHICH DOES NOT INDEX ANY AUTHORS LINES
C
 60   IF(IXPD.EQ.0) WRITE(NTOUT,58) IHP,DF,DOBS,IHED(IGP),INTN(IGP),
     * INTED(IGP),(NH(L),L=1,3),FLAG(IGP),THOBS,THCLC, DIFF, SWT
C 58   FORMAT(1H ,I3,2F8.4,A1,I3,A1,14X,3I3,A2,2F8.3,F7.3,F6.2)
 58   FORMAT(1H ,I3,2F8.4,A1,I3,A1,13X,3I4,A2,2F8.3,F7.3,F6.2)
 62   IGP=IGP+1
      IF (IGP-NUMOBS) 64,64,68
 64   IF (IABS(IOC(IGP)) .EQ. I2) GO TO 40
      I2=IABS(IOC(IGP))
      GO TO 32
 68   I2=0
      GO TO 32
C-----AUTHORS  OR EDITER INDEXED REFLECTION PRINTED HERE
 70   THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      IF (IGP .LT. 2) GO TO 75
      IF (IABS(IOC(IGP-1)) .NE. I2) GO TO 75
 73   IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INTN(IGP),
     *INTED(IGP),(JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT
C 74   FORMAT(1H ,3H***,2F8.4,A1,I3,A1,3I3,5X,A2,2F8.3,F7.3,F6.2)
 74   FORMAT(1H ,3H***,2F8.4,A1,I3,A1,3I4,13X,A2,2F8.3,F7.3,F6.2)
      GO TO 62
 75   IF (JH(1) .EQ. NH(1) .AND. JH(2) .EQ. NH(2) .AND.
     *JH(3) .EQ. NH(3)) GO TO 82
C
C-----CHECK IF MATCHES -H,-K,-L
C
      IF(JH(1).EQ.-NH(1) .AND. JH(2).EQ.-NH(2) .AND.
     *JH(3) .EQ.-NH(3)) GO TO 82
C
C-----IF HEX OR TET TEST IF THE H**2 + K**2 ARE EQUAL AND IF L'S ARE EQUAL
C
      IF ((ICRS .EQ. ITCRS(4) .OR. ICRS .EQ. ITCRS(5)) .AND.
     * (JH(1)*JH(1)+JH(2)*JH(2)) .EQ. (NH(1)*NH(1)+
     * NH(2)*NH(2)) .AND. JH(3) .EQ. NH(3)) GO TO 82
C
C-----IF CUBIC TEST IF THE H**2 + K**2 + L**2 ARE EQUAL
C
      IF (ICRS .EQ. ITCRS(7) .AND. (JH(1)*JH(1) + JH(2)*JH(2)
     * + JH(3)*JH(3)) .EQ. (NH(1)*NH(1) + NH(2)*NH(2) +
     * NH(3)*NH(3))) GO TO 82
C
C-----AUTHOR AND GENERATED HKL DO NOT MATCH PRINT THE
C-----ONE WITH LARGEST D FIRST
C
      IF (DLST(IGP)-D) 76,76,80
 76   IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
      GO TO 73
 80   IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INTN(IGP),INTED(IGP)
     *,(JH(L),L=1,3),FLAG(IGP),THOBS, THCLC, DIFF, SWT
      IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
      GO TO 62
C
C-----PRINT BOTH AUTHORS AND GENERATED ON SAME LINE
C
 82   IF (IXPD .EQ. 0) WRITE (NTOUT, 84) IHP, DF, DOBS, IHED(IGP),
     * INTN(IGP),INTED(IGP),(JH(L),L= 1,3),(NH(L), L = 1, 3), FLAG(IGP),
     *THOBS, THCLC, DIFF, SWT
 84   FORMAT (1H , I3, 2F8.4, A1,I3,A1, 3I3, 5X, 3I3, A2, 2F8.3, F7.3,
     & F6.2)
C 84   FORMAT (1H , I3, 2F8.4, A1,I3,A1, 3I4, 1X, 3I4, A2
C     *, 2F8.3,F7.3,F6.2)
      GO TO 62
 99   RETURN
      END
      SUBROUTINE FRCHEK(NUMCRD)
C      ############################################################
C      #                                                          #
C      #                          FRCHEK                          #
C      #                                                          #
C      ############################################################
C
C-----SUBROUTINE TO CHECK FOR ERRORS ON REFLECTION CARDS
C
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/IO/NTOUT,NTIN,NEXTN,IOPKS,IOSCR
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      LOGICAL HGOOD
C
C-----INITIALIZE FLAGS
C
      HGOOD = .TRUE.
C
C-----CHECK THAT D-SPACING, ALT. LAMBDA, 2-THETA, AND WEIGHT
C-----ARE NOT NEGATIVE
C
      IF ((D .GE. 0.0) .AND. (WLC .GE. 0.0) .AND. (OBS .GE. 0.0)
     * .AND. (WT .GE. 0.0)) GO TO 50
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 30) NUMCRD, D, WLC, OBS, WT
      ENDIF
      WRITE(NTOUT, 30) NUMCRD, D, WLC, OBS, WT
 30   FORMAT (' ', '**ERROR**CARD #',I3,'-NOT USED (REFLECTION) ',
     * ' HAS ILLEGAL NEGATIVE VALUE; NONE OF FOLLOWING ',
     * 'SHOULD BE NEGATIVE:' /
     * ' ', 'D-SPACING = ', F9.6, '  /  ALTERNATE LAMBDA = ',
     * F8.5, '  /  2-THETA = ', F9.5, '  /  WEIGHT = ', F9.5)
      HGOOD = .FALSE.
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH
C-----NON ZERO
C
 50   CONTINUE
      IF((D .LE. 0.0001) .OR. (OBS .LE. 0.0001)) GO TO 70
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 60) NUMCRD, D, OBS
      ENDIF
      WRITE(NTOUT, 60) NUMCRD, D, OBS
 60   FORMAT (' ', '**ERROR**CARD #',I3,'-NOT USED (REFLECTION) ',
     * ' HAS A VALUE FOR BOTH THE ',
     * 'D-SPACING (= ', F9.6, ') AND 2-THETA (= ',
     * F9.5, ')')
      HGOOD = .FALSE.
 70   CONTINUE
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH ZERO
C
      IF ((D .GT. 0.0001) .OR. (OBS .GT. 0.0001)) GO TO 999
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 85) NUMCRD, D, OBS
      ENDIF
      WRITE(NTOUT, 85) NUMCRD, D, OBS
 85   FORMAT (' ', '**ERROR**CARD #',I3,'-NOT USED (REFLECTION) ',
     * ' NEITHER D-SPACING (= ', F9.6,
     * ') NOR 2-THETA (= ', F9.5, ') IS POSITIVE')
      HGOOD = .FALSE.
 999  RETURN
      END
      SUBROUTINE HKLES
C      ############################################################
C      #                                                          #
C      #                          HKLES                           #
C      #                                                          #
C      ############################################################
C*********************************************************************
C
C-----ROUTINE NOW ONLY CHECKS HKL VS. EXTINCTION CODES
C
      PARAMETER (MAXOBS=200)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/IERRS/IWARN,IERR
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 IHN,IHS,IHU
      DATA IHN,IHS,IHU/'N','*','U'/
C-----BEGIN LOOP THROUGH INPUT REFLECTIONS FOR EXTINCTION CHECK
      IF(NOPT .LT. 1) GO TO 999
      DO 20  I=1,NUMOBS
C
C-----TEST IF THIS IS AN INDEXED REFLECTION.  DO NOT TEST THOSE
C-----MARKED WITH "*" OR "U".
C
      IF(IHED(I).EQ.IHS .OR. IHED(I).EQ.IHU) GOTO 20
      JH = IH(I,1)
      JK=IH(I,2)
      JL=IH(I,3)
      CALL CHKEXT(JH,JK,JL,JEXT)
      IF(JEXT .EQ.0) GO TO 20
C-----WRITE OUT ERROR MESSAGE FOR ANY FORBIDDEN INDICIES
 9    ANGLE = OBSTH(I)
      IF(ITHT.EQ.0) ANGLE=ANGLE+ANGLE
      IF(SPGIN.NE.'    ') THEN 
          IF (NTOUT .EQ. 12) THEN
              WRITE(*, 10) JH, JK, JL, ANGLE, DSP(I), SPGI
          ENDIF
          WRITE(NTOUT,10) JH,JK,JL,ANGLE,DSP(I),SPGI
      ENDIF
      IF(SPGIN.EQ.'    ') THEN 
          IF (NTOUT .EQ. 12) THEN
              WRITE(*, 11) JH, JK, JL, ANGLE, DSP(I)
          ENDIF
          WRITE(NTOUT,11) JH,JK,JL,ANGLE,DSP(I)
      ENDIF
      IERR=IERR+1
 10   FORMAT(1H ,19H**ERROR**REFLECTION,3I3,7H/ANGLE=,F7.3,3H/D=,
     * F7.4,20H SHOULD BE ABSENT IN,1X,A8)
 11   FORMAT(1H ,19H**ERROR**REFLECTION,3I3,7H/ANGLE=,F7.3,3H/D=,
     * F7.4,  ' SHOULD BE ABSENT')
      IHED(I)=IHN
 20   CONTINUE
 999  RETURN
      END
      SUBROUTINE HKLGEN
C      ############################################################
C      #                                                          #
C      #                          HKLGEN                          #
C      #                                                          #
C      ############################################################
C GENERATES MILLER INDICES CORRESPONDING TO PLANES AT DISTANCES FROM
C DMIN ON UP - MAXIMUM OF MAXGEN REFLECTIONS MAY BE GENERATED
C
       PARAMETER (MAXGEN=1000)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/SCRT/E(7),NH(3)
 9    QMAX=1.0/(DMIN*DMIN)
      NR=0
      E(1)=Z(1)
      E(2)=Z(2)
      E(3)=Z(4)
      TD=E(1)*E(2)-E(3)*E(3)
      IL=0
 15   NH(3)=IL
      E(4)=(Z(5)+Z(5))*NH(3)
      E(5)=(Z(6)+Z(6))*NH(3)
      E(6)=Z(3)*NH(3)*NH(3)-QMAX
      TN=E(3)*E(5)-E(1)*E(4)
      DSCRS=TN*TN-(4.0*E(1)*E(6)-E(5)*E(5))*TD
      IF (DSCRS.LT.0.0) GO TO 60
      CALL SKIP (DSCRM,DSCRS,TN,TD,IK,IK1,IK2,IL,GT,HT,QMAX,DEN,
     & IH,IH1,IH2,JEXT,JSWT)
      GO TO (9,15),JSWT
 60   RETURN
      END
      SUBROUTINE HKLPR(FLAG)
C      ############################################################
C      #                                                          #
C      #                          HKLPR                           #
C      #                                                          #
C      ############################################################
C
C PRINTS H,K,L,CALCULATED AND OBSERVED D-S AND THETAS
C
      PARAMETER (MAXOBS=200)
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/SCRT/E(7),NH(3)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*2 FLAG
C-----SEQUENCE NUMBER
      NUMSEQ = NUMCYC + 1
      WT=SWT*SWT
      TC=THCMP
      OB=THOBS
      TD=DIFF
      IF (ITHT.NE.0) GO TO 12
      TC=TC+TC
      OB=OB+OB
      TD=TD+TD
 12   WRITE(NTOUT,15) NUMSEQ,(NH(L),L=1,3),FLAG,D,DOBS,PWL,TC,OB,TD,
     * WT
      RETURN
 15   FORMAT(' ',I3,3I3,A2,F7.4,F9.4,3X,F8.5,F9.3,F10.3,F10.3,F10.3)
      END
      SUBROUTINE NORME
C      ############################################################
C      #                                                          #
C      #                          NORME                           #
C      #                                                          #
C      ############################################################
C ACCUMULATES NORMAL EQUATIONS AND SUM OF SQUARES
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/SCRT/E(7),NH(3)
      EQUIVALENCE (RSMX,RSDMAX),(IRSD,MAXM)
      L=0
      NP1=NLSQV+1
      DO 20 J=1,NLSQV
      DO 20 K=J,NP1
      L=L+1
 20   A(L)=A(L)+E(J)*E(K)
      SUM=SUM+E(NP1)**2
      IF (ABS(E(NP1)).LE.ABS(RSMX)) GO TO 30
      MAXM = NUMCYC
      RSMX=E(NP1)
 30   RETURN
      END
      SUBROUTINE OBSEQ
C      ############################################################
C      #                                                          #
C      #                          OBSEQ                           #
C      #                                                          #
C      ############################################################
C FORMS OBSERVATION EQUATION FOR ACCEPTED REFLECTIONS
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/SCRT/E(7),NH(3)
      COMMON/SWFG/DEGRAD
      NUMCYC=NUMCYC+1
      DIV=COS(0.017453293*THCMP)
      IF (DIV) 5,5,8
 5    NUMCYC=NUMCYC-1
      RETURN
 8    FAC=(DEGRAD*D*CONST*SWT)/DIV
      EQCNS=SWT*DIFF
      CALL DLQOT
      E(NLSQV+1)=-EQCNS
      GO TO (10,20,30,40,50,60,70),ITYP
 10   E(1)=B(1)+B(2)+B(3)
      GO TO 80
 20   E(1)=B(1)+B(2)
      E(2)=B(3)
      GO TO 80
 30   DO 35 J=1,3
 35   E(J)=B(J)
      GO TO 80
 40   DO 45 J=1,3
 45   E(J)=B(J)
      E(4)=B(5)
      GO TO 80
 50   E(1)=B(1)+B(2)
      E(2)=B(3)
      GO TO 80
 60   DO 65 J=1,6
 65   E(J)=B(J)
      GO TO 80
 70   DO 75 J=1,2
 75   E(J)=B(3*J-2)+B(3*J-1)+B(3*J)
 80   RETURN
      END
      SUBROUTINE OPSET
C      ############################################################
C      #                                                          #
C      #                          OPSET                           #
C      #                                                          #
C      ############################################################
C DOES BOOKKEEPING FOR SETTING UP EXTINCTION RELATIONS TO USE
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      NOPT=0
      IF (JTYP.EQ.8) IOP(6)=3
      DO 9 L=1,27
      IF (IOP(L).LT.2.OR.IOP(L).GT.6.OR.IOP(L).EQ.5) GO TO 9
      NOPT=NOPT+1
      JOP(NOPT)=L
 9    CONTINUE
      RETURN
      END
      SUBROUTINE OUTPUT(DONE)
C      ############################################################
C      #                                                          #
C      #                          OUTPUT                          #
C      #                                                          #
C      ############################################################
      PARAMETER (MAXOBS=200)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/CPPCON/IALF12
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(6,6),FACTR
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CCONTR/ ID0
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/OUTHLD/TCR(3)
      DIMENSION V(6)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED,HKLED
      REAL TEMP(3)
      LOGICAL DONE
      CHARACTER*80 IHEAD
      CHARACTER*6 IALF12
      TOLP=TOLTH
      IF(IALF12.EQ.'2-') TOLP=TOLP+TOLP
      IF ((IPHKL .EQ. 2) .AND. (DONE)) WRITE (NTOUT, 430) ICYCLE,IHEAD,
     * IALF12,TOLP
 430  FORMAT ('1', 'CYCLE', I3 / 1X, A80/ 1X,A2, 'THETA TOLERANCE = ',
     * F9.5)
      RM=-RSDMAX
      TSE=THTSE
      IF (ITHT.NE.0) GO TO 9
      RM=RM+RM
      TSE=TSE+TSE
 9    IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,10) RM,IRSD,TSE,MMN
 10   FORMAT('0'/' ','LARGEST RESIDUAL REDUCED TO UNIT WEIGHT',F8.5,3X,
     * 'OBS',I4 / 3X,'STANDARD ERROR UNIT WT OBS',F8.5,3X,
     * 'DEGREES OF FREEDOM',I4)
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,122)
 122  FORMAT(1H0,17X,1HA,8X,1HB,8X,1HC,6X,5HALPHA,5X,4HBETA,6X,
     * 5HGAMMA,5X,6HVOLUME)
      PRINT*
C
C-----CONVERT FROM MINUTES TO DEEGREES
C
      DO 15 I = 1, 3, 1
      TEMP(I) = AR(I) / 60.0
 15   CONTINUE
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,12) (X(I),I=1,3),
     * (TEMP(I),I=1,3),VR
 12   FORMAT(11H RECIP CELL,2X,3(F8.5,1X),1X,F8.4,2X,F8.4,2X,
     & F8.4,1X,E11.4)
      DO 50 I = 1, 3, 1
      TEMP(I) = SERCE(I+3) / 60.0
 50   CONTINUE
      IF (DONE) WRITE(NTOUT,86) (SERCE(I),I=1,3), (TEMP(I), I = 1, 3)
 86   FORMAT(12H R C STD ERR,1X,3(E9.2),2X,2(F7.4,3X),F7.4)
      DO 80 I = 1, 3, 1
      TEMP(I) = UO(I) / 60.0
 80   CONTINUE
      TEMP1 = VR - VRO
      IF ((IPHKL .NE.2) .OR. (DONE)) WRITE(NTOUT,14) (TCR(J),J=1,3),
     * (TEMP(J),J=1,3),TEMP1
 14   FORMAT(12H R C CORRECT,1X,3(E9.2),2X,2(F7.4,3X),F7.4,1X,E11.4)
      PRINT*
      DO 22 I = 1, 3, 1
 22   TEMP(I) = (ALS(I))/60.0
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE (NTOUT,24) (AD(I),I=1,3),
     * (TEMP(I),I=1,3),VC
 24   FORMAT (' ', 'DIRECT CELL', 3(F9.5),2X,F8.4,2X,F8.4,2X,
     & F8.4,1X,E11.4)
      IF(DONE) WRITE (NTOUT,500) (SEDCE(I), I = 1, 6),
     * FACTR
 500  FORMAT (' ','D C STD ERR',1X,3F9.6,1X,F8.4,2X,F8.4,2X,F8.4,
     & 1X,E11.4)
      DO 26 I = 1, 3, 1
      TEMP(I) = AD(I) - AO(I)
      UO(I) = ALS(I) - ALO(I)
      FMN(I) = UO(I) / 60.0
 26   CONTINUE
      TEMP1 = VC - VCO
      IF((IPHKL.NE.2) .OR. (DONE)) WRITE(NTOUT,30) (TEMP(I),I=1,3),
     * (FMN(I),I=1,3),TEMP1
 30   FORMAT(12H D C CORRECT,3F9.5,2X,F8.4,2X,F8.4,2X,F8.4,1X,E11.4)
      IF (DONE) WRITE(NTOUT,132)
 132  FORMAT('0', 'DIRECT CELL VARIANCE-COVARIANCE MATRIX' / 75X,3HROW)
      DO 150 I = 1, 6, 1
      IF (DONE) WRITE(NTOUT,142) (VCME(I,L),L=1,6),I
 142  FORMAT(1X,6E12.4,I4)
C-----PREPARE FOR CALCULATION OF CORRELATION MATRIX
      V(I)=1.0
C-----1.0E-15 CHOOSEN TO AVOID DIVISION BY ZERO
      IF(VCME(I,I).GT.1.0E-15) V(I)=SQRT(VCME(I,I))
 150  CONTINUE
C
C-----OUTPUT CORRELATION MATRIX ON LAST CYCLE
C
      IF (DONE) WRITE(NTOUT,160)
 160  FORMAT('0', 'DIRECT CELL    CORRELATION      MATRIX' / 75X,3HROW)
      DO 180 I = 1,6,1
          DO 170 J = 1,6,1
              VCME(I,J) = VCME(I,J)/(V(I)*V(J))
 170      CONTINUE
          IF (DONE) WRITE(NTOUT,172) (VCME(I,L),L=1,6),I
 172          FORMAT(1X,6F12.7,I4)
 180  CONTINUE
      RETURN
      END
      SUBROUTINE PDNVRT(A,NLSQV,B)
C      ############################################################
C      #                                                          #
C      #                          PDNVRT                          #
C      #                                                          #
C      ############################################################
C COMPLETES THE INVERSION OF POSITIVE DEFINITE SYMMETRIC MATRIX OF
C ORDER N, STARTING WITH THE TRIANGULARIZED MATRIX RESULTING FROM
C PDSQRT, THE UPPER TRIANGLE OF THE INVERSE BEING STORED SO THAT ITS
C ITH ROW AND JTH COLUMN ELEMENT IS A((2*N-I)*(I-1)/2+I-J+1)
C WITH 1.LE.I.LE.J.LE.N.
      DIMENSION A(27),B(6)
      IE=0
      NP1=NLSQV+1
      NP2=NLSQV+2
      INM=((NLSQV+3)*NLSQV)/2-1
      II=1
      DO 395 I=1,NLSQV
          B(I)=A(II)
          J=I+1
 155      IF (J.GT.NLSQV) GO TO 200
          SUM=0.0
          IJ=II+J-I
          L=J-1
          DO 170 K=I,L
              SUM=SUM-A(IJ)*B(K)
 170          IJ=IJ+NP1-K
          B(J)=A(IJ)*SUM
          J=J+1
      GO TO 155
 200  J=NLSQV
      IJ=INM
 210  SUM=B(J)
      K=NLSQV
 220  IF (K.LE.J) GO TO 250
      SUM=SUM-A(IJ)*B(K)
      IJ=IJ-1
      K=K-1
      GO TO 220
 250  B(J)=A(IJ)*SUM
      J=J-1
      IF (J.LT.I) GO TO 300
      IJ=IJ-2
      GO TO 210
 300  DO 315 J=I,NLSQV
      IE=IE+1
 315  A(IE)=B(J)
 395  II=II+NP2-I
      RETURN
      END
      SUBROUTINE PDSQRT(A,NLSQV,B,IERR)
C      ############################################################
C      #                                                          #
C      #                          PDSQRT                          #
C      #                                                          #
C      ############################################################
C SOLUTION OF N LINEAR ALGEBRAIC EQUATIONS BY SQUARE ROOT METHOD.
C UPPER TRIANGLE OF GIVEN POSITIVE DEFINITE SYSTEM STORED SO THAT
C ELEMENT IN ROW I AND COLUMN J IS A((2*N+4-I)*(I-1)/2+J-I+1), WITH
C COLUMN N+1 CONTAINING RIGHT HAND SIDE EQUATION CONSTANTS.
C B() IS SOLUTION VECTOR. IERR=-1 IF N NOT A POSITIVE INTEGER OR IF N
C EXCEEDS PROGRAMMED LIMIT, IERR=0 IF SOLUTION CARRIED TO COMPLETION,
C ELSE IERR=ROW FOR WHICH FIRST NON-POSITIVE DIAGONAL PIVOT DETECTED.
      DIMENSION A(27),B(6)
      IF (NLSQV.GE.1.AND.NLSQV.LE.6) GO TO 1
      IERR=-1
      GO TO 999
C     THESE TWO CARDS ARE INSERTED TO MAINTAIN THE NUMBER SEQUENCE.
C     THERE ARE NO FORTRAN STATEMENTS MISSING.
 1    I2=NLSQV+1
      DO 35 I=1,NLSQV
      J=NLSQV
      K=I
      SUM=0.0
      IL=I-1
      IF (IL.LT.1) GO TO 15
      DO 12 L=1,IL
      FAC=A(K)
      SUM=SUM-FAC*FAC
      K=K+J
 12   J=J-1
 15   SUM=SUM+A(K)
      IF (SUM.GT.0.0) GO TO 20
      IERR=I
      GO TO 999
 20   FAC=1.0/SQRT(SUM)
      A(K)=FAC
      I1=I+1
      DO 35 J=I1,I2
      SUM=0.0
      K=NLSQV
      IJ=J
      II=I
      IF (IL.LT.1) GO TO 30
      DO 25 L=1,IL
      AI=A(II)
      SUM=SUM-AI*A(IJ)
      II=II+K
      IJ=IJ+K
 25   K=K-1
 30   SUM=SUM+A(IJ)
 35   A(IJ)=FAC*SUM
      J=((NLSQV+3)*NLSQV)/2
      I=NLSQV
 42   IF (I-1) 998,45,45
 45   SUM=A(J)
      J=J-1
      K=I+1
      L=NLSQV
 48   IF (L-K) 55,50,50
 50   SUM=SUM-A(J)*B(L)
      J=J-1
      L=L-1
      GO TO 48
 55   B(I)=A(J)*SUM
      J=J-1
      I=I-1
      GO TO 42
 998  IERR=0
 999  RETURN
      END
      SUBROUTINE PKREAD
C      ############################################################
C      #                                                          #
C      #                          PKREAD                          #
C      #                                                          #
C      ############################################################
C
C-----INTERACTIVE MODE (DEMAND) INPUT OF REQUIRED PARAMETERS
C
      PARAMETER (MAXOBS=200, MAXPKS=300)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/PKNAME/PCLNAM
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN,TOLMX
      COMMON/IERRS/IWARN,IERR
      COMMON/RDGOOD/RGOOD,SYSEXT
C-------------------------------------------------------------
C  PEAK FILE PARAMETERS
C
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/PKFIL/NAME,CRSYS,TMTMMX,TMTMMN
      COMMON/TEMPRT/NTMMS,AVTMP,SDTMPR,TMPRMX,TMPRMN
      CHARACTER*4 TMTMMX,TMTMMN
      CHARACTER*1 CRSYS
      CHARACTER*6 NPFLG
      CHARACTER*40 NAME
C
C  END OF PEAK FILE PARAMETRS.
C-------------------------------------------------------------
      LOGICAL HGOOD,RGOOD,SYSEXT
      CHARACTER*6 IALF
      CHARACTER*80 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*8  CRS
C     CHARACTER*11 PCLNAM
      CHARACTER*7 PCLNAM
      DATA CRS/'CTOMRAHX'/
C
C-------------------------------------------------------------
C
C-----INITIALIZE
C
      PCLNAM=' '
      SYSEXT = .FALSE.
      RGOOD  = .TRUE.
C-----SET FLAG FOR 2-THETA INPUT
      ITHT = 0
      NUMOBS = 0
      PWL = 1.5405981
      OBS = 0.0
      D   = 0.0
      DO 2 I=1,3,1
      AO(I) = 0.0
      ALO(I)=0.0
 2    CONTINUE
      WRITE(*,1010) 
 1010 FORMAT(' Please enter the peaks filename (A36,',
     &	' default ext. = .pkn): ')
      READ(*, 1020) NAME
 1020 FORMAT(A40)
      J = INDEX(NAME, '.')
     	IF (J .EQ. 0) THEN
		J = INDEX(NAME, ' ')
		NAME(J:J + 3) = '.PKN'
	ENDIF
	PRINT*
      WRITE(NTOUT, 1085) NAME
 1085 FORMAT(' PEAKS  FILE : ', A40)
      PRINT*
      OPEN(IOPKS,IOSTAT=IOS,FILE=NAME,STATUS='OLD',ACCESS='SEQUENTIAL'
     * ,FORM='FORMATTED')
C
      IF(IOS.EQ.0) GOTO 390
      IF (NTOUT .EQ. 12) THEN
        WRITE(*,1090) IOS
      ENDIF
      WRITE(NTOUT,1090) IOS
 1090 FORMAT(1H0,'**FILE ASSIGNMENT ERROR FOR PEAKS  FILE ,IER=',I5)
      RGOOD = .FALSE.
      RETURN
C
C     ******************************************************************
C
C-----NOW TO REQUEST LEAST-SQUARES CONTROL PARAMETERS
C
 390  WRITE(*,530)
 530  FORMAT('0','ENTER TOLMN,TOLMX,RESOLV,IXPD. DEFAULTS ',
     * 'WITH "/" TO 0.03, 0.15, 0.075, 0'/
     * ' ','TOLMN,TOLMX: MINIMUM AND MAXIMUM 2-THETA TOLERANCES'/
     * ' ','RESOLV: ESTIMATE OF RESOLUTION OF 2 PEAKS (DEG. 2-THETA)'/
     * ' ','IXPD:   =0 FOR FINAL TABLE PRINTING, =1 TO OMIT' /)
      IXPD =0
      RESOLV = 0.0
      READ(*,*) TOLMN,TOLMX,RESOLV,IXPD
      IF(TOLMN.LT.0.01) TOLMN=0.03
      IF(TOLMX.LT.0.01) TOLMX=5*TOLMN
      IF(RESOLV.LT.0.01) RESOLV=0.075
C-----CONVERT TO THETA UNITS
      TOLMN = TOLMN/2
      TOLMX = TOLMX/2
      RESOLV= RESOLV/2
C
C-----GET THTMX AND NCYC
C
	PRINT*
      WRITE(*,535)
 535  FORMAT('0','ENTER THTMX AND NCYC. DEFAULTS WITH "/" TO 40.0 '
     * ,' AND 2 CYCLES'/
     * ' ','THTMX: 2-THETA MAXIMUM FOR DATA IN FIRST NCYC CYCLES OF ',
     * 'LEAST SQUARES'/
     * ' ',' (AUTHORS INDEXED LINES ARE USED IN EVERY CYCLE)' /)
      THTMX = 0.0
      NCYC  = 0
      READ(*,*) THTMX,NCYC
      IF(THTMX.LE.0.01) THTMX = 40.
      IF(NCYC .EQ.0)   NCYC = 2
      THTMX = THTMX/2
	PRINT*
      WRITE(*,540)
 540  FORMAT('0','ENTER IWTYP,IWCYC. DEFAULTS WITH "/" TO 0,0.'/
     *' IWTYP : 0,1,2 INPUT,UNIT,HESS WEIGHTS ',/
     *' IWCYC : NO. OF CYCLES TO USE WEIGHTS' /)
      IWTYP = 0
      IWCYC = 0
      READ(*,*) IWTYP,IWCYC
C
C-----ENTER D-GENERATION CONTROL PARAMETERS
C
	PRINT*
      WRITE(*,602)
 602  FORMAT('0','ENTER THEMX, IPHKL, WL. DEFAULTS WITH A "/"'/
     *' THEMX: 2THETA MAXIMUM, FOR D GENERATION  ',
     *'( DEFAULT MAX. INPUT 2TH.)'/
     *' IPHKL: PRINT HKL: 0 EVERYTHING, 1 SUMMARY, 2 LAST CYCLE(DEF.=2)'
     */' WL   : WAVELENGTH ( DEFAULT CU= 1.5405981 )' /)
      IPHKL=2
      THEMX = 0.0
      PWL2  = 0.0
      READ(*,*) THEMX,IPHKL, PWL2
      IF(PWL2.GT.0.01) PWL = PWL2
C-----CONVERT MAX 2-THETA GENERATION LIMIT TO THETA UNIT
      THEMX = THEMX/2
C
C READ FILE PEAKS
C
      CALL RDPKS
C
C         STORE CRYSTAL SYSTEM
C
      I = INDEX(CRS, CRSYS)
      ICRYST = CSC(I)
C
C-----SET TO IDG AND FMN AS REQUIRED BY GEOLOGICAL SURVEY CODE
C
 400  DO 410 I = 1, 3, 1
      IDG(I) = INT(ALO(I))
      FMN(I) = 60.0 * (ALO(I) - REAL(IDG(I)))
 410  CONTINUE
      IF (NUMOBS .EQ. 0) GOTO 990
      IDOLSQ = 1
      IF (THEMX .GT. 179.) THEMX = OBSTH(NUMOBS) + 2.
 990      WRITE(*, 992) NUMOBS
 992  FORMAT('0','PKS  INPUT COMPLETED.', I5,' REFLECTIONS READ')
      RETURN
      END
      SUBROUTINE PMATCH(IPKSQ,LP,DL)
C      ############################################################
C      #                                                          #
C      #                          PMATCH                          #
C      #                                                          #
C      ############################################################
C
C MATCH EXPECTED PEAK TO OBSEREVED PEAKS FROM FILE PKS
C
      PARAMETER (MAXPKS=300)
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      CHARACTER* 6  NPFLG
C
C-----------------------------------------------
C
          TOL=6.*THTSE
          TOLM=-TOL
          DL=999
          LP=0
        DO 420 I=IPKSQ,NPKS
          IF(NPFLG(I)(6:6).EQ.'0')GOTO 420
          DLT=PKPRM(2,I)-THCMP
          IF(DLT .GT. TOL ) GOTO 999
          IF(DLT.LT. TOLM ) GOTO 420
          IF(ABS(DLT)  .GT. DL ) GOTO 420
          LP=I
          DL=DLT
 420  CONTINUE
 999  RETURN
      END
      SUBROUTINE PRCHKL(NUMCRD)
C      ############################################################
C      #                                                          #
C      #                          PRCHKL                          #
C      #                                                          #
C      ############################################################
C
C-----SUBROUTINE ASSUMES THAT EITHER D OR 2-THETA > 0
C
      PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      LOGICAL HGOOD
      IF (NOINDX .EQ. 0) GOTO 10
C-----SET ALL INPUT LINES TO UNINDEXED
      DO 5 I = 1, 3
 5    	IHA(I) = 0
      	HKLED = 'U'
C
C-----SET WAVELENGTH AND LS WEIGHT
C
 10   	IF (WLC .LT. 0.001) WLC = PWL
      	IF (WT .LE. 0.0) WT = 1.0
      	IF (D .GT. 0.0) GOTO 25
 20   	THOBS = OBS
      	IF (ITHT .EQ. 0) THOBS = 0.5 * THOBS
      	IF (THOBS .GE. 90.0) GOTO 26
      	DOBS = 0.5 * WLC / SIN(0.017453293 * THOBS)
      	GOTO 29
 25   	CNST = 0.5 * WLC
      	THOBS = THETA(CNST, D)
      IF (THOBS.GT.0.0.AND.THOBS.LT.90.0) GO TO 28
 26   IF (NTOUT .EQ. 12) THEN
          WRITE(*, 27) NUMCRD, THOBS
      ENDIF
      WRITE(NTOUT, 27) NUMCRD, THOBS
 27   FORMAT (' ', '**ERROR**CARD #-NOT USED (REFLECTION) ', I3,
     * ' HAD AN ',
     * 'ILLEGAL CALCULATED THETA OF = ', F6.2)
 28   CONTINUE
      DOBS=D
 29   NUMOBS=NUMOBS+1
      OBSTH(NUMOBS)=THOBS
      DSP(NUMOBS)=DOBS
      WL(NUMOBS)=WLC
      IF(IWTYP.EQ.1) WT=1.0
      IF(IWTYP.EQ.2) WT=1.0/SIN(2.0*THOBS/57.3)**2
      SW(NUMOBS)=SQRT(WT)
      DO 60 L=1,3
 60   IH(NUMOBS,L)=IHA(L)
C
C-----FLAG IF NOT READ SO COMPUTER WILL ASSIGN
C
      IF(HKLED.NE.' ') THEN
      IHED(NUMOBS) = HKLED
      ELSE
      IHED(NUMOBS) = ITIH(1)
      IF ((IHA(1) .EQ. 0) .AND. (IHA(2) .EQ. 0) .AND.
     * (IHA(3) .EQ. 0)) IHED(NUMOBS) = ITIH(4)
      END IF
 99   RETURN
      END
      SUBROUTINE PRMCHK(ICRS,NLSQV,ITYP,JTYP)
C      ############################################################
C      #                                                          #
C      #                          PRMCHK                          #
C      #                                                          #
C      ############################################################
C-----SETS ITYP AND JTYP ACCORDING TO CRYSTAL SYSTEM
C-----SYMMETRY CONSTRAINTS HAVE ALREADY BEEN IMPOSED ON LATTICE (IN CELLCK)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/UNQ/IFA,IFB,IFC,IRH
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 ICRS
      ITYP=0
      IF (ICRS .NE. ITCRS(7)) GO TO 13
      JTYP=1
      ITYP=1
      NLSQV=1
      GO TO 55
 13   IF (ICRS .NE. ITCRS(5)) GO TO 21
      JTYP=2
 15   ITYP=2
      NLSQV=2
      GO TO 55
C-----RHOMBOHEDRAL AND HEXAGONAL AXES
 21   IF (ICRS .NE. ITCRS(6) .OR. IRH.NE.1) GO TO 24
      JTYP=8
      GO TO 15
 24   IF (ICRS .NE. ITCRS(3)) GO TO 30
      JTYP=3
      ITYP=3
      NLSQV=3
      GO TO 55
 30   IF (ICRS .NE. ITCRS(2)) GO TO 38
      JTYP=4
      ITYP=4
      NLSQV=4
      GO TO 55
 38   IF (ICRS .NE. ITCRS(4)) GO TO 42
      JTYP=5
      ITYP=5
      NLSQV=2
      GO TO 55
C-----RHOMBOHEDRAL ON TRIGONAL AXES
 42   IF (ICRS .NE. ITCRS(6)) GO TO 51
      JTYP=7
      ITYP=7
      NLSQV=2
      GO TO 55
 51   IF (ICRS .NE. ITCRS(1)) GO TO 55
      JTYP=6
      ITYP=6
      NLSQV=6
 55   RETURN
      END
      SUBROUTINE QCOMP(NH,Z,Q)
C      ############################################################
C      #                                                          #
C      #                          QCOMP                           #
C      #                                                          #
C      ############################################################
C COMPUTES RECIPROCAL OF SQUARE OF DISTANCE FROM ORIGIN FOR PLANE HKL
      DIMENSION NH(3),Z(6)
      Q= (Z(1)*NH(1)+Z(4)*NH(2)+Z(6)*NH(3))*NH(1)
     1  +(Z(4)*NH(1)+Z(2)*NH(2)+Z(5)*NH(3))*NH(2)
     2  +(Z(6)*NH(1)+Z(5)*NH(2)+Z(3)*NH(3))*NH(3)
      RETURN
      END
      SUBROUTINE RCMPD
C      ############################################################
C      #                                                          #
C      #                          RCMPD                           #
C      #                                                          #
C      ############################################################
C COMPUTES D SPACING FOR GENERATED REFLECTIONS
      PARAMETER (MAXGEN=1000)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/SCRT/E(7),NH(3)
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      DO 5 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      Z(I)=X(I)**2
 5    Z(I+3)=X(I)*X(J)*U(K)
      DO 20 IC=1,NR
      DO 10 J=1,3
 10   NH(J)=IHG(IC,J)
      CALL QCOMP(NH,Z,Q)
      IF (Q .GT. 0.0) GO TO 16
      DCM(IC)=0.0
      GO TO 20
 16   DCM(IC)=1.0/SQRT(Q)
 20   CONTINUE
      RETURN
      END
      SUBROUTINE RDPKS
C      ############################################################
C      #                                                          #
C      #                          RDPKS                           #
C      #                                                          #
C      ############################################################
C
C   READ FROM THE PEAKFILE  THE PEAK PARAMETERS
C
      PARAMETER (MAXOBS=200, MAXPKS=300)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CBLKG/IHEAD
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
C-------------------------------------------------------------
C  PEAK FILE PARAMETERS
C
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/PKFIL/NAME,CRSYS,TMTMMX,TMTMMN
      COMMON/REFPRM/NRGRF,NRCPP,NRCBER,NRCGRP,NRGNT,IREV
      COMMON/TEMPRT/NTMMS,AVTMP,SDTMPR,TMPRMX,TMPRMN
	COMMON RELINT(MAXPKS)
*
*
      CHARACTER*4 TMTMMX,TMTMMN
      CHARACTER*1 CRSYS
      CHARACTER*40 NAME
      CHARACTER*6 NPFLG
C
C  END OF PEAK FILE PARAMETRS.
C-------------------------------------------------------------
      CHARACTER*80 IHEAD
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
	INTEGER J, K, LETTER
      CHARACTER*1 IHED,INTED,HKLED
C
C------------------------------------------------------------
C
      IER = 0
      REWIND IOPKS
C
C READ THE FIRST  RECORD  
C
      READ(IOPKS, 1020) IHEAD
 1020 FORMAT(A80)
C
C SKIP RECORDS 2 - 11
C
      DO 224 I = 1, 10
      	READ(IOPKS, 1020)
 224  CONTINUE
C
C READ  RECORD 12 TEMPERATURE AVERAGE,STANDARD DEVIATION,MINIMIUM
C             MAXIMUM TEMPERATURE AND TIME OF DAY OF THE MIN MAX .
C
      READ (IOPKS,1110) AVTMP,SDTMPR,TMPRMX,TMPRMN,TMTMMX,TMTMMN
 1110 FORMAT(31X, 4F6.1, 2A4 )
C
C READ RECORD 13 CELL CONSTANTS
C
      READ (IOPKS,1025) AO,ALO,CRSYS
 1025 FORMAT(3F9.5,3F8.3,6X,A1)
C
C-----SKIP RECORD 14 (E.S.D. OF CELL PARAMETERS)
C
      READ (IOPKS,1020)
C
C-----READ RECORD 15 FOR SPACE GROUP
C
      READ(IOPKS, 1023) SPGI
 1023 FORMAT(A8)
C
C-----CHECK TO SEE WHETHER SPACE GROUP CONTAINS ANY LOWERCASE LETTERS;
C	 IF SO, CONVERT EACH TO ITS CORRESPONDING UPPERCASE VALUE
C
	J = LEN(SPGI)
	DO 8888 K = 1, J
		LETTER = ICHAR(SPGI(K:K))
		IF (LETTER .GT. 90) THEN
			LETTER = LETTER - 32
			SPGI(K:K) = CHAR(LETTER)
		ENDIF
 8888 CONTINUE
C
C SKIP  RECORDS 16, 17
C
      READ (IOPKS,1020)
      READ (IOPKS,1020)
C
C READ RECORD 18
C
      READ (IOPKS,1030) NPKS
 1030 FORMAT(I5)
	PRINT*
      WRITE(NTOUT,1401) NPKS
 1401 FORMAT(' # OF PEAKS IN THE FILE = ',I5)
C
C READ RECORDS 19,20 . REFLEC FLAGS.
C
      READ (IOPKS,1020)
      READ (IOPKS,1020)
*		leave room for error analysis
	DO 1234 I = 1, 4
		READ(IOPKS, 1020)
 1234 CONTINUE
C
C READ RECORD 25,  REFINEMENT PARAMETERS
C
      READ(IOPKS, 1038) NRGRF, NRCPP, IREV
 1038 FORMAT(2I2, 8X, I2)
*
C
C-----READ (IF ANY) THE GENERAL PROFILE REFINEMENT PARAMETERS RECORDS
C
      DO 250 I = 1, NRGRF
      	READ(IOPKS, 1020)
 250  CONTINUE
C
C-----SET UP TO READ PEAK POSITION,INTENSITY,HKL,WT,ETC DATA
C
      IF (IREV .EQ. 0) THEN
         	IF (NRCPP .EQ. 0) NRCPP = 1
         	NOINDX = 1
         	IWTYP = 1
      ENDIF
      K = 0
      WLC = 0.0
      TTTEST = 2 * THEMX
      IF (TTTEST .LT. 0.01) TTTEST = 180.0
      DO 280 I = 1, NPKS
          READ(IOPKS, 1040) NPFLG(I),(PKPRM(J,I),J=1,4),WT,RELINT(I),
     &	    HKLED,IHA
 1040 	FORMAT(A6,2(F8.3,5X) ,F10.2,F5.1,5X,F5.2,F8.1,5X,A1,3I3)
C
C-----IF FLAGGED FOR L.S. LOAD THE INFORMATION INTO COMMONS
C
      	IF (NPFLG(I)(6:6) .EQ. '1') GOTO 260
      	K = K + 1
      	OBS = PKPRM(2, I)
C-----TEST 2-THETA INPUT AGAINST 2-THETA MAX
      	IF (OBS .GT. TTTEST) GOTO 999
      	IF (NUMOBS .GE. MAXOBS) GOTO 800
C
C IF HKLED .NE. TO M,+, OR BLANK ,RESET H,K,L TO ZERO & HKLED TO BLANK
C
      IF (HKLED .EQ. 'M' .OR. HKLED .EQ. ' ' .OR. HKLED .EQ. '+') THEN
          GOTO 255
      ELSE
          HKLED = ' '
          	IHA(1) = 0
          	IHA(2) = 0
          	IHA(3) = 0
      	END IF
C
 255  	CALL PRCHKL(K)
      	NPKSQ(K) = I
C
C-----READ (IF ANY) THE NRCPP PROFILE REFINEMENT PARAMETER RECORDS
C
 260  	DO 270 J = 1, NRCPP
      		READ(IOPKS, 1020)
 270  	CONTINUE
 280  CONTINUE
      GOTO 999
C
C-----NUMBER OF L.S. ALLOWED REFLECTIONS EXCEEDS MAXOBS
C
 800  IF (NTOUT .EQ. 12) THEN
          WRITE(*, 802) MAXOBS, MAXOBS
      ENDIF
      WRITE(NTOUT, 802) MAXOBS, MAXOBS
 802  FORMAT('0','**WARNING**THE NUMBER OF L.S. FLAGGED REFLECTIONS',
     * ' EXCEEDS',I5,' USING FIRST',I5)
C
 999  RETURN
      END
      SUBROUTINE RSCMP
C      ############################################################
C      #                                                          #
C      #                          RSCMP                           #
C      #                                                          #
C      ############################################################
C COMPUTES RECIPROCAL CELL ELEMENTS FROM DIRECT CELL ELEMENTS
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      DO 10 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      U(I)=(CSA(J)*CSA(K)-CSA(I))/(SNA(J)*SNA(K))
      W(I)=SQRT(1.0-U(I)**2)
      X(J)=1.0/(AD(J)*W(I)*SNA(K))
 10   AR(I)=3437.7468*(1.5707963-ATAN2(U(I),W(I)))
      VR=X(1)*X(2)*X(3)*SNA(1)*W(2)*W(3)
      VC=1.0/VR
C-----CALCULATE (A*)**2,ETC.
      DO 20 I=1,3
      J = MOD(I,3)+1
      K = MOD(J,3)+1
      Z(I)=X(I)**2
      Z(I+3)=X(I)*X(J)*U(K)
 20   CONTINUE
      RETURN
      END
      SUBROUTINE SESUB
C      ############################################################
C      #                                                          #
C      #                          SESUB                           #
C      #                                                          #
C      ############################################################
C COMPUTES STANDARD ERRORS AND VARIANCE-COVARIANCE MATRIX
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/BLKB/CR(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(6,6),FACTR
      DIMENSION TT(6,6), ST(6,6),  DD(3), SS(21)
      DO 2 I=1,21
 2    SS(I)=0.0
      FACTR=THTSE*THTSE
      CALL PDNVRT(A,NLSQV,B)
      IEC=((NLSQV+1)*NLSQV)/2
      DO 8 I=1,IEC
 8    A(I)=A(I)*FACTR
      GO TO (10,20,30,40,50,60,70),ITYP
 10   DO 11 I=1,3
 11   SS(I)=A(1)
      SS(7)=A(1)
      SS(8)=A(1)
      SS(12)=A(1)
      GO TO 80
 20   SS(1)=A(1)
      SS(2)=A(1)
      SS(7)=A(1)
      SS(3)=A(2)
      SS(8)=A(2)
      SS(12)=A(3)
      GO TO 80
 30   DO 32 I=1,3
 32   SS(I)=A(I)
      DO 34 I=7,8
 34   SS(I)=A(I-3)
      SS(12)=A(6)
      GO TO 80
   40 DO 42 I=1,3
 42   SS(I)=A(I)
      SS(5)=A(4)
      DO 44 I=7,8
 44   SS(I)=A(I-2)
      DO 46 I=7,9
 46   SS(2*I-4)=A(I)
      SS(19)=A(10)
      GO TO 80
 50   GO TO 20
 60   DO 62 I=1,21
 62   SS(I)=A(I)
      GO TO 80
 70   DO 72 I=1,3
 72   SS(I)=A(1)
      SS(7)=A(1)
      SS(8)=A(1)
      SS(12)=A(1)
      DO 74 I=4,6
 74   SS(I)=A(2)
      DO 76 I=9,11
 76   SS(I)=A(2)
      DO 78 I=13,15
 78   SS(I)=A(2)
      DO 79 I=16,21
 79   SS(I)=A(3)
 80   II=1
      DO 82 I=1,3
      SERCE(I)=SQRT(SS(II))
 82   II=II+7-I
      DO 84 I=4,6
      SERCE(I)=3437.7468*SQRT(SS(II))/W(I-3)
 84   II=II+7-I
      DO 88  I=1,3
 88   SNA(I)=SQRT(1.0-CSA(I)**2)
      DO 995 I=1,3
      DO  95 J=1,3
      IF (I-J) 93,94,93
 93   TT(I,J)=0.0
      GO TO 95
 94   TT(I,J)=-AD(I)/X(I)
 95   CONTINUE
 995  CONTINUE
      DO 100 I=4,6
      DO 100 J=1,3
 100  TT(I,J)=0.0
      DO 105 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
 105  DD(I)=-AD(J)*AD(K)*X(J)*X(K)
      DO 915 I=1,3
      DO 115 J=4,6
      IF (I-J+3) 108,110,108
 108  TT(I,J)=DD(J-3)*AD(I)*CSA(J-3)
      GO TO 115
 110  K=MOD(J,3)+1
      L=MOD(K,3)+1
      TT(I,J)=DD(J-3)*AD(J-3)*CSA(K)*CSA(L)
 115  CONTINUE
 915  CONTINUE
      DO 120 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
 120  DD(I)=1.0/(W(J)*W(K))
      DO 925 I=4,6
      DO 125 J=4,6
      IF (I-J) 123,122,123
 122  TT(I,J)=DD(I-3)/SNA(J-3)
      GO TO 125
 123  IJ12=12-I-J
      TT(I,J)=DD(I-3)*CSA(IJ12)/SNA(J-3)
 125  CONTINUE
 925  CONTINUE
      DO 130 I=1,6
      DO 130 J=1,6
      SUM=0.0
      IJ=I
      DO 128 K=1,6
      SUM=SUM+SS(IJ)*TT(J,K)
      IF (I-K) 127,127,126
 126  IJ=IJ+6-K
      GO TO 128
 127  IJ=IJ+1
 128  CONTINUE
 130  ST(I,J)=SUM
      DO 140 I=1,6
      DO 138 J=1,6
      SUM=0.0
      DO 136 K=1,6
 136  SUM=SUM+TT(I,K)*ST(K,J)
 138  VCME(I,J)=SUM
 140  CONTINUE
      DO 145 I=1,6
 145  SEDCE(I)=SQRT(VCME(I,I))
      DO 148 I=4,6
 148  SEDCE (I) = (3437.7468*SEDCE (I))/60.
      FACTR=AD(1)*AD(2)*AD(3)
      FACTR=FACTR*FACTR/VC
      DO 150 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      CR(I)=VC/AD(I)
 150  CR(I+3)=FACTR*SNA(I)*(CSA(I)-CSA(J)*CSA(K))
      FACTR=0.0
      DO 152 I=1,6
      DO 152 J=1,6
 152  FACTR=FACTR+CR(I)*CR(J)*VCME(I,J)
      IF (FACTR) 154,154,156
 154  FACTR=0.0
      GO TO 999
 156  FACTR=SQRT(FACTR)
 999  RETURN
      END
      SUBROUTINE SKIP
     & (DSCRM,DSCRS,TN,TD,IK,IK1,IK2,IL,GT,HT,QMAX,DEN,
     & IH,IH1,IH2,JEXT,JSWT)
C      ############################################################
C      #                                                          #
C      #                          SKIP                            #
C      #                                                          #
C      ############################################################
      PARAMETER (MAXGEN=1000)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/IERRS/IWARN,IERR
      COMMON/SCRT/E(7),NH(3)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/UNQ/IFA,IFB,IFC,IRH
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*4 IH205
      DATA IH205/'205 '/
      DSCRM=SQRT(DSCRS)
      IHKSW = 0
C-----LIMITS FOR K IN LAYER OF FIXED L
      IK1=INT((TN-DSCRM)*0.5/TD)
      IK2=INT((TN+DSCRM)*0.5/TD)
C-----IF A-UNIQUE MONOCLINIC: NO RESTRICTIONS ON K
      IF(JTYP.EQ.4 .AND. IFA.EQ.0) GO TO 29
      GO TO (25,27,27,27,27,29,29,27),JTYP
 25   IF (IK1.LT.   IL) IK1=   IL
      GO TO 29
 27   IF (IK1.LT.0) IK1=0
 29   IK=IK2
      IF (IK .LT. IK1) GO TO 58
C-----NEXT K, IS IT WITHIN LIMITS?
 31   NH(2)=IK
      GT=(E(3)+E(3))*NH(2)+E(5)
      HT=(Z(5)*NH(3)+Z(2)*NH(2))*NH(2)+(Z(5)*NH(2)+Z(3)*NH(3))*NH(3)-
     * QMAX
      CALL SKIP1(DSCRM,DSCRS,GT,HT,DEN,KSWT,Z)
      GO TO (57,577),KSWT
C-----LIMITS FOR H WITH K AND L FIXED
 577  IH1=INT(-(GT+DSCRM)/DEN)
      IH2=INT((DSCRM-GT)/DEN)
C-----IF A-UNIQUE MONOCLINIC: LIMIT H TO BE .GE.0
      IF(JTYP.EQ.4 .AND. IFA.EQ.0) GO TO 40
      GO TO (42,42,40,44,42,44,44,38),JTYP
 38   IF (MOD(IL,3).EQ.0) GO TO 42
 40   IF (IH1.LT.0) IH1=0
      GO TO 44
 42   IF (IH1.LT.IK) IH1=IK
 44   IH=IH2
      IF (IH .LT. IH1) GO TO 57
C-----NEXT H. IT IS WITHIN D-SPACING LIMITS.
 46   NH(1)=IH
C-----TEST HKL FOR SPACE GROUP EXTINCTIONS
C-----PATCH ADDED BY CRH TO PROPERLY HANDEL PA3 HKL GENERATION.
C-----CODE ORIGINALLY ASSUMED PERMUTABLE INDICIES-BUT THIS IS NOT
C-----ALLOWED IN PA3. FOR EXAMPLE, THE EXTINCT 320 WAS GENERATED
C-----BUT THE ALLOWED 230 WAS NOT.
      IF (NOPT.LT.1) GO TO 50
      IHKSW = 0
      IHT = IH
      IKT = IK
 48   CALL CHKEXT(IHT,IKT,IL,JEXT)
      IF (JEXT .EQ. 0) GO TO 50
C-----SPGIN = '205 ' IS TEST FOR SPACE GROUP PA3
      IF(SPGIN.NE.IH205 .OR. IHKSW.EQ.1) GOTO 56
C-----SWITCH H AND K AND TEST AGAIN FOR PA3
      NH(1) = IK
      NH(2) = IH
      IHT = IK
      IKT = IH
      IHKSW = 1
      GO TO 48
 50   CALL QCOMP(NH,Z,Q)
      IF (Q.LE.0.0) GO TO 56
C-----TEST FOR MINIMUM D-VALUE
      DTEMP=1.0/SQRT(Q)
      IF(DTEMP.LT.DMIN) GOTO 56
      NR=NR+1
      DCM(NR)=DTEMP
C-----ASSIGN HKL TO ARRAY IHG OF COMMON/HDGEN/
      DO 52 J = 1, 3
 52   IHG(NR,J) = NH(J)
C-----HAVE WE REACHED ARRAY STORAGE CAPACITY?
      IF (NR.LT. MAXGEN) GO TO 56
      CALL SORTD(NR,DCM,IHG)
      CALL SKWEZE
      IF (NR.LT.MAXGEN) GO TO 56
      IF (NTOUT .EQ. 12) THEN
          WRITE(*,54) MAXGEN,DMIN
      ENDIF
      WRITE(NTOUT,54) MAXGEN,DMIN
C
C   FOR EQUALIVALANCE WITH AIDS
C
      IWARN = IWARN + 1
 54   FORMAT (' ','MORE THAN',I4,' REFLECTIONS EXIST FOR DMIN =',F10.6)
      DMIN=1.08*DMIN
      IF (NTOUT .EQ. 12) THEN
          WRITE(*, 61) DMIN
      ENDIF
      WRITE(NTOUT, 61) DMIN
 61   FORMAT(31H0NEW DMIN HAS BEEN SET EQUAL TO ,F10.5,/
     &60HOAND GENERATION OF INDICES STARTED AGAIN FROM THE BEGINNING.)
      JSWT = 1
      GO TO 599
 56   IF(IHKSW.EQ.0) GOTO 5656
C-----SWITCH H(1) AND H(2)  PA3 PATCH
      NH(1) = IKT
      NH(2) = IHT
 5656 IH=IH-1
      IF(IH-IH1)57,46,46
 57   IK=IK-1
      IF(IK-IK1)58,31,31
 58   IL=IL+1
      JSWT = 2
 599  RETURN
      END
      SUBROUTINE SKIP1(DSCRM,DSCRS,GT,HT,DEN,KSWT,Z)
C      ############################################################
C      #                                                          #
C      #                          SKIP1                           #
C      #                                                          #
C      ############################################################
      DIMENSION Z(6)
      DEN = Z(1)
      DEN = DEN + Z(1)
      DSCRS = 2.0 * DEN * HT
      DTMP = GT*GT
      DSCRS = DTMP - DSCRS
      IF (DSCRS.LT.0.0) GO TO 57
      DSCRM=SQRT(DSCRS)
      KSWT = 2
 1    RETURN
 57   KSWT = 1
      GO TO 1
      END
      SUBROUTINE SKWEZE
C      ############################################################
C      #                                                          #
C      #                          SKWEZE                          #
C      #                                                          #
C      ############################################################
C ELIMINATES REFLECTIONS WITH IDENTICAL D-SPACINGS
C
      PARAMETER (MAXGEN=1000)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/IERRS/IWARN,IERR
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/UNQ/IFA,IFB,IFC,IRH
      DIMENSION IH(3),JH(3)
      TOL=1.0E-5
      I=1
 12   J=I+1
      IF (J.GT.NR) GO TO 50
      IF ((DCM(I)-DCM(J)).GE.TOL) GO TO 40
      DO 15 K=1,3
      IH(K)=IHG(I,K)
 15   JH(K)=IHG(J,K)
C
C-----SWITCH TEMPORARY INDICIES IH AND JH TO B-UNIQUE SETTING FOR TEST
C     ONLY IF MONOCLINIC
C
 19   IF(ITYP.NE.4 .OR. IFB.EQ.0) GO TO 21
C
C-----IS IT C-UNIQUE
C
      IF(IFC.NE.0) GO TO 20
      IS   = IH(3)
      IH(3)= IH(2)
      IH(2)= IS
      IS   = JH(3)
      JH(3)= JH(2)
      JH(2)= IS
      GO TO 21
C-----BE SURE IT IS A-UNIQUE
 20   IF(IFA.NE.0) GO TO 60
      IS   = IH(2)
      IH(2)= IH(1)
      IH(1)= IS
      IS   = JH(2)
      JH(2)= JH(1)
      JH(1)=IS
C
C-----TEST HKL FOR EQUIVALENCE
C
 21   CALL TSTHKL(ITYP,IH,JH,IEQL)
      IF (IEQL.NE.0) GO TO 27
      J=J+1
      IF (J.GT.NR) GO TO 27
      IF ((DCM(I)-DCM(J)).GE.TOL) GO TO 27
      DO 25 K=1,3
 25   JH(K)=IHG(J,K)
      GO TO 19
 27   JMI=J-I-1
      J2=NR-JMI
      J1=I+1
      IF (J2 .LT. J1) GO TO 35
      DO 34 K=J1,J2
      K2= K+JMI
      DCM(K)=DCM(K2)
      DO 32 L=1,3
 32   IHG(K,L)=IHG(K2,L)
 34   CONTINUE
 35   NR=J2
 40   I=I+1
      GO TO 12
 50   RETURN
 60   IF (NTOUT .EQ. 12) THEN
          WRITE(*,61)
      ENDIF
      WRITE(NTOUT,61)
C
C-----FOR EQUALIVALENCE WITH AIDS
C
      IERR = IERR + 1
 61   FORMAT(1H0,50H**ERROR**IN SUBROUTINE SKWEZE - MONOCLINIC SYSTEMS)
      NR=0
      RETURN
      END
      SUBROUTINE SLCR
C      ############################################################
C      #                                                          #
C      #                          SLCR                            #
C      #                                                          #
C      ############################################################
C
C-----ATTEMPTS TO INDEX REFLECTIONS NOT ALREADY INDEXED
C
C-----TESTS EACH REFLECTION AGAINST REJECTION CRITERIA: 
C     DELTA 2-THETA > TOL
C     TWO OBSERVED LINES WITHIN TOL
C     TWO CALCULATED LINES WITHIN TOL
C
C-----CALL SUBROUTINES OBSEQ AND NORME FOR EACH ACCEPTED REFLECTION
C     TO SET UP LEAST SQUARES EQUATIONS
C
      PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(MAXGEN,3),DCM(MAXGEN),NR,DMIN
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/SCRT/E(7),NH(3)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/FLAG(MAXOBS)
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/BLKH/NCYC,AA(7),DLST(MAXOBS),IOC(MAXOBS),THTMX
      COMMON/BLKJ/TOLMN,TOLMX
      COMMON/ALL/NLSQV,NUMCYC,FAC
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      CHARACTER*1 IHED,INTED,HKLED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF12
      CHARACTER*2 FLAG
      CHARACTER*80 IHEAD
      ICYCLE=ICYCLE+1
      IF(NUMOBS .LT. 1) GO TO 999
C
C-----TEST IF WEIGHTS ARE TO BE CHANGED AFTER IWCYC CYCLES
C
      IF(IWCYC.EQ.0) GOTO 3
      IF(ICYCLE.LT.IWCYC) GOTO 3
      DO 1 L=1,NUMOBS
 1    SW(L) = 1.0
 3    IRSD=0
      SUM=0.0
      RSDMAX=0.0
      TOLP = TOLTH
      IF (ITHT .EQ. 0) TOLP = TOLP + TOLP
      IF (IDOLSQ .EQ. 0) GO TO 7
      IF (IPHKL .NE. 2) WRITE(NTOUT,2) ICYCLE,IHEAD,IALF12,TOLP
 2    FORMAT(6H1CYCLE,I3/1X,A80/1X,A2,17HTHETA TOLERANCE =,F9.5)
C
C-----ROUTINE TO CHECK FOR BAD HKL'S
C
      NUM = 1
      IF ((NCYC + 1) .LE. ICYCLE) CALL BADHKL(NUMOBS,NUM)
      IF (IPHKL .EQ. 0) WRITE(NTOUT,8) IALF12,IALF12,IALF12
 8    FORMAT(4H0  N,2X,1HH,2X,1HK,2X,1HL,3X,6HD CALC,4X,5HD OBS,4X,
     * 6HLAMBDA,3X,A2,5HTHETA,3X,A2,5HTHETA,3X,A2,
     * 5HTHETA,3X,'2-THETA' / T47, 'CALC', 6X, 'OBS', 7X, 'DIFF', 5X,
     & 'WEIGHT')
 7    CONTINUE
      DO 10 L=1,IMN
 10   A(L)=0.0
      NUMCYC = 0
C
C-----BEGIN SEARCH FOR CLOSEST D-CALC TO D-OBS
C
      TOL  =TOLTH
      IHP=1
      DO 100 IGP=1,NUMOBS
      FLAG(IGP) = '  '
      SWT = SW(IGP)
      THOBS=OBSTH(IGP)
      DO 20 L=1,3
      NH(L)=IH(IGP,L)
 20   CONTINUE
      PWL = WL(IGP)
      DOBS=DSP(IGP)
C
C-----FIND THE CLOSEST MATCH BETWEEN NEXT DOBS AND DCALC
C
C     IHP = INDEX OF THE CLOSEST CALCULATED LINE
C     IGP = INDEX OF CURRENT OBSERVED LINE
C
C     CONNECTION BETWEEN THESE POINTERS IS SAVED IN ARRAY IOC(IGP)=IHP
C
      DMNDF=ABS(DCM(IHP)-DOBS)
      JHP=IHP+1
 28   IF (JHP .GT. NR) GO TO 32
      IF (ABS(DCM(JHP)-DOBS) .GT. DMNDF) GO TO 32
      DMNDF=ABS(DCM(JHP)-DOBS)
      JHP=JHP+1
      GO TO 28
 32   IHP=JHP-1
      IOC(IGP)=IHP
C
C------TEST IF INDEXED
C
      IF(IHED(IGP).EQ.ITIH(1) .OR. IHED(IGP).EQ.ITIH(2) .OR.
     * IHED(IGP).EQ.ITIH(3) .OR. IHED(IGP).EQ.ITIH(7)) GOTO 70
C
C-----UNINDEXED, SPACE GROUP EXTINCT OR A KNOWN IMPURITY
C     TRY TO AUTO INDEX THIS LINE
C
 33    CONTINUE
      D=DCM(IHP)
      DLST(IGP)=D
      CONST=0.5*PWL
      IF (D .LE. CONST) GO TO 92
      THCMP=THETA(CONST,D)
C-----NO CALCULATED LINE IS WITHIN TOL OF THE CURRENT OBSERVED LINE
      IF (ABS((THOBS-THCMP)*SWT) .GT. TOL) GO TO 93
      J=IGP-1
      ASSIGN 50 TO JADRS
 40   IF (J .LT. 1 .OR. J .GT. NUMOBS) GO TO 48
C-----TWO OBSERVED LINES ARE WITHIN TOLMN.  REJECT FROM LS
      IF (ABS(OBSTH(J)-THOBS)*SWT .LT. TOLMN) GO TO 94
      CNST=0.5*PWL
      IF (D .LE. CNST) GO TO 48
      THTRY=THETA(CNST,D)
C-----SECOND OBSERVED LINE IS WITHIN TOL OF THE CLOSEST CALCULATED LINE
      IF(ABS((OBSTH(J)-THTRY)*SWT) .LE. TOL) GOTO 94
 48   GO TO JADRS,(50,56)
 50   J=IGP+1
      ASSIGN 56 TO JADRS
      GO TO 40
 56   K=IHP-1
      ASSIGN 66 TO KADRS
 60   IF (K .LT. 1 .OR. K .GT. NR) GO TO 64
      DB=DCM(K)
      IF (DB .LE. CONST) GO TO 64
      THTRY=THETA(CONST,DB)
C-----ANOTHER CALCULATED LINE IS WITHIN TOLMN OF THE CLOSEST CALC LINE
      IF (ABS(THTRY-THCMP)*SWT .LT. TOLMN) GO TO 94
C-----ANOTHER CALCULATED LINE IS WITHIN TOL OF THE CURRENT OBSERVED LINE
      IF (ABS(THTRY-THOBS)*SWT .LE. TOL) GO TO 94
 64   GO TO KADRS,(66,68)
 66   K=IHP+1
      ASSIGN 68 TO KADRS
      GO TO 60
C
C-----DO NOT PERMIT AUTO INDEXING BEYOND THTMX FOR THE FIRST NCYC CYCLES
C
 68   IF (THOBS .GT. THTMX .AND. ICYCLE .LE. NCYC) GO TO 100
C
C-----SET HKL FOR THE NONINDEXED OBSERVED LINE AS A UNIQUE INDEX HAS
C     BEEN FOUND
C
      DO 69 L=1,3
 69   NH(L) =IHG(IHP,L)
      GO TO 90
C
C-----INDEXED REFLECTION - IH(IGP,4)= 'BLANK', 'M', '+' OR 'E'.
C
 70   CONST=0.5*PWL
      CALL QCOMP(NH,Z,Q)
      IF(Q.LT.0.00001) GOTO 92
      D=1.0/SQRT(Q)
      DLST(IGP)=D
      IF (CONST .GE. D) GO TO 92
      THCMP=THETA(CONST,D)
      IF (ABS((THCMP-THOBS)*SWT) .LE. TOL) GO TO 90
C-----REJECT INPUT INDEXED LINE FROM LEAST SQUARES SINCE OBS-CALC IS > TOL
      FLAG(IGP) = ' R'
C-----CHECK IF WILD INDEXING ERROR.  IF SO CHANGE TO UNINDEXED.
      NUM = 1
      CALL BADHKL(NUM,IGP)
      IF(IHED(IGP).EQ.ITIH(4)) GOTO 33
C
C-----IF WITHIN TOLERENCE AND CAN BE UNIQUELY INDEXED INCLUDE IN
C-----LEAST SQUARES EQUATION (IE, NOT 'R')
C
 90   DIFF=THCMP-THOBS
      IF (IPHKL .EQ. 0 .AND. IDOLSQ .EQ. 1) CALL HKLPR(FLAG(IGP))
      IF(FLAG(IGP).EQ.' R' .OR. IDOLSQ.EQ.0) GOTO 100
      CALL OBSEQ
      CALL NORME
      GO TO 100
C-----OBSERVED LINE BEYOND 180 DEG 2-THETA
 92   FLAG(IGP) =' X'
      GOTO 100
C-----NO CALCULATED LINE IS WITHIN TOL OF THE OBSERVED LINE IGP
 93   FLAG(IGP) =' R'
      GOTO 100
C-----MULTIPLE INDEXING POSSIBLE DUE TO TWO OR MORE OBS OR CALC
C     LINES WITHIN TOL OR TOLMN OF EACH OTHER.
 94   FLAG(IGP) =' M'
 100  CONTINUE
 999  RETURN
      END
      SUBROUTINE SORT
C      ############################################################
C      #                                                          #
C      #                          SORT                            #
C      #                                                          #
C      ############################################################
C
C SORT GIVEN REFLECTIONS SO AS TO BE IN DECREASING VALUE FOR D-SPACING
C
      PARAMETER (MAXOBS=200)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/BLKF/SW(MAXOBS),WL(MAXOBS)
      CHARACTER*1 IHED,INTED,HKLED
 64   I=NUMOBS
 65   I=I-1
      IF (I.LT.1) GO TO 99
      DO 80 J=1,I
      IF (DSP(J).GE.DSP(J+1)) GO TO 80
      DOBS=DSP(J)
      DSP(J)=DSP(J+1)
      DSP(J+1)=DOBS
      THOBS=OBSTH(J)
      OBSTH(J)=OBSTH(J+1)
      OBSTH(J+1)=THOBS
      WLC=WL(J)
      WL(J)=WL(J+1)
      WL(J+1)=WLC
      SWT=SW(J)
      SW(J)=SW(J+1)
      SW(J+1)=SWT
      DO 75 K=1,3
      ITEMP=IH(J,K)
      IH(J,K)=IH(J+1,K)
 75   IH(J+1,K)=ITEMP
 80   CONTINUE
      GO TO 65
 99   RETURN
      END
      SUBROUTINE SORTD(NR,DCM,IH)
C      ############################################################
C      #                                                          #
C      #                          SORTD                           #
C      #                                                          #
C      ############################################################
C
C SORTS ARRAY DCM SO THAT ELEMENTS ARE IN DECREASING ORDER - MILLER
C INDICES IN ARRAY IH MADE TO CORRESPOND
C
C  NR IS THE NUMBER OF VALUES IN ARRAY DCM
C
      PARAMETER (MAXGEN=1000)
      DIMENSION DCM(MAXGEN),IH(MAXGEN,3),NH(3)
      I=NR
 2    I=I-1
      IF (I.LT.1) GO TO 12
      DO 10 J=1,I
      IF (DCM(J).GE.DCM(J+1)) GO TO 10
      FAC=DCM(J)
      DCM(J)=DCM(J+1)
      DCM(J+1)=FAC
      DO  9 K=1,3
      NH(K)=IH(J,K)
      IH(J,K)=IH(J+1,K)
 9    IH(J+1,K)=NH(K)
 10   CONTINUE
      GO TO 2
 12   RETURN
      END
      SUBROUTINE SPG(SPGR,SPGRN,SPGRA,ICRS,IPASS)
C      ############################################################
C      #                                                          #
C      #                          SPG                             #
C      #                                                          #
C      ############################################################
C**********************************************************************
C
C-----ROUTINE TO ASSIGN THE SPACE GROUP NUMBER AND ORIENTATION CODE AND
C-----ASPECT CODE FOR THE SPACE GROUP SPGR
C
C-----IPASS = 1 FOR NORMAL ANALYSIS
C           = 2 FOR CRYSTAL DATA DATA BANK ANALYSIS
C-----SPACE GROUP NUMBER AS GIVEN IN THE 'INTENATIONAL TABLES, VOL 1'
C-----STORED IN SPGRN AS FOUR CHARACTER STRING
C
C-----ORIENTATION CODE IS AS FOLLOWS
C         (BLANK) OR A  -  STANDARD SETTING
C         B,C,D,E,F - ALTERNATE SETTING
C           STORED IN SPGRA AS A ONE CHARACTER STRING
C
C-----SPGRA -ASPECT CODE (A1)
C-----SPGRN -#, ORIENTATION CODE   (A4)
C
C*************************************************************************
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/UNQ/IFA,IFB,IFC,IRH
      COMMON/IERRS/IWARN,IERR
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 SPGRA,ICRS
      CHARACTER*4 SPGRN
      CHARACTER*4 NUMSP(416),NUMAS(130)
      CHARACTER*8  ILSG(416), IASP(130)
      CHARACTER*8 SPGR
      CHARACTER*1 IASPEC(2)
C-----ANORTHIC (TRICLINIC) STARTS HERE AT NUMBER 1
C-----P1        (1)
      DATA ILSG(1)/'P1      '/  ,NUMSP(  1)/'  1 '/
C-----P BAR 1   (2)
      DATA ILSG(2)/'P-1     '/  ,NUMSP(  2)/'  2 '/
C-----MONOCLINIC STARTS HERE AT NUMBER 3
C-----P2        (3)
      DATA ILSG(3)/'P2      '/  ,NUMSP(  3)/'  3 '/
C-----P21       (4)
      DATA ILSG(4)/'P21     '/  ,NUMSP(  4)/'  4 '/
C-----C2        (5A)
      DATA ILSG(5)/'C2      '/  ,NUMSP(  5)/'  5A'/
C-----A2        (5B)
      DATA ILSG(6)/'A2      '/  ,NUMSP(  6)/'  5B'/
C-----I2        (5C)
      DATA ILSG(7)/'I2      '/  ,NUMSP(  7)/'  5C'/
C-----PM        (6)
      DATA ILSG(8)/'PM      '/  ,NUMSP(  8)/'  6 '/
C-----PC        (7A)
      DATA ILSG(9)/'PC      '/  ,NUMSP(  9)/'  7A'/
C-----PA        (7B)
      DATA ILSG(10)/'PA      '/ ,NUMSP( 10)/'  7B'/
C-----PN        (7C)
      DATA ILSG(11)/'PN      '/ ,NUMSP( 11)/'  7C'/
C-----CM        (8A)
      DATA ILSG(12)/'CM      '/ ,NUMSP( 12)/'  8A'/
C-----AM        (8B)
      DATA ILSG(13)/'AM      '/ ,NUMSP( 13)/'  8B'/
C-----IM        (8C)
      DATA ILSG(14)/'IM      '/ ,NUMSP( 14)/'  8C'/
C-----CC        (9A)
      DATA ILSG(15)/'CC      '/ ,NUMSP( 15)/'  9A'/
C-----AA        (9B)
      DATA ILSG(16)/'AA      '/ ,NUMSP( 16)/'  9B'/
C-----IA        (9C)
      DATA ILSG(17)/'IA      '/ ,NUMSP( 17)/'  9C'/
C-----P2/M      (10)
      DATA ILSG(18)/'P2/M    '/ ,NUMSP( 18)/' 10 '/
C-----P21/M     (11)
      DATA ILSG(19)/'P21/M   '/ ,NUMSP( 19)/' 11 '/
C-----C2/M      (12A)
      DATA ILSG(20)/'C2/M    '/ ,NUMSP( 20)/' 12A'/
C-----A2/M      (12B)
      DATA ILSG(21)/'A2/M    '/ ,NUMSP( 21)/' 12B'/
C-----I2/M      (12C)
      DATA ILSG(22)/'I2/M    '/ ,NUMSP( 22)/' 12C'/
C-----P2/C      (13A)
      DATA ILSG(23)/'P2/C    '/ ,NUMSP( 23)/' 13A'/
C-----P2/A      (13B)
      DATA ILSG(24)/'P2/A    '/ ,NUMSP( 24)/' 13B'/
C-----P2/N       (13C)
      DATA ILSG(25)/'P2/N    '/ ,NUMSP( 25)/' 13C'/
C-----P21/C     (14A)
      DATA ILSG(26)/'P21/C   '/ ,NUMSP( 26)/' 14A'/
C-----P21/A     (14B)
      DATA ILSG(27)/'P21/A   '/ ,NUMSP( 27)/' 14B'/
C-----P21/N     (14C)
      DATA ILSG(28)/'P21/N   '/ ,NUMSP( 28)/' 14C'/
C-----C2/C      (15A)
      DATA ILSG(29)/'C2/C    '/ ,NUMSP( 29)/' 15A'/
C-----A2/A      (15B)
      DATA ILSG(30)/'A2/A    '/ ,NUMSP( 30)/' 15B'/
C-----I2/A      (15C)
      DATA ILSG(31)/'I2/A    '/ ,NUMSP( 31)/' 15C'/
C-----ORTHORHOMBIC STARTS HERE AT NUMBER 32
C-----P222      (16)
      DATA ILSG(32)/'P222    '/ ,NUMSP( 32)/' 16 '/
C-----P2221     (17A)
      DATA ILSG(33)/'P2221   '/ ,NUMSP( 33)/' 17A'/
C-----P2122     (17B)
      DATA ILSG(34)/'P2122   '/ ,NUMSP( 34)/' 17B'/
C-----P2212     (17C)
      DATA ILSG(35)/'P2212   '/ ,NUMSP( 35)/' 17C'/
C-----P21212    (18A)
      DATA ILSG(36)/'P21212  '/ ,NUMSP( 36)/' 18A'/
C-----P22121    (18B)
      DATA ILSG(37)/'P22121  '/ ,NUMSP( 37)/' 18B'/
C-----P21221    (18C)
      DATA ILSG(38)/'P21221  '/ ,NUMSP( 38)/' 18C'/
C-----P212121   (19)
      DATA ILSG(39)/'P212121 '/ ,NUMSP( 39)/' 19 '/
C-----C2221     (20A)
      DATA ILSG(40)/'C2221   '/ ,NUMSP( 40)/' 20A'/
C-----A2122     (20B)
      DATA ILSG(41)/'A2122   '/ ,NUMSP( 41)/' 20B'/
C-----B2212     (20C)
      DATA ILSG(42)/'B2212   '/ ,NUMSP( 42)/' 20C'/
C-----C222      (21A)
      DATA ILSG(43)/'C222    '/ ,NUMSP( 43)/' 21A'/
C-----B222      (21B)
      DATA ILSG(44)/'B222    '/ ,NUMSP( 44)/' 21B'/
C-----A222      (21C)
      DATA ILSG(45)/'A222    '/ ,NUMSP( 45)/' 21C'/
C-----F222      (22)
      DATA ILSG(46)/'F222    '/ ,NUMSP( 46)/' 22 '/
C-----I222      (23)
      DATA ILSG(47)/'I222    '/ ,NUMSP( 47)/' 23 '/
C-----I212121   (24)
      DATA ILSG(48)/'I212121 '/ ,NUMSP( 48)/' 24 '/
C-----PMM2      (25A)
      DATA ILSG(49)/'PMM2    '/ ,NUMSP( 49)/' 25A'/
C-----PM2M      (25B)
      DATA ILSG(50)/'PM2M    '/ ,NUMSP( 50)/' 25B'/
C-----P2MM      (25C)
      DATA ILSG(51)/'P2MM    '/ ,NUMSP( 51)/' 25C'/
C-----PMC21     (26A)
      DATA ILSG(52)/'PMC21   '/ ,NUMSP( 52)/' 26A'/
C-----P21MA     (26B)
      DATA ILSG(53)/'P21MA   '/ ,NUMSP( 53)/' 26B'/
C-----P21AM     (26C)
      DATA ILSG(54)/'P21AM   '/ ,NUMSP( 54)/' 26C'/
C-----PB21M     (26D)
      DATA ILSG(55)/'PB21M   '/ ,NUMSP( 55)/' 26D'/
C-----PCM21     (26E)
      DATA ILSG(56)/'PCM21   '/ ,NUMSP( 56)/' 26E'/
C-----PM21B     (26F)
      DATA ILSG(57)/'PM21B   '/ ,NUMSP( 57)/' 26F'/
C-----PCC2      (27A)
      DATA ILSG(58)/'PCC2    '/ ,NUMSP( 58)/' 27A'/
C-----PB2B      (27B)
      DATA ILSG(59)/'PB2B    '/ ,NUMSP( 59)/' 27B'/
C-----P2AA      (27C)
      DATA ILSG(60)/'P2AA    '/ ,NUMSP( 60)/' 27C'/
C-----PMA2      (28A)
      DATA ILSG(61)/'PMA2    '/ ,NUMSP( 61)/' 28A'/
C-----P2CM      (28B)
      DATA ILSG(62)/'P2CM    '/ ,NUMSP( 62)/' 28B'/
C-----P2MB      (28C)
      DATA ILSG(63)/'P2MB    '/ ,NUMSP( 63)/' 28C'/
C-----PBM2      (28D)
      DATA ILSG(64)/'PBM2    '/ ,NUMSP( 64)/' 28D'/
C-----PC2M      (28E)
      DATA ILSG(65)/'PC2M    '/ ,NUMSP( 65)/' 28E'/
C-----PM2A      (28F)
      DATA ILSG(66)/'PM2A    '/ ,NUMSP( 66)/' 28F'/
C-----PCA21     (29A)
      DATA ILSG(67)/'PCA21   '/ ,NUMSP( 67)/' 29A'/
C-----P21CA     (29B)
      DATA ILSG(68)/'P21CA   '/ ,NUMSP( 68)/' 29B'/
C-----PB21A     (29C)
      DATA ILSG(69)/'PB21A   '/ ,NUMSP( 69)/' 29C'/
C-----P21AB     (29D)
      DATA ILSG(70)/'P21AB   '/ ,NUMSP( 70)/' 29D'/
C-----PC21B     (29E)
      DATA ILSG(71)/'PC21B   '/ ,NUMSP( 71)/' 29E'/
C-----PBC21     (29F)
      DATA ILSG(72)/'PBC21   '/ ,NUMSP( 72)/' 29F'/
C-----PNC2      (30A)
      DATA ILSG(73)/'PNC2    '/ ,NUMSP( 73)/' 30A'/
C-----PCN2      (30B)
      DATA ILSG(74)/'PCN2    '/ ,NUMSP( 74)/' 30B'/
C-----PN2B      (30C)
      DATA ILSG(75)/'PN2B    '/ ,NUMSP( 75)/' 30C'/
C-----PB2N      (30D)
      DATA ILSG(76)/'PB2N    '/ ,NUMSP( 76)/' 30D'/
C-----P2NA      (30E)
      DATA ILSG(77)/'P2NA    '/ ,NUMSP( 77)/' 30E'/
C-----P2AN      (30F)
      DATA ILSG(78)/'P2AN    '/ ,NUMSP( 78)/' 30F'/
C-----PMN21     (31A)
      DATA ILSG(79)/'PMN21   '/ ,NUMSP( 79)/' 31A'/
C-----PNM21     (31B)
      DATA ILSG(80)/'PNM21   '/ ,NUMSP( 80)/' 31B'/
C-----P21NM     (31C)
      DATA ILSG(81)/'P21NM   '/ ,NUMSP( 81)/' 31C'/
C-----PN21M     (31D)
      DATA ILSG(82)/'PN21M   '/ ,NUMSP( 82)/' 31D'/
C-----PM21N     (31E)
      DATA ILSG(83)/'PM21N   '/ ,NUMSP( 83)/' 31E'/
C-----P21MN     (31F)
      DATA ILSG(84)/'P21MN   '/ ,NUMSP( 84)/' 31F'/
C-----PBA2      (32A)
      DATA ILSG(85)/'PBA2    '/ ,NUMSP( 85)/' 32A'/
C-----P2CB      (32B)
      DATA ILSG(86)/'P2CB    '/ ,NUMSP( 86)/' 32B'/
C-----PC2A      (32C)
      DATA ILSG(87)/'PC2A    '/ ,NUMSP( 87)/' 32C'/
C-----PNA21     (33A)
      DATA ILSG(88)/'PNA21   '/ ,NUMSP( 88)/' 33A'/
C-----PBN21     (33B)
      DATA ILSG(89)/'PBN21   '/ ,NUMSP( 89)/' 33B'/
C-----P21CN     (33C)
      DATA ILSG(90)/'P21CN   '/ ,NUMSP( 90)/' 33C'/
C-----P21NB     (33D)
      DATA ILSG(91)/'P21NB   '/ ,NUMSP( 91)/' 33D'/
C-----PN21A     (33E)
      DATA ILSG(92)/'PN21A   '/ ,NUMSP( 92)/' 33E'/
C-----PC21N     (33F)
      DATA ILSG(93)/'PC21N   '/ ,NUMSP( 93)/' 33F'/
C-----PNN2      (34A)
      DATA ILSG(94)/'PNN2    '/ ,NUMSP( 94)/' 34A'/
C-----PN2N      (34B)
      DATA ILSG(95)/'PN2N    '/ ,NUMSP( 95)/' 34B'/
C-----P2NN      (34C)
      DATA ILSG(96)/'P2NN    '/ ,NUMSP( 96)/' 34C'/
C-----CMM2      (35A)
      DATA ILSG(97)/'CMM2    '/ ,NUMSP( 97)/' 35A'/
C-----BM2M      (35B)
      DATA ILSG(98)/'BM2M    '/ ,NUMSP( 98)/' 35B'/
C-----A2MM      (35C)
      DATA ILSG(99)/'A2MM    '/ ,NUMSP( 99)/' 35C'/
C-----CMC21     (36A)
      DATA ILSG(100)/'CMC21   '/,NUMSP(100)/' 36A'/
C-----A21AM     (36B)
      DATA ILSG(101)/'A21AM   '/,NUMSP(101)/' 36B'/
C-----A21MA     (36C)
      DATA ILSG(102)/'A21MA   '/,NUMSP(102)/' 36C'/
C-----BM21B     (36D)
      DATA ILSG(103)/'BM21B   '/,NUMSP(103)/' 36D'/
C-----BB21M     (36E)
      DATA ILSG(104)/'BB21M   '/,NUMSP(104)/' 36E'/
C-----CCM21     (36F)
      DATA ILSG(105)/'CCM21   '/,NUMSP(105)/' 36F'/
C-----CCC2      (37A)
      DATA ILSG(106)/'CCC2    '/,NUMSP(106)/' 37A'/
C-----A2AA      (37B)
      DATA ILSG(107)/'A2AA    '/,NUMSP(107)/' 37B'/
C-----BB2B      (37C)
      DATA ILSG(108)/'BB2B    '/,NUMSP(108)/' 37C'/
C-----AMM2      (38A)
      DATA ILSG(109)/'AMM2    '/,NUMSP(109)/' 38A'/
C-----AM2M      (38B)
      DATA ILSG(110)/'AM2M    '/,NUMSP(110)/' 38B'/
C-----B2MM      (38C)
      DATA ILSG(111)/'B2MM    '/,NUMSP(111)/' 38C'/
C-----BMM2      (38E)
      DATA ILSG(113)/'BMM2    '/,NUMSP(113)/' 38E'/
C-----C2MM      (38D)
      DATA ILSG(112)/'C2MM    '/,NUMSP(112)/' 38D'/
C-----CM2M      (38F)
      DATA ILSG(114)/'CM2M    '/,NUMSP(114)/' 38F'/
C-----ABM2      (39A)
      DATA ILSG(115)/'ABM2    '/,NUMSP(115)/' 39A'/
C-----BMA2      (39B)
      DATA ILSG(116)/'BMA2    '/,NUMSP(116)/' 39B'/
C-----C2MA      (39C)
      DATA ILSG(117)/'C2MA    '/,NUMSP(117)/' 39C'/
C-----AB2M      (39D)
      DATA ILSG(118)/'AB2M    '/,NUMSP(118)/' 39D'/
C-----CM2A      (39E)
      DATA ILSG(119)/'CM2A    '/,NUMSP(119)/' 39E'/
C-----B2AM      (39F)
      DATA ILSG(120)/'B2AM    '/,NUMSP(120)/' 39F'/
C-----AMA2      (40A)
      DATA ILSG(121)/'AMA2    '/,NUMSP(121)/' 40A'/
C-----C2CM      (40B)
      DATA ILSG(122)/'C2CM    '/,NUMSP(122)/' 40B'/
C-----BBM2      (40C)
      DATA ILSG(123)/'BBM2    '/,NUMSP(123)/' 40C'/
C-----B2MB      (40D)
      DATA ILSG(124)/'B2MB    '/,NUMSP(124)/' 40D'/
C-----CC2M      (40E)
      DATA ILSG(125)/'CC2M    '/,NUMSP(125)/' 40E'/
C-----AM2A      (40F)
      DATA ILSG(126)/'AM2A    '/,NUMSP(126)/' 40F'/
C-----ABA2      (41A)
      DATA ILSG(127)/'ABA2    '/,NUMSP(127)/' 41A'/
C-----AB2A      (41B)
      DATA ILSG(128)/'AB2A    '/,NUMSP(128)/' 41B'/
C-----C2CA      (41C)
      DATA ILSG(129)/'C2CA    '/,NUMSP(129)/' 41C'/
C-----B2AB      (41D)
      DATA ILSG(130)/'B2AB    '/,NUMSP(130)/' 41D'/
C-----CC2A      (41E)
      DATA ILSG(131)/'CC2A    '/,NUMSP(131)/' 41E'/
C-----BBA2      (41F)
      DATA ILSG(132)/'BBA2    '/,NUMSP(132)/' 41F'/
C-----FMM2      (42A)
      DATA ILSG(133)/'FMM2    '/,NUMSP(133)/' 42A'/
C-----FM2M      (42B)
      DATA ILSG(134)/'FM2M    '/,NUMSP(134)/' 42B'/
C-----F2MM      (42C)
      DATA ILSG(135)/'F2MM    '/,NUMSP(135)/' 42C'/
C-----FDD2      (43A)
      DATA ILSG(136)/'FDD2    '/,NUMSP(136)/' 43A'/
C-----FD2D      (43B)
      DATA ILSG(137)/'FD2D    '/,NUMSP(137)/' 43B'/
C-----F2DD      (43C)
      DATA ILSG(138)/'F2DD    '/,NUMSP(138)/' 43C'/
C-----IMM2      (44A)
      DATA ILSG(139)/'IMM2    '/,NUMSP(139)/' 44A'/
C-----IM2M      (44B)
      DATA ILSG(140)/'IM2M    '/,NUMSP(140)/' 44B'/
C-----I2MM      (44C)
      DATA ILSG(141)/'I2MM    '/,NUMSP(141)/' 44C'/
C-----IBA2      (45A)
      DATA ILSG(142)/'IBA2    '/,NUMSP(142)/' 45A'/
C-----IB2A      (45B)
      DATA ILSG(143)/'IB2A    '/,NUMSP(143)/' 45B'/
C-----I2AA      (45C)
      DATA ILSG(144)/'I2AA    '/,NUMSP(144)/' 45C'/
C-----IMA2      (46A)
      DATA ILSG(145)/'IMA2    '/,NUMSP(145)/' 46A'/
C-----IM2A      (46B)
      DATA ILSG(146)/'IM2A    '/,NUMSP(146)/' 46B'/
C-----IBM2      (46C)
      DATA ILSG(147)/'IBM2    '/,NUMSP(147)/' 46C'/
C-----I2AM      (46D)
      DATA ILSG(148)/'I2AM    '/,NUMSP(148)/' 46D'/
C-----IB2M      (46E)
      DATA ILSG(149)/'IB2M    '/,NUMSP(149)/' 46E'/
C-----I2MA      (46F)
      DATA ILSG(150)/'I2MA    '/,NUMSP(150)/' 46F'/
C-----PMMM      (47)
      DATA ILSG(151)/'PMMM    '/,NUMSP(151)/' 47 '/
C-----PNNN      (48)
      DATA ILSG(152)/'PNNN    '/,NUMSP(152)/' 48 '/
C-----PCCM      (49A)
      DATA ILSG(153)/'PCCM    '/,NUMSP(153)/' 49A'/
C-----PMAA      (49B)
      DATA ILSG(154)/'PMAA    '/,NUMSP(154)/' 49B'/
C-----PBMB      (49C)
      DATA ILSG(155)/'PBMB    '/,NUMSP(155)/' 49C'/
C-----PBAN      (50A)
      DATA ILSG(156)/'PBAN    '/,NUMSP(156)/' 50A'/
C-----PNCB      (50B)
      DATA ILSG(157)/'PNCB    '/,NUMSP(157)/' 50B'/
C-----PCNA      (50C)
      DATA ILSG(158)/'PCNA    '/,NUMSP(158)/' 50C'/
C-----PMMA      (51A)
      DATA ILSG(159)/'PMMA    '/,NUMSP(159)/' 51A'/
C-----PMCM      (51B)
      DATA ILSG(160)/'PMCM    '/,NUMSP(160)/' 51B'/
C-----PCMM      (51C)
      DATA ILSG(161)/'PCMM    '/,NUMSP(161)/' 51C'/
C-----PMAM      (51D)
      DATA ILSG(162)/'PMAM    '/,NUMSP(162)/' 51D'/
C-----PBMM      (51E)
      DATA ILSG(163)/'PBMM    '/,NUMSP(163)/' 51E'/
C-----PMMB      (51F)
      DATA ILSG(164)/'PMMB    '/,NUMSP(164)/' 51F'/
C-----PNNA      (52A)
      DATA ILSG(165)/'PNNA    '/,NUMSP(165)/' 52A'/
C-----PNNB      (52B)
      DATA ILSG(166)/'PNNB    '/,NUMSP(166)/' 52B'/
C-----PNAN      (52C)
      DATA ILSG(167)/'PNAN    '/,NUMSP(167)/' 52C'/
C-----PNCN      (52D)
      DATA ILSG(168)/'PNCN    '/,NUMSP(168)/' 52D'/
C-----PBNN      (52E)
      DATA ILSG(169)/'PBNN    '/,NUMSP(169)/' 52E'/
C-----PCNN      (52F)
      DATA ILSG(170)/'PCNN    '/,NUMSP(170)/' 52F'/
C-----PMNA      (53A)
      DATA ILSG(171)/'PMNA    '/,NUMSP(171)/' 53A'/
C-----PNCM      (53B)
      DATA ILSG(172)/'PNCM    '/,NUMSP(172)/' 53B'/
C-----PBMN      (53C)
      DATA ILSG(173)/'PBMN    '/,NUMSP(173)/' 53C'/
C-----PMAN      (53D)
      DATA ILSG(174)/'PMAN    '/,NUMSP(174)/' 53D'/
C-----PCNM      (53E)
      DATA ILSG(175)/'PCNM    '/,NUMSP(175)/' 53E'/
C-----PNMB      (53F)
      DATA ILSG(176)/'PNMB    '/,NUMSP(176)/' 53F'/
C-----PCCA      (54A)
      DATA ILSG(177)/'PCCA    '/,NUMSP(177)/' 54A'/
C-----PBAA      (54B)
      DATA ILSG(178)/'PBAA    '/,NUMSP(178)/' 54B'/
C-----PBCB      (54C)
      DATA ILSG(179)/'PBCB    '/,NUMSP(179)/' 54C'/
C-----PCCB      (54D)
      DATA ILSG(180)/'PCCB    '/,NUMSP(180)/' 54D'/
C-----PBAB      (54E)
      DATA ILSG(181)/'PBAB    '/,NUMSP(181)/' 54E'/
C-----PCAA      (54F)
      DATA ILSG(182)/'PCAA    '/,NUMSP(182)/' 54F'/
C-----PBAM      (55A)
      DATA ILSG(183)/'PBAM    '/,NUMSP(183)/' 55A'/
C-----PCMA      (55B)
      DATA ILSG(184)/'PCMA    '/,NUMSP(184)/' 55B'/
C-----PMCB      (55C)
      DATA ILSG(185)/'PMCB    '/,NUMSP(185)/' 55C'/
C-----PCCN      (56A)
      DATA ILSG(186)/'PCCN    '/,NUMSP(186)/' 56A'/
C-----PBNB      (56B)
      DATA ILSG(187)/'PBNB    '/,NUMSP(187)/' 56B'/
C-----PNAA      (56C)
      DATA ILSG(188)/'PNAA    '/,NUMSP(188)/' 56C'/
C-----PBCM      (57A)
      DATA ILSG(189)/'PBCM    '/,NUMSP(189)/' 57A'/
C-----PCMB      (57B)
      DATA ILSG(190)/'PCMB    '/,NUMSP(190)/' 57B'/
C-----PBMA      (57C)
      DATA ILSG(191)/'PBMA    '/,NUMSP(191)/' 57C'/
C-----PCAM      (57D)
      DATA ILSG(192)/'PCAM    '/,NUMSP(192)/' 57D'/
C-----PMAB      (57E)
      DATA ILSG(193)/'PMAB    '/,NUMSP(193)/' 57E'/
C-----PMCA      (57F)
      DATA ILSG(194)/'PMCA    '/,NUMSP(194)/' 57F'/
C-----PNNM      (58A)
      DATA ILSG(195)/'PNNM    '/,NUMSP(195)/' 58A'/
C-----PNMN      (58B)
      DATA ILSG(196)/'PNMN    '/,NUMSP(196)/' 58B'/
C-----PMNN      (58C)
      DATA ILSG(197)/'PMNN    '/,NUMSP(197)/' 58C'/
C-----PMMN      (59A)
      DATA ILSG(198)/'PMMN    '/,NUMSP(198)/' 59A'/
C-----PNMM      (59B)
      DATA ILSG(199)/'PNMM    '/,NUMSP(199)/' 59B'/
C-----PMNM      (59C)
      DATA ILSG(200)/'PMNM    '/,NUMSP(200)/' 59C'/
C-----PBCN      (60A)
      DATA ILSG(201)/'PBCN    '/,NUMSP(201)/' 60A'/
C-----PNAB      (60B)
      DATA ILSG(202)/'PNAB    '/,NUMSP(202)/' 60B'/
C-----PNCA      (60C)
      DATA ILSG(203)/'PNCA    '/,NUMSP(203)/' 60C'/
C-----PBNA      (60D)
      DATA ILSG(204)/'PBNA    '/,NUMSP(204)/' 60D'/
C-----PCAN      (60E)
      DATA ILSG(205)/'PCAN    '/,NUMSP(205)/' 60E'/
C-----PCNB      (60F)
      DATA ILSG(206)/'PCNB    '/,NUMSP(206)/' 60F'/
C-----PBCA      (61A)
      DATA ILSG(207)/'PBCA    '/,NUMSP(207)/' 61A'/
C-----PCAB      (61B)
      DATA ILSG(208)/'PCAB    '/,NUMSP(208)/' 61B'/
C-----PNMA      (62A)
      DATA ILSG(209)/'PNMA    '/,NUMSP(209)/' 62A'/
C-----PMNB      (62B)
      DATA ILSG(210)/'PMNB    '/,NUMSP(210)/' 62B'/
C-----PBNM      (62C)
      DATA ILSG(211)/'PBNM    '/,NUMSP(211)/' 62C'/
C-----PMCN      (62D)
      DATA ILSG(212)/'PMCN    '/,NUMSP(212)/' 62D'/
C-----PCMN      (62E)
      DATA ILSG(213)/'PCMN    '/,NUMSP(213)/' 62E'/
C-----PNAM      (62F)
      DATA ILSG(214)/'PNAM    '/,NUMSP(214)/' 62F'/
C-----CMCM      (63A)
      DATA ILSG(215)/'CMCM    '/,NUMSP(215)/' 63A'/
C-----BBMM      (63B)
      DATA ILSG(216)/'BBMM    '/,NUMSP(216)/' 63B'/
C-----AMAM      (63C)
      DATA ILSG(217)/'AMAM    '/,NUMSP(217)/' 63C'/
C-----AMMA      (63D)
      DATA ILSG(218)/'AMMA    '/,NUMSP(218)/' 63D'/
C-----CCMM      (63E)
      DATA ILSG(219)/'CCMM    '/,NUMSP(219)/' 63E'/
C-----BMMB      (63F)
      DATA ILSG(220)/'BMMB    '/,NUMSP(220)/' 63F'/
C-----CMCA      (64A)
      DATA ILSG(221)/'CMCA    '/,NUMSP(221)/' 64A'/
C-----ABAM      (64B)
      DATA ILSG(222)/'ABAM    '/,NUMSP(222)/' 64B'/
C-----CCMA      (64C)
      DATA ILSG(223)/'CCMA    '/,NUMSP(223)/' 64C'/
C-----ABMA      (64D)
      DATA ILSG(224)/'ABMA    '/,NUMSP(224)/' 64D'/
C-----BMAB      (64E)
      DATA ILSG(225)/'BMAB    '/,NUMSP(225)/' 64E'/
C-----BBAM      (64F)
      DATA ILSG(226)/'BBAM    '/,NUMSP(226)/' 64F'/
C-----CMMM      (65A)
      DATA ILSG(227)/'CMMM    '/,NUMSP(227)/' 65A'/
C-----BMMM      (65B)
      DATA ILSG(228)/'BMMM    '/,NUMSP(228)/' 65B'/
C-----AMMM      (65C)
      DATA ILSG(229)/'AMMM    '/,NUMSP(229)/' 65C'/
C-----CCCM      (66A)
      DATA ILSG(230)/'CCCM    '/,NUMSP(230)/' 66A'/
C-----AMAA      (66B)
      DATA ILSG(231)/'AMAA    '/,NUMSP(231)/' 66B'/
C-----BBMB      (66C)
      DATA ILSG(232)/'BBMB    '/,NUMSP(232)/' 66C'/
C-----CMMA      (67A)
      DATA ILSG(233)/'CMMA    '/,NUMSP(233)/' 67A'/
C-----ABMM      (67B)
      DATA ILSG(234)/'ABMM    '/,NUMSP(234)/' 67B'/
C-----BMAM      (67C)
      DATA ILSG(235)/'BMAM    '/,NUMSP(235)/' 67C'/
C-----CCCA      (68A)
      DATA ILSG(236)/'CCCA    '/,NUMSP(236)/' 68A'/
C-----BBAB      (68B)
      DATA ILSG(237)/'BBAB    '/,NUMSP(237)/' 68B'/
C-----ABAA      (68C)
      DATA ILSG(238)/'ABAA    '/,NUMSP(238)/' 68C'/
C-----FMMM      (69)
      DATA ILSG(239)/'FMMM    '/,NUMSP(239)/' 69 '/
C-----FDDD      (70)
      DATA ILSG(240)/'FDDD    '/,NUMSP(240)/' 70 '/
C-----IMMM      (71)
      DATA ILSG(241)/'IMMM    '/,NUMSP(241)/' 71 '/
C-----IBAM      (72A)
      DATA ILSG(242)/'IBAM    '/,NUMSP(242)/' 72A'/
C-----IMAA      (72B)
      DATA ILSG(243)/'IMAA    '/,NUMSP(243)/' 72B'/
C-----IBMA      (72C)
      DATA ILSG(244)/'IBMA    '/,NUMSP(244)/' 72C'/
C-----IBCA      (73)
      DATA ILSG(245)/'IBCA    '/,NUMSP(245)/' 73 '/
C-----IMMA      (74A)
      DATA ILSG(246)/'IMMA    '/,NUMSP(246)/' 74A'/
C-----IBMM      (74B)
      DATA ILSG(247)/'IBMM    '/,NUMSP(247)/' 74B'/
C-----IMAM      (74C)
      DATA ILSG(248)/'IMAM    '/,NUMSP(248)/' 74C'/
C-----TETRAGONAL STARTS HERE AT NUMBER 249
C-----P4        (75)
      DATA ILSG(249)/'P4      '/,NUMSP(249)/' 75 '/
C-----P41       (76)   AND P43
      DATA ILSG(250)/'P41     '/,NUMSP(250)/' 76 '/
C-----P41,3     (ASPECT 76)
      DATA ILSG(251)/'XXXXXXXX'/,NUMSP(251)/' 76B'/
C-----P42       (77)
      DATA ILSG(252)/'P42     '/,NUMSP(252)/' 77 '/
C-----P43       (78)    ASS. 76
      DATA ILSG(253)/'P43     '/,NUMSP(253)/' 78 '/
C-----I4        (79)
      DATA ILSG(254)/'I4      '/,NUMSP(254)/' 79 '/
C-----I41       (80)
      DATA ILSG(255)/'I41     '/,NUMSP(255)/' 80 '/
C-----P BAR 4   (81)
      DATA ILSG(256)/'P-4     '/,NUMSP(256)/' 81 '/
C-----I BAR 4   (82)
      DATA ILSG(257)/'I-4     '/,NUMSP(257)/' 82 '/
C-----P4/M      (83)
      DATA ILSG(258)/'P4/M    '/,NUMSP(258)/' 83 '/
C-----P42/M     (84)
      DATA ILSG(259)/'P42/M   '/,NUMSP(259)/' 84 '/
C-----P4/N      (85)
      DATA ILSG(260)/'P4/N    '/,NUMSP(260)/' 85 '/
C-----P42/N     (86)
      DATA ILSG(261)/'P42/N   '/,NUMSP(261)/' 86 '/
C-----I4/M      (87)
      DATA ILSG(262)/'I4/M    '/,NUMSP(262)/' 87 '/
C-----I41/A     (88)
      DATA ILSG(263)/'I41/A   '/,NUMSP(263)/' 88 '/
C-----P422      (89)
      DATA ILSG(264)/'P422    '/,NUMSP(264)/' 89 '/
C-----P4212     (90)
      DATA ILSG(265)/'P4212   '/,NUMSP(265)/' 90 '/
C-----P4122     (91)   AND P4322
      DATA ILSG(266)/'P4122   '/,NUMSP(266)/' 91 '/
C-----P41,322   (ASPECT 91)
      DATA ILSG(267)/'XXXXXXXX'/,NUMSP(267)/' 91B'/
C-----P41212    (92)   AND P43212
      DATA ILSG(268)/'P41212  '/,NUMSP(268)/' 92 '/
C-----P41,3212  (ASPECT 92)
      DATA ILSG(269)/'XXXXXXXX'/,NUMSP(269)/' 92B'/
C-----P4222     (93)
      DATA ILSG(270)/'P4222   '/,NUMSP(270)/' 93 '/
C-----P42212    (94)
      DATA ILSG(271)/'P42212  '/,NUMSP(271)/' 94 '/
C-----P4322     (95)    ASS. 91
      DATA ILSG(272)/'P4322   '/,NUMSP(272)/' 95 '/
C-----P43212    (96)    ASS. 92
      DATA ILSG(273)/'P43212  '/,NUMSP(273)/' 96 '/
C-----I422      (97)
      DATA ILSG(274)/'I422    '/,NUMSP(274)/' 97 '/
C-----I4122     (98)
      DATA ILSG(275)/'I4122   '/,NUMSP(275)/' 98 '/
C-----P4MM      (99)
      DATA ILSG(276)/'P4MM    '/,NUMSP(276)/' 99 '/
C-----P4BM      (100)
      DATA ILSG(277)/'P4BM    '/,NUMSP(277)/'100 '/
C-----P42CM     (101)
      DATA ILSG(278)/'P42CM   '/,NUMSP(278)/'101 '/
C-----P42NM     (102)
      DATA ILSG(279)/'P42NM   '/,NUMSP(279)/'102 '/
C-----P4CC      (103)
      DATA ILSG(280)/'P4CC    '/,NUMSP(280)/'103 '/
C-----P4NC      (104)
      DATA ILSG(281)/'P4NC    '/,NUMSP(281)/'104 '/
C-----P42MC     (105)
      DATA ILSG(282)/'P42MC   '/,NUMSP(282)/'105 '/
C-----P42BC     (106)
      DATA ILSG(283)/'P42BC   '/,NUMSP(283)/'106 '/
C-----I4MM      (107)
      DATA ILSG(284)/'I4MM    '/,NUMSP(284)/'107 '/
C-----I4CM      (108)
      DATA ILSG(285)/'I4CM    '/,NUMSP(285)/'108 '/
C-----I41MD     (109)
      DATA ILSG(286)/'I41MD   '/,NUMSP(286)/'109 '/
C-----I41CD     (110)
      DATA ILSG(287)/'I41CD   '/,NUMSP(287)/'110 '/
C-----PBAR42M   (111)
      DATA ILSG(288)/'P-42M   '/,NUMSP(288)/'111 '/
C-----PBAR42C   (112)
      DATA ILSG(289)/'P-42C   '/,NUMSP(289)/'112 '/
C-----PBAR421M  (113)
      DATA ILSG(290)/'P-421M  '/,NUMSP(290)/'113 '/
C-----PBAR421C  (114)
      DATA ILSG(291)/'P-421C  '/,NUMSP(291)/'114 '/
C-----PBAR4M2   (115)
      DATA ILSG(292)/'P-4M2   '/,NUMSP(292)/'115 '/
C-----PBAR4C2   (116)
      DATA ILSG(293)/'P-4C2   '/,NUMSP(293)/'116 '/
C-----PBAR4B2   (117)
      DATA ILSG(294)/'P-4B2   '/,NUMSP(294)/'117 '/
C-----PBAR4N2   (118)
      DATA ILSG(295)/'P-4N2   '/,NUMSP(295)/'118 '/
C-----IBAR4M2   (119)
      DATA ILSG(296)/'I-4M2   '/,NUMSP(296)/'119 '/
C-----IBAR4C2   (120)
      DATA ILSG(297)/'I-4C2   '/,NUMSP(297)/'120 '/
C-----IBAR42M   (121)
      DATA ILSG(298)/'I-42M   '/,NUMSP(298)/'121 '/
C-----IBAR42D   (122)
      DATA ILSG(299)/'I-42D   '/,NUMSP(299)/'122 '/
C-----P4/MMM    (123)
      DATA ILSG(300)/'P4/MMM  '/,NUMSP(300)/'123 '/
C-----P4/MCC    (124)
      DATA ILSG(301)/'P4/MCC  '/,NUMSP(301)/'124 '/
C-----P4/NBM    (125)
      DATA ILSG(302)/'P4/NBM  '/,NUMSP(302)/'125 '/
C-----P4/NNC    (126)
      DATA ILSG(303)/'P4/NNC  '/,NUMSP(303)/'126 '/
C-----P4/MBM    (127)
      DATA ILSG(304)/'P4/MBM  '/,NUMSP(304)/'127 '/
C-----P4/MNC    (128)
      DATA ILSG(305)/'P4/MNC  '/,NUMSP(305)/'128 '/
C-----P4/NMM    (129)
      DATA ILSG(306)/'P4/NMM  '/,NUMSP(306)/'129 '/
C-----P4/NCC    (130)
      DATA ILSG(307)/'P4/NCC  '/,NUMSP(307)/'130 '/
C-----P42/MMC   (131)
      DATA ILSG(308)/'P42/MMC '/,NUMSP(308)/'131 '/
C-----P42/MCM   (132)
      DATA ILSG(309)/'P42/MCM '/,NUMSP(309)/'132 '/
C-----P42/NBC   (133)
      DATA ILSG(310)/'P42/NBC '/,NUMSP(310)/'133 '/
C-----P42/NNM   (134)
      DATA ILSG(311)/'P42/NNM '/,NUMSP(311)/'134 '/
C-----P42/MBC   (135)
      DATA ILSG(312)/'P42/MBC '/,NUMSP(312)/'135 '/
C-----P42/MNM   (136)
      DATA ILSG(313)/'P42/MNM '/,NUMSP(313)/'136 '/
C-----P42/NMC   (137)
      DATA ILSG(314)/'P42/NMC '/,NUMSP(314)/'137 '/
C-----P42/NCM   (138)
      DATA ILSG(315)/'P42/NCM '/,NUMSP(315)/'138 '/
C-----I4/MMM    (139)
      DATA ILSG(316)/'I4/MMM  '/,NUMSP(316)/'139 '/
C-----I4/MCM    (140)
      DATA ILSG(317)/'I4/MCM  '/,NUMSP(317)/'140 '/
C-----I41/AMD   (141)
      DATA ILSG(318)/'I41/AMD '/,NUMSP(318)/'141 '/
C-----I41/ACD   (142)
      DATA ILSG(319)/'I41/ACD '/,NUMSP(319)/'142 '/
C-----HEXAGONAL AND RHOMBOHEDRAL START HERE AT NUMBER 320
C-----P3        (143)
      DATA ILSG(320)/'P3      '/,NUMSP(320)/'143 '/
C-----P31       (144)  AND P32
      DATA ILSG(321)/'P31     '/,NUMSP(321)/'144 '/
C-----P31,2     (ASPECT 144)
      DATA ILSG(322)/'XXXXXXXX'/,NUMSP(322)/'144B'/
C-----P32       (145)   ASS. 144
      DATA ILSG(323)/'P32     '/,NUMSP(323)/'145 '/
C-----R3        (146)
      DATA ILSG(324)/'R3      '/,NUMSP(324)/'146 '/
C-----P BAR 3   (147)
      DATA ILSG(325)/'P-3     '/,NUMSP(325)/'147 '/
C-----R BAR 3   (148)
      DATA ILSG(326)/'R-3     '/,NUMSP(326)/'148 '/
C-----P312      (149)
      DATA ILSG(327)/'P312    '/,NUMSP(327)/'149 '/
C-----P321      (150)
      DATA ILSG(328)/'P321    '/,NUMSP(328)/'150 '/
C-----P3112     (151)  AND P3212
      DATA ILSG(329)/'P3112   '/,NUMSP(329)/'151 '/
C-----P31,212   (ASPECT 151)
      DATA ILSG(330)/'XXXXXXXX'/,NUMSP(330)/'151B'/
C-----P3121     (152)  AND P3221
      DATA ILSG(331)/'P3121   '/,NUMSP(331)/'152 '/
C-----P31,221   (ASPECT 152)
      DATA ILSG(332)/'XXXXXXXX'/,NUMSP(332)/'152B'/
C-----P3212     (153)   ASS. 151
      DATA ILSG(333)/'P3212   '/,NUMSP(333)/'153 '/
C-----P3221     (154)   ASS. 152
      DATA ILSG(334)/'P3221   '/,NUMSP(334)/'154 '/
C-----R32       (155)
      DATA ILSG(335)/'R32     '/,NUMSP(335)/'155 '/
C-----P3M1      (156)
      DATA ILSG(336)/'P3M1    '/,NUMSP(336)/'156 '/
C-----P31M      (157)
      DATA ILSG(337)/'P31M    '/,NUMSP(337)/'157 '/
C-----P3C1      (158)
      DATA ILSG(338)/'P3C1    '/,NUMSP(338)/'158 '/
C-----P31C      (159)
      DATA ILSG(339)/'P31C    '/,NUMSP(339)/'159 '/
C-----R3M       (160)
      DATA ILSG(340)/'R3M     '/,NUMSP(340)/'160 '/
C-----R3C       (161)
      DATA ILSG(341)/'R3C     '/,NUMSP(341)/'161 '/
C-----PBAR31M   (162)
      DATA ILSG(342)/'P-31M   '/,NUMSP(342)/'162 '/
C-----PBAR31C   (163)
      DATA ILSG(343)/'P-31C   '/,NUMSP(343)/'163 '/
C-----PBAR3M1   (164)
      DATA ILSG(344)/'P-3M1   '/,NUMSP(344)/'164 '/
C-----PBAR3C1   (165)
      DATA ILSG(345)/'P-3C1   '/,NUMSP(345)/'165 '/
C-----RBAR3M    (166)
      DATA ILSG(346)/'R-3M    '/,NUMSP(346)/'166 '/
C-----RBAR3C    (167)
      DATA ILSG(347)/'R-3C    '/,NUMSP(347)/'167 '/
C-----P6        (168)
      DATA ILSG(348)/'P6      '/,NUMSP(348)/'168 '/
C-----P61       (169)  AND P65
      DATA ILSG(349)/'P61     '/,NUMSP(349)/'169 '/
C-----P61,5     (ASPECT 169)
      DATA ILSG(350)/'XXXXXXXX'/,NUMSP(350)/'169B'/
C-----P65       (170)   ASS. 169
      DATA ILSG(351)/'P65     '/,NUMSP(351)/'170 '/
C-----P62       (171)  AND P64
      DATA ILSG(352)/'P62     '/,NUMSP(352)/'171 '/
C-----P62,4     (ASPECT 171)
      DATA ILSG(353)/'XXXXXXXX'/,NUMSP(353)/'171B'/
C-----P64       (172)   ASS. 171
      DATA ILSG(354)/'P64     '/,NUMSP(354)/'172 '/
C-----P63       (173)
      DATA ILSG(355)/'P63     '/,NUMSP(355)/'173 '/
C-----P-6       (174)
      DATA ILSG(356)/'P-6     '/,NUMSP(356)/'174 '/
C-----P6/M      (175)
      DATA ILSG(357)/'P6/M    '/,NUMSP(357)/'175 '/
C-----P63/M     (176)
      DATA ILSG(358)/'P63/M   '/,NUMSP(358)/'176 '/
C-----P622      (177)
      DATA ILSG(359)/'P622    '/,NUMSP(359)/'177 '/
C-----P6122     (178)  AND P6522
      DATA ILSG(360)/'P6122   '/,NUMSP(360)/'178 '/
C-----P61,522   (ASPECT 178)
      DATA ILSG(361)/'XXXXXXXX'/,NUMSP(361)/'178B'/
C-----P6522     (179)   ASS. 178
      DATA ILSG(362)/'P6522   '/,NUMSP(362)/'179 '/
C-----P6222     (180)  AND P6422
      DATA ILSG(363)/'P6222   '/,NUMSP(363)/'180 '/
C-----P62,422   (ASPECT 180)
      DATA ILSG(364)/'XXXXXXXX'/,NUMSP(364)/'180B'/
C-----P6422     (181)   ASS. 180
      DATA ILSG(365)/'P6422   '/,NUMSP(365)/'181 '/
C-----P6322     (182)
      DATA ILSG(366)/'P6322   '/,NUMSP(366)/'182 '/
C-----P6MM      (183)
      DATA ILSG(367)/'P6MM    '/,NUMSP(367)/'183 '/
C-----P6CC      (184)
      DATA ILSG(368)/'P6CC    '/,NUMSP(368)/'184 '/
C-----P63CM     (185)
      DATA ILSG(369)/'P63CM   '/,NUMSP(369)/'185 '/
C-----P63MC     (186)
      DATA ILSG(370)/'P63MC   '/,NUMSP(370)/'186 '/
C-----PBAR6M2   (187)
      DATA ILSG(371)/'P-6M2   '/,NUMSP(371)/'187 '/
C-----PBAR6C2   (188)
      DATA ILSG(372)/'P-6C2   '/,NUMSP(372)/'188 '/
C-----PBAR62M   (189)
      DATA ILSG(373)/'P-62M   '/,NUMSP(373)/'189 '/
C-----PBAR62C   (190)
      DATA ILSG(374)/'P-62C   '/,NUMSP(374)/'190 '/
C-----P6/MMM    (191)
      DATA ILSG(375)/'P6/MMM  '/,NUMSP(375)/'191 '/
C-----P6/MCC    (192)
      DATA ILSG(376)/'P6/MCC  '/,NUMSP(376)/'192 '/
C-----P63/MCM   (193)
      DATA ILSG(377)/'P63/MCM '/,NUMSP(377)/'193 '/
C-----P63/MMC   (194)
      DATA ILSG(378)/'P63/MMC '/,NUMSP(378)/'194 '/
C-----CUBIC STARTS HERE AT NUMBER 379
C-----P23       (195)
      DATA ILSG(379)/'P23     '/,NUMSP(379)/'195 '/
C-----F23       (196)
      DATA ILSG(380)/'F23     '/,NUMSP(380)/'196 '/
C-----I23       (197)
      DATA ILSG(381)/'I23     '/,NUMSP(381)/'197 '/
C-----P213      (198)
      DATA ILSG(382)/'P213    '/,NUMSP(382)/'198 '/
C-----I213      (199)
      DATA ILSG(383)/'I213    '/,NUMSP(383)/'199 '/
C-----PM3       (200)
      DATA ILSG(384)/'PM3     '/,NUMSP(384)/'200 '/
C-----PN3       (201)
      DATA ILSG(385)/'PN3     '/,NUMSP(385)/'201 '/
C-----FM3       (202)
      DATA ILSG(386)/'FM3     '/,NUMSP(386)/'202 '/
C-----FD3       (203)
      DATA ILSG(387)/'FD3     '/,NUMSP(387)/'203 '/
C-----IM3       (204)
      DATA ILSG(388)/'IM3     '/,NUMSP(388)/'204 '/
C-----PA3       (205)
      DATA ILSG(389)/'PA3     '/,NUMSP(389)/'205 '/
C-----IA3       (206)
      DATA ILSG(390)/'IA3     '/,NUMSP(390)/'206 '/
C-----P432      (207)
      DATA ILSG(391)/'P432    '/,NUMSP(391)/'207 '/
C-----P4232     (208)
      DATA ILSG(392)/'P4232   '/,NUMSP(392)/'208 '/
C-----F432      (209)
      DATA ILSG(393)/'F432    '/,NUMSP(393)/'209 '/
C-----F4132     (210)
      DATA ILSG(394)/'F4132   '/,NUMSP(394)/'210 '/
C-----I432      (211)
      DATA ILSG(395)/'I432    '/,NUMSP(395)/'211 '/
C-----P4332     (212)  AND P4132
      DATA ILSG(396)/'P4332   '/,NUMSP(396)/'212 '/
C-----P41,332   (ASPECT 212)
      DATA ILSG(397)/'XXXXXXXX'/,NUMSP(397)/'212B'/
C-----P4132     (213)   ASS. 212
      DATA ILSG(398)/'P4132   '/,NUMSP(398)/'213 '/
C-----I4132     (214)
      DATA ILSG(399)/'I4132   '/,NUMSP(399)/'214 '/
C-----PBAR43M   (215)
      DATA ILSG(400)/'P-43M   '/,NUMSP(400)/'215 '/
C-----FBAR43M   (216)
      DATA ILSG(401)/'F-43M   '/,NUMSP(401)/'216 '/
C-----IBAR43M   (217)
      DATA ILSG(402)/'I-43M   '/,NUMSP(402)/'217 '/
C-----PBAR43N   (218)
      DATA ILSG(403)/'P-43N   '/,NUMSP(403)/'218 '/
C-----FBAR43C   (219)
      DATA ILSG(404)/'F-43C   '/,NUMSP(404)/'219 '/
C-----IBAR43D   (220)
      DATA ILSG(405)/'I-43D   '/,NUMSP(405)/'220 '/
C-----PM3M      (221)
      DATA ILSG(406)/'PM3M    '/,NUMSP(406)/'221 '/
C-----PN3N      (222)
      DATA ILSG(407)/'PN3N    '/,NUMSP(407)/'222 '/
C-----PM3N      (223)
      DATA ILSG(408)/'PM3N    '/,NUMSP(408)/'223 '/
C-----PN3M      (224)
      DATA ILSG(409)/'PN3M    '/,NUMSP(409)/'224 '/
C-----FM3M      (225)
      DATA ILSG(410)/'FM3M    '/,NUMSP(410)/'225 '/
C-----FM3C      (226)
      DATA ILSG(411)/'FM3C    '/,NUMSP(411)/'226 '/
C-----FD3M      (227)
      DATA ILSG(412)/'FD3M    '/,NUMSP(412)/'227 '/
C-----FD3C      (228)
      DATA ILSG(413)/'FD3C    '/,NUMSP(413)/'228 '/
C-----IM3M      (229)
      DATA ILSG(414)/'IM3M    '/,NUMSP(414)/'229 '/
C-----IA3D      (230)
      DATA ILSG(415)/'IA3D    '/,NUMSP(415)/'230 '/
      DATA NUMSP(416)/'  0 '/
C-----ASPECT TABLE
C
C-----ANORTHIC (TRICLINIC) STARTS HERE AT ASPECT NUMBER 1
C-----P*,-1 (2) P-1, P1
      DATA IASP(1)/'P*,-1   '/  ,NUMAS(  1)/'  2 '/
C-----MONOCLINIC STARTS HERE AT ASPECT NUMBER 2
C-----P*/* (10) P2/M, P2, PM
      DATA IASP(2)/'P*/*    '/  ,NUMAS(  2)/' 10 '/
C-----P21/* (11) P21/M, P21
      DATA IASP(3)/'P21/*   '/  ,NUMAS(  3)/' 11 '/
C-----C*/* (12A) C2/M, C2, CM
      DATA IASP(4)/'C*/*    '/  ,NUMAS(  4)/' 12A'/
C-----A*/* (12B) A2/M, A2, AM
      DATA IASP(5)/'A*/*    '/  ,NUMAS(  5)/' 12B'/
C-----I*/* (12C) I2/M, I2, IM
      DATA IASP(6)/'I*/*    '/  ,NUMAS(  6)/' 12C'/
C-----P*/C (13A) P2/C, PC
      DATA IASP(7)/'P*/C    '/  ,NUMAS(  7)/' 13A'/
C-----P*/A (13B) P2/A, PA
      DATA IASP(8)/'P*/A    '/  ,NUMAS(  8)/' 13B'/
C-----P*/N (13C) P2/N, PN
      DATA IASP(9)/'P*/N    '/  ,NUMAS(  9)/' 13C'/
C-----C*/C (15A) C2/C, CC
      DATA IASP(10)/'C*/C    '/ ,NUMAS( 10)/' 15A'/
C-----A*/A (15B) A2/A, AA
      DATA IASP(11)/'A*/A    '/ ,NUMAS( 11)/' 15B'/
C-----I*/A (15C) I2/A, IA
      DATA IASP(12)/'I*/A    '/ ,NUMAS( 12)/' 15C'/
C-----ORTHORHOMBIC STARTS HERE AT ASPECT NUMBER 13
C-----P*** (47) PMMM, P222, PMM2, PM2M, P2MM
      DATA IASP(13)/'P***    '/ ,NUMAS( 13)/' 47 '/
C-----PCC* (49A) PCCM, PCC2
      DATA IASP(14)/'PCC*    '/ ,NUMAS( 14)/' 49A'/
C-----P*AA (49B) PMAA, P2AA
      DATA IASP(15)/'P*AA    '/ ,NUMAS( 15)/' 49B'/
C-----PB*B (49C) PBMB, PB2B
      DATA IASP(16)/'PB*B    '/ ,NUMAS( 16)/' 49C'/
C-----P**A (51A) PMMA, P21MA, PM2A
      DATA IASP(17)/'P**A    '/ ,NUMAS( 17)/' 51A'/
C-----P*C* (51B) PMCM, PMC21, P2CM
      DATA IASP(18)/'P*C*    '/ ,NUMAS( 18)/' 51B'/
C-----PC** (51C) PCMM, PCM21, PC2M
      DATA IASP(19)/'PC**    '/ ,NUMAS( 19)/' 51C'/
C-----P*A* (51D) PMAM, P21AM, PMA2
      DATA IASP(20)/'P*A*    '/ ,NUMAS( 20)/' 51D'/
C-----PB** (51E) PBMM, PB21M, PBM2
      DATA IASP(21)/'PB**    '/ ,NUMAS( 21)/' 51E'/
C-----P**B (51F) PMMB, PM21B, P2MB
      DATA IASP(22)/'P**B    '/ ,NUMAS( 22)/' 51F'/
C-----P*NA (53A) PMNA, P2NA
      DATA IASP(23)/'P*NA    '/ ,NUMAS( 23)/' 53A'/
C-----PNC* (53B) PNCM, PNC2
      DATA IASP(24)/'PNC*    '/ ,NUMAS( 24)/' 53B'/
C-----PB*N (53C) PBMN, PB2N
      DATA IASP(25)/'PB*N    '/ ,NUMAS( 25)/' 53C'/
C-----P*AN (53D) PMAN, P2AN
      DATA IASP(26)/'P*AN    '/ ,NUMAS( 26)/' 53D'/
C-----PCN* (53E) PCNM, PCN2
      DATA IASP(27)/'PCN*    '/ ,NUMAS( 27)/' 53E'/
C-----PN*B (53F) PNMB, PN2B
      DATA IASP(28)/'PN*B    '/ ,NUMAS( 28)/' 53F'/
C-----PBA* (55A) PBAM, PBA2
      DATA IASP(29)/'PBA*    '/ ,NUMAS( 29)/' 55A'/
C-----PC*A (55B) PCMA, PC2A
      DATA IASP(30)/'PC*A    '/ ,NUMAS( 30)/' 55B'/
C-----P*CB (55C) PMCB, P2CB
      DATA IASP(31)/'P*CB    '/ ,NUMAS( 31)/' 55C'/
C-----PBC* (57A) PBCM, PBC21
      DATA IASP(32)/'PBC*    '/ ,NUMAS( 32)/' 57A'/
C-----PC*B (57B) PCMB, PC21B
      DATA IASP(33)/'PC*B    '/ ,NUMAS( 33)/' 57B'/
C-----PB*A (57C) PBMA, PB21A
      DATA IASP(34)/'PB*A    '/ ,NUMAS( 34)/' 57C'/
C-----PCA* (57D) PCAM, PCA21
      DATA IASP(35)/'PCA*    '/ ,NUMAS( 35)/' 57D'/
C-----P*AB (57E) PMAB, P21AB
      DATA IASP(36)/'P*AB    '/ ,NUMAS( 36)/' 57E'/
C-----P*CA (57F) PMCA, P21CA
      DATA IASP(37)/'P*CA    '/ ,NUMAS( 37)/' 57F'/
C-----PNN* (58A) PNNM, PNN2
      DATA IASP(38)/'PNN*    '/ ,NUMAS( 38)/' 58A'/
C-----PN*N (58B) PNMN, PN2N
      DATA IASP(39)/'PN*N    '/ ,NUMAS( 39)/' 58B'/
C-----P*NN (58C) PMNN, P2NN
      DATA IASP(40)/'P*NN    '/ ,NUMAS( 40)/' 58C'/
C-----P**N (59A) PMMN, PM21N, P21MN
      DATA IASP(41)/'P**N    '/ ,NUMAS( 41)/' 59A'/
C-----PN** (59B) PNMM, PNM21, PN21M
      DATA IASP(42)/'PN**    '/ ,NUMAS( 42)/' 59B'/
C-----P*N* (59C) PMNM, PMN21, P21NM
      DATA IASP(43)/'P*N*    '/ ,NUMAS( 43)/' 59C'/
C-----PN*A (62A) PNMA, PN21A
      DATA IASP(44)/'PN*A    '/ ,NUMAS( 44)/' 62A'/
C-----P*NB (62B) PMNB, P21NB
      DATA IASP(45)/'P*NB    '/ ,NUMAS( 45)/' 62B'/
C-----PBN* (62C) PBNM, PBN21
      DATA IASP(46)/'PBN*    '/ ,NUMAS( 46)/' 62C'/
C-----P*CN (62D) PMCN, P21CN
      DATA IASP(47)/'P*CN    '/ ,NUMAS( 47)/' 62D'/
C-----PC*N (62E) PCMN, PC21N
      DATA IASP(48)/'PC*N    '/ ,NUMAS( 48)/' 62E'/
C-----PNA* (62F) PNAM, PNA21
      DATA IASP(49)/'PNA*    '/ ,NUMAS( 49)/' 62F'/
C-----C*C* (63A) CMCM, CMC21, C2CM
      DATA IASP(50)/'C*C*    '/ ,NUMAS( 50)/' 63A'/
C-----BB** (63B) BBMM, BB21M, BBM2
      DATA IASP(51)/'BB**    '/ ,NUMAS( 51)/' 63B'/
C-----A*A* (63C) AMAM, A21AM, AMA2
      DATA IASP(52)/'A*A*    '/ ,NUMAS( 52)/' 63C'/
C-----A**A (63D) AMMA, A21MA, AM2A
      DATA IASP(53)/'A**A    '/ ,NUMAS( 53)/' 63D'/
C-----CC** (63E) CCMM, CCM21, CC2M
      DATA IASP(54)/'CC**    '/ ,NUMAS( 54)/' 63E'/
C-----B**B (63F) BMMB, BM21B, B2MB
      DATA IASP(55)/'B**B    '/ ,NUMAS( 55)/' 63F'/
C-----C*CA (64A) CMCA, C2CA
      DATA IASP(56)/'C*CA    '/ ,NUMAS( 56)/' 64A'/
C-----ABA* (64B) ABAM, ABA2
      DATA IASP(57)/'ABA*    '/ ,NUMAS( 57)/' 64B'/
C-----CC*A (64C) CCMA, CC2A
      DATA IASP(58)/'CC*A    '/ ,NUMAS( 58)/' 64C'/
C-----AB*A (64D) ABMA, AB2A
      DATA IASP(59)/'AB*A    '/ ,NUMAS( 59)/' 64D'/
C-----B*AB (64E) BMAB, B2AB
      DATA IASP(60)/'B*AB    '/ ,NUMAS( 60)/' 64E'/
C-----BBA* (64F) BBAM, BBA2
      DATA IASP(61)/'BBA*    '/ ,NUMAS( 61)/' 64F'/
C-----C*** (65A) CMMM, C222, CMM2, C2MM, CM2M
      DATA IASP(62)/'C***    '/ ,NUMAS( 62)/' 65A'/
C-----B*** (65B) BMMM, B222, BM2M, B2MM, BMM2
      DATA IASP(63)/'B***    '/ ,NUMAS( 63)/' 65B'/
C-----A*** (65C) AMMM, A222, A2MM, AMM2, AM2M
      DATA IASP(64)/'A***    '/ ,NUMAS( 64)/' 65C'/
C-----CCC* (66A) CCCM, CCC2
      DATA IASP(65)/'CCC*    '/ ,NUMAS( 65)/' 66A'/
C-----A*AA (66B) AMAA, A2AA
      DATA IASP(66)/'A*AA    '/ ,NUMAS( 66)/' 66B'/
C-----BB*B (66C) BBMB, BB2B
      DATA IASP(67)/'BB*B    '/ ,NUMAS( 67)/' 66C'/
C-----C**A (67A) CMMA, C2MA, CM2A
      DATA IASP(68)/'C**A    '/ ,NUMAS( 68)/' 67A'/
C-----AB** (67B) ABMM, ABM2, AB2M
      DATA IASP(69)/'AB**    '/ ,NUMAS( 69)/' 67B'/
C-----B*A* (67C) BMAM, BMA2, B2AM
      DATA IASP(70)/'B*A*    '/ ,NUMAS( 70)/' 67C'/
C-----F*** (69) FMMM, F222, FMM2, FM2M, F2MM
      DATA IASP(71)/'F***    '/ ,NUMAS( 71)/' 69 '/
C-----I*** (71) IMMM, I212121, IMM2, IM2M, I2MM
      DATA IASP(72)/'I***    '/ ,NUMAS( 72)/' 71 '/
C-----IBA* (72A) IBAM, IBA2
      DATA IASP(73)/'IBA*    '/ ,NUMAS( 73)/' 72A'/
C-----I*AA (72B) IMAA, I2AA
      DATA IASP(74)/'I*AA    '/ ,NUMAS( 74)/' 72B'/
C-----IB*A (72C) IBMA, IB2A
      DATA IASP(75)/'IB*A    '/ ,NUMAS( 75)/' 72C'/
C-----I**A (74A) IMMA, IM2A, I2MA
      DATA IASP(76)/'I**A    '/ ,NUMAS( 76)/' 74A'/
C-----IB** (74B) IBMM, IBM2, IB2M
      DATA IASP(77)/'IB**    '/ ,NUMAS( 77)/' 74B'/
C-----I*A* (74C) IMAM, IMA2, I2AM
      DATA IASP(78)/'I*A*    '/ ,NUMAS( 78)/' 74C'/
C-----TETRAGONAL STARTS HERE AT ASPECT NUMBER 79
C-----P41,3 (76) P41, P43
      DATA IASP(79)/'P41,3   '/ ,NUMAS( 79)/' 76 '/
C-----P4/* (83) P4/M, P4, P-4
      DATA IASP(80)/'P4/*    '/ ,NUMAS( 80)/' 83 '/
C-----P42/* (84) P42/M, P42
      DATA IASP(81)/'P42/*   '/ ,NUMAS( 81)/' 84 '/
C-----I4/* (87) I4/M, I4, I-4
      DATA IASP(82)/'I4/*    '/ ,NUMAS( 82)/' 87 '/
C-----P41,322 (91) P4122, P4322
      DATA IASP(83)/'P41,322 '/ ,NUMAS( 83)/' 91 '/
C-----P41,3212 (92) P41212, P43212
      DATA IASP(84)/'P41,3212'/ ,NUMAS( 84)/' 92 '/
C-----P421* (113) P-421M, P4212
      DATA IASP(85)/'P421*   '/ ,NUMAS( 85)/'113 '/
C-----I4*D (122) I-42D, I41MD
      DATA IASP(86)/'I4*D    '/ ,NUMAS( 86)/'122 '/
C-----P4/*** (123) P4/MMM, P422, P4MM, P-42M, P-4M2
      DATA IASP(87)/'P4/***  '/ ,NUMAS( 87)/'123 '/
C-----P4/*CC (124) P4/MCC, P4CC
      DATA IASP(88)/'P4/*CC  '/ ,NUMAS( 88)/'124 '/
C-----P4/*B* (127) P4/MBM, P4BM, P-4B2
      DATA IASP(89)/'P4/*B*  '/ ,NUMAS( 89)/'127 '/
C-----P4/*NC (128) P4/MNC, P4NC
      DATA IASP(90)/'P4/*NC  '/ ,NUMAS( 90)/'128 '/
C-----P4/**C (131) P42/MMC, P42MC, P-42C
      DATA IASP(91)/'P4/**C  '/ ,NUMAS( 91)/'131 '/
C-----P4/*C* (132) P42/MCM, P42CM, P-4C2
      DATA IASP(92)/'P4/*C*  '/ ,NUMAS( 92)/'132 '/
C-----P4/*BC (135) P42/MBC, P42BC
      DATA IASP(93)/'P4/*BC  '/ ,NUMAS( 93)/'135 '/
C-----P4/*N* (136) P42/MNM, P42NM, P-4N2
      DATA IASP(94)/'P4/*N*  '/ ,NUMAS( 94)/'136 '/
C-----I4/*** (139) I4/MMM, I422, I4MM, I-4M2, I-42M
      DATA IASP(95)/'I4/***  '/ ,NUMAS( 95)/'139 '/
C-----I4/*C* (140) I4/MCM, I4CM, I-4C2
      DATA IASP(96)/'I4/*C*  '/ ,NUMAS( 96)/'140 '/
C-----HEXAGONAL STARTS HERE AT ASPECT NUMBER 97
C-----P31,2 (144) P31, P32
      DATA IASP(97)/'P31,2   '/ ,NUMAS( 97)/'144 '/
C-----P*,-3 (147) P-3, P3
      DATA IASP(98)/'P*,-3   '/ ,NUMAS( 98)/'147 '/
C-----R* (148) R-3, R3
      DATA IASP(99)/'R*      '/ ,NUMAS( 99)/'148 '/
C-----P31,212 (151) P3112, P3212
      DATA IASP(100)/'P31,212 '/,NUMAS(100)/'151 '/
C-----P31,221 (152) P3121, P3221
      DATA IASP(101)/'P31,221 '/,NUMAS(101)/'152 '/
C-----P31* (162) P-31M, P312, P31M
      DATA IASP(102)/'P31*    '/,NUMAS(102)/'162 '/
C-----P*1C,-3M (163) P-31C, P31C
      DATA IASP(103)/'P*1C,-3M'/,NUMAS(103)/'163 '/
C-----P3*1 (164) P-3M1, P321, P3M1
      DATA IASP(104)/'P3*1    '/,NUMAS(104)/'164 '/
C-----P*C1,-3M (165) P-3C1, P3C1
      DATA IASP(105)/'P*C1,-3M'/,NUMAS(105)/'165 '/
C-----R** (166) R-3M, R32, R3M
      DATA IASP(106)/'R**     '/,NUMAS(106)/'166 '/
C-----R*C (167) R-3C, R3C
      DATA IASP(107)/'R*C     '/,NUMAS(107)/'167 '/
C-----P61,5 (169) P61, P65
      DATA IASP(108)/'P61,5   '/,NUMAS(108)/'169 '/
C-----P62,4 (171) P62, P64
      DATA IASP(109)/'P62,4   '/,NUMAS(109)/'171 '/
C-----P6/* (175) P6/M, P6, P-6
      DATA IASP(110)/'P6/*    '/,NUMAS(110)/'175 '/
C-----P63/* (176) P63/M, P63
      DATA IASP(111)/'P63/*   '/,NUMAS(111)/'176 '/
C-----P61,522 (178) P6122, P6522
      DATA IASP(112)/'P61,522 '/,NUMAS(112)/'178 '/
C-----P62,422 (180) P6222, P6422
      DATA IASP(113)/'P62,422 '/,NUMAS(113)/'180 '/
C-----P6/*** (191) P6/MMM, P622, P6MM, P-6M2, P-62M
      DATA IASP(114)/'P6/***  '/,NUMAS(114)/'191 '/
C-----P6/*CC (192) P6/MCC, P6CC
      DATA IASP(115)/'P6/*CC  '/,NUMAS(115)/'192 '/
C-----P6/*C* (193) P63/MCM, P63CM, P-6C2
      DATA IASP(116)/'P6/*C*  '/,NUMAS(116)/'193 '/
C-----P6/**C (194) P63/MMC, P63MC, P-62C
      DATA IASP(117)/'P6/**C  '/,NUMAS(117)/'194 '/
C-----CUBIC STARTS HERE AT ASPECT NUMBER 118
C-----P*3 (200) PM3, P23
      DATA IASP(118)/'P*3     '/,NUMAS(118)/'200 '/
C-----F*3 (202) FM3, F23
      DATA IASP(119)/'F*3     '/,NUMAS(119)/'202 '/
C-----I*3 (204) IM3, I23, I213
      DATA IASP(120)/'I*3     '/,NUMAS(120)/'204 '/
C-----P41,332 (212) P4332, P4132
      DATA IASP(121)/'P41,332 '/,NUMAS(121)/'212 '/
C-----P*3* (221) PM3M, P432, P-43M
      DATA IASP(122)/'P*3*    '/,NUMAS(122)/'221 '/
C-----P*3N (223) PM3N, P-43N
      DATA IASP(123)/'P*3N    '/,NUMAS(123)/'223 '/
C-----F*3* (225) FM3M, F432, F-43M
      DATA IASP(124)/'F*3*    '/,NUMAS(124)/'225 '/
C-----F*3C (226) FM3C, F-43C
      DATA IASP(125)/'F*3C    '/,NUMAS(125)/'226 '/
C-----I*3* (229) IM3M, I432, I-43M
      DATA IASP(126)/'I*3*    '/,NUMAS(126)/'229 '/
C
C-----ALSO ACCEPT THE FOUR ASPECTS WITHOUT LAUE SYMMETRY
C-----P*,-1 (2)    ACCEPT P*
      DATA IASP(127)/'P*      '/,NUMAS(127)/'  2 '/
C-----P*,-3 (147)    ACCEPT P*
      DATA IASP(128)/'P*      '/,NUMAS(128)/'147 '/
C-----P*1C,-3M (163)    ACCEPT P*1C
      DATA IASP(129)/'P*1C    '/,NUMAS(129)/'163 '/
C-----P*C1,-3M (165)    ACCEPT P*C1
      DATA IASP(130)/'P*C1    '/,NUMAS(130)/'165 '/
      DATA IASPEC(1)/' '/, IASPEC(2)/'*'/
C-----BEGINING
 10   IOK=0
      IMATCH=0
      NASPEC=1
C
C-----TEST ICRS TO DETERMINE WHICH CRYSTAL SYSTEM
C
      IF(ICRS.EQ.ITCRS(1)) GO TO 100
      IF(ICRS.EQ.ITCRS(2)) GO TO 200
      IF(ICRS.EQ.ITCRS(3)) GO TO 300
      IF(ICRS.EQ.ITCRS(4)) GO TO 400
      IF(ICRS.EQ.ITCRS(5)) GO TO 500
      IF(ICRS.EQ.ITCRS(6)) GO TO 500
      IF(ICRS.EQ.ITCRS(7)) GO TO 600
      GO TO 700
C-----ANORTHIC REGION
 100  DO 110  I= 1,2
      IF(SPGR.NE.ILSG(I))  GO TO 110
      IOK=1
      IMATCH=I
      GO TO 120
 110  CONTINUE
      IF(SPGR.NE.IASP(1).AND.SPGR.NE.IASP(127)) GO TO 120
      IOK=1
      IMATCH=1
      IF(SPGR.EQ.IASP(127)) IMATCH=127
      NASPEC=2 
 120  CONTINUE
      GO TO 700
C-----MONOCLINIC REGION
C-----DO NOT ASSIGN NUMBER IF A-CENTERED, A-UNIQUE ETC
 200  IF(IPASS.EQ.1.AND.SPGR(1:1).EQ.ITSG(2).AND.IFA.EQ.0)GO TO 700
      IF(IPASS.EQ.1.AND.SPGR(1:1).EQ.ITSG(3).AND.IFB.EQ.0)GO TO 700
      IF(IPASS.EQ.1.AND.SPGR(1:1).EQ.ITSG(4).AND.IFC.EQ.0)GO TO 700
      DO 210  I=3,31
      IF(SPGR.NE.ILSG(I)) GO TO 210
      IOK=1
      IMATCH=I
      GO TO 230
 210  CONTINUE
      DO 220 I=2,12
      IF(SPGR.NE.IASP(I)) GO TO 220
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 230
 220  CONTINUE 
 230  CONTINUE 
      GO TO 700
C-----ORTHORHOMBIC REGION
 300  DO 310  I=32,248
      IF(SPGR.NE.ILSG(I))  GO TO 310
      IOK=1
      IMATCH=I
      GO TO 330
 310  CONTINUE
      DO 320 I=13,78
      IF(SPGR.NE.IASP(I)) GO TO 320
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 330
 320  CONTINUE
 330  CONTINUE
      GO TO 700
C-----TETRAGONAL REGION
 400  DO 410 I=249,319
      IF(SPGR.NE.ILSG(I))  GO TO 410
      IOK=1
      IMATCH=I
      GO TO 430
 410  CONTINUE
      DO 420 I=79,96
      IF(SPGR.NE.IASP(I)) GO TO 420
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 430
 420  CONTINUE
 430  CONTINUE
      GO TO 700
C-----HEXAGONAL AND RHOMBOHEDRAL REGION
 500  DO 510  I=320,378
      IF(SPGR.NE.ILSG(I))  GO TO 510
      IOK=1
      IMATCH=I
      GO TO 530
 510  CONTINUE
      DO 520 I=97,117
      IF(SPGR.NE.IASP(I)) GO TO 520
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 530
 520  CONTINUE
      DO 525 I=128,130
      IF(SPGR.NE.IASP(I)) GO TO 525
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 530
 525  CONTINUE 
 530  CONTINUE
      GO TO 700
C-----CUBIC REGION
 600  DO 610  I=379,415
      IF(SPGR.NE.ILSG(I))  GO TO 610
      IOK=1
      IMATCH=I
      GO TO 630
610   CONTINUE
      DO 620 I=118,126
      IF(SPGR.NE.IASP(I)) GO TO 620
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 630
 620  CONTINUE
 630  CONTINUE
C
C-----WAS SPGR# FOUND?
C
 700  IF(IOK.EQ.1) GOTO 800
      IMATCH=416
C
C-----ASSIGN THE SPACE GROUP NUMBER AND ASPECT CODE
C
 800  SPGRA=IASPEC(NASPEC)
      IF(NASPEC.EQ.1) GO TO 810
      SPGRN=NUMAS(IMATCH)
      GO TO 820
 810  SPGRN=NUMSP(IMATCH)
 820  CONTINUE
 999  RETURN
      END
      SUBROUTINE SRMTCH(IPKSQ,IHP,IGP,NH)
C      ############################################################
C      #                                                          #
C      #                          SRMTCH                          #
C      #                                                          #
C      ############################################################
C
C SEARCH AND MATCH ANY PEAK FROM THE PKS FILE
C THAT IS NOT INCLUDED IN THE LEAST SQUARES.
C
      PARAMETER (MAXPKS=300)
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
          DIMENSION NH(3)
      CHARACTER*6 NPFLG
C
C-----------------
C
      IF(IGP.GT. NPKS)GOTO 300
      IF(IPKSQ.EQ.1)  GOTO 220
      IPKSQ=NPKSQ(IGP-1)
 220  CALL PMATCH(IPKSQ,LP,DL)
      IF(LP .LT. 1)  GOTO 300
      WRITE(NTOUT,1100) IHP, D, (NH(L),L=1,3), THCMP,LP
 1100 FORMAT(1H ,I3,F8.4,25X,3I3, 9X,F9.3, 11X,'**',I4)
C       WRITE(NTOUT,1100) IHP, D, (NH(L),L=1,3), THCMP,LP,PKPRM(3,LP)
C     *,PKPRM(4,LP),NPFLG(LP),PKPRM(1,LP),PKPRM(2,LP),DL
C 1100 FORMAT(1H ,I3,F8.4,26X,3I4, 9X,F9.3, 11X,'**',I5,F8.1
C     *,F6.1,2X,A6,F9.3,F8.3,F6.3)
      GOTO 999
 300  WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
 30   FORMAT(1H ,I3,F8.4,25X,3I3, 9X,F9.3)
C 30   FORMAT(1H ,I3,F8.4,26X,3I4, 9X,F9.3)
C
 999  RETURN
      END
      FUNCTION THETA(C,D)
C      ############################################################
C      #                                                          #
C      #                          THETA                           #
C      #                                                          #
C      ############################################################
C COMPUTES ARCSIN(C/D) PROVIDED C.LE.D. ELSE THETA SET TO 90.00
      FAC=D*D-C*C
      IF (FAC.GE.0.0 .AND. (D*D+C*C) .GT. 0.0) GO TO 7
      FAC=90.0
      GO TO 8
 7    FAC=57.29578*ATAN2(C,SQRT(FAC))
 8    THETA=FAC
      RETURN
      END
      SUBROUTINE TSTHKL(ITYP,IH,JH,IEQL)
C      ############################################################
C      #                                                          #
C      #                          TSTHKL                          #
C      #                                                          #
C      ############################################################
C
C TESTS FOR EXACT EQUALITY OF D-SPACINGS FOR TWO REFLECTIONS
C
C RETURNS IEQL   = 1 FOR EQUIVALENT HKL'S
C                = 0 FOR NOT EQUIVALENT HKL'S
C
C USES TEMPORARY HKL ARRAYS IHTM(3) AND JHTM(3) FOR IH(3) AND JH(3)
C TO AVOID MODIFICATIONS TO THE INPUT HKL VALUES.
C
C ITYP IS SET UP BY SUBROUTINE PRMCHK
C
      COMMON/IERRS/IWARN,IERR
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/UNQ/IFA,IFB,IFC,IRH
      DIMENSION IH(3),JH(3),ITEST(6,7),IHKLC(6,10),IHTM(3),JHTM(3)
      DATA ITEST/8,5*0, 3,7,4*0, 1,2,3,3*0, 1,2,3,6,0,0, 3,10,4*0,
     *           1,2,3,4,5,6, 8,9,4*0/,
     * IHKLC/2*1,4*0, 2,2,4*0, 3,3,4*0, 1,2,4*0, 2,3,4*0, 3,1,4*0,
     *       3*1,3*2, 1,1,2,2,3,3, 1,2,2,3,3,1, 1,1,2,2,0,0/
C
C-----MOVE IH AND JH TO IHTM AND JHTM
C
      DO 10 I = 1,3
      IHTM(I) = IH(I)
      JHTM(I) = JH(I)
 10   CONTINUE
C
C-----SWITCH TEMPORARY INDICIES IH AND JH TO B-UNIQUE SETTING FOR TEST
C     ONLY IF MONOCLINIC
C
      IF(ITYP.NE.4 .OR. IFB.EQ.0) GO TO 100
C
C-----IS IT C-UNIQUE
C
      IF(IFC.NE.0) GO TO 20
      IS   = IHTM(3)
      IHTM(3)= IHTM(2)
      IHTM(2)= IS
      IS   = JHTM(3)
      JHTM(3)= JHTM(2)
      JHTM(2)= IS
      GO TO 100
C-----BE SURE IT IS A-UNIQUE
 20   IF(IFA.NE.0) GO TO 60
      IS   = IHTM(2)
      IHTM(2)= IHTM(1)
      IHTM(1)= IS
      IS   = JHTM(2)
      JHTM(2)= JHTM(1)
      JHTM(1)=IS
      GO TO 100
C
C-----PROGRAM BUG. SHOULD NOT REACH HERE IF IFA,IFB,IFC,ITYP ARE PROPERLY SET
C
 60   IF (NTOUT .EQ. 12) THEN
          WRITE(*,61)
      ENDIF
      WRITE(NTOUT,61)
      IERR = IERR + 1
 61   FORMAT('0','**ERROR**IN SUBROUTINE TSTHKL - IFA,IFB,IFC,ITYP',
     * ' ARE INCONSISTENT**ERROR**')
      NR=0
      RETURN
C
C-----BEGIN THE TEST FOR EQUIVALENT HKL VALUES
C
 100  DO 130 I=1,6
      INTRY=ITEST(I,ITYP)
      IF (INTRY.LT.1.OR.INTRY.GT.10) GO TO 132
      ISUM=0
      J=1
 105  K=IHKLC(J,INTRY)
      IF (K.LT.1.OR.K.GT.3) GO TO 120
      L=IHKLC(J+1,INTRY)
      ISUM=ISUM+IHTM(K)*IHTM(L)-JHTM(K)*JHTM(L)
      J=J+2
      IF (J.LT.6) GO TO 105
 120  IF (ISUM.EQ.0) GO TO 130
      IEQL=1
      GO TO 134
 130  CONTINUE
 132  IEQL=0
 134  RETURN
      END
      SUBROUTINE UPDPKS
C      ############################################################
C      #                                                          #
C      #                          UPDPKS                          #
C      #                                                          #
C      ############################################################
C
C    UPDATE FILE PKS  FOR THE LSQ90 PROGRAM
C   UPDATE ONLY UNIT CELL AND HKL IF SO REQUESTED BY USER
C
      PARAMETER (MAXOBS=200, MAXPKS=300)
      COMMON/IO/NTOUT,NTIN,NTEXT,IOPKS,IOSCR
      COMMON/CBLKG/IHEAD
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ,NOINDX
      COMMON/REALNO/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(MAXOBS),DSP(MAXOBS),IH(MAXOBS,3),PWL,
     * NUMOBS,INTN(MAXOBS)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/CPPDAT/ IHED(MAXOBS),INTED(MAXOBS),HKLED
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(6,6),FACTR
C-------------------------------------------------------------
C  PEAK FILE PARAMETERS
C
      COMMON/PEAKS/NPKS,NPKMX,PKPRM(4,MAXPKS),NPKSQ(MAXPKS)
      COMMON/CPEAKS/NPFLG(MAXPKS)
      COMMON/PKFIL/NAME,CRSYS,TMTMMX,TMTMMN
      COMMON/REFPRM/NRGRF,NRCPP,NRCBER,NRCGRP,NRGNT,IREV
      COMMON/TEMPRT/NTMMS,AVTMP,SDTMPR,TMPRMX,TMPRMN
      CHARACTER*4 TMTMMX,TMTMMN
      CHARACTER*1 CRSYS
      CHARACTER*40 NAME
      CHARACTER*6 NPFLG
	CHARACTER*80 SAME
C
C  END OF PEAK FILE PARAMETRS.
C-------------------------------------------------------------
      CHARACTER*80 IHEAD,RCRD, BLANK
      CHARACTER*1 SPGIA,ICRS,ANSW
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 IHED,INTED,HKLED
	INTEGER UPPKS
C
          DIMENSION  IHKL(3),TEMP(3)
C
C------------------------------------------------------------
C
      IER = 0
C  UPDATE FILE ?
 200  WRITE(*, 1010 )
 1010 FORMAT(/,' DO YOU WANT TO UPDATE THE PKN FILE?  Y/N ')
          READ(*,1012 ) ANSW
 1012 FORMAT(A1)
          IF (ANSW .EQ. 'N') GOTO 999
          IF (ANSW .EQ. 'Y') GOTO  201
          GOTO 200
 201  IF (IREV .EQ. 0) GOTO 960
 202  WRITE(*, 1014)
 1014 FORMAT(/,' UPDATE THE CELL CONSTANTS?  Y/N ')
      READ(*,1012) ANSW
		IUPCL=0
          IF(ANSW.EQ.'Y') GOTO 203
          IF(ANSW.EQ.'N') GOTO 204
          GOTO 202
 203  IUPCL=1
 204  WRITE(*,1016)
 1016 FORMAT(/,' UPDATE THE  HKL''S?  Y/N ')
          READ(*,1012 ) ANSW
          IUPHK=0
          IF(ANSW.EQ.'Y') GOTO 205
          IF(ANSW.EQ.'N') GOTO 206
          GOTO 204
 205  IUPHK=1
C
C     OPEN SCRATCH FILE
C
C     *************************************************************
C
C     THIS MAY BE MACHINE SPECIFIC.  A SCRATCH FILE NEEDS TO BE
C     ATTACHED TO THE RUN ON UNIT 21.
C
 206  OPEN(IOSCR,IOSTAT=IS,STATUS='SCRATCH',ACCESS=
     * 'SEQUENTIAL',FORM='FORMATTED')
C
      IF(IS.EQ.0) GOTO 210
      WRITE(*,1045) IS
 1045 FORMAT(1H0,'**FILE ASSIGNMENT ERROR ',I4,' FOR SCR FILE')
      GOTO 970
C
C     *************************************************************
C
 210  REWIND IOPKS
C
C          ---- COPY TO SCRATCH 11 TO EOF ----
C
C SKIP THE FIRST 12 RECORDS
C
      DO 220 I=1,12
      	READ (IOPKS,1020)
 1020 FORMAT(A80)
 220  CONTINUE
C COPY RECORDS 13 TO 25 TO SCRATCH
      DO 224 I = 13, 25
      	READ (IOPKS,1020) RCRD
      	WRITE(IOSCR,1020) RCRD
 224  CONTINUE
C
C COPY THE NRGRF RECORDS TO SCRATCH
      DO 225 I=1,NRGRF
      	READ (IOPKS,1020) RCRD
      	WRITE(IOSCR,1020) RCRD
 225  CONTINUE
C  COPY THE REST TO SCRATCH FILE
C
      DO 230 I=1,NPKS
      READ (IOPKS,1020) RCRD
      WRITE(IOSCR,1020) RCRD
          DO 229 J=1,NRCPP
      READ (IOPKS,1020) RCRD
      WRITE(IOSCR,1020) RCRD
 229  CONTINUE
 230  CONTINUE
C
      DO 235 I=1,10
      READ (IOPKS,1020) RCRD
      WRITE(IOSCR,1020) RCRD
 235  CONTINUE
C
C     END OF COPY FILE TO SCRATCH
C
      REWIND IOPKS
      REWIND IOSCR
	UPPKS = 35
C
C OPEN NEW VERSION FOR PEAK UPDATES
C
	OPEN(UPPKS, FILE = NAME, STATUS = 'NEW', ERR = 9800)
	GOTO 9799
 9800 PRINT*, ' UNABLE TO OPEN THE UPDATED PEAKS FILE.'
	GOTO 999
C
C SKIP 12 REC ON IOPKS, BUT COPY THEM TO THE UPDATE FILE
C
 9799 DO 240 I = 1, 12
      	READ(IOPKS, 1020) SAME
		WRITE(UPPKS, 1020) SAME
 240  CONTINUE
C
      IF (IUPCL .EQ. 1) THEN
C
C WRITE RECORD 13 CELL CONSTANTS
C
      DO 242 I = 1, 3, 1
 242  	TEMP(I) = (ALS(I))/60.0
      	READ (IOSCR,1020) RCRD
          WRITE(UPPKS,1022) (AD(I),I=1,3),(TEMP(I),I=1,3),RCRD(52:80)
 1022 	FORMAT(3F9.5,3F8.3,A29)
C
C                 RECORD 14, CELL STANDARD DEVIATION
C
          READ (IOSCR,1020) RCRD
          WRITE(UPPKS,1022) (SEDCE(I),I=1,6),RCRD(52:80)
          NCP=15
      ELSE
          NCP=13
      END IF
C         COPY RECORDS 13 OR 15 TO 25
          DO 245 I=NCP,25
          	READ(IOSCR,1020) RCRD
          	WRITE(UPPKS,1020)RCRD
 245  	CONTINUE
C
          DO 250 I=1,NRGRF
          	READ(IOSCR,1020) RCRD
          	WRITE(UPPKS,1020) RCRD
 250  	CONTINUE
C         COPY THE PEAKS
          IUSD=1
          NXUS=NPKSQ(IUSD)
          DO 270 I=1,NPKS
C
      		READ (IOSCR,1020) RCRD
          	IF( IUPHK .EQ. 0) GOTO 255
        		IF( I .EQ. NXUS ) THEN
      			IF(IHED(IUSD) .EQ. ' ' .OR. IHED(IUSD).EQ.'C'
     * .OR. IHED(IUSD).EQ.'M' .OR. IHED(IUSD).EQ.'+') THEN
          RCRD(71:71)=IHED(IUSD)
          IHKL(1)=IH(IUSD,1)
          IHKL(2)=IH(IUSD,2)
          IHKL(3)=IH(IUSD,3)
         ELSE
          RCRD(71:71)=' '
          IHKL(1)=0
          IHKL(2)=0
          IHKL(3)=0
         END IF
          IUSD=IUSD+1
          NXUS=NPKSQ(IUSD)
        ELSE
          RCRD(71:71)=' '
          IHKL(1)=0
          IHKL(2)=0
          IHKL(3)=0
        END IF
      WRITE(UPPKS,1040)  RCRD(1:71),IHKL
 1040 FORMAT(A71,3I3 )
          GOTO 258
 255  WRITE(UPPKS,1020) RCRD
 258     DO 260 J=1,NRCPP
      READ (IOSCR,1020) RCRD
      WRITE(UPPKS,1020) RCRD
 260  CONTINUE
 270  CONTINUE
C
 280  DO 290 I=1,10
      READ (IOSCR,1020) RCRD
      WRITE(UPPKS,1020) RCRD
 290  CONTINUE
C
      GOTO 999
 960  WRITE(*,1310)
 1310 FORMAT(/,'  *** OLD FILE STRUCTURE. NO UPDATING',/,
     *' USE EDTPKS TO CONVERT TO NEW STRUCTURE ***')
      GOTO 999
C
 970  WRITE(*,1110) IS
 1110 FORMAT(' ERROR IN OPENING THE SCRATCH FILE ,IOS=',I5)
      IER = 1
 999	CLOSE(UNIT = UPPKS)
C
      RETURN
      END
