**==aa0001.f  
C LAST UPDATE 1/3/91
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C******************************
C**    Program 'newlaue'     **
C******************************
C
C The program 'newlaue' is used to calculate and display simulated
C Laue diffraction patterns. It now forms part of the Daresbury Laboratory
C Laue software suite.
C
C It is based on M. Elder's LGEN program written for the PERQ computer.
C A large amount of development was carried out by E. Pantos and
C T Jhahjadi who prepared a version 'LAUE' for the srslib program
C library. This version has been further developed by I. Clifton and
C J. Campbell.
C
C====== GLOBALS:
C
      INCLUDE 'implicit_none.finc'
      INCLUDE 'pgstat.finc'
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'xysav.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'data.finc'
C
      COMMON/AMAT/ A(3,3),AMATX(3,3)
      REAL         A     ,AMATX
      COMMON/SPOTS/ NR
      INTEGER       NR
C
      COMMON /STDONE/ STDONE
      LOGICAL STDONE
C
      EXTERNAL BD,GENBD,UPDATA
C
      INTEGER LUNSTO, LUNSTI
C
C====== LOCALS:
C
      INTEGER I, ITTYP
      CHARACTER*20 TRM
C
C-------------------------------------------------------------------------------
C
C====== Initialize program global parameters
C
      DEVICE = 'FULL    '
      SQLEN = 1.0
      OVERLAY = .FALSE.
      ISWIT = 0
      EREPLOT = .FALSE.
      STDONE = .FALSE.
      CALL TRWSET(LUNSTI(0),LUNSTO(0),0,0,0)
C
C====== Cell parameters to silly values to show which are changed
C
      DO 20 I = 1 , 6
         CELL(I) = 0.0
 20   CONTINUE
C
C====== Matrix to zero. MSYS=system, MROT=rotation axis, MBEAM=beam axis
C====== lattice type = blank
C
      MSYS = 0
      MROT = 0
      MBEAM = 0
      LATT = ' '
      ISYS = 0
      KSYS(1) = 0
      KSYS(2) = 0
      KSYS(3) = 0
C
C====== Geometry to 0.0
C
      PHIS(1) = 0.0
      PHIS(2) = 0.0
      PHIS(3) = 0.0
      WVM = 0.0
      WVX = 0.0
      CTOF = 0.0
      WVS = 1.0
C
C====== Default spindle setting to 0.0, dmin to 1.1, radius to 50 mm.
C
      SPNDLE = 0.
      DMIN = 1.1
      RADI = 50.
      RADI2 = RADI*RADI
      LIMIT = INDPRM
C
C====== Initialize graphics and vdu
C
      ITTYP = 0
      CALL UGTENV('TERM',TRM)
      IF (TRM(1:5).EQ.'xterm') ITTYP = 1
      CALL QGINIT(20,6,ITTYP,LUNSTI(0),LUNSTO(0))
      CALL QSCLRA
      CALL QSSCRL(1,24)
C
C====== Get in main control code
C
      CALL SCREEN
C
C====== Close graphics and reset screen
C
      CALL QGENTR
      CALL QGCLR
      CALL QGALPH
      CALL QSCLRA
      CALL QSSCRL(1,24)
      STOP
      END
**==bd.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**    Block data       **
C*************************
C
      BLOCK DATA BD
C
      INCLUDE 'systyp.finc'
C
      DATA MSYST/'   ','TRI','MON','ORT','TET','HEX','ROM','CUB'/
      DATA MAXIS/'-c*','-b*','-a*','   ','+a*','+b*','+c*'/
C
      END
**==acalc.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ACALC         **
C*************************
C
C
        SUBROUTINE ACALC
C
C Purpose: Calculate the master matrix, a, from the orientation matrix
C          premultiplied by the phi matrices. Code from IDXREF.
C
        COMMON/DATA/ CELL(6),WVM,WVX,WVS,CF,PHIS(3),SPNDLE,CCELL(6),
     *               NUMA,NUMC,DMIN
C
C====== GLOBALS:
C
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
C
      COMMON/AMAT/ A(3,3),AA(3,3)
C
C====== LOCALS:
C
      DIMENSION CX(3,3),CY(3,3),CZ(3,3),C(3,3),PC(3,3)
      DIMENSION AC1(3,3),AC2(3,3),AC3(3,3),AC4(3,3)
      DIMENSION AC5(3,3),AC6(3,3)
C
C-------------------------------------------------------------------------------
C
C====== Pass the packed cell parameters in ccell to the mats routine of IDX
C====== The AC arrays hold the (unnecessary) derivative matrices.
C
      CALL CLEAR(AA)
      CALL MATS(AA,AC1,AC2,AC3,AC4,AC5,AC6,CCELL)
C
C====== Define all rotation matrices
C
      RAPI = 3.1415926536/180.
      CPX = COS(PHIS(1)*RAPI)
      SPX = SIN(PHIS(1)*RAPI)
      CPY = COS(PHIS(2)*RAPI)
      SPY = SIN(PHIS(2)*RAPI)
      CPZ = COS(PHIS(3)*RAPI)
      SPZ = SIN(PHIS(3)*RAPI)
C
      CALL CLEAR(CX)
      CX(1,1) = 1.0
      CX(2,2) = CPX
      CX(2,3) = -SPX
      CX(3,2) = SPX
      CX(3,3) = CPX
C
      CALL CLEAR(CY)
      CY(1,1) = CPY
      CY(1,3) = SPY
      CY(2,2) = 1.0
      CY(3,1) = -SPY
      CY(3,3) = CPY
C
      CALL CLEAR(CZ)
      CZ(1,1) = CPZ
      CZ(1,2) = -SPZ
      CZ(2,1) = SPZ
      CZ(2,2) = CPZ
      CZ(3,3) = 1.0
C
C====== Matrix a is the transformation from indices to orthogonal
C====== Coordinates
C
      CALL MATM33(CY,CX,C)
      CALL MATM33(CZ,C,PC)
      CALL MATM33(PC,AA,A)
C
      RETURN
      END
**==acos1.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ACOS1         **
C*************************
C
C
      REAL FUNCTION ACOS1(X)
C
C Purpose: Allow for round-off errors
C
      REAL X
C
C====== LOCALS:
C
      REAL SIGN
C
C-------------------------------------------------------------------------------
C
      SIGN = 1.
      IF (X.LT.0.) SIGN = -1.
      IF (ABS(X).GT.1.) THEN
C
C====== (ABS(X)<=1) => (ABS(X)<1.001) (DR)
C
         IF (ABS(X).LT.1.001) X = SIGN
      END IF
      ACOS1 = ACOS(X)
      RETURN
      END
**==ainvrs.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       AINVRS        **
C*************************
C
C
      SUBROUTINE AINVRS(AINV,ERROR,LABEL)
C
      REAL AINV(3,3)
      LOGICAL ERROR
      CHARACTER*(*) LABEL(*)
C
C====== GLOBALS:
C
      COMMON/MATRIX/ MSYS,MROT,MBEAM
      INTEGER MSYS,MROT,MBEAM
      COMMON/DATA/CELL(6),JUNK(8),CCELL(6),NUMA,NUMC,DMIN
C
C====== LOCALS:
C
      REAL RAPI,OUTCEL(3),Q2(3,3),Q3(3,3),Q4(3,3),Q5(3,3),
     +     Q6(3,3),Q7(3,3),AINV2(3,3)
      INTEGER IOK,J,I
C
C-------------------------------------------------------------------------------
C
C
C====== Code
C
      IF (MSYS.LE.0 .OR. MSYS.GT.7) THEN
         ERROR = .TRUE.
         CALL ERMESG(' The crystal system has not been set ')
         GO TO 50
      END IF
      CALL CELLTEST(MSYS,CELL,LABEL,IOK,OUTCEL,1.0)
      RAPI = 3.141592/180.
      NUMC = 0
      NUMA = 0
      J = 0
      DO 20 I = 1 , 6
         IF (OUTCEL(I).NE.0.0) THEN
            J = J + 1
            NUMC = NUMC + 1
            CCELL(J) = OUTCEL(I)
C
C====== If an angle, then also change to radians
C
            IF (I.GT.3) THEN
               NUMA = NUMA + 1
               CCELL(J) = CCELL(J)*RAPI
            END IF
         END IF
 20   CONTINUE
      IF (NUMC.EQ.0) THEN
         CALL ERMESG(' No cell parameters have been set')
         ERROR = .TRUE.
         GO TO 50
      END IF
      CALL MATS(AINV,Q2,Q3,Q4,Q5,Q6,Q7,CCELL)
      CALL MINV(AINV,AINV2,ICODE)
      DO 40 I = 1 , 3
         DO 30 J = 1 , 3
            AINV(I,J) = AINV2(I,J)
 30      CONTINUE
 40   CONTINUE
      ERROR = .FALSE.
 50   RETURN
      END
**==allaue.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ALLAUE        **
C*************************
C
C
      SUBROUTINE ALLAUE(IOPT,LIMIT)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose : To select option for indexing laue spots
C
      INTEGER IOPT,LIMIT
C
C IOPT  : OPTION INDEX, 2= LOW INDEX POINTS, 3= ALL INDICES =<99
C LIMIT : LIMIT OF HKL VALUES AFTER DIVIDING BY HIGHEST COMMON DENOMINATOR
C
C====== GLOBALS:
C
      INCLUDE 'progdim.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'spots.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'point.finc'
C
C====== XABS and YORD in /GRAPH/ are the film coordinates of plotted points.
C====== IRLPPOS gives the position in the reciprocal-lattice arrays XG, YG, ZG
C====== etc. of the corresponding rl-point. This is necessary because when not
C====== in "compress" mode XG etc contains all rlp's generated (as opposed to
C====== only plotted rlp's otherwise). IRLPPOS negative means that the point
C======  refered to is (-XG,-YG,-ZG) rather than (XG,YG,ZG). (Only one of these
C======  is stored.)
C
C====== LOCALS:
C
      REAL   YFE,XFE
      INTEGER I,J,N,IH,IK,IL,II,NSPOT,ICOMFAC,IHCF
      CHARACTER*12 HKLLAB
      LOGICAL LOWINDEX
C
C-------------------------------------------------------------------------------
C
      DO 20 N = 1 , NB
         YFE = YORD(N)
         XFE = XABS(N)
         NSPOT = IABS(IRLPPOS(N))
C
C====== Check that spot is in window for expanded plot
C
         IF (ISWIT.EQ.2) THEN
            IF (ABS(XFE-XSUB).GT.RSUB) GO TO 20
            IF (ABS(YFE-YSUB).GT.RSUB) GO TO 20
         END IF
C
C====== Unpack index values from list
C
         CALL UNPACK(IHKL(NSPOT),IH,IK,IL)
         IF (IRLPPOS(N).LT.0) THEN
            IH = -IH
            IK = -IK
            IL = -IL
         END IF
C
C====== Check if low index spot
C
         CALL LOWIND(IH,IK,IL,LIMIT,LOWINDEX)
         IF (LOWINDEX) THEN
C
C====== Don't plot spots without simple indices to avoid multi-labelling.
C
            ICOMFAC = IHCF(IH,IK)
            ICOMFAC = IHCF(ICOMFAC,IL)
            IF (ICOMFAC.LE.1) THEN
C
C====== Determine actual cursor position and shift yfe to centre triangle
C====== at centre of spot
C
               IF (ISWIT.EQ.2) THEN
                  XFE = (XFE-XSUB)*SSUB
                  YFE = (YFE-YSUB)*SSUB
               END IF
               XFE = XFE*SCALE + XM
               YFE = YFE*SCALE + YM + 0.05
C
C======Encode indices.
C
               WRITE (HKLLAB,6010) IH , IK , IL
               CALL STRIPB(HKLLAB,12)
C
C====== Annotate indexed spot
C
               CALL QGENTR
               CALL QGTEXT(XFE,YFE,8.0,HKLLAB)
            END IF
         END IF
C
 20   CONTINUE
      CALL QGALPH
      RETURN
C
C====== Format statements
C
 6010 FORMAT (' ',I3,',',I3,',',I3)
      END
**==anyori.f  
 
 
C
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ANYORI        **
C*************************
C
C
      SUBROUTINE ANYORI
C
C
C====== GLOBALS:
C
      INCLUDE 'pgstat.finc'
C
      COMMON /DATFLG/PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      LOGICAL PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
C
      COMMON /VSAVE/FSLPIN
      CHARACTER*45 FSLPIN
C
C====== /VSAVE/ contains user input
C
C====== FSLPIN : User input from fslp program
C
C====== LOCALS:
C
      LOGICAL EOF
      INTEGER ICPGVN,ICDGVN,IGPGVN,IGDGVN,JJ,I,K
      SAVE  ICPGVN,ICDGVN,IGPGVN,IGDGVN
      CHARACTER*80 INLINE,BLANK
      LOGICAL  RESPON
      CHARACTER*1 ANSWER
      DATA BLANK(1:40)/'                                        '/,
     +    BLANK(41:80)/'                                        '/
      DATA ICPGVN,ICDGVN,IGPGVN,IGDGVN/0,0,0,0/
C
C-------------------------------------------------------------------------------
C
C
C====== Read in the various input data for fslp style input,manipulate it and
C====== return
C
C====== While more to know ask !
C
      PASET = .FALSE.
      PBSET = .FALSE.
      PCSET = .FALSE.
      P1SET = .FALSE.
      P2SET = .FALSE.
      DASET = .FALSE.
      DBSET = .FALSE.
      DCSET = .FALSE.
      D1SET = .FALSE.
      D2SET = .FALSE.
      ICPGVN = 0
      ICDGVN = 0
      IGPGVN = 0
      IGDGVN = 0
      CALL TWRITE(
     +           '>>> Enter a pole or direction in the form Pq=dd,dd,dd'
     +           )
      CALL TWRITE('    or Dq=dd,dd,dd where q is one of {A,B,C,1,2}')
      CALL TPROMP('    and dd is an arbitrary real number: ')
 20   JJ = ICPGVN + ICDGVN + IGPGVN + IGDGVN
      IF (JJ.LT.2) THEN
         CALL TPROMP('>>> Enter a pole or direction: ')
         CALL TREAD(INLINE,EOF)
         IF (EOF) GO TO 50
         IF (INLINE.EQ.BLANK) GO TO 20
C
C====== Save user input to display in menu
C
         DO 30 I = 1 , 15
            K = JJ*15 + I
            FSLPIN(K:K) = INLINE(I:I)
 30      CONTINUE
         CALL UPDATE(INLINE,ICPGVN,ICDGVN,IGPGVN,IGDGVN)
         IF (ABORT) GO TO 50
         GO TO 20
      ELSE
         CALL TPROMP('>>> Do you wish to enter a third pole/direction? '
     +               )
         RESPON = .FALSE.
         CALL TREAD(ANSWER,EOF)
         IF (EOF) THEN
         END IF
         IF (ANSWER.EQ.'Y' .OR. ANSWER.EQ.'y') RESPON = .TRUE.
         IF (RESPON) THEN
            CALL TPROMP('>>> Enter a pole or direction: ')
            CALL TREAD(INLINE,EOF)
            IF (EOF) GO TO 50
            IF (INLINE.EQ.BLANK) GO TO 20
C
C====== Save user input to display in menu
C
            DO 40 I = 1 , 15
               K = 30 + I
               FSLPIN(K:K) = INLINE(I:I)
 40         CONTINUE
            CALL UPDATE(INLINE,ICPGVN,ICDGVN,IGPGVN,IGDGVN)
            IF (ABORT) GO TO 50
         END IF
      END IF
      RETURN
C
 50   ABORT = .TRUE.
      RETURN
      END
**==arrdis.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ARRDIS        **
C*************************
C
C
      SUBROUTINE ARRDIS(ARR,N)
C
      REAL ARR(*)
      INTEGER N
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , N
         WRITE (STR,6010) I , ARR(I)
         CALL TWRITE(STR)
 20   CONTINUE
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('ARRAY(',I5,')=',E12.4)
      END
**==arrset.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ARRSET        **
C*************************
C
C
      SUBROUTINE ARRSET(OUTARR,ARRIN,N)
C
C Purpose: Performs the matrix operation, a=b
C
      REAL OUTARR(*),ARRIN(*)
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , N
         OUTARR(I) = ARRIN(I)
 20   CONTINUE
      RETURN
      END
**==bgivn.f  
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       BGIVN         **
C*************************
C
C
      SUBROUTINE BGIVN
C
C====== GLOBALS:
C
      COMMON/KNOW/KPA,KPB,KPC,KDA,KDB,KDC,SIN1B,SINZA,COSZA
      REAL SIN1B,SINZA,COSZA
      INTEGER KPA,KPB,KPC,KDA,KDB,KDC
      COMMON/CARDNL/PA(3),PB(3),PC(3),DA(3),DB(3),DC(3)
      REAL PA,PB,PC,DA,DB,DC
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
C
C====== LOCALS:
C
      REAL    Z(3),AA(3,3),PZ(3),BB(3),X
      REAL    PNORM,DNORM
C
C-------------------------------------------------------------------------------
C
      IF (KPB.NE.2) THEN
         IF (KP1.NE.4) THEN
C
C====== B is a direction,  1 is a direction
C
            X = DNORM(DB)
            X = DNORM(D1)
            Z(1) = DB(2)*D1(3) - DB(3)*D1(2)
            Z(2) = DB(3)*D1(1) - DB(1)*D1(3)
            Z(3) = DB(1)*D1(2) - DB(2)*D1(1)
            X = PNORM(Z)
            DO 20 I = 1 , 3
               AA(1,I) = DB(I)
               AA(2,I) = D1(I)
 20         CONTINUE
            BB(3) = 0.
            BB(1) = BB(3)
            BB(2) = SIN1B
            CALL SETAA(AA,Z,3)
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            X = PNORM(BB)
            DO 30 I = 1 , 3
               PZ(I) = BB(I)
               AA(1,I) = DB(I)
 30         CONTINUE
            CALL SETAA(AA,PZ,2)
            CALL SETAA(AA,Z,3)
            BB(1) = 0.
            BB(2) = COSZA*V**2
            BB(3) = SINZA*V**2
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 40 I = 1 , 3
               PA(I) = BB(I)
 40         CONTINUE
            RETURN
         ELSE
C
C====== B is a direction,  1 is a pole
C
            X = DNORM(DB)
            X = PNORM(P1)
            CALL RST(P1,DB,Z,BB,3.)
            X = DNORM(Z)
            DO 50 I = 1 , 3
               AA(1,I) = -Z(I)
               AA(2,I) = DB(I)
 50         CONTINUE
            BB(2) = 0.
            BB(1) = BB(2)
            CALL SETAA(AA,P1,3)
            BB(3) = SIN1B
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            X = PNORM(BB)
            DO 60 I = 1 , 3
               PZ(I) = BB(I)
               AA(1,I) = DB(I)
               AA(3,I) = -Z(I)
 60         CONTINUE
            BB(1) = 0.
            BB(3) = SINZA
            CALL SETAA(AA,PZ,2)
            BB(2) = COSZA*V**2
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 70 I = 1 , 3
               PA(I) = BB(I)
 70         CONTINUE
            RETURN
         END IF
      ELSE IF (KP1.NE.4) THEN
C
C====== B is a pole,  1 is a direction
C
         X = PNORM(PB)
         X = DNORM(D1)
         CALL RST(PB,D1,Z,BB,3.)
         X = DNORM(Z)
         BB(2) = 0.
         BB(1) = BB(2)
         DO 80 I = 1 , 3
            AA(1,I) = Z(I)
            AA(3,I) = D1(I)
 80      CONTINUE
         CALL SETAA(AA,PB,2)
         BB(3) = SIN1B
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         X = PNORM(BB)
         DO 90 I = 1 , 3
            PZ(I) = BB(I)
 90      CONTINUE
         CALL SETAA(AA,PB,1)
         CALL SETAA(AA,PZ,2)
         DO 100 I = 1 , 3
            AA(3,I) = Z(I)
 100     CONTINUE
         BB(1) = 0.
         BB(2) = COSZA*V**2
         BB(3) = SINZA
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 110 I = 1 , 3
            PA(I) = BB(I)
 110     CONTINUE
         RETURN
      ELSE
C
C====== B is a pole,  1 is a pole
C
         X = PNORM(PB)
         X = PNORM(P1)
         Z(1) = PB(2)*P1(3) - PB(3)*P1(2)
         Z(2) = PB(3)*P1(1) - PB(1)*P1(3)
         Z(3) = PB(1)*P1(2) - PB(2)*P1(1)
         X = DNORM(Z)
         DO 120 I = 1 , 3
            AA(1,I) = Z(I)
 120     CONTINUE
         BB(2) = 0.
         BB(1) = BB(2)
         CALL SETAA(AA,PB,2)
         BB(3) = SIN1B
         CALL SETAA(AA,P1,3)
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         X = PNORM(BB)
         DO 130 I = 1 , 3
            PZ(I) = BB(I)
 130     CONTINUE
         CALL SETAA(AA,PB,1)
         CALL SETAA(AA,PZ,2)
         BB(1) = 0.
         BB(2) = V**2*COSZA
         BB(3) = SINZA
         DO 140 I = 1 , 3
            AA(3,I) = Z(I)
 140     CONTINUE
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 150 I = 1 , 3
            PA(I) = BB(I)
 150     CONTINUE
         RETURN
      END IF
      END
**==card.f  
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CARD          **
C*************************
C
C
      SUBROUTINE CARD(ARR)
C
C Purpose: To determine if any of the given data correspond to cardinal
C          positions
C
      REAL ARR(10,4)
C
C====== GLOBALS:
C
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +RMAX,ULAM,LLAM
      COMMON/PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
      COMMON/CARDNL/PA(3),PB(3),PC(3),DA(3),DB(3),DC(3)
      REAL PA,PB,PC,DA,DB,DC
C
C====== LOCALS:
C
      INTEGER CRD1,CRD2,J1,J2,M1,M2,K1,K2
C
C-------------------------------------------------------------------------------
C
      J1 = 7
      J2 = 9
      M2 = 0
      M1 = M2
      IF (PHI1B.EQ.90.) THEN
         IF (PHI1ZA.EQ.0.) M1 = 1
         IF (PHI1ZA.EQ.90.) M1 = 2
         IF (PHI1ZA.EQ.-90.) M1 = 3
      END IF
      IF (PHI2B.EQ.90.) THEN
         IF (PHI2ZA.EQ.0.) M2 = 1
         IF (PHI2ZA.EQ.90.) M2 = 2
         IF (PHI2ZA.EQ.-90.) M2 = 3
      END IF
      IF (PHI1ZA.EQ.0.) THEN
         IF (PHI1B.EQ.0.) M1 = 4
         IF (PHI1B.EQ.180.) M1 = 5
      END IF
      IF (PHI2ZA.EQ.0.) THEN
         IF (PHI2B.EQ.0.) M2 = 4
         IF (PHI2B.EQ.180.) M2 = 5
      END IF
      IF (M1.EQ.0 .AND. M2.EQ.0) RETURN
      IF (M1.NE.0) THEN
         K1 = 1
         IF (M1.EQ.3 .OR. M1.EQ.5) K1 = -1
         IF (M1.EQ.2 .OR. M1.EQ.3) CRD1 = 3
         IF (M1.EQ.4 .OR. M1.EQ.5) CRD1 = 2
         IF (M1.EQ.1) CRD1 = 1
         IF (ARR(8,4).NE.0.0) THEN
            IF (CRD1.EQ.3) CRD1 = 6
            IF (CRD1.EQ.2) CRD1 = 5
            IF (CRD1.EQ.1) CRD1 = 4
            J1 = 8
         END IF
      END IF
      IF (M2.NE.0) THEN
         K2 = 1
         IF (M2.EQ.3 .OR. M2.EQ.5) K2 = -1
         IF (M2.EQ.2 .OR. M2.EQ.3) CRD2 = 3
         IF (M2.EQ.4 .OR. M2.EQ.5) CRD2 = 2
         IF (M2.EQ.1) CRD2 = 1
         IF (ARR(10,4).NE.0.0) THEN
            IF (CRD2.EQ.3) CRD2 = 6
            IF (CRD2.EQ.2) CRD2 = 5
            IF (CRD2.EQ.1) CRD2 = 4
            J2 = 10
         END IF
      END IF
      IF (M1.NE.0) THEN
         DO 20 L = 1 , 3
            ARR(CRD1,L) = K1*ARR(J1,L)
            ARR(J1,L) = 0.
 20      CONTINUE
         ARR(CRD1,4) = 1
         ARR(J1,4) = 0
         IF (M2.EQ.0) THEN
            PHI1ZA = PHI2ZA
            PHI1B = PHI2B
            PHI2B = 999.
            PHI2ZA = PHI2B
            DO 30 I = 1 , 4
               ARR(7,I) = ARR(9,I)
               ARR(8,I) = ARR(10,I)
               ARR(9,I) = 0.
               ARR(10,I) = 0.
 30         CONTINUE
            GO TO 50
         END IF
      END IF
      DO 40 L = 1 , 3
         ARR(CRD2,L) = K2*ARR(J2,L)
         ARR(J2,L) = 0.
 40   CONTINUE
      ARR(CRD2,4) = 1
      ARR(J2,4) = 0.
      PHI2B = 999.
      PHI2ZA = PHI2B
      IF (M1.NE.0) THEN
         PHI1B = 999.
         PHI1ZA = PHI1B
      END IF
 50   DO 60 I = 1 , 3
         PA(I) = ARR(1,I)
         PB(I) = ARR(2,I)
         PC(I) = ARR(3,I)
         DA(I) = ARR(4,I)
         DB(I) = ARR(5,I)
         DC(I) = ARR(6,I)
         P1(I) = ARR(7,I)
         D1(I) = ARR(8,I)
         P2(I) = ARR(9,I)
         D2(I) = ARR(10,I)
 60   CONTINUE
      RETURN
      END
**==cellcx.f  
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CELLCX        **
C*************************
C
C Purpose: Convert between expanded and contracted form of cell params
C
      SUBROUTINE CELLCX(MSYS,CELLC,CELLX,IT,ICTYP)
C
C PARAMETERS
C
C        MSYS (I)       CRYSTAL SYSTEM 1-7
C       CELLC (I OR O)  CONTRACTED FORM OF CELL PARAMETERS (1-6 VALS)
C       CELLX (O OR I)  EXPANDED FORM OF CELL PARAMETERS (6 VALUES)
C          IT (I)       =1 CONVERT FROM CONTRACTED TO EXPANDED
C                       =2 CONVERT FROM EXPANDED TO CONTRACTED
C       ICTYP (I)       CELL TYPE =1 REAL, =2 RECIPROCAL
C
C
      REAL CELLC(6),CELLX(6)
C
C-------------------------------------------------------------------------------
C
      IF (IT.EQ.1) THEN
         IF (MSYS.EQ.1) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = CELLC(4)
            CELLX(5) = CELLC(5)
            CELLX(6) = CELLC(6)
            RETURN
         ELSE IF (MSYS.EQ.2) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = 90.0
            CELLX(5) = CELLC(4)
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.3) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(2)
            CELLX(3) = CELLC(3)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.4) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(2)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         ELSE IF (MSYS.EQ.5) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(2)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 120.0
            IF (ICTYP.EQ.2) CELLX(6) = 60.0
            RETURN
         ELSE IF (MSYS.EQ.6) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(1)
            CELLX(4) = CELLC(2)
            CELLX(5) = CELLC(2)
            CELLX(6) = CELLC(2)
            RETURN
         ELSE IF (MSYS.EQ.7) THEN
            CELLX(1) = CELLC(1)
            CELLX(2) = CELLC(1)
            CELLX(3) = CELLC(1)
            CELLX(4) = 90.0
            CELLX(5) = 90.0
            CELLX(6) = 90.0
            RETURN
         END IF
         RETURN
      END IF
      IF (IT.EQ.2) THEN
         DO 20 I = 1 , 6
            CELLC(I) = 0.0
 20      CONTINUE
         IF (MSYS.EQ.1) THEN
            DO 30 I = 1 , 6
               CELLC(I) = CELLX(I)
 30         CONTINUE
            RETURN
         ELSE IF (MSYS.EQ.2) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(2)
            CELLC(3) = CELLX(3)
            CELLC(4) = CELLX(5)
            RETURN
         ELSE IF (MSYS.EQ.3) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(2)
            CELLC(3) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.4) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.5) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(3)
            RETURN
         ELSE IF (MSYS.EQ.6) THEN
            CELLC(1) = CELLX(1)
            CELLC(2) = CELLX(4)
            RETURN
         ELSE IF (MSYS.EQ.7) THEN
            CELLC(1) = CELLX(1)
            RETURN
         END IF
      END IF
      RETURN
      END
**==celltest.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CELLTEST      **
C*************************
C
C
      SUBROUTINE CELLTEST(MSYS,CELL,LABEL,IOK,OUTCEL,WVS)
C
C Purpose: Check to see if the reciprocal cell parameters are consistent with
C          the lattice type. If inconsistent (eg length of zero in ortho) then
C          give warning message and return iok=1 so user can adjust them. If
C          ok then leave iok and return. To encourage users to understand the
C          principle, set redundant parameters to zero (eg b* and c* in cubic).
C          Note that program assumes b unique for monoclinic, c unique for hex
C          and tetragonal.
C
      DIMENSION CELL(6), OUTCEL(6)
      CHARACTER*6 LABEL(34)
C
C======LOCALS:
C
      CHARACTER*15 TEMP
      CHARACTER*80 ERSTR
C
C-------------------------------------------------------------------------------
C
      CALL ARRSET(OUTCEL,CELL,6)
      IF (MSYS.EQ.2) THEN
C
C====== Monoclinic
C
         DO 20 I = 1 , 3
            IF (CELL(I).EQ.0.0) THEN
               WRITE (ERSTR,6010)
               GO TO 160
            END IF
 20      CONTINUE
         IF (CELL(5).EQ.0.0) THEN
            WRITE (ERSTR,6020)
            GO TO 160
         END IF
         DO 30 I = 4 , 6 , 2
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.90.) THEN
                  WRITE (ERSTR,6030)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 30      CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL MONOCL(OUTCEL)
      ELSE IF (MSYS.EQ.3) THEN
C
C====== Orthorhombic
C
         DO 40 I = 1 , 3
            IF (CELL(I).EQ.0.0) THEN
               WRITE (ERSTR,6040)
               GO TO 160
            END IF
 40      CONTINUE
         DO 50 I = 4 , 6
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.90.) THEN
                  WRITE (ERSTR,6050)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 50      CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL ORTHOR(OUTCEL)
      ELSE IF (MSYS.EQ.4) THEN
C
C====== Tetragonal
C
         DO 60 I = 1 , 3 , 2
            IF (CELL(I).EQ.0.0) THEN
               WRITE (ERSTR,6060)
               GO TO 160
            END IF
 60      CONTINUE
         IF (CELL(2).NE.0.0) THEN
            IF (CELL(2).NE.CELL(1)) THEN
               WRITE (ERSTR,6070)
               CALL TWRITE(ERSTR)
            END IF
            CELL(2) = 0.0
            CALL SETPAR(2,LABEL(2),CELL(2))
         END IF
         DO 70 I = 4 , 6
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.90.) THEN
                  WRITE (ERSTR,6080)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 70      CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL TETRAG(OUTCEL)
      ELSE IF (MSYS.EQ.5) THEN
C
C====== Hexagonal
C
         DO 80 I = 1 , 3 , 2
            IF (CELL(I).EQ.0.0) THEN
               WRITE (ERSTR,6090)
               GO TO 160
            END IF
 80      CONTINUE
         IF (CELL(2).NE.0.0) THEN
            IF (CELL(2).NE.CELL(1)) THEN
               WRITE (ERSTR,6100)
               CALL TWRITE(ERSTR)
            END IF
            CELL(2) = 0.0
            CALL SETPAR(2,LABEL(2),CELL(2))
         END IF
         DO 90 I = 4 , 5
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.90.) THEN
                  WRITE (ERSTR,6110)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 90      CONTINUE
         IF (CELL(6).NE.0.) THEN
            IF (CELL(6).NE.120.) THEN
               WRITE (ERSTR,6100)
               CALL TWRITE(ERSTR)
            END IF
            CELL(6) = 0.
         END IF
         CALL ARRSET(OUTCEL,CELL,6)
         CALL HEXAGN(OUTCEL)
      ELSE IF (MSYS.EQ.6) THEN
C
C====== Rhombohedral
C
         IF (CELL(1).EQ.0.0) THEN
            WRITE (ERSTR,6120)
            GO TO 160
         END IF
         DO 100 I = 2 , 3
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.CELL(1)) THEN
                  WRITE (ERSTR,6130)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 100     CONTINUE
         IF (CELL(4).EQ.0.0) THEN
            WRITE (ERSTR,6140)
            GO TO 160
         END IF
         DO 110 I = 5 , 6
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.CELL(4)) THEN
                  WRITE (ERSTR,6150)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 110     CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL RHOMBO(OUTCEL)
      ELSE IF (MSYS.EQ.7) THEN
C
C====== Cubic
C
         IF (CELL(1).EQ.0.0) THEN
            WRITE (ERSTR,6160)
            GO TO 160
         END IF
         DO 120 I = 2 , 3
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.CELL(1)) THEN
                  WRITE (ERSTR,6170)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 120     CONTINUE
         DO 130 I = 4 , 6
            IF (CELL(I).NE.0.0) THEN
               IF (CELL(I).NE.90.) THEN
                  WRITE (ERSTR,6180)
                  CALL TWRITE(ERSTR)
               END IF
               CELL(I) = 0.0
               CALL SETPAR(I,LABEL(I),CELL(I))
            END IF
 130     CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL CUBIC(OUTCEL)
      ELSE
C
C====== Triclinic
C
         DO 140 I = 1 , 6
            IF (CELL(I).EQ.0.0) THEN
               WRITE (ERSTR,6190)
               GO TO 160
            END IF
 140     CONTINUE
         CALL ARRSET(OUTCEL,CELL,6)
         CALL TRICLN(OUTCEL)
      END IF
C
      IOK = 0
      DO 150 I = 1 , 3
         OUTCEL(I) = OUTCEL(I)*WVS
 150  CONTINUE
      RETURN
C
 160  CALL TWRITE(ERSTR)
      IOK = 1
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('!!! Zero cell length in monoclinic case')
 6020 FORMAT ('!!! Zero beta-star in monoclinic case')
 6030 FORMAT ('!!! Monoclinic case must have unique axis b')
 6040 FORMAT ('!!! Zero cell length in orthorhombic case')
 6050 FORMAT ('!!! No angles needed for orthorhombic case')
 6060 FORMAT ('!!! Zero cell length in tetragonal case')
 6070 FORMAT ('!!! C must be unique axis for tetragonal case')
 6080 FORMAT ('!!! No angles needed for tetragonal case')
 6090 FORMAT ('!!! Zero cell length in hexagonal case')
 6100 FORMAT ('!!! C must be unique axis for hexagonal case')
 6110 FORMAT ('!!! No angles needed for hexagonal case')
 6120 FORMAT ('!!! Zero cell length in rhombohedral case')
 6130 FORMAT ('!!! Only one cell length needed for rhombohedral case')
 6140 FORMAT ('!!! Zero cell angle in rhombohedral case')
 6150 FORMAT ('!!! Only one angle needed for rhombohedral case')
 6160 FORMAT ('!!! Zero cell length in cubic case')
 6170 FORMAT ('!!! Only one cell length needed for cubic case')
 6180 FORMAT ('!!! No angles needed for cubic case')
 6190 FORMAT ('!!! Zero cell parameter in triclinic case')
      END
**==celprm.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CELPRM        **
C*************************
C
C
      SUBROUTINE CELPRM (VALUES,NVALS,IOPT,LABEL)
C
      INCLUDE 'implicit_none.finc'
C
      REAL   VALUES(*)
      INTEGER IOPT,NVALS
      CHARACTER*6 LABEL(*)
C
C====== GLOBALS:
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'data.finc'
C
C====== LOCALS:
C
      CHARACTER*15 TEMP
      CHARACTER*80 STR
      INTEGER I
C
C-------------------------------------------------------------------------------
C
      IF (IOPT.NE.4) THEN
         IF (IOPT.NE.5) THEN
            IF (IOPT.NE.6) THEN
               IF (NVALS.LE.0) THEN
                  CALL QSSETC(1,24)
                  WRITE (STR,6010) LABEL(IOPT) , CELL(IOPT)
                  CALL TPROMP(STR)
                  CALL TREAD(STR,ABORT)
                  IF (ABORT) GO TO 20
                  CALL STRVAL(STR,' ,',6,VALUES,NVALS)
                  IF (NVALS.LE.0) VALUES(1) = CELL(IOPT)
               END IF
C
               CELL(IOPT) = VALUES(1)
               IF (CELL(IOPT).EQ.0.0) THEN
                  WRITE (TEMP,6030) LABEL(IOPT)
                  CALL ITEM(IOPT,TEMP,15,.FALSE.)
               ELSE
                  WRITE (TEMP,6020) LABEL(IOPT) , CELL(IOPT)
                  CALL ITEM(IOPT,TEMP,15,.FALSE.)
               END IF
               GO TO 20
            END IF
         END IF
      END IF
C
C====== Set cell angles
C
      IF (NVALS.LE.0) THEN
         CALL QSSETC(1,24)
         WRITE (STR,6040) LABEL(IOPT) , CELL(IOPT)
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         IF (ABORT) GO TO 20
         CALL STRVAL(STR,' ,',6,VALUES,NVALS)
         IF (NVALS.LE.0) VALUES(1) = CELL(IOPT)
      END IF
C
      CELL(IOPT) = VALUES(1)
      IF (CELL(IOPT).EQ.0.0) THEN
         WRITE (TEMP,6030) LABEL(IOPT)
         CALL ITEM(IOPT,TEMP,15,.FALSE.)
      ELSE
         WRITE (TEMP,6020) LABEL(IOPT) , CELL(IOPT)
         CALL ITEM(IOPT,TEMP,15,.FALSE.)
      END IF
C
 20   RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter lattice length for ',A1,' [',F8.3,' A]: ')
 6020 FORMAT (A6,F8.4,1X)
 6030 FORMAT (A6,9X)
 6040 FORMAT ('>>> Enter lattice angle ',A5,' [',F8.4,' Deg]: ')
      END
**==chk12.f  
 
 
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CHK12         **
C*************************
C
C
      SUBROUTINE CHK12(E)
C
C Purpose: Check that the angle between points 1 and 2 agrees with
C          the crystal formula
C
      REAL E
C
C====== GLOBALS:
C
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +RMAX,ULAM,LLAM
      COMMON/SC/COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
      REAL COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
      COMMON /KNOW/DUM(6),SIN1B,SINZA,COSZA
      REAL DUM,SIN1B,SINZA,COSZA
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
      COMMON/REC/RECAL
      REAL RECAL
C
C====== LOCALS:
C
      CHARACTER*80 ERSTR
      REAL Z(3),CONV,XPI,PDOTD,XP,PNORM,COS12,COSAB,XD,DNORM,XDD,DDOTD
      REAL C1,CF,STERFOR,ACOS1,TH12,DIFF,STERF,P2B,P2B2,B,ALPH,R,ARG
      REAL C,CC1,CC2,PHI1ZA,D,P2ZA,P2ZA2,CC3
      INTEGER IL,LEGVAR
      CHARACTER*10 RECALC(3)
      LOGICAL ERB,ERZ
      DATA RECALC(2),RECALC(3)/'RECALCULAT','ED TO BE  '/
C
C-------------------------------------------------------------------------------
C
      CONV = XPI(1.)/180.
      PDOTD = 0
C
C====== Calculate angle from crystal formula
C
      IF (KP1.NE.4) THEN
         XD = DNORM(D1)
         IF (KP2.NE.2) THEN
            XDD = DNORM(D2)
            CALL RST(Z,D2,Z,Z,0.)
            DDOTD = 0
            DO 20 I = 1 , 3
               DDOTD = DDOTD + D1(I)*Z(I)
 20         CONTINUE
            XDD = 1.
            XD = XDD
            COS12 = DDOTD/(XD*XDD)
            GO TO 50
         ELSE
            XP = PNORM(P2)
            DO 30 I = 1 , 3
               PDOTD = PDOTD + P2(I)*D1(I)
 30         CONTINUE
         END IF
      ELSE
         XP = PNORM(P1)
         IF (KP2.NE.2) THEN
            XD = DNORM(D2)
            DO 40 I = 1 , 3
               PDOTD = PDOTD + P1(I)*D2(I)
 40         CONTINUE
         ELSE
            XP = PNORM(P2)
            COS12 = COSAB(P1,P2)
            GO TO 50
         END IF
      END IF
      XP = 1.
      XD = XP
C
C====== Values of P1 and D2 are reset in PNORM and DNORM respectively,
C====== therefore XP=XD=1.
C
      COS12 = PDOTD*XP/XD
C
C====== values of D1 and D2 are reset in DNORM, therefore XD=XDD=1.
C
 50   C1 = SINZA*SIN2ZA + COSZA*COS2ZA
C
C====== Calculate angle from input data ( stereographic formula)
C
      CF = COS1B*COS2B + SIN1B*SIN2B*C1
      STERFOR = ACOS1(CF)/CONV
      TH12 = ACOS1(COS12)/CONV
      DIFF = ABS(STERFOR-TH12)
      IF (DIFF.LE.1.) THEN
C
C====== RECAL=1    Best of PHI2B and PHI2ZA
C====== RECAL=2    PHI2B recalculated
C====== RECAL=3    PHI2ZA recalculated
C
         IF (RECAL.EQ.0.) RETURN
         IF (ABS(PHI2ZA).GE.89.) RECAL = 2.0
         IF (ABS(PHI2B).GE.179.) RECAL = 3.0
         IF (COS1B.NE.0.) THEN
            B = SIN1B*C1
            ALPH = ATAN(B/COS1B)
            IF (ALPH.LT.0.) ALPH = ALPH + XPI(1.)
C
C====== Recalculate PHI2B
C
            R = SQRT(COS1B**2+B**2)
            IF (R.EQ.0.) R = 1.
            IF (ABS(COS12).LT..0001) COS12 = 0.
            ARG = COS12/R
            IF (ARG.LE.1.0001 .AND. ARG.GE..9999) ARG = 1.
            IF (ARG.GE.-1.0001 .AND. ARG.LE.-.9999) ARG = -1.
            IF (COS1B.NE.0.) C = ACOS(ARG)
            IF (COS1B.EQ.0.) C = ASIN(ARG)
            CC1 = 999.
            ERZ = .FALSE.
            ERB = ERZ
            IL = LEGVAR(C)
            IF (IL.NE.0) THEN
               IF (RECAL.EQ.2.) THEN
                  WRITE (ERSTR,6020)
                  CALL TWRITE(ERSTR)
               END IF
               ERB = .TRUE.
               GO TO 60
            ELSE
               P2B = ALPH - C
               IF (P2B.GT.-.001 .AND. P2B.LT..001) P2B = 0.
               IF (P2B.LT.180.001 .AND. P2B.GT.179.999) P2B = XPI(1.)
               IF (P2B.EQ.0. .OR. P2B.EQ.XPI(1.)) PHI2ZA = 0.
               IF (P2B.LT.0.) P2B = XPI(1.) + P2B
               IF (P2B.GT.XPI(1.)) P2B = P2B - XPI(1.)
               P2B2 = ALPH + C
               IF (P2B2.LT.0.) P2B2 = XPI(1.) + P2B2
               IF (P2B2.GT.XPI(1.)) P2B2 = P2B2 - XPI(1.)
            END IF
         ELSE
            IF (COS2B.EQ.0.) RECAL = 3.
            ERZ = .FALSE.
            ERB = ERZ
            IF (RECAL.EQ.3.) GO TO 60
            P2B = ASIN(COS12/C1)
            P2B2 = XPI(1.) - P2B
         END IF
      ELSE
C
C====== Difference greater than 1 degree - data error
C
         WRITE (ERSTR,6030) TH12 , STERFOR
         CALL TWRITE(ERSTR)
         E = 1.
         RETURN
      END IF
      CC1 = ABS(PHI2B*CONV-P2B)
      CC2 = ABS(PHI2B*CONV-P2B2)
      IF (CC1.LT.CC2 .AND. RECAL.EQ.2.) GO TO 90
      IF (CC1.GE.CC2) THEN
         CC1 = CC2
         P2B = P2B2
C
C====== Recalculate PHI2ZA
C
         IF (RECAL.EQ.2.) GO TO 90
      END IF
 60   C = (COS12-COS1B*COS2B)/(SIN1B*SIN2B)
      PHI1ZA = ASIN(SINZA)
      D = ACOS1(C)
      IF (SINZA.EQ.0.) THEN
         P2ZA = D
         P2ZA2 = -P2ZA
      ELSE IF (COSZA.NE.0.) THEN
         IL = LEGVAR(D)
         IF (IL.NE.0) THEN
            IF (RECAL.EQ.3.) THEN
               WRITE (ERSTR,6040)
               CALL TWRITE(ERSTR)
            END IF
            ERZ = .TRUE.
            GO TO 70
         ELSE
            P2ZA = PHI1ZA - D
            P2ZA2 = PHI1ZA + D
         END IF
      ELSE
         P2ZA = ASIN(C)
         P2ZA2 = -P2ZA
      END IF
      CC2 = ABS(PHI2ZA*CONV-P2ZA)
      CC3 = ABS(PHI2ZA*CONV-P2ZA2)
      IF (CC2.GE.CC3) THEN
         CC2 = CC3
         P2ZA = P2ZA2
      END IF
C
C====== Choose smallest diff for new PHI2B or PHI2ZA
C
 70   IF (RECAL.EQ.2.) GO TO 90
      IF (RECAL.NE.3.) THEN
         IF (CC1.LT.CC2) GO TO 90
      END IF
 80   IF (.NOT.(ERZ)) THEN
         PHI2ZA = P2ZA/CONV
         RECALC(1) = '   PHI2ZA '
         WRITE (ERSTR,6010) RECALC , PHI2ZA
         CALL TWRITE(ERSTR)
         GO TO 100
      END IF
 90   IF (ERB) GO TO 80
      PHI2B = P2B/CONV
      RECALC(1) = '    PHI2B '
      PHI2B = P2B/CONV
      WRITE (ERSTR,6010) RECALC , PHI2B
      CALL TWRITE(ERSTR)
 100  E = 0.
      SIN2ZA = SIN(PHI2ZA*CONV)
      COS2ZA = COS(PHI2ZA*CONV)
      SIN2B = SIN(PHI2B*CONV)
      COS2B = COS(PHI2B*CONV)
      IF (PHI2ZA.EQ.0.) SIN2ZA = 0.
      IF (PHI2ZA.EQ.0.) COS2ZA = 1.0
      IF (PHI2ZA.EQ.90.) SIN2ZA = 1.0
      IF (PHI2ZA.EQ.90.) COS2ZA = 0.0
      IF (PHI2ZA.EQ.-90.) SIN2ZA = -1.0
      IF (PHI2ZA.EQ.-90.) COS2ZA = 0.0
      IF (PHI2B.EQ.0.) SIN2B = 0.0
      IF (PHI2B.EQ.0.) COS2B = 1.0
      IF (PHI2B.EQ.90.) SIN2B = 1.0
      IF (PHI2B.EQ.90.) COS2B = 0.0
      IF (PHI2B.EQ.180.) SIN2B = 0.0
      IF (PHI2B.EQ.180.) COS2B = -1.0
      RETURN
C
C====== Format Statements
C
 6010 FORMAT (3A10,F10.4)
 6020 FORMAT ('!!! PHI2B calculation not valid')
 6030 FORMAT ('!!! Input data error - angle ','between points 1 and 2=',
     +        F4.1,49X,'=',F10.4,' from input data')
 6040 FORMAT ('!!! PHI2ZA recalculation not valid')
      END
**==clear.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CLEAR         **
C*************************
C
C
        SUBROUTINE CLEAR(A)
C
        DIMENSION A(9)
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , 9
         A(I) = 0.0
 20   CONTINUE
      RETURN
      END
**==cosab.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       COSAB         **
C*************************
C
C
      REAL FUNCTION COSAB(PA,PB)
C
C Purpose: Calculate angle between poles a and b
C
      REAL      PA(3),PB(3)
C
C====== GLOBALS:
C
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
C
C====== LOCALS:
C
      REAL  AA(3,3),X,Y,PNORM
C
C-------------------------------------------------------------------------------
C
      CALL SETAA(AA,PB,1)
      X = 0.
      DO 20 I = 1 , 3
         X = X + PA(I)*AA(1,I)
 20   CONTINUE
      Y = PNORM(PA)
      COSAB = X*Y/V**2
      RETURN
      END
**==cubic.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       CUBIC         **
C*************************
C
C
      SUBROUTINE CUBIC(CELL)
C
      REAL CELL(*)
C
C-------------------------------------------------------------------------------
C
      CELL(1) = 1/CELL(1)
      RETURN
      END
**==dnorm.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       DNORM         **
C*************************
C
C
      REAL FUNCTION DNORM(D)
C
      REAL D(3)
C
C====== GLOBALS:
C
      COMMON/ANGLE/COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      REAL COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
C
C====== LOCALS:
C
      REAL X1,Y1,Z1,X
C
C-------------------------------------------------------------------------------
C
      X1 = D(1)*A + D(2)*B*COSG + D(3)*C*COSB
      Y1 = D(2)*B*SING + D(3)*C*(COSA-COSB*COSG)/SING
      Z1 = D(3)*V/(A*B*SING)
      X = SQRT(X1**2+Y1**2+Z1**2)
      DO 20 I = 1 , 3
         D(I) = D(I)/X
 20   CONTINUE
      DNORM = X
      RETURN
      END
**==enorm.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ENORM         **
C*************************
C
C
      REAL FUNCTION ENORM(I)
C
      INTEGER I
C
C Purpose: Return the euclidean norm of DA,DB,DC
C          according as I=1,2or3, or return 1 for
C          ENORM<1.0E-5
C
C
C====== GLOBALS:
C
      COMMON /CARDNL/CDVEC(9),DA(3),DB(3),DC(3)
C
C-------------------------------------------------------------------------------
C
      IF (I.EQ.2) THEN
         TEMP = DB(1)*DB(1) + DB(2)*DB(2) + DB(3)*DB(3)
      ELSE IF (I.EQ.3) THEN
         TEMP = DC(1)*DC(1) + DC(2)*DC(2) + DC(3)*DC(3)
      ELSE
         TEMP = DA(1)*DA(1) + DA(2)*DA(2) + DA(3)*DA(3)
      END IF
      IF (TEMP.LT.1.0E-5) TEMP = 1.0
      ENORM = SQRT(TEMP)
      RETURN
      END
**==ermesg.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ERMESG        **
C*************************
C
C
      SUBROUTINE ERMESG(STRING)
C
      CHARACTER*(*) STRING
      CHARACTER*80 ERSTR
C
C-------------------------------------------------------------------------------
C
      ERSTR = '!!! '//STRING
      CALL TWRITE(ERSTR)
      CALL QSBELL
      CALL QSBELL
      CALL QSBELL
      RETURN
      END
**==erotmt.f  
C LAST UPDATE
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       EROTMT        **
C*************************
C
C
      SUBROUTINE EROTMT(ANG,B,A,RMSD)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Use the formulae of the preceding routine to calculate the new
C          matrix (B), from the rotation angles in degrees (ANG). RMSD returns
C          the root mean square deviation of new matrix elements from old (A).
C
      REAL RMSD
      REAL A(3,3),ANG(3),B(3,3)
C
C====== LOCALS:
C
      REAL CX,CY,CZ,RAD,SX,SY,SZ
      INTEGER I,J
C
C-------------------------------------------------------------------------------
C
      RAD = 180./3.14159265
      CX = COS(ANG(1)/RAD)
      CY = COS(ANG(2)/RAD)
      CZ = COS(ANG(3)/RAD)
      SX = SIN(ANG(1)/RAD)
      SY = SIN(ANG(2)/RAD)
      SZ = SIN(ANG(3)/RAD)
      B(1,1) = CY*CZ
      B(1,2) = SX*SY*CZ - CX*SZ
      B(1,3) = CX*SY*CZ + SX*SZ
      B(2,1) = CY*SZ
      B(2,2) = SX*SY*SZ + CX*CZ
      B(2,3) = CX*SY*SZ - SX*CZ
      B(3,1) = -SY
      B(3,2) = SX*CY
      B(3,3) = CX*CY
      RMSD = 0.
      DO 30 I = 1 , 3
         DO 20 J = 1 , 3
            RMSD = (A(I,J)-B(I,J))**2 + RMSD
 20      CONTINUE
 30   CONTINUE
      RMSD = SQRT(RMSD/9.)
      RETURN
      END
**==evangl.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       EVANGL        **
C*************************
C
C
      SUBROUTINE EVANGL(NOBS,IHKL,XC,ANG,RMSD,DEV,SOL,IDET)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: On entry have nobs reflections with indices in ihkl.
C          Observed film coords (mm) are in xc
C
C          Firstly, calculate the standard reciprocal lattice coords
C          (x) from the indices.
C
      REAL DEV,RMSD
      INTEGER IDET,NOBS
      REAL ANG(3),SOL(3,3),XC(5,20)
      INTEGER IHKL(3,20)
      REAL CF,DMIN,SPNDLE,WVM,WVS,WVX
      INTEGER NUMA,NUMC
      REAL CCELL(6),CELL(6),DS2(20),PHIS(3),X(3,20)
      COMMON /DATA/CELL,WVM,WVX,WVS,CF,PHIS,SPNDLE,CCELL,NUMA,NUMC,DMIN
      COMMON /DS/DS2,X
C
C====== LOCALS:
C
      REAL RF,TH
      INTEGER I,ICOD,J,K
      REAL A(3,3),AA(3,3),AAA(3,20),AC1(3,3),AC2(3,3),AC3(3,3),AC4(3,3),
     1     AC5(3,3),AC6(3,3),AI(3,3),B(3,20),NEWSOL(3,3),XTMP(3),XX(3)
C
C-------------------------------------------------------------------------------
C
      CALL CLEAR(AA)
      CALL MATS(AA,AC1,AC2,AC3,AC4,AC5,AC6,CCELL)
      DO 30 I = 1 , NOBS
         DO 20 J = 1 , 3
            X(J,I) = AA(J,1)*IHKL(1,I) + AA(J,2)*IHKL(2,I) + AA(J,3)
     +               *IHKL(3,I)
 20      CONTINUE
         DS2(I) = X(1,I)**2 + X(2,I)**2 + X(3,I)**2
 30   CONTINUE
C
C====== Now calculate the observed reciprocal lattice points (b)
C
      DO 40 I = 1 , NOBS
         TH = 0.5*ATAN2(SQRT(XC(1,I)**2+XC(2,I)**2),CF)
         RF = -SQRT(DS2(I))/(2.0*SIN(TH))
         B(1,I) = DS2(I)/(2.0*RF)
         B(2,I) = XC(1,I)*(-RF+B(1,I))/CF
         B(3,I) = XC(2,I)*(-RF+B(1,I))/CF
 40   CONTINUE
C
C====== Now calculate the x-transpose.x matrix (a) and invert it (ai).
C
      DO 70 I = 1 , 3
         DO 60 J = 1 , 3
            A(I,J) = 0.
            DO 50 K = 1 , NOBS
               A(I,J) = A(I,J) + X(I,K)*X(J,K)
 50         CONTINUE
 60      CONTINUE
 70   CONTINUE
      CALL MINV(A,AI,ICOD)
C
C====== If the matrix was not inverted (determinant near zero)
C====== return immediately
C
      IF (ICOD.EQ.1) THEN
         IDET = 2
         RETURN
 
      END IF
C
C====== Now store in aaa the (a-transpose.a)inverted.a-transpose matrix
C
      DO 100 I = 1 , 3
         DO 90 J = 1 , NOBS
            AAA(I,J) = 0.
            DO 80 K = 1 , 3
               AAA(I,J) = AAA(I,J) + AI(I,K)*X(K,J)
 80         CONTINUE
 90      CONTINUE
 100  CONTINUE
C
C====== Now loop through the 3 sets of simultaneous equations, calculating
C====== the 3 vector solutions - stored in sol.
C
      DO 130 I = 1 , 3
         DO 120 J = 1 , 3
            SOL(I,J) = 0.
            DO 110 K = 1 , NOBS
               SOL(I,J) = SOL(I,J) + AAA(J,K)*B(I,K)
 110        CONTINUE
 120     CONTINUE
 130  CONTINUE
C
C====== Now unravel the actual rotation angles from the matrix sol.
C
      CALL FNDANG(SOL,ANG,NEWSOL,IDET,RMSD)
      IF (IDET.EQ.2) RETURN
C
C====== The rotation matrix derived from these angles is now in newsol.
C====== Apply it to get calculated film coordinates to compare with
C====== the observed ones.
C
      CALL EVCOOR(NEWSOL,XC,DEV,NOBS,IDET)
      RETURN
      END
**==evcoor.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       EVCOOR        **
C*************************
C
C
      SUBROUTINE EVCOOR(NEWSOL,XC,DEV,NOBS,IDET)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Evaluate the film coords (xc(3-5,i)) from the standard r.l. coords
C          (x) using the matrix (newsol), and returning rmsdev in dev.
C
      REAL DEV
      INTEGER IDET,NOBS
      REAL NEWSOL(3,3),XC(5,20)
      REAL CF,DMIN,SPNDLE,WVM,WVS,WVX
      INTEGER NUMA,NUMC
      REAL CCELL(6),CELL(6),DS2(20),PHIS(3),X(3,20)
      COMMON /DATA/CELL,WVM,WVX,WVS,CF,PHIS,SPNDLE,CCELL,NUMA,NUMC,DMIN
      COMMON /DS/DS2,X
C
C====== LOCALS:
C
      REAL RF
      INTEGER I,J
      REAL XTMP(3),XX(3)
C
C-------------------------------------------------------------------------------
C
      DEV = 0.
      DO 30 I = 1 , NOBS
C
C====== Change the sign of the 3rd standard r.l. coordinate if det=-1
C
         IF (IDET.NE.0) THEN
            XTMP(3) = -X(3,I)
            XTMP(2) = -X(2,I)
            XTMP(1) = -X(1,I)
 
         ELSE
            XTMP(3) = X(3,I)
            XTMP(2) = X(2,I)
            XTMP(1) = X(1,I)
         END IF
 
         DO 20 J = 1 , 3
            XX(J) = NEWSOL(J,1)*XTMP(1) + NEWSOL(J,2)*XTMP(2)
     +              + NEWSOL(J,3)*XTMP(3)
 20      CONTINUE
         RF = DS2(I)/(2.0*XX(1))
         XC(3,I) = CF*XX(2)/(-RF+XX(1))
         XC(4,I) = CF*XX(3)/(-RF+XX(1))
         XC(5,I) = -RF + XX(1)
         DEV = (XC(3,I)-XC(1,I))**2 + (XC(4,I)-XC(2,I))**2 + DEV
 30   CONTINUE
      DEV = SQRT(DEV/NOBS)
      RETURN
      END
**==fndang.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       FNDANG        **
C*************************
C
C
      SUBROUTINE FNDANG(A,ANG,B,IDET,RMSD)
C
      INCLUDE 'implicit_none.finc'
C
C====== A contains a matrix with the following form
C
C====== cy.cz       sx.sy.cz - cx.sz    cx.sy.cz + sx.sz
C
C====== cy.sz       sx.sy.sz + cx.cz    cx.sy.sz - sx.cz
C
C====== -sy              sx.cy               cx.cy
C
C====== and on return ang should contain the corresponding angles - x,y,z
C====== cy stands for cos(y), etc.
C
      REAL RMSD
      INTEGER IDET
      REAL A(3,3),ANG(3),B(3,3)
C
C====== LOCALS:
C
      CHARACTER*80 ERSTR
      REAL ADET,CON,CY,DET,PI,SY,X,XMZ,XPZ,Y,Z
      INTEGER I,J
C
C-------------------------------------------------------------------------------
C
      PI = 3.14159265
C
C====== First check for det=1 for true rotation matrix
C
      IDET = 0
      DET = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)
     +      *A(3,2) - A(1,2)*A(2,1)*A(3,3) - A(1,1)*A(2,3)*A(3,2)
     +      - A(1,3)*A(2,2)*A(3,1)
      ADET = ABS(DET)
      IF (ABS(1.0-ADET).GT.0.1) THEN
         WRITE (ERSTR,6010) DET
         CALL TWRITE(ERSTR)
         WRITE (ERSTR,6020)
         CALL TWRITE(ERSTR)
         IDET = 2
         RETURN
      END IF
      IF (DET.LT.0.0) THEN
         WRITE (ERSTR,6030)
         CALL TWRITE(ERSTR)
         DO 30 I = 1 , 3
            DO 20 J = 1 , 3
               A(I,J) = -A(I,J)
 20         CONTINUE
 30      CONTINUE
         IDET = 1
      END IF
C
C====== Evaluate y from a(3,1): range -pi/2 to +pi/2
C====== There is an ambiguity since pi-y gives same sin, but this is
C====== taken care of by x and z each +pi
C
      ANG(2) = ASIN(-A(3,1))
C
C====== Guard against cy very close to zero
C
      IF ((1.-ABS(A(3,1))).GT.0.001) THEN
         ANG(1) = ATAN2(A(3,2),A(3,3))
         ANG(3) = ATAN2(A(2,1),A(1,1))
         XPZ = ATAN2(-(A(1,2)+A(2,3)),-(A(1,3)-A(2,2)))
         XMZ = ATAN2((A(1,2)-A(2,3)),(A(1,3)+A(2,2)))
         X = 0.5*(XPZ+XMZ)
         Z = 0.5*(XPZ-XMZ)
         IF (ABS(ANG(1)-X).GT.0.1) THEN
            IF (ANG(1).GT.X) CON = PI
            IF (ANG(1).LT.X) CON = -PI
            X = X + CON
         END IF
 
         IF (ABS(ANG(3)-Z).GT.0.1) THEN
            IF (ANG(3).GT.Z) CON = PI
            IF (ANG(3).LT.Z) CON = -PI
            Z = Z + CON
         END IF
 
         ANG(1) = 0.5*(ANG(1)+X)
         ANG(3) = 0.5*(ANG(3)+Z)
         CY = 0.25*(A(3,3)/COS(ANG(1))+A(3,2)/SIN(ANG(1))+A(1,1)
     +        /COS(ANG(3))+A(2,1)/SIN(ANG(3)))
         SY = 0.5*((A(1,2)+A(2,3))/SIN(ANG(1)+ANG(3))+1+(A(1,3)-A(2,2))
     +        /COS(ANG(1)+ANG(3))+1)
         Y = ATAN2(SY,CY)
         ANG(2) = (ANG(2)+2.*Y)/3.
 
      ELSE IF (A(3,1).LT.0.0) THEN
C
C====== This is the case when y=pi/2, sy=1, cy=0. The top right 2*2 of the
C====== a matrix has terms s(x-z),c(x-z)/c(x-z),-s(x-z). Assume z=0.
C====== ( lt above changed from gt by Pella Aug 86)
C
         ANG(1) = ATAN2((A(1,2)-A(2,3)),(A(1,3)+A(2,2)))
         ANG(3) = 0.
 
      ELSE
C
C====== This is the case when y=-pi/2, sy=-1, cy=0. The top right 2*2 of
C====== the a matrix has terms -s(x+z),-c(x+z)/c(x+z),-s(x+z). Assume z=0.
C
         ANG(1) = ATAN2((-A(1,2)-A(2,3)),(-A(1,3)+A(2,2)))
         ANG(3) = 0.
      END IF
C
C====== Evaluate the true rotation matrix, angles in degrees.
C
      DO 40 I = 1 , 3
         ANG(I) = ANG(I)*180./PI
 40   CONTINUE
      CALL EROTMT(ANG,B,A,RMSD)
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('!!! Reject - determinant of matching matrix is ',F10.5)
 6020 FORMAT ('This means that  the transformation matrix is not',
     +        ' a true rotation matrix')
 6030 FORMAT ('!!! Determinant is -1 so matrix signs are reversed')
      END
**==fslp.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       FSLP          **
C*************************
C
C
      SUBROUTINE FSLP
C
C Purpose: Program to make various crystallographic calculations
C          and produce graphic output
C
C====== GLOBALS:
C
      INCLUDE 'pgstat.finc'
      COMMON/EXIT/JOUT
      INTEGER JOUT
      COMMON/REC/RECAL
      REAL RECAL
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
      COMMON/KNOW/KPA,KPB,KPC,KDA,KDB,KDC,SIN1B,SINZA,COSZA
      REAL SIN1B,SINZA,COSZA
      INTEGER KPA,KPB,KPC,KDA,KDB,KDC
      COMMON/CHK/DEL1,DEL2
      REAL DEL1,DEL2
      COMMON/ANGLE/COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      REAL COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
      COMMON/CARDNL/PA(3),PB(3),PC(3),DA(3),DB(3),DC(3)
      REAL PA,PB,PC,DA,DB,DC
      COMMON/SC/COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
      REAL COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
      COMMON/SUF/SUFF(7,5),SUFT(7,5),ICLASS,IHEX
      INTEGER  SUFF,SUFT
      INTEGER ICLASS,IHEX
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +RMAX,ULAM,LLAM,CL
      REAL PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMA,HKL,RMAX
      REAL ULAM,LLAM,CL
C
C====== LOCALS:
C
      CHARACTER*80 ERSTR
      DOUBLE PRECISION TITLE(10)
      REAL   AA(3,3),BB(3),CC(3),Z(3),ARR(10,4)
      REAL   XA,XB,XC,SWAP
      REAL   XLIMIT,YLIMIT,CUTOFF,UCUT,PHIZB,CP,THETAY
      REAL   PHI1,PHI2,PI,XPI,CONV,THETAZ,X,PNORM,DNORM,AB
      REAL   COSAB,BC,CA,DEL3,SIGN,E,TH2,TH1,DIFF,PT,DT,COSZB
      REAL   BACK,RVALIS(6),VALIS
      INTEGER  IVALIS(1)
      INTEGER KMAX,KVOLTS,NOPLOT,IP,KD1,KD2,L1,JMP1,JM,JMP,MM,JJ
      LOGICAL SAMEDIA,LL,CHECK1
      CHARACTER*8 REFL2(12),ILIS(1),RLIS(6),NAME*3,INPDTA*9,VLIS(37)
      CHARACTER*4 REFL1(11)
      CHARACTER*10 ERR(2)
      CHARACTER*15 KINP,KINQ,KINR,INP(10),INQ(10),INR(10)
      DATA REFL1/'HKL:','HHL:','HKH:','HHL:','HH0:','0KL:','H0L:',
     &'HK0','H00:','0K0:','00L:'/
      DATA REFL2/'H+K,H+L=','    H+K=','    H+L=','    K+L=','  H+K+L='
     &,' -H+K+L=','      H=','      K=','      L=',
     &'   2H+L=','   2H+K=','   2L+H='/
      DATA ILIS/'@@@@@@@@'/,RLIS/'A','B','C','ALPHA','BETA','GAMMA'/,
     &         NAME/'ABC'/
      DATA VLIS/'PA(1)','PA(2)','PA(3)','PB(1)','PB(2)','PB(3)',
     &'PC(1)','PC(2)','PC(3)','DA(1)','DA(2)','DA(3)','DB(1)',
     &'DB(2)','DB(3)','DC(1)','DC(2)','DC(3)','P1(1)','P1(2)',
     &'P1(3)','P2(1)','P2(2)','P2(3)','D1(1)','D1(2)','D1(3)',
     &'D2(1)','D2(2)','D2(3)',
     &'PHI1B','PHI2B','PHI1ZA','PHI2ZA','RECAL','NOPLOT',
     &'BACK'/
      CHECK1(XA,XB,XC) = (DEL1.LT.XA) .AND. (DEL2.GT.XA) .AND. 
     +                   (DEL1.LT.XB) .AND. (DEL2.GT.XB) .AND. 
     +                   (DEL1.LT.XC) .AND. (DEL2.GT.XC)
C
C-------------------------------------------------------------------------------
C
      INP(1) = '('' PA'',3F4.0)'
      INP(2) = '('' PB'',3F4.0)'
      INP(3) = '('' PC'',3F4.0)'
      INP(4) = '('' DA'',3F4.0)'
      INP(5) = '('' DB'',3F4.0)'
      INP(6) = '('' DC'',3F4.0)'
      INP(7) = '('' P1'',3F4.0)'
      INP(8) = '('' D1'',3F4.0)'
      INP(9) = '('' P2'',3F4.0)'
      INP(10) = '('' D2'',3F4.0)'
      INQ(1) = '('' PA'',3F5.0)'
      INQ(2) = '('' PB'',3F5.0)'
      INQ(3) = '('' PC'',3F5.0)'
      INQ(4) = '('' DA'',3F5.0)'
      INQ(5) = '('' DB'',3F5.0)'
      INQ(6) = '('' DC'',3F5.0)'
      INQ(7) = '('' P1'',3F5.0)'
      INQ(8) = '('' D1'',3F5.0)'
      INQ(9) = '('' P2'',3F5.0)'
      INQ(10) = '('' D2'',3F5.0)'
      INR(1) = '('' PA'',3F6.0)'
      INR(2) = '('' PB'',3F6.0)'
      INR(3) = '('' PC'',3F6.0)'
      INR(4) = '('' DA'',3F6.0)'
      INR(5) = '('' DB'',3F6.0)'
      INR(6) = '('' DC'',3F6.0)'
      INR(7) = '('' P1'',3F6.0)'
      INR(8) = '('' D1'',3F6.0)'
      INR(9) = '('' P2'',3F6.0)'
      INR(10) = '('' D2'',3F6.0)'
 
 20   DO 30 I = 1 , 3
         D2(I) = 0.
         D1(I) = D2(I)
         P2(I) = D1(I)
         P1(I) = P2(I)
         DC(I) = P1(I)
         DB(I) = DC(I)
         DA(I) = DB(I)
         PC(I) = DA(I)
         PB(I) = PC(I)
         PA(I) = PB(I)
 30   CONTINUE
      CALL GETFSL
      IF (ABORT) GO TO 530
      IF (C.EQ.0.) C = 1.
      IF (B.EQ.0.) B = 1.
      IF (A.EQ.0.) A = 1.
      IF (GAMMA.EQ.0.) GAMMA = 90.
      IF (BETA.EQ.0.) BETA = 90.
      IF (ALPHA.EQ.0.) ALPHA = 90.
      IF (A.EQ.B .AND. B.NE.C .AND. ALPHA.EQ.BETA .AND. GAMMA.EQ.120.)
     +    IHEX = 1
      IF (PHI2ZA.EQ.0.) PHI2ZA = 999.
      IF (PHI1ZA.EQ.0.) PHI1ZA = 999.
      IF (PHI2B.EQ.0.) PHI2B = 999.
      IF (PHI1B.EQ.0.) PHI1B = 999.
      PHIZB = 999.
 
      DO 40 K = 1 , 3
         ARR(1,K) = PA(K)
         ARR(2,K) = PB(K)
         ARR(3,K) = PC(K)
         ARR(4,K) = DA(K)
         ARR(5,K) = DB(K)
         ARR(6,K) = DC(K)
         ARR(7,K) = P1(K)
         ARR(8,K) = D1(K)
         ARR(9,K) = P2(K)
         ARR(10,K) = D2(K)
 40   CONTINUE
 
      DO 50 I = 1 , 10
         ARR(I,4) = 1.
         IF (ARR(I,1).EQ.ARR(I,2) .AND. ARR(I,2).EQ.ARR(I,3) .AND. 
     +       ARR(I,3).EQ.0.) ARR(I,4) = 0.
 50   CONTINUE
      CALL CARD(ARR)
      DO 70 I = 1 , 10
         IF (ARR(I,4).NE.0.) THEN
            IP = 0
            DO 60 J = 1 , 3
               CP = ABS(ARR(I,J))
               IF (CP.GT.99. .AND. CP.LE.999.) IP = 1
               IF (CP.GT.999.) IP = 2
 60         CONTINUE
            IF (IP.EQ.0) THEN
               KINP = INP(I)
            ELSE IF (IP.EQ.1) THEN
               KINQ = INQ(I)
            ELSE IF (IP.EQ.2) THEN
               KINR = INR(I)
            END IF
         END IF
 70   CONTINUE
C
C====== Calculate constants
C
      THETAY = 90. - GAMMA
      DEL1 = 0.95
      DEL2 = 1.05
      PHI1 = 90. - BETA
      PHI2 = 90. - ALPHA
      PI = XPI(1.)
      CONV = PI/180.
      THETAY = THETAY*CONV
      ALPHA = ALPHA*CONV
      BETA = BETA*CONV
      GAMMA = GAMMA*CONV
      PHI1 = PHI1*CONV
      PHI2 = PHI2*CONV
      COSA = COS(ALPHA)
      COSB = COS(BETA)
      COSG = COS(GAMMA)
      SINA = SIN(ALPHA)
      SINB = SIN(BETA)
      SING = SIN(GAMMA)
      IF (ALPHA.EQ.90.) SINA = 1.0
      IF (ALPHA.EQ.90.) COSA = 0.0
      IF (BETA.EQ.90.) SINB = 1.0
      IF (BETA.EQ.90.) COSB = 0.0
      IF (GAMMA.EQ.90.) SING = 1.0
      IF (GAMMA.EQ.90.) COSG = 0.0
      THETAZ = ASIN(((SIN(PHI1))**2+(SIN(PHI2))**2)**0.5)
      V = A*B*C*SQRT(1.-(COSA**2)-(COSB**2)-COSG**2+2.*COSA*COSB*COSG)
      S11 = (B**2.)*(C**2.)*SINA**2
      S22 = (A**2.)*(C**2.)*SINB**2
      S33 = (A**2.)*(B**2.)*SING**2
      S12 = A*B*C**2.*(COSA*COSB-COSG)
      S23 = A**2.*B*C*(COSB*COSG-COSA)
      S13 = A*B**2.*C*(COSG*COSA-COSB)
      COSTZ = COS(THETAZ)
C
C====== Find which of a,b and c are given
C
      CALL GIVEN(PA,KPA,4)
      CALL GIVEN(PB,KPB,2)
      CALL GIVEN(PC,KPC,1)
      CALL GIVEN(DA,KDA,4)
      CALL GIVEN(DB,KDB,2)
      CALL GIVEN(DC,KDC,1)
      CALL GIVEN(P1,KP1,4)
      CALL GIVEN(D1,KD1,4)
      CALL GIVEN(P2,KP2,2)
      CALL GIVEN(D2,KD2,2)
      L1 = IBITOR(IBITOR(KPA,KPB),
     +     IBITOR(IBITOR(KPC,KDA),IBITOR(KDB,KDC)))
      IF (L1.EQ.0) GO TO 280
      IF (L1.NE.7) THEN
C
C====== a,b,c are not all given.   see whether pairs are given
C
         L1 = IBITOR(IBITOR(KPA,KPB),IBITOR(KDA,KDB))
         IF (L1.EQ.6) GO TO 250
 
         L1 = IBITOR(IBITOR(KPA,KPC),IBITOR(KDA,KDC))
         IF (L1.EQ.5) GO TO 260
         L1 = IBITOR(IBITOR(KPB,KPC),IBITOR(KDB,KDC))
         IF (L1.NE.3) GO TO 280
         GO TO 270
      ELSE
C
C====== a,b,c are given.   check whether they are poles or
C====== directions (or combination) and jump to appropriate section
C
         L1 = IBITOR(KPA,IBITOR(KPB,KPC))
C
C====== are a,b,c all poles
C
         IF (L1.NE.7) THEN
            L1 = IBITOR(KDA,IBITOR(KDB,KDC))
C
C====== are a,b,c all directions
C
            IF (L1.NE.7) THEN
C
C====== Find whether pole or direction and normalise
C
               IF (KDA.NE.4) THEN
                  X = PNORM(PA)
               ELSE
                  X = DNORM(DA)
               END IF
               IF (KDB.NE.2) THEN
                  X = PNORM(PB)
               ELSE
                  X = DNORM(DB)
               END IF
               IF (KDC.NE.1) THEN
                  X = PNORM(PC)
               ELSE
                  X = DNORM(DC)
               END IF
C
C====== Find pairs of directions or poles
C
               IF ((KDA.NE.4) .OR. (KDB.NE.2)) THEN
                  IF ((KDA.EQ.4) .AND. (KDC.EQ.1)) GO TO 150
                  IF ((KDB.EQ.2) .AND. (KDC.EQ.1)) GO TO 140
                  IF ((KPA.EQ.4) .AND. (KPB.EQ.2)) GO TO 250
                  IF ((KPA.EQ.4) .AND. (KPC.EQ.1)) GO TO 260
                  IF ((KPB.EQ.2) .AND. (KPC.EQ.1)) GO TO 270
                  CALL TWRITE('!!! Oops')
                  RETURN
               END IF
            ELSE
C
C====== a,b and c are directions
C
               X = DNORM(DA)
               X = DNORM(DB)
               X = DNORM(DC)
               JMP = 1
 80            DO 90 I = 1 , 3
                  AA(1,I) = DA(I)
                  AA(2,I) = DB(I)
                  AA(3,I) = DC(I)
 90            CONTINUE
               JM = JMP - 2
               IF (JM.LT.0) THEN
                  BB(1) = 1.
                  BB(3) = 0.
                  BB(2) = BB(3)
                  CALL SOLVEQN(AA,BB,3,1,1,3,3)
                  DO 100 I = 1 , 3
                     PA(I) = BB(I)
 100              CONTINUE
                  JMP = 2
                  GO TO 80
               ELSE IF (JM.EQ.0) THEN
                  BB(3) = 0.
                  BB(1) = BB(3)
                  BB(2) = 1.
                  CALL SOLVEQN(AA,BB,3,1,1,3,3)
                  DO 110 I = 1 , 3
                     PB(I) = BB(I)
 110              CONTINUE
                  JMP = 3
                  GO TO 80
               ELSE
                  BB(2) = 0.
                  BB(1) = BB(2)
                  BB(3) = 1.
                  CALL SOLVEQN(AA,BB,3,1,1,3,3)
                  DO 120 I = 1 , 3
                     PC(I) = BB(I)
 120              CONTINUE
                  XA = PNORM(PA)
                  XB = PNORM(PB)
                  XC = PNORM(PC)
                  LL = CHECK1(XA,XB,XC)
                  IF (LL) GO TO 190
                  WRITE (ERSTR,6010) XA , XB , XC
                  CALL TWRITE(ERSTR)
                  ABORT = .TRUE.
                  RETURN
               END IF
            END IF
         ELSE
C
C====== a,b and c are poles
C
            X = PNORM(PA)
            X = PNORM(PB)
            X = PNORM(PC)
            GO TO 160
         END IF
      END IF
C
C====== a and b are directions , c is a pole
C
 130  CALL TWODIR(DA,DB,PA,PB,PC,3)
      IF (ABORT) GO TO 530
      KPA = 4
      KPB = 2
      GO TO 180
C
C====== b and c are directions , a is a pole
C
 140  CALL TWODIR(DB,DC,PB,PC,PA,5)
      IF (ABORT) GO TO 530
      KPB = 2
      KPC = 1
      GO TO 160
C
C====== a and c are directions , b is a pole
C
 150  CALL TWODIR(DA,DC,PA,PC,PB,4)
      IF (ABORT) GO TO 530
      KPA = 4
      KPC = 1
      GO TO 170
C
C====== Check if directions are known. it so then
C====== else calculate directions
C
 160  IF (KDA.NE.4) THEN
         JMP1 = 1
         GO TO 200
      END IF
 170  IF (KDB.NE.2) THEN
         JMP1 = 2
         GO TO 200
      END IF
 180  IF (KDC.NE.1) THEN
         JMP1 = 3
         GO TO 200
      END IF
 190  XA = DNORM(DA)
      XB = DNORM(DB)
      XC = DNORM(DC)
C
C====== Check that calculated values of a,b,c are orthogonal
C
      AB = COSAB(PA,PB)
      BC = COSAB(PB,PC)
      CA = COSAB(PC,PA)
      DEL3 = .0001
      IF ((ABS(AB).LT.DEL3) .AND. (ABS(BC).LT.DEL3) .AND. 
     +    (ABS(CA).LT.DEL3)) THEN
         LL = CHECK1(XA,XB,XC)
         IF (LL) THEN
            IF (SWAP.NE.0.) THEN
               PT = PHI1B
               DT = PHI1ZA
               PHI1B = PHI2B
               PHI1ZA = PHI2ZA
               PHI2B = PT
               PHI2ZA = DT
            END IF
            GO TO 530
         ELSE
            WRITE (ERSTR,6020) XA , XB , XC
            CALL TWRITE(ERSTR)
            ABORT = .TRUE.
            RETURN
         END IF
      ELSE
         AB = ACOS(AB)/CONV
         BC = ACOS(BC)/CONV
         CA = ACOS(CA)/CONV
         WRITE (ERSTR,6030) AB , BC , CA
         CALL TWRITE(ERSTR)
         WRITE (ERSTR,6040)
         CALL TWRITE(ERSTR)
         GO TO 20
      END IF
 200  DO 210 I = 1 , 3
         AA(1,I) = PA(I)
         AA(2,I) = PB(I)
         AA(3,I) = PC(I)
 210  CONTINUE
      JM = JMP1 - 2
      IF (JM.LT.0) THEN
         BB(1) = 1.
         BB(3) = 0.
         BB(2) = BB(3)
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 220 I = 1 , 3
            DA(I) = BB(I)
 220     CONTINUE
         GO TO 170
      ELSE IF (JM.EQ.0) THEN
         BB(3) = 0.
         BB(1) = BB(3)
         BB(2) = 1.
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 230 I = 1 , 3
            DB(I) = BB(I)
 230     CONTINUE
         GO TO 180
      ELSE
         BB(2) = 0.
         BB(1) = BB(2)
         BB(3) = 1.
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 240 I = 1 , 3
            DC(I) = BB(I)
 240     CONTINUE
         GO TO 190
      END IF
C
C====== a and b are given
C
 250  CALL TWOGIVN(DA,DB,DC,PA,PB,PC,6,KDA,KDB,KDC,KPA,KPB,KPC,4,2,1)
      IF (ABORT) GO TO 530
      IF (JOUT.EQ.1) GO TO 130
      IF (JOUT.EQ.2) GO TO 160
      IF (JOUT.EQ.3) GO TO 150
      IF (JOUT.EQ.4) GO TO 140
      IF (JOUT.LE.0) GO TO 130
      GO TO 140
C
C====== a and c are given
C
 260  CALL TWOGIVN(DC,DA,DB,PC,PA,PB,7,KDC,KDA,KDB,KPC,KPA,KPB,1,4,2)
      IF (ABORT) GO TO 530
      IF (JOUT.EQ.1) GO TO 150
      IF (JOUT.EQ.2) GO TO 160
      IF (JOUT.EQ.3) GO TO 140
      IF (JOUT.EQ.4) GO TO 130
      IF (JOUT.LE.0) GO TO 150
      GO TO 130
C
C====== b and c are given
C
 270  CALL TWOGIVN(DB,DC,DA,PB,PC,PA,8,KDB,KDC,KDA,KPB,KPC,KPA,2,1,4)
      IF (ABORT) GO TO 530
      IF (JOUT.EQ.1) GO TO 140
      IF (JOUT.EQ.2) GO TO 160
      IF (JOUT.EQ.3) GO TO 130
      IF (JOUT.EQ.4) GO TO 150
      IF (JOUT.LE.0) GO TO 140
      GO TO 150
C
C====== Find whether one of a,b,c is given
C
 280  L1 = IBITOR(KP1,KD1)
      IF (L1.EQ.0) THEN
         ERR(1) = 'POINT 1 NO'
         ERR(2) = 'T GIVEN   '
         GO TO 330
      END IF
 290  COSZA = COS(PHI1ZA*CONV)
      SINZA = SIN(PHI1ZA*CONV)
      COS1B = COS(PHI1B*CONV)
      SIN1B = SIN(PHI1B*CONV)
      IF (PHI1B.EQ.0.) SIN1B = 0.0
      IF (PHI1B.EQ.90.) SIN1B = 1.0
      IF (PHI1B.EQ.0.) COS1B = 1.0
      IF (PHI1B.EQ.90.) COS1B = 0.0
      IF (PHI1ZA.EQ.0.) COSZA = 1.0
      IF (PHI1ZA.EQ.90.) COSZA = 0.0
      IF (PHI1ZA.EQ.0.) SINZA = 0.0
      IF (PHI1ZA.EQ.90.) SINZA = 1.0
      IF (PHI1B.LT.0.) THEN
         WRITE (ERSTR,6050)
         CALL TWRITE(ERSTR)
         GO TO 20
      END IF
 300  L1 = IBITOR(KPA,KDA)
      IF (L1.NE.4) GO TO 370
C
C====== a is given
C
C====== Check for special cases
C
      IF (PHI1B.NE.0.) THEN
         IF (PHI1B.NE.180.) GO TO 320
C
C====== (1)=-B
C
         SIGN = -1.
         MM = 1
      ELSE
C
C====== (1)=B
C
         SIGN = 1.
         MM = 1
      END IF
 310  CALL POLDIR(PB,DB,KPB,KDB,2,SIGN,P1,D1,KP1)
      IF (MM.EQ.1) GO TO 250
      IF (MM.EQ.2) GO TO 270
 320  IF (PHI1B.NE.90.) GO TO 340
      IF (ABS(PHI1ZA).NE.90.) THEN
         IF (PHI1ZA.NE.0.) GO TO 340
         ERR(1) = 'A IS GIVEN'
         ERR(2) = ' TWICE    '
      ELSE
C
C====== (1)=C
C
         SIGN = 1.
         IF (PHI1ZA.EQ.-90.) SIGN = -1.
         CALL POLDIR(PC,DC,KPC,KDC,1,SIGN,P1,D1,KP1)
         GO TO 260
      END IF
 330  WRITE (ERSTR,6060) ERR
      CALL TWRITE(ERSTR)
      GO TO 20
C
C====== End special cases
C
 340  IF (PHI1ZA.NE.0.) THEN
         SIGN = 1
         CALL ONEGIVN(PA,DA,PB,DB,KPA,4,KPB,KDB,2,SIGN,V,KP2,SINZA,
     +                SIN1B,KP1)
         GO TO 250
      ELSE
         DO 350 I = 1 , 3
            P2(I) = PA(I)
            D2(I) = DA(I)
 350     CONTINUE
         IF (KPA.EQ.4) KP2 = 2
         IF (KDA.EQ.4) KD2 = 2
         CALL SPEC(PC,DC,KPC,KDC,V,1)
         IF (PHI1B.GE.90.) THEN
            DO 360 I = 1 , 3
               DC(I) = -DC(I)
               PC(I) = -PC(I)
 360        CONTINUE
         END IF
         KD2 = 0
         KP2 = KD2
         GO TO 260
      END IF
 370  L1 = IBITOR(KPB,KDB)
      IF (L1.NE.2) THEN
         L1 = IBITOR(KPC,KDC)
         IF (L1.NE.1) THEN
C
C====== No cardinal positions given
C
            L1 = IBITOR(IBITOR(KP1,KD1),IBITOR(KP2,KD2))
            IF (L1.NE.6) THEN
               ERR(1) = 'AT LEAST 2'
               ERR(2) = ' PTS REQD '
               GO TO 330
            ELSE IF (PHI2B.EQ.0.) THEN
               SIGN = 1.
               CALL POLDIR(PB,DB,KPB,KDB,2,SIGN,P2,D2,KP2)
               GO TO 280
            ELSE IF (PHI2B.NE.180.) THEN
               IF (PHI2B.NE.90.) GO TO 400
               IF (ABS(PHI2ZA).NE.90.) THEN
                  IF (PHI2ZA.NE.0.) GO TO 400
                  CALL POLDIR(PA,DA,KPA,KDA,4,1.,P2,D2,KP2)
                  GO TO 280
               ELSE
                  SIGN = 1.
                  IF (PHI2ZA.EQ.-90.) SIGN = -1.
                  CALL POLDIR(PC,DC,KPC,KDC,1,SIGN,P2,D2,KP2)
                  GO TO 280
               END IF
            ELSE
               SIGN = -1.
               CALL POLDIR(PB,DB,KPB,KDB,2,SIGN,P2,D2,KP2)
               GO TO 280
            END IF
C
C====== c is given
C
C
C====== Check for special cases
C
         ELSE IF (PHI1B.NE.0.) THEN
            IF (PHI1B.NE.90.) GO TO 390
            IF (PHI1ZA.EQ.0.) THEN
C
C====== (1)=A
C
               CALL POLDIR(PA,DA,KPA,KDA,4,1.,P1,D1,KP1)
               GO TO 260
            ELSE IF (PHI1ZA.NE.90.) THEN
               IF (PHI1ZA.NE.-90.) GO TO 390
               ERR(1) = 'C AND -C A'
               ERR(2) = 'RE GIVEN  '
               GO TO 330
            ELSE
               ERR(1) = 'C IS GIVEN'
               ERR(2) = ' TWICE    '
               GO TO 330
            END IF
         ELSE
C
C====== (1)=B
C
            SIGN = 1.
            MM = 2
            GO TO 310
         END IF
C
C====== b  is  given
C
      ELSE IF (PHI1B.NE.0.) THEN
         IF (PHI1B.EQ.180.) THEN
            ERR(1) = 'B AND -B A'
            ERR(2) = 'RE GIVEN  '
            GO TO 330
         END IF
      ELSE
         ERR(1) = 'B IS GIVEN'
         ERR(2) = ' TWICE    '
         GO TO 330
      END IF
 380  CALL BGIVN
      X = PNORM(PA)
      KPA = 4
      GO TO 250
 390  IF (PHI1B.NE.180.) THEN
         SIGN = -1.
         IF (PHI1ZA.LT.0.) SIGN = 1.
         CALL ONEGIVN(PC,DC,PB,DB,KPC,1,KPB,KDB,2,SIGN,V,KP2,SINZA,
     +                SIN1B,KP1)
         GO TO 270
      ELSE
C
C====== (1)=-B
C
         SIGN = -1.
         MM = 2
         GO TO 310
      END IF
 400  IF (D1(1).NE.0. .OR. D1(2).NE.0. .OR. D1(3).NE.0.) X = DNORM(D1)
      IF (D2(1).NE.0. .OR. D2(2).NE.0. .OR. D2(3).NE.0.) X = DNORM(D2)
      COS2B = COS(PHI2B*CONV)
      SIN2B = SIN(PHI2B*CONV)
      SIN2ZA = SIN(PHI2ZA*CONV)
      COS2ZA = COS(PHI2ZA*CONV)
      IF (PHI2B.EQ.0.) COS2B = 1.0
      IF (PHI2B.EQ.90.) COS2B = 0.0
      IF (PHI2B.EQ.0.) SIN2B = 0.0
      IF (PHI2B.EQ.90.) SIN2B = 1.0
      IF (PHI2ZA.EQ.0.) COS2ZA = 1.0
      IF (PHI2ZA.EQ.90.) COS2ZA = 0.0
      IF (PHI2ZA.EQ.0.) SIN2ZA = 0.0
      IF (PHI2ZA.EQ.90.) SIN2ZA = 1.0
      E = 0
      IF (SWAP.EQ.0.) CALL CHK12(E)
      IF (E.EQ.1.) RETURN
      IF (PHI2ZA.EQ.0.) THEN
         IF (PHI2B.EQ.0.) THEN
            KPB = 2
            IF (P2(1).EQ.0. .AND. P2(2).EQ.0. .AND. P2(3).EQ.0.) KDB = 2
            IF (KDB.EQ.2) KPB = 0
            DO 410 I = 1 , 3
               PB(I) = P2(I)
               DB(I) = D2(I)
               D2(I) = 0.
               P2(I) = D2(I)
 410        CONTINUE
            GO TO 380
         ELSE IF (PHI2B.EQ.180.) THEN
            KPB = 2
            IF (P2(1).EQ.0. .AND. P2(2).EQ.0. .AND. P2(3).EQ.0.) KDB = 2
            IF (KDB.EQ.2) KPB = 0
            DO 420 I = 1 , 3
               PB(I) = -P2(I)
               DB(I) = -D2(I)
               D2(I) = 0.
               P2(I) = D2(I)
 420        CONTINUE
            GO TO 380
         END IF
      END IF
      SAMEDIA = .FALSE.
      TH2 = 999.
      TH1 = TH2
      IF (PHI1ZA.EQ.0. .OR. PHI2ZA.EQ.0.) THEN
         IF (PHI1ZA.EQ.0. .AND. PHI1B.GT.90.) TH1 = XPI(1.)
         IF (PHI1ZA.EQ.0. .AND. PHI1B.LT.90.) TH1 = 0.0
         IF (PHI2ZA.EQ.0. .AND. PHI2B.GT.90.) TH2 = XPI(1.)
         IF (PHI2ZA.EQ.0. .AND. PHI2B.LT.90.) TH2 = 0.0
      END IF
      IF (PHI1B.EQ.90. .OR. PHI2B.EQ.90.) THEN
         IF (PHI1B.EQ.90. .AND. PHI1ZA.GT.0.) TH1 = XPI(0.5)
         IF (PHI1B.EQ.90. .AND. PHI1ZA.LT.0.) TH1 = XPI(1.5)
         IF (PHI2B.EQ.90. .AND. PHI2ZA.GT.0.) TH2 = XPI(0.5)
         IF (PHI2B.EQ.90. .AND. PHI2ZA.LT.0.) TH2 = XPI(1.5)
      END IF
      IF (TH1.EQ.999.) TH1 = ATAN(TAN(PHI1B*CONV)*ABS(SINZA))
      IF (TH2.EQ.999.) TH2 = ATAN(TAN(PHI2B*CONV)*ABS(SIN2ZA))
      IF (PHI1B.GT.90. .AND. PHI1ZA.NE.0.) TH1 = XPI(1.)
     +    + PHI1ZA/ABS(PHI1ZA)*TH1
      IF (PHI1B.LT.90. .AND. PHI1ZA.LT.0.) TH1 = XPI(2.) - TH1
      IF (PHI2B.GT.90. .AND. PHI2ZA.NE.0.) TH2 = XPI(1.)
     +    + PHI2ZA/ABS(PHI2ZA)*TH2
      IF (PHI2B.LT.90. .AND. PHI2ZA.LT.0.) TH2 = XPI(2.) - TH2
      IF (TH1.NE.TH2) THEN
         DIFF = ABS(TH2-TH1)
         IF (DIFF.NE.XPI(1.)) THEN
            IF (DIFF.LT.XPI(1.) .AND. TH1.LT.TH2) GO TO 430
            IF (DIFF.GT.XPI(1.) .AND. TH2.LT.TH1) GO TO 430
            GO TO 450
         END IF
      END IF
C
C====== 1 and 2 are on same diametral line
C
      IF (PHI1ZA.GT.PHI2ZA) GO TO 430
      IF (PHI1ZA.EQ.PHI2ZA) THEN
         IF (PHI2B.LT.PHI1B) GO TO 430
      END IF
      PHIZB = XPI(1.5) - TH2
      SAMEDIA = .TRUE.
      GO TO 450
C
C====== Swap points 1 and 2
C
 430  DO 440 I = 1 , 3
         PT = P1(I)
         DT = D1(I)
         P1(I) = P2(I)
         D1(I) = D2(I)
         P2(I) = PT
         D2(I) = DT
 440  CONTINUE
      PT = PHI1B
      DT = PHI1ZA
      PHI1B = PHI2B
      PHI1ZA = PHI2ZA
      PHI2B = PT
      PHI2ZA = DT
      PT = KP1
      KP1 = 0
      IF (KP2.EQ.2) KP1 = 4
      KP2 = 0
      IF (PT.EQ.4.) KP2 = 2
      PT = KD1
      KD1 = 0
      IF (KD2.EQ.2) KD1 = 4
      KD2 = 0
      IF (PT.EQ.4.) KD2 = 2
      SWAP = 1.
      GO TO 290
C
C====== Check for special cases
C
 450  IF (PHI1B.EQ.90.) THEN
         IF (PHI2B.EQ.90.) THEN
            CALL SPEC(PB,DB,KPB,KDB,V,2)
            GO TO 370
         END IF
      END IF
      IF (PHI1ZA.EQ.0.) THEN
         IF (PHI2ZA.EQ.0.) THEN
            CALL SPEC(PC,DC,KPC,KDC,V,1)
C
C====== Solving for db when phi1za=phi2za=0.
C
            BB(1) = COS1B
            BB(2) = COS2B
            BB(3) = 0.
            IF (KP1.EQ.4) THEN
               DO 460 J = 1 , 3
                  AA(1,J) = P1(J)
 460           CONTINUE
            ELSE
               CALL RST(P1,D1,Z,CC,0.)
               DO 470 J = 1 , 3
                  AA(1,J) = CC(J)
 470           CONTINUE
            END IF
            IF (KP2.EQ.2) THEN
               DO 480 J = 1 , 3
                  AA(2,J) = P2(J)
 480           CONTINUE
            ELSE
               CALL RST(P2,D2,Z,CC,0.)
               DO 490 J = 1 , 3
                  AA(2,J) = CC(J)
 490           CONTINUE
            END IF
            IF (KPC.EQ.1) THEN
               DO 500 J = 1 , 3
                  AA(3,J) = PC(J)
 500           CONTINUE
            ELSE
               CALL RST(PC,DC,Z,CC,0.)
               DO 510 J = 1 , 3
                  AA(3,J) = CC(J)
 510           CONTINUE
            END IF
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 520 J = 1 , 3
               DB(J) = BB(J)
 520        CONTINUE
            KDB = 2
            X = DNORM(DB)
            GO TO 270
         END IF
      END IF
      IF (ABS(PHI1ZA).NE.90. .OR. ABS(PHI2ZA).NE.90.) THEN
         IF (.NOT.(SAMEDIA)) THEN
            IF (PHIZB.EQ.999.) THEN
               CALL ZONEAX(PHI1ZA,PHI1B,PHIZB,CONV)
            END IF
         END IF
         COSZB = COS(PHIZB)
         CALL NOCDNL(PB,COS2B,COSZB,COS1B,V)
         KPB = 2
         GO TO 370
      ELSE
         CALL SPEC(PA,DA,KPA,KDA,V,4)
         GO TO 300
      END IF
 
 530  RETURN
C
C====== Format statements
C
 6010 FORMAT ('!!! FSLP: error 1 ',3F10.5)
 6020 FORMAT ('!!! fslp: error 2 ',3F10.5)
 6030 FORMAT ('!!! A,B,C are not orthogonal.',' check input data')
 6040 FORMAT ('angle AB=',F6.3,2X,'angle BC=',F6.3,2X,'angle CA=',F6.3)
 6050 FORMAT ('!!! Incorrect data - PHI1B negative')
 6060 FORMAT ('!!! Insufficient data provided - ',2A10)
      END
**==genbd.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GENBD         **
C*************************
C
C
      BLOCK DATA GENBD
C
      INCLUDE 'implicit_none.finc'
      COMMON /GENCH/ COMPND,CRYSID
      CHARACTER*76 COMPND
      CHARACTER*6  CRYSID
 
      COMMON /GENPAR/ XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,
     1                FILMW,FIDBOX,N1OD,BASEOD,G1OD,CURVE,
     2                NXRAST,NYRAST,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     3                IFLIP,XLOW,XHIGH,YLOW,YHIGH,IRD
      REAL XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,FILMW,FIDBOX,
     1     BASEOD,G1OD,CURVE,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     2     XLOW,XHIGH,YLOW,YHIGH
      INTEGER N1OD,NXRAST,NYRAST,IFLIP,IRD
 
      COMMON /FIDS/ FIDX(3),FIDY(3)
      REAL FIDX,FIDY
 
      DATA COMPND/'TEST SAMPLE'/,CRYSID/'CRYS'/
      DATA XC/0/,YC/0/,WC/0/,TWIST/0/,TILT/0/,BULGE/0/,YSCALE/0.998/
      DATA XREJ/0/,YREJ/0/,FILMW/120/,FIDBOX/5/,N1OD/128/
      DATA BASEOD/0.04/,G1OD/2.3/CURVE/0.07/
      DATA NXRAST/2400/,NYRAST/2400/DSCAL/2.0/
      DATA XLOW/1.0/,XHIGH/2400.0/,YLOW/1.0/,YHIGH/2400.0/
      DATA XCEN_IN/0.0/,YCEN_IN/0.0/,RASTSZ/50.0/,IFLIP/1/,IRD/0/
      DATA FIDX/-5000,-5000,5000/,FIDY/-4000,4000,4000/
      END
**==getdat.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GETDAT        **
C*************************
C
C
      SUBROUTINE GETDAT (IOPT,LABEL,INPFLE,DATFLE)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Read crystal parameters from file
C
      INTEGER IOPT
      CHARACTER*6 LABEL
      CHARACTER*12 INPFLE,DATFLE
C
C====== GLOBALS:
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
 
      COMMON /GENCH/ COMPND,CRYSID
      CHARACTER*76 COMPND
      CHARACTER*6  CRYSID
 
      COMMON /GENPAR/ XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,
     1                FILMW,FIDBOX,N1OD,BASEOD,G1OD,CURVE,
     2                NXRAST,NYRAST,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     3                IFLIP,XLOW,XHIGH,YLOW,YHIGH,IRD
      REAL XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,FILMW,FIDBOX,
     1     BASEOD,G1OD,CURVE,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     2     XLOW,XHIGH,YLOW,YHIGH
      INTEGER N1OD,NXRAST,NYRAST,IFLIP,IRD
 
      COMMON /FIDS/ FIDX(3),FIDY(3)
      REAL FIDX,FIDY
 
      INTEGER LENSTR
C
C====== LOCALS:
C
      LOGICAL ERROR,EOF
      CHARACTER*15 TEMP
      CHARACTER*80 DUMFLE
      CHARACTER*80 STR
      CHARACTER PATH*60,NAME*40,TYPE*8,VERS*8
      INTEGER ISAV,I,IFAIL
      INTEGER NFID
      REAL RCELL(6),CELL_PARAM(10)
      INTEGER     NVALS, NWORDS
      CHARACTER*32  WORDS(12)
      REAL VALUES(12)
      INTEGER    EXPECTED_NVALS(7)
      CHARACTER*3  SYSTEM_NAME
      CHARACTER*5  SYSTEMS(7)
      INTEGER    AXES(2), ISIGN
      CHARACTER*1  CHAR
      DATA   SYSTEMS  /'TRICL',
     1                 'MONOC',
     2                 'ORTHO',
     3                 'TETRA',
     4                 'HEXAG',
     5                 'RHOMB',
     6                 'CUBIC'/
      DATA   EXPECTED_NVALS  /6, 4, 3, 2, 2, 2, 1/
C
C-------------------------------------------------------------------------------
C
      CALL QSSETC(1,24)
      WRITE (STR,6010) INPFLE(1:LENSTR(INPFLE))
      CALL TPROMP(STR)
      CALL TREAD(DUMFLE,EOF)
      IF (EOF) GO TO 80
      IF (DUMFLE.EQ.' ') DUMFLE = INPFLE
 20   CALL CCPPSF(DUMFLE,PATH,NAME,TYPE,VERS)
      INPFLE = NAME
      DATFLE = NAME
      IF (TYPE.EQ.' ') DUMFLE = DUMFLE(1:LENSTR(DUMFLE))//'.gen'
 
      OPEN (UNIT=3,FILE=DUMFLE,STATUS='OLD',ERR=50,IOSTAT=IFAIL)
 
      WRITE (TEMP,6020) LABEL , DATFLE(1:LENSTR(DATFLE))
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      READ (3,'(A)',END=100) COMPND
      READ (3,'(A)',END=100) CRYSID
C
C====== Read Crystal Information
C======
C====== Expect input to be of form:
C======
C====== <cell_parameters> <crystal_system> <lattice> <spindle_axis> <beam_axis>
C======
C====== where:
C======     <cell_parameters> are up to six numbers, and are in the order
C======                 astar, bstar, cstar, alpha, beta, gamma
C======                 Only supply as many as needed e.g. for rhombohedral
C======                 just give   astar, alpha.
C======
C====== <crystal_system>  name of crystal system - only first three letters
C======                 are used, e.g. tri for triclinic
C======
C====== <lattice>         a single letter for the type of unit cell. Default P
C======
C====== <beam_axis>       a word is needed here - only first two characters used
C======                 i.e.  can start with  +a , +b , +c , -a , -b , -c
C======                 specifies alignment of reciprocal lattice wrt.
C======                 beam axis (i.e. X-axis)
C======
C====== <spindle_axis>    similar form to <beam_axis> but this time specifies
C======                 alignment wrt. spindle axis (i.e. Z-axis)
C======
C====== An e.g. of a complete input line is:
C======
C======     0.123 0.456 0.0789  ortho a +astar -cstar
C======
C====== but could be shortened to
C======
C======     0.123 0.456 0.0789  ort a a -c
C======
C====== Upper or lower case can be used and intermixed freely
C
C-------------------------------------------------------------------------------
C
      ERROR = .FALSE.
 
      READ (3,'(A)',END=30) STR
 30   CALL STRTKN(STR,' ,',10,WORDS,NWORDS,CELL_PARAM,NVALS)
 
      IF (NWORDS.LE.4) THEN
         IF (NWORDS.EQ.3) THEN
            WORDS(4) = WORDS(3)
            WORDS(3) = WORDS(2)
            WORDS(2) = 'P'
         END IF
 
         CALL TOUPPR(WORDS(1))
         CALL TOUPPR(WORDS(2))
         CALL TOUPPR(WORDS(3))
         CALL TOUPPR(WORDS(4))
 
         SYSTEM_NAME = WORDS(1)(1:3)
         DO 40 I = 1 , 7
            IF (SYSTEM_NAME.EQ.SYSTEMS(I)(1:3)) GO TO 60
 40      CONTINUE
      END IF
      GO TO 90
 50   CALL QSSETC(1,24)
      CALL TWRITE('!!! Cannot open file')
      CALL UGERR(IFAIL,STR)
      CALL TWRITE(STR)
      WRITE (STR,6030)
      CALL TPROMP(STR)
      CALL TREAD(DUMFLE,EOF)
      IF (EOF) GO TO 80
      IF (DUMFLE.NE.' ') GO TO 20
      INPFLE = 'control'
      DATFLE = 'control'
      WRITE (TEMP,6020) LABEL , DATFLE(1:LENSTR(DATFLE))
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      RETURN
 
 60   MSYS = I
      IF (NVALS.NE.EXPECTED_NVALS(I)) GO TO 90
 
      DO 70 I = 1 , 2
         IF (WORDS(I+2)(1:1).EQ.'-') THEN
            ISIGN = -1
            CHAR = WORDS(I+2)(2:2)
         ELSE IF (WORDS(I+2)(1:1).EQ.'+') THEN
            ISIGN = 1
            CHAR = WORDS(I+2)(2:2)
         ELSE
            ISIGN = 1
            CHAR = WORDS(I+2)(1:1)
         END IF
         AXES(I) = 0
         IF (CHAR.EQ.'A') AXES(I) = 1
         IF (CHAR.EQ.'B') AXES(I) = 2
         IF (CHAR.EQ.'C') AXES(I) = 3
         AXES(I) = AXES(I)*ISIGN
         IF (AXES(I).EQ.0) GO TO 90
 70   CONTINUE
      MROT = AXES(1)
      MBEAM = AXES(2)
C
C====== Set up arrays for systematic absences.
C
C====== 'R' only applies to rhombohedral indexed on hexagonal lattice
C
      IF (WORDS(2).EQ.'R' .AND. MSYS.NE.5) WORDS(2) = 'P'
      IF (WORDS(2).EQ.'P') THEN
         LATT = 'P'
         ISYS = 0
         KSYS(1) = 0
         KSYS(2) = 0
         KSYS(3) = 0
      ELSE IF (WORDS(2).EQ.'A') THEN
         LATT = 'A'
         ISYS = 2
         KSYS(2) = 1
         KSYS(3) = 1
      ELSE IF (WORDS(2).EQ.'B') THEN
         LATT = 'B'
         ISYS = 2
         KSYS(1) = 1
         KSYS(3) = 1
      ELSE IF (WORDS(2).EQ.'C') THEN
         LATT = 'C'
         ISYS = 2
         KSYS(1) = 1
         KSYS(2) = 1
      ELSE IF (WORDS(2).EQ.'I') THEN
         LATT = 'I'
         ISYS = 2
         KSYS(1) = 1
         KSYS(2) = 1
         KSYS(3) = 1
      ELSE IF (WORDS(2).EQ.'F') THEN
         LATT = 'F'
         ISYS = 4
      ELSE IF (WORDS(2).EQ.'R') THEN
         LATT = 'R'
         ISYS = 3
         KSYS(1) = -1
         KSYS(2) = 1
         KSYS(3) = 1
      ELSE
         GO TO 90
      END IF
      CALL CELLCX(MSYS,CELL_PARAM,RCELL,1,2)
C
C====== Read other parameters
C
      READ (3,*,END=100) PHIS
      READ (3,*,END=100) WVS , WVM , WVX
      READ (3,*,END=100) CTOF , DMIN , RADI
      READ (3,*,END=100) SPNDLE
      READ (3,*,END=100) XC , YC , WC
      READ (3,*,END=100) TWIST , TILT , BULGE
      READ (3,*,END=100) YSCALE
      READ (3,*,END=100) XREJ , YREJ
      READ (3,*,END=100) NFID , (FIDX(I),FIDY(I),I=1,3)
      READ (3,*,END=100) FILMW , FIDBOX , N1OD , BASEOD , G1OD
      READ (3,'(A)',END=100) STR
      CALL STRTKN(STR,' ,',12,WORDS,NWORDS,VALUES,NVALS)
      NXRAST = 2400
      IF (NVALS.GE.1) NXRAST = NINT(VALUES(1))
      NYRAST = 2400
      IF (NVALS.GE.2) NYRAST = NINT(VALUES(2))
      DSCAL = 2.0
      IF (NVALS.GE.3) DSCAL = VALUES(3)
      XCEN_IN = 0.0
      IF (NVALS.GE.4) XCEN_IN = VALUES(4)
      YCEN_IN = 0.0
      IF (NVALS.GE.5) YCEN_IN = VALUES(5)
      RASTSZ = 50.0
      IF (NVALS.GE.6) RASTSZ = VALUES(6)
      XLOW = 1.0
      IF (NVALS.GE.7) XLOW = VALUES(7)
      XHIGH = FLOAT(NXRAST)
      IF (NVALS.GE.8) XHIGH = VALUES(8)
      YLOW = 1.0
      IF (NVALS.GE.9) YLOW = VALUES(9)
      YHIGH = FLOAT(NYRAST)
      IF (NVALS.GE.10) YHIGH = VALUES(10)
      IFLIP = 1
      IF (NWORDS.GE.1) THEN
         IF (WORDS(1)(1:1).EQ.'i'.OR.WORDS(1)(1:1).EQ.'I') IFLIP = 2
      END IF
      CALL RECCEL(CELL,RCELL,WVS)
      IF (MSYS.EQ.2) THEN
         CELL(4) = 0.0
         CELL(6) = 0.0
      ELSE IF (MSYS.EQ.3) THEN
         CELL(4) = 0.0
         CELL(5) = 0.0
         CELL(6) = 0.0
      ELSE IF (MSYS.EQ.4) THEN
         CELL(2) = 0.0
         CELL(4) = 0.0
         CELL(5) = 0.0
         CELL(6) = 0.0
      ELSE IF (MSYS.EQ.5) THEN
         CELL(2) = 0.0
         CELL(4) = 0.0
         CELL(5) = 0.0
         CELL(6) = 0.0
      ELSE IF (MSYS.EQ.6) THEN
         CELL(2) = 0.0
         CELL(3) = 0.0
         CELL(5) = 0.0
         CELL(6) = 0.0
      ELSE IF (MSYS.EQ.7) THEN
         CELL(2) = 0.0
         CELL(3) = 0.0
         CELL(4) = 0.0
         CELL(5) = 0.0
         CELL(6) = 0.0
      END IF
      FSLPIN = ' '
 
      CLOSE (UNIT=3)
      IRD = 1
 80   RETURN
C
C====== Display error messages
C
 90   CALL QSSETC(1,24)
      CALL TWRITE('!!! Invalid crystals parameters in file')
      RETURN
 100  CALL QSSETC(1,24)
      CALL TWRITE('!!! Premature end of file when reading .gen file')
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter name of previously saved .gen',' file [',A,
     +        ']: ')
 6020 FORMAT (A6,A8,1X)
 6030 FORMAT ('>>> Enter file name: ')
      END
**==getfsl.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GETFSL        **
C*************************
C
C
      SUBROUTINE GETFSL
C
      INCLUDE 'pgstat.finc'
C
      COMMON /ANGLE/COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      COMMON /DATFLG/PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      LOGICAL PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +              RMAX,ULAM,LLAM,CL
       REAL         PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +              RMAX,ULAM,LLAM,CL
      LOGICAL EOF,ERR
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      CALL SETABC(A,B,C,ALPHA,BETA,GAMMA)
      CALL ANYORI
      IF (ABORT) GO TO 40
 20   IF (P1SET .OR. D1SET) THEN
         WRITE (STR,6010)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (EOF) GO TO 30
         PHI1ZA = FLPVAL(STR,ERR)
         IF (ERR) GO TO 40
         WRITE (STR,6020)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (EOF) GO TO 30
         PHI1B = FLPVAL(STR,ERR)
         IF (ERR) GO TO 40
      END IF
      IF (P2SET .OR. D2SET) THEN
         WRITE (STR,6030)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (EOF) GO TO 30
         PHI2ZA = FLPVAL(STR,ERR)
         IF (ERR) GO TO 40
         WRITE (STR,6040)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (EOF) GO TO 30
         PHI2B = FLPVAL(STR,ERR)
         IF (ERR) GO TO 40
      END IF
      RETURN
 30   WRITE (STR,6050)
      CALL TWRITE(STR)
      GO TO 20
 
 40   ABORT = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter the angle PHI1ZA: ')
 6020 FORMAT ('>>> Enter the angle PHI1B: ')
 6030 FORMAT ('>>> Enter the angle PHI2ZA: ')
 6040 FORMAT ('>>> Enter the angle PHI2B: ')
 6050 FORMAT ('!!! Error reading angle try again please')
      END
**==given.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GIVEN         **
C*************************
C
C
      SUBROUTINE GIVEN(AA,KA,I)
C
      REAL AA(3)
      INTEGER KA , I
C
C Purpose: Checks if aa is given
C
C
C====== LOCALS:
C
      INTEGER ICT
      SAVE ICT
      DATA ICT/ 0/
C
C-------------------------------------------------------------------------------
C
      ICT = ICT + 1
      IF (AA(1).EQ.0.) THEN
         IF (AA(2).EQ.0.) THEN
            IF (AA(3).EQ.0.) THEN
               KA = 0
               RETURN
            END IF
         END IF
      END IF
      KA = I
      RETURN
      END
**==gplot.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GPLOT         **
C*************************
C
C
      SUBROUTINE GPLOT
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Plot laue diffraction point
C
      REAL   X,Y
      INTEGER N
C
C X,Y : mm coords of point to be plotted
C N   : number of points
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'histo.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'project.finc'
 
      COMMON /FIDS/ FIDX(3),FIDY(3)
      REAL FIDX,FIDY
      COMMON /SYMTYP/ SYMB
      LOGICAL SYMB
C
C====== LOCALS:
C
      LOGICAL EOF
      REAL   RX,RY,RADIUS,XSTART,YSTART,XWIDTH,YWIDTH,DEVLEN
      INTEGER I,ISYMBOL,IOV
      REAL   CSIZ
      CHARACTER*1 ANSWER
C
C RX,RY  : scaled spot coordinates
C DEVLEN : Device dependent scaling factor adjusted for PSPACE
C
C-------------------------------------------------------------------------------
C
      SAVE /SYMTYP/
      SYMB = .TRUE.
      CALL TPROMP(
     +         '>>> Plot reflections as symbols (S) or points (P) [S]: '
     +         )
      CALL TREAD(ANSWER,EOF)
      CALL TOUPPR(ANSWER)
      SYMB = .TRUE.
      IF (ANSWER.EQ.'P') SYMB = .FALSE.
C
C====== Erase screen if required
C
      IF (.NOT.OVERLAY) THEN
         CALL QGENTR
         CALL QGCLR
         CALL QGPSET(2)
         CALL QGALPH
      END IF
 
      CALL TWRITE(' ')
      CALL TWRITE(' ')
      CALL TWRITE(' ')
      CALL TWRITE(' ')
C
C====== SCALE is multiplication factor to convert mm to device coordinates
C====== SQLEN is device dependent scaling factor set in routine SELPLT
C
      XSTART = 0.5*767.0
      XWIDTH = 0.83*767.0
      YSTART = 0.13*767.0
      YWIDTH = XWIDTH
C
C====== Select appropriate radius.
C
      IF (PROJTYPE.EQ.PROJLAUE) THEN
         RADIUS = RADI
      ELSE IF (PROJTYPE.EQ.PROJGNOM) THEN
         RADIUS = RADIGNOM
      ELSE
         RADIUS = RADISTER
      END IF
 
      IF (DEVICE.EQ.'FULL    ') DEVLEN = 2.0*RADIUS
      IF (DEVICE.NE.'FULL    ') DEVLEN = SQLEN*XWIDTH/767.0
      SCALE = 1.0
      IF (DEVICE.NE.'FULL    ') SCALE = 0.1
C
C====== XM,YM are centre coordinates in laue coords (mm)
C
      XM = 0.5*DEVLEN
      YM = 0.5*DEVLEN
C
C====== Set device and problem space
C
      CALL QGMAPC(XSTART,XSTART+XWIDTH,YSTART,YSTART+YWIDTH,0.0,DEVLEN,
     +            0.0,DEVLEN)
      CALL QGENTR
C
C====== Draw plot boundary and fiducials only for single graph
C
      IF (.NOT.(OVERLAY)) THEN
         CALL QGMOVE(0.0,0.0)
         CALL QGDRAW(0.0,DEVLEN)
         CALL QGDRAW(DEVLEN,DEVLEN)
         CALL QGDRAW(DEVLEN,0.0)
         CALL QGDRAW(0.0,0.0)
C
C====== Draw fiducial at centre of plot
C
         CSIZ = 4.0
         IF (.NOT.SYMB) CSIZ = 2.0
         CALL QGSYMB(XM,YM,1,CSIZ)
         IF (ISWIT.NE.2) CALL QGCIRC(XM,YM,RADIUS*SCALE,0.0,360.0,360)
C
C====== If not a film plot or radius is too small, don't draw other fiducials
C
         IF (PROJTYPE.EQ.PROJLAUE .AND. RADI.GT.50.2) THEN
            CALL QGSYMB(XM+FIDX(1)*0.01*SCALE,YM+FIDY(1)*0.01*SCALE,1,
     +                  CSIZ)
            CALL QGSYMB(XM+FIDX(2)*0.01*SCALE,YM+FIDY(2)*0.01*SCALE,1,
     +                  CSIZ)
            CALL QGSYMB(XM+FIDX(3)*0.01*SCALE,YM+FIDY(3)*0.01*SCALE,1,
     +                  CSIZ)
         END IF
      END IF
C
C====== Draw a cross or * at each laue point
C====== + for singlets, * for multiplets
C====== for overlay square & square plus cross
C
      CSIZ = 2.0
      IOV = 0
      IF (OVERLAY) IOV = 2
      DO 20 I = 1 , NB
         RX = XM + XABS(I)*SCALE
         RY = YM + YORD(I)*SCALE
         IF (.NOT.(SYMB)) THEN
            CALL QGSYMB(RX,RY,0,0.15)
         ELSE IF (MULTXY(I).GT.1) THEN
            CALL QGSYMB(RX,RY,IOV+1,CSIZ)
            CALL QGSYMB(RX,RY,2,CSIZ)
         ELSE
            CALL QGSYMB(RX,RY,IOV+1,CSIZ)
         END IF
 20   CONTINUE
      RETURN
      END
**==gunplt.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       GUNPLT        **
C*************************
C
C
      SUBROUTINE GUNPLT(RX,RY,X,Y)
C
C Purpose: Convert from cursor to mm coords & check that cursor
C          was within film radius.
C
      REAL   X,Y
      REAL   RX,RY
C
C X,Y    : spot coordinates
C RX,RY  : cursor coordinates
C
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'radc.finc'
      LOGICAL INCIRC
C
C-------------------------------------------------------------------------------
C
C====== RX,RY are cursor coordinates user has supplied
C====== X,Y are returned mm coordinates of point
C====== SCALE converts point coords from device to laue spot coords
C
      X = (RX-XM)/SCALE
      Y = (RY-YM)/SCALE
      IF (.NOT.INCIRC(X,Y)) THEN
         X = 0.0
         Y = 0.0
      END IF
      RETURN
      END
**==hard.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       HARD          **
C*************************
C
C
      SUBROUTINE HARD (LABEL)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Prints hard copy of plot with associated parameter values
C
      CHARACTER*6 LABEL(*)
C
C LABEL  : names of options
C
C
      INCLUDE 'progdim.finc'
      INCLUDE 'histo.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'laues.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
      INCLUDE 'project.finc'
 
      COMMON /SYMTYP/ SYMB
      LOGICAL SYMB
 
C
C====== LOCALS:
C
      LOGICAL      EOF
      INTEGER      I,ILINE,NCHAR
      REAL         YP
      CHARACTER*9  DAT,TIM
      CHARACTER*16 BLANK
      CHARACTER*80 FILNAM
      CHARACTER*13 PROJEC
      CHARACTER*80 COMMENT
      SAVE /SYMTYP/
 
      DATA BLANK/'                '/
C
C-------------------------------------------------------------------------------
C
      CALL QGENTR
      CALL QGPIXC
C
C====== Print logo and date
C
      WRITE (COMMENT,6090)
      CALL QGTEXT(375.0,750.0,12.0,COMMENT(1:42))
 
      CALL UTIME(TIM)
      CALL CCPDAT(DAT)
      WRITE (COMMENT,6100) DAT , TIM
      CALL QGTEXT(375.0,78.0,12.0,COMMENT(1:20))
 
      IF (PROJTYPE.EQ.PROJSTER) THEN
         PROJEC = 'Stereographic'
      ELSE IF (PROJTYPE.EQ.PROJGNOM) THEN
         PROJEC = '    Gnomonic'
      ELSE
         PROJEC = '        Film'
      END IF
      WRITE (COMMENT,6010) PROJEC
      CALL QGTEXT(527.0,78.0,12.0,COMMENT(1:24))
 
      WRITE (COMMENT,6020) DEVICE
      CALL QGTEXT(793.0,78.0,12.0,COMMENT(1:24))
C
C====== Print spot type identification
C
      IF (SYMB) THEN
         CALL QGTEXT(375.0,39.0,12.0,'Single pattern:')
         CALL QGTEXT(523.0,39.0,12.0,'Single spots')
         CALL QGSYMB(613.0,43.0,1,2.0)
         CALL QGTEXT(624.0,39.0,12.0,'Multiple spots')
         CALL QGSYMB(731.0,43.0,1,2.0)
         CALL QGSYMB(731.0,43.0,2,2.0)
         IF (OVERLAY) THEN
            CALL QGTEXT(375.0,23.0,12.0,'Overlayed pattern:')
            CALL QGTEXT(523.0,23.0,12.0,'Single spots')
            CALL QGSYMB(613.0,27.0,3,2.0)
            CALL QGTEXT(624.0,23.0,12.0,'Multiple spots')
            CALL QGSYMB(731.0,27.0,3,2.0)
            CALL QGSYMB(731.0,43.0,2,2.0)
         END IF
      END IF
C
C====== Print parameter values
C
      CALL QGTEXT(0.0,750.0,18.0,'Crystal Parameters')
 
      YP = 707.0
      WRITE (COMMENT,6080) LABEL(12) , MSYST(MSYS+1) , LATT
      CALL QGTEXT(0.0,YP,16.0,COMMENT(1:15))
 
      DO 20 I = 1 , 6
         YP = YP - 18.0
         IF (CELL(I).NE.0.0) WRITE (COMMENT,6030) LABEL(I) , CELL(I)
         IF (CELL(I).EQ.0.0) WRITE (COMMENT,6040) LABEL(I)
         CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 20   CONTINUE
 
      WRITE (COMMENT,6030) LABEL(7) , WVM
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6030) LABEL(8) , WVX
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6030) LABEL(9) , CTOF
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6030) LABEL(10) , DMIN
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6030) LABEL(11) , RADI
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6030) LABEL(17) , SPNDLE
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      WRITE (COMMENT,6060) LABEL(13) , MAXIS(MROT+4) , MAXIS(MBEAM+4)
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 
      DO 30 I = 1 , 3
         WRITE (COMMENT,6070) LABEL(13+I) , PHIS(I)
         YP = YP - 18.0
         CALL QGTEXT(0.0,YP,18.0,COMMENT(1:15))
 30   CONTINUE
C
C====== Print multiplicities
C
      YP = 340.0
      CALL QGTEXT(0.0,YP,18.0,'Multiplicity')
      YP = YP - 18.0
      CALL QGTEXT(0.0,YP,18.0,' M  Spots     Lambda  Spots')
 
      YP = YP - 18.0
      DO 40 I = 1 , 15
         YP = YP - 18.0
         WRITE (COMMENT,6050) I , NMULT(I) , WMULT(I) , NHOLD(I)
         CALL QGTEXT(0.0,YP,18.0,COMMENT(1:26))
 40   CONTINUE
C
C====== Prompt for comment line
C
      CALL QGALPH
      CALL QSSETC(1,24)
      CALL TPROMP('>>> Enter comment: ')
      CALL QSBELL
      CALL TREAD(COMMENT,EOF)
      IF (.NOT.(EOF)) THEN
C
C====== Count characters in string
C
         NCHAR = 1
         DO 50 I = 80 , 1 , -1
            IF (COMMENT(I:I).NE.' ') GO TO 60
 50      CONTINUE
 
 60      NCHAR = I
         CALL QGENTR
 
         CALL QGTEXT(375.0,55.0,12.0,COMMENT(1:NCHAR))
         CALL QGALPH
C
C====== Save the picture in the postscript file
C
         CALL QGALPH
         CALL QSSETC(1,24)
         CALL TPROMP(
     +         '>>> Enter name for output Postscript file [output.ps]: '
     +         )
         CALL TREAD(FILNAM,EOF)
         IF (.NOT.(EOF)) THEN
            IF (FILNAM.EQ.' ') FILNAM = 'output.ps'
            OPEN (UNIT=25,FILE=FILNAM,ERR=70)
            CALL QGWRPS(25,1)
         END IF
      END IF
 
 70   CALL QGENTR
      CALL QGCLR
      CALL QGALPH
 
      IF (OVERLAY) OVERLAY = .FALSE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT (A13,' Projection')
 6020 FORMAT (' Plotter scale: ',A8)
 6030 FORMAT (A6,1X,F8.4)
 6040 FORMAT (A6,9X)
 6050 FORMAT (I2,I6,2X,F9.3,1X,I6)
 6060 FORMAT (A6,1X,A3,',',A3,1X)
 6070 FORMAT (A6,F8.2,1X)
 6080 FORMAT (A6,1X,A3,1X,',',1X,A1,1X)
 6090 FORMAT ('Program NEWLAUE')
 6100 FORMAT (A9,2X,A9)
      END
**==hexagn.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       HEXAGN        **
C*************************
C
C
      SUBROUTINE HEXAGN(CELL)
C
      REAL CELL(*)
C
C-------------------------------------------------------------------------------
C
      CELL(1) = 2.0/(SQRT(3.0)*CELL(1))
      CELL(3) = 1.0/CELL(3)
      RETURN
      END
**==hklxyz.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       HKLXYZ        **
C*************************
C
C
      SUBROUTINE HKLXYZ(DSTMAX,IFLAG,USED)
C
      LOGICAL USED
C
C Purpose:
C
C  Routine to calculate and store orthogonal reciprocal lattice coords
C  for all reflections within dstar-max in the hemisphere +h, all k,l.
C  In essence the routine flow is to
C       (1) increase h from 0 to min
C       (2) increase k from 0 to max, then
C           decrease k from -1 to min
C       (3) increase l from 0 to max, then
C           decrease l from -1 to min
C  with h varying least, l most rapidly. The max and min values are
C  determined by a dstar which exceeds the limit. Complications are
C  caused by non-orthogonal cells: for given h,k l=0 may exceed dstar-
C  max, but some other l may not. The logic is that if at least one l
C  for given h,k is found within dstar-max, then the l loops end when
C  dstar exceeds dstar-max. If such an l is not found then the loops end
C  in both directions when the calculated dstar is increasing. Similarly
C  for the control of k loops, where the test is for at least one k,l
C  inside for given h.
C
C  An ordinary first entry has iflag=0. On return nr is the number of
C  reciprocal lattice points saved. If nr reaches the array limit then
C  the user has the option of truncating the search (in which case iflag
C  remains as 0) or setting iflag=1 to tell the main routine to cause
C  these spots to be plotted and then to return here to generate the nex
C  set.
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'xysav.finc'
 
      COMMON/AMAT/ A(3,3),DUMMY(3,3)
      COMMON/SYS/ISYS,KSYS(3)
      COMMON/SPOTS/ NR
 
      CHARACTER*1 IYN
      LOGICAL ABSNT,SYSABSF,EOF
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
C
C====== Re-entry with iflag=1
C
      IF (IFLAG.EQ.1) THEN
         NR = NR + 1
C
C====== Increment l and continue
C
         IF (LPOS) THEN
            L = L + 1
         ELSE
            L = L - 1
         END IF
         GO TO 40
      END IF
C
C====== Initialisations
C
      DSTEST = DSTMAX*DSTMAX
      NR = 1
      KSTART = 0
      LSTART = 0
C
C====== Start h loop
C
      H = 0
C
C====== Start k loop
C
 20   K = KSTART
      KPOS = .TRUE.
C
C====== Do not use 0k. as well as 0-k.
C
      IF (H.EQ.0 .AND. K.EQ.0) KPOS = .FALSE.
      KIN = .FALSE.
      DST2KM = 1000.
C
C====== Check for this h,k systematically absent, whatever the l value
C
 30   IF (ISYS.NE.0) THEN
         CALL SYSAHK(H,K,ABSNT)
         IF (ABSNT) THEN
            IF (KPOS) THEN
               K = K + 1
            ELSE
               K = K - 1
            END IF
            GO TO 30
         END IF
      END IF
C
C====== Start l loop - skip 000 and do not do 00l as well as 00-l
C
      L = LSTART
      IF (H.EQ.0 .AND. K.EQ.0) THEN
         LPOS = .FALSE.
         L = -1
      ELSE
         LPOS = .TRUE.
      END IF
      LIN = .FALSE.
      DST2LM = 1000.
C
C====== Check for this h,k,l systematically absent
C
 40   IF (ISYS.NE.0) THEN
         CALL SYSABS(H,K,L,ABSNT)
         IF (ABSNT .OR. (USED .AND. SYSABSF(H,K,L))) THEN
            IF (LPOS) THEN
               L = L + 1
            ELSE
               L = L - 1
            END IF
            GO TO 40
         END IF
      END IF
C
C====== Calculate dstar squared.
C
      XG(NR) = A(1,1)*H + A(1,2)*K + A(1,3)*L
      YG(NR) = A(2,1)*H + A(2,2)*K + A(2,3)*L
      ZG(NR) = A(3,1)*H + A(3,2)*K + A(3,3)*L
      DST2 = XG(NR)**2 + YG(NR)**2 + ZG(NR)**2
C
C====== Test for within resolution
C
      IF (DST2.LE.DSTEST) THEN
         IHKL(NR) = IPACK(H,K,L)
         LIN = .TRUE.
         KIN = .TRUE.
         NR = NR + 1
         IF (NR.GT.LIMIT) THEN
C
C====== Ran out of array space
C
            IF (IFLAG.EQ.0) THEN
               WRITE (STR,6010) LIMIT , H , K , L
               CALL TWRITE(STR)
               WRITE (STR,6020)
               CALL TPROMP(STR)
               CALL TREAD(IYN,EOF)
               IF (EOF) THEN
C
                  ABORT = .TRUE.
                  RETURN
               ELSE
                  IF (IYN.EQ.'Y' .OR. IYN.EQ.'y') THEN
                     WRITE (STR,6030)
                     CALL TWRITE(STR)
                     NR = LIMIT
                     RETURN
                  ELSE
                     WRITE (STR,6040)
                     CALL TWRITE(STR)
                     WRITE (STR,6050)
                     CALL TWRITE(STR)
                  END IF
                  IFLAG = 1
               END IF
            END IF
            NR = LIMIT
            RETURN
         ELSE
C
C====== Increment l and continue
C
            IF (LPOS) THEN
               L = L + 1
            ELSE
               L = L - 1
            END IF
            GO TO 40
         END IF
C
C====== hkl outside resolution ... test if any hits for this l so far
C
      ELSE IF (LIN) THEN
C
C====== Yes ... reverse l direction
C
         IF (LPOS) THEN
            LPOS = .FALSE.
            L = LSTART - 1
            GO TO 40
C
C====== or increment k if already reversed l
C
         ELSE IF (KPOS) THEN
            K = K + 1
         ELSE
            K = K - 1
         END IF
         GO TO 30
C
C===== No  ... check if getting closer ... save and continue if so
C
      ELSE IF (DST2.LT.DST2LM) THEN
         DST2LM = DST2
         IF (LPOS) THEN
            L = L + 1
         ELSE
            L = L - 1
         END IF
         GO TO 40
C
C====== Getting further away ... reverse l and continue
C
      ELSE IF (LPOS) THEN
         LPOS = .FALSE.
         L = LSTART - 1
         GO TO 40
C
C====== No hits for this l so far ... test if any for this k so far
C
      ELSE IF (KIN) THEN
C
C====== Yes ... reverse k direction
C
         IF (KPOS) THEN
            KPOS = .FALSE.
            K = KSTART - 1
            GO TO 30
C
C====== or increment h if already reversed k
C
         ELSE
            H = H - 1
         END IF
         GO TO 20
C
C====== No  ... check if getting closer ... save and continue if so
C
      ELSE IF (DST2.LT.DST2KM) THEN
         DST2KM = DST2
         IF (KPOS) THEN
            K = K + 1
         ELSE
            K = K - 1
         END IF
         GO TO 30
C
C====== Getting further away ... reverse k and continue
C
      ELSE IF (KPOS) THEN
         KPOS = .FALSE.
         K = KSTART - 1
         GO TO 30
C
C====== No hits for this h value so stop, returning iflag=0 to mark end
C
      ELSE
         IFLAG = 0
         NR = NR - 1
         RETURN
      END IF
C
C====== Format statements
C
 6010 FORMAT ('!!! Limit of',I6,' reflections reached at H,K,L=',3I4)
 6020 FORMAT ('>>> Do you wish to truncate calculation here (Y/N)',
     +        ' [N]: ')
 6030 FORMAT ('OK. Will truncate here and plot what exists')
 6040 FORMAT ('OK. Will plot these, then return for more')
 6050 FORMAT ('Be advised that reciprocal space will not be saved')
      END
**==i1stch.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       I1STCH        **
C*************************
C
C
      INTEGER FUNCTION I1STCH(STRING)
C
C Purpose: Returns the location of the first non-blank
C          character in string or zero if string is blank
C
      CHARACTER*(*) STRING
C
C STRING : the character string in question
C
C====== LOCALS:
C
      INTEGER I
C
C I      : the single character index under scrutiny
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , LEN(STRING)
         IF (STRING(I:I).NE.' ') THEN
            I1STCH = I
            GO TO 30
         END IF
 20   CONTINUE
      I1STCH = 0
 30   RETURN
      END
**==ibitor.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       IBITOR        **
C*************************
C
C
      INTEGER FUNCTION IBITOR(II,JJ)
C
      INTEGER IRES(32)
      INTEGER I31
C
      DATA I31/31/
C
C-------------------------------------------------------------------------------
C
      I = II
      J = JJ
      DO 20 JK = 1 , 32
         IRES(JK) = 0
 20   CONTINUE
      IRE = 0
      INDIC = 0
      JNDJC = 0
      IF (I.LT.0) THEN
         INDIC = -1
         I = 2**I31 + I
      END IF
      IF (J.LT.0) THEN
         JNDJC = -1
         J = 2**I31 + J
      END IF
      DO 30 JK = 1 , 31
         IF ((MOD(I,2).EQ.1) .OR. (MOD(J,2).EQ.1)) THEN
            IRES(JK) = +1
         END IF
         I = I/2
         J = J/2
 30   CONTINUE
      DO 40 JK = 32 , 1 , -1
         IRE = IRES(JK) + IRE*2
 40   CONTINUE
      IF ((INDIC.LT.0) .OR. (JNDJC.LT.0)) THEN
         IRE = IRE + 2**I31
      END IF
      IBITOR = IRE
      RETURN
      END
**==icvt.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ICVT          **
C*************************
C
C
      INTEGER FUNCTION ICVT(STRING)
C
      CHARACTER*(*) STRING
C
C-------------------------------------------------------------------------------
C
      ISIGN = 1
      NUM = 0
      IPOS = I1STCH(STRING)
      IF (STRING(IPOS:IPOS).EQ.'-') THEN
         IPOS = IPOS + 1
         ISIGN = -1
      END IF
      DO 20 I = IPOS , LEN(STRING)
         IVAL = INDEX('0123456789',STRING(I:I)) - 1
         IF (IVAL.LT.0) GO TO 30
         NUM = NUM*10 + IVAL
 20   CONTINUE
 30   ICVT = NUM*ISIGN
      RETURN
      END
**==ihcf.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       IHCF          **
C*************************
C
C
      INTEGER FUNCTION IHCF (II, JJ)
C
      INTEGER II, JJ
C
C Purpose: To find the highest common factor of two positive integers
C
C Author: Ian Clifton
C
C====== LOCALS:
C
      INTEGER I, J, K, ISAV
C
C-------------------------------------------------------------------------------
C
      I = II
      J = JJ
      IF (I.EQ.J) THEN
         IHCF = I
         RETURN
      END IF
      IF (I.LT.J) THEN
         ISAV = I
         I = J
         J = ISAV
      END IF
      IF (J.EQ.0) THEN
         IHCF = I
         RETURN
      END IF
 20   K = MOD(I,J)
      IF (K.EQ.0) THEN
         IHCF = J
         RETURN
      END IF
      I = J
      J = K
      GO TO 20
      END
**==incirc.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INCIRC        **
C*************************
C
C
      LOGICAL FUNCTION INCIRC(XF,YF)
 
C Purpose: Decide whether film point XF,YF is inside the appropriate circle
C          for the projection.
C
      INCLUDE 'radc.finc'
      INCLUDE 'project.finc'
C
C-------------------------------------------------------------------------------
C
      IF (PROJTYPE.EQ.PROJLAUE) THEN
         IF (ABS(XF).GT.RADI) GO TO 20
         IF (ABS(YF).GT.RADI) GO TO 20
         IF ((XF*XF+YF*YF).GT.RADI2) GO TO 20
      ELSE IF (PROJTYPE.EQ.PROJGNOM) THEN
         IF (ABS(XF).GT.RADIGNOM) GO TO 20
         IF (ABS(YF).GT.RADIGNOM) GO TO 20
         IF ((XF*XF+YF*YF).GT.RADIGNOM2) GO TO 20
      ELSE
         IF (ABS(XF).GT.RADISTER) GO TO 20
         IF (ABS(YF).GT.RADISTER) GO TO 20
         IF ((XF*XF+YF*YF).GT.RADISTER2) GO TO 20
      END IF
      INCIRC = .TRUE.
      RETURN
 20   INCIRC = .FALSE.
      RETURN
      END
**==indang.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INDANG        **
C*************************
C
C
      SUBROUTINE INDANG
C
C Purpose: This is a dual purpose routine
C          if nref=0 on entry then first generate reflections with small hkl
C          otherwise nref reflections have already been generated
C
      INCLUDE 'newlaue_auto_params.finc'
C
C     .. Scalars in Common ..
      REAL CF,DMIN,SPNDLE,WVM,WVS,WVX
      INTEGER ICENT,ILGP,ISYS,MBEAM,MROT,MSYS,NREF,NUMA,NUMC
C     ..
C     .. Arrays in Common ..
      REAL A(MAXARR,MAXARR),B(MAXARR),CCELL(6),CELL(6),PHIS(3)
      INTEGER INDX(MAXARR,3),KSYS(3)
C     ..
C     .. Local Scalars ..
      INTEGER I,II,IIT,IITT,ITEST,J,JJ,JJT,JJTT,JTEST,KK,KKT,KKTT,M,MM,
     1        NMAX,NRAD2
      LOGICAL ABSNT
C     ..
C     .. Local Arrays ..
      REAL AA(3,3),AC1(3,3),AC2(3,3),AC3(3,3),AC4(3,3),AC5(3,3),
     1     AC6(3,3),XREF(4,MAXARR)
C     ..
C     .. External Subroutines ..
      EXTERNAL CLEAR,MATS,SYSABS
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,ACOS,MOD,SQRT,IABS
C     ..
C     .. Common blocks ..
      COMMON /AUTO/NREF,INDX,B,A
      COMMON /DATA/CELL,WVM,WVX,WVS,CF,PHIS,SPNDLE,CCELL,NUMA,NUMC,DMIN
      COMMON /MATRIX/MSYS,MROT,MBEAM,ILGP,ICENT
      COMMON /SYS/ISYS,KSYS
C     ..
      LOGICAL EOF,ERR
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      IF (NREF.LE.0) THEN
C
C====== Generate reflections in a sphere, maximum index 5 is limited by
C====== the nrad2 limit which follows
C
         NMAX = MAXHKL
         NRAD2 = 10
         WRITE (STR,6010) MAXRAD2
         CALL TASKI(STR,NRAD2,EOF)
         IF (NRAD2.GT.MAXRAD2) THEN
            WRITE (STR,6020) MAXRAD2
            CALL TWRITE(STR)
            NRAD2 = MAXRAD2    
         END IF
 
         DO 60 II = -NMAX , NMAX
            ITEST = II**2
            IF (ITEST.LE.NRAD2) THEN
               DO 50 JJ = -NMAX , NMAX
                  JTEST = ITEST + JJ**2
                  IF (JTEST.LE.NRAD2) THEN
                     DO 40 KK = -NMAX , NMAX
                        IF ((JTEST+KK**2).GT.NRAD2) GO TO 40
                        IF (II.EQ.0 .AND. JJ.EQ.0 .AND. KK.EQ.0)
     +                      GO TO 40
C
C====== Identify harmonics
C
                        DO 30 M = 2 , NMAX
                           IF ((IABS(MOD(II,M))+IABS(MOD(JJ,M))+IABS(MOD
     +                         (KK,M))).EQ.0) THEN
                              IF (ISYS.EQ.0) GO TO 40
                              IIT = II/M
                              JJT = JJ/M
                              KKT = KK/M
                              DO 20 MM = 1 , M - 1
                                 IITT = IIT*MM
                                 JJTT = JJT*MM
                                 KKTT = KKT*MM
C
C====== and eliminate them if the fundamental or lower harmonic is present.
C
                                 CALL SYSABS(IITT,JJTT,KKTT,ABSNT)
                                 IF (.NOT.ABSNT) GO TO 40
 20                           CONTINUE
                           END IF
 
 30                     CONTINUE
C
C====== Eliminate systematic absences if there are any
C
                        IF (ISYS.NE.0) THEN
                           CALL SYSABS(II,JJ,KK,ABSNT)
                           IF (ABSNT) GO TO 40
                        END IF
 
                        NREF = NREF + 1
                        INDX(NREF,1) = II
                        INDX(NREF,2) = JJ
                        INDX(NREF,3) = KK
                        IF (NREF.EQ.MAXARR) THEN
                           WRITE (STR,6030) MAXARR
                           CALL TWRITE(STR)
                           GO TO 70
 
                        END IF
 
 40                  CONTINUE
                  END IF
 50            CONTINUE
            END IF
 60      CONTINUE
         WRITE (STR,6040) NREF
         CALL TWRITE(STR)
      END IF
C
C====== Evaluate the standard orientation matrix and then the r. l. coords
C
 70   CALL CLEAR(AA)
      CALL MATS(AA,AC1,AC2,AC3,AC4,AC5,AC6,CCELL)
      DO 80 I = 1 , NREF
         XREF(1,I) = AA(1,1)*INDX(I,1) + AA(1,2)*INDX(I,2) + AA(1,3)
     +               *INDX(I,3)
         XREF(2,I) = AA(2,1)*INDX(I,1) + AA(2,2)*INDX(I,2) + AA(2,3)
     +               *INDX(I,3)
         XREF(3,I) = AA(3,1)*INDX(I,1) + AA(3,2)*INDX(I,2) + AA(3,3)
     +               *INDX(I,3)
         XREF(4,I) = SQRT(XREF(1,I)**2+XREF(2,I)**2+XREF(3,I)**2)
 80   CONTINUE
C
C====== Now loop through all pairs of reflections calculating inter-planar
C====== angles
C
      DO 100 I = 1 , NREF
         DO 90 J = 1 , I
            IF (I.EQ.J) THEN
               A(I,J) = 0.0
               GO TO 90
 
            END IF
 
            A(I,J) = (XREF(1,I)*XREF(1,J)+XREF(2,I)*XREF(2,J)+XREF(3,I)
     +               *XREF(3,J))/(XREF(4,I)*XREF(4,J))
            IF (ABS(A(I,J)).GT.0.9999) THEN
               A(I,J) = 1.
            END IF
 
            A(I,J) = ACOS(A(I,J))
            A(J,I) = A(I,J)
 90      CONTINUE
 100  CONTINUE
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter a limit for h**2+k**2+l**2 (max=',I3,')')
 6020 FORMAT (' ',I3,' assumed.')
 6030 FORMAT ('!!! Only room for',I5,' standard reflections, sphere ',
     +        'incomplete')
 6040 FORMAT (I5,' reflections stored')
      END
**==indchk.f  
C LAST UPDATE:
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INDCHK        **
C*************************
C
C
      SUBROUTINE INDCHK(I,ITEST)
C
C Purpose: Check to see if reflection in position i of indx is in the
C          unique set of reflections because of lattice symmetry.
C          return itest=1 if so, else itest=0.
C
      INCLUDE 'newlaue_auto_params.finc'
C
 
C     .. Scalar Arguments ..
      INTEGER I,ITEST
C     ..
C     .. Scalars in Common ..
      INTEGER ICENT,ILGP,MBEAM,MROT,MSYS,NREF
C     ..
C     .. Arrays in Common ..
      REAL A(MAXARR,MAXARR),B(MAXARR)
      INTEGER INDX(MAXARR,3)
C     ..
C     .. Local Scalars ..
      INTEGER IH,IK,IL
C     ..
C     .. Common blocks ..
      COMMON /AUTO/NREF,INDX,B,A
      COMMON /MATRIX/MSYS,MROT,MBEAM,ILGP,ICENT
C     ..
C
C-------------------------------------------------------------------------------
C
      ITEST = 0
      IH = INDX(I,1)
      IK = INDX(I,2)
      IL = INDX(I,3)
      IF (MSYS.EQ.2) THEN
C
C====== Monoclinic
C
         IF (IK.LT.0) RETURN
         IF (IH.LT.0) RETURN
         IF (IH.EQ.0 .AND. IL.LT.0) RETURN
         GO TO 20
      ELSE IF (MSYS.EQ.3) THEN
C
C====== Orthorhombic
C
         IF (IH.LT.0) RETURN
         IF (IK.LT.0) RETURN
         IF (IL.LT.0) RETURN
         GO TO 20
      ELSE IF (MSYS.EQ.4) THEN
C
C====== Tetragonal
C
         IF (IH.LT.0) RETURN
         IF (IK.LT.0) RETURN
         IF (IL.LT.0) RETURN
         IF (IH.GT.IK) RETURN
         GO TO 20
      ELSE IF (MSYS.EQ.5) THEN
C
C====== Hexagonal
C
         IF (IH.LT.0) RETURN
         IF (IL.LT.0) RETURN
         IF (IK.LT.0) RETURN
         IF (IK.GT.IH) RETURN
         GO TO 20
      ELSE IF (MSYS.EQ.6) THEN
C
C====== Rhombohedral
C
         IF (IH.LT.0) RETURN
         IF (IK.LT.0) RETURN
      ELSE IF (MSYS.NE.7) THEN
C
C====== Triclinic
C
         IF (IH.LT.0) RETURN
         IF (IH.EQ.0 .AND. IK.LT.0) RETURN
         IF (IH.EQ.0 .AND. IK.EQ.0 .AND. IL.LT.0) RETURN
         GO TO 20
      END IF
C
C====== Cubic
C
      IF (IH.LT.0) RETURN
      IF (IK.LT.0) RETURN
      IF (IL.LT.0) RETURN
      IF (IH.GT.IK) RETURN
      IF (IK.GT.IL) RETURN
C
C====== Acceptable
C
 20   ITEST = 1
      RETURN
      END
**==indespot.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INDESPOT      **
C*************************
C
C
      SUBROUTINE INDESPOT
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: To select option for indexing laue spots
C
C
C====== LOCALS:
C
      CHARACTER*1 ANSWER,OPTION(8)
      INTEGER INDOPT,I,INDHIG
      CHARACTER*80 STR
      LOGICAL EOF,ERR
 
      REAL FLPVAL
 
      DATA OPTION/'S','L','A','N','s','l','a','n'/
C
C-------------------------------------------------------------------------------
C
      INDOPT = 0
      CALL QGALPH
      CALL QSSETC(1,24)
 20   WRITE (STR,6020)
      CALL TWRITE(STR)
      WRITE (STR,6030)
      CALL TPROMP(STR)
      CALL TREAD(ANSWER,EOF)
      IF (EOF) GO TO 60
      IF (ANSWER.NE.' ') THEN
         DO 30 I = 1 , 8
            IF (ANSWER.EQ.OPTION(I)) THEN
               INDOPT = I
               IF (INDOPT.GT.4) INDOPT = INDOPT - 4
               GO TO 40
            END IF
 30      CONTINUE
         GO TO 20
      END IF
 
 40   INDHIG = 99
      IF (INDOPT.EQ.2) THEN
 
 50      WRITE (STR,6010)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (.NOT.(EOF)) THEN
            INDHIG = NINT(FLPVAL(STR,ERR))
            IF (INDHIG.LT.1 .OR. INDHIG.GT.99) GO TO 50
C
C====== Annotate all spots within index range
C
            CALL ALLAUE(INDOPT,INDHIG)
         END IF
      ELSE IF (INDOPT.EQ.3) THEN
         CALL ALLAUE(INDOPT,INDHIG)
      ELSE
 
         CALL SPOTID(INDOPT)
      END IF
 60   RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter highest positive index value: ')
 6020 FORMAT ('>>> Enter index annotation option')
 6030 FORMAT ('    Single spot, Low index spots, All spots [None]: ')
      END
**==indexl.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INDEXL        **
C*************************
C
C
      SUBROUTINE INDEXL
C
      INCLUDE 'implicit_none.finc'
      INCLUDE 'newlaue_auto_params.finc'
      REAL CTOF,DMIN,RADI,RADI2,SPNDLE,WVM,WVS,WVX
      INTEGER NREF,NUMA,NUMC
      REAL A(MAXARR,MAXARR),B(MAXARR),CCELL(6),CELL(6),PHIS(3)
      INTEGER INDX(MAXARR,3)
      COMMON /AUTO/NREF,INDX,B,A
      COMMON /DATA/CELL,WVM,WVX,WVS,CTOF,PHIS,SPNDLE,CCELL,NUMA,NUMC,
     1       DMIN
      COMMON /RADC/RADI,RADI2
      COMMON /STDONE/ STDONE
      LOGICAL STDONE
C
C====== LOCALS:
C
      LOGICAL EOF,ERR
      CHARACTER*80 STR
      INTEGER NVALS
      REAL VALUES(4)
      INTEGER NSTMAX
      PARAMETER(NSTMAX=12)
      REAL STANG(NSTMAX,3),STDEV(3),DEVMAX,TMP,PHTEMP(3)
      INTEGER NSTORE,LMAX,NMAX,ISOL,ITCNT
      REAL ADJ,COSW,DEV,DEVSAV,OM,PI,RMSD,SINW,X,XCEN,XD,XF,Y,YCEN,YD,YF
      INTEGER I,IDET,IDIR,IDUMMY1,IDUMMY2,IDUMMY3,ITIM,J,K,KK1,KK2,KK3,
     1        L,MAX,N,NOBS,NSOL,NUMCURS
      LOGICAL SUMMA,SWAP
      CHARACTER IYN*1,IYNI*1,XTALID*6,FNAME*80,TTL*20
      CHARACTER LABEL*6,FIL1*12,FIL2*12
      REAL ANG(3),ANGL(20,20),FID(2,3),NEWSOL(3,3),SOL(3,3),XC(5,20),
     1     XSPOT(4,20)
      INTEGER IHKL(3,20),IPSOL(20,20),ISPOT(3,20),MANGL(20,20)
 
      REAL FLPVAL
C
C-------------------------------------------------------------------------------
C
      PI = 3.14159265
      NSTORE = 0
      LABEL = ' '
      IF (.NOT.STDONE) THEN
         WRITE (STR,6370)
         CALL TWRITE(STR)
         GO TO 380
      END IF
 
      WRITE (STR,6040)
      CALL TPROMP(STR)
      CALL TREAD(IYNI,EOF)
      CALL TOUPPR(IYNI)
C
C====== If the nodals are indexed by the user then there is no need to
C====== look for angle matches
C
      IF (IYNI.NE.'Y') THEN
C
C====== Get the angles between possible nodal reflections
C
         CALL TWRITE(' ')
         WRITE (STR,6050)
         CALL TWRITE(STR)
         CALL TWRITE(' ')
         NREF = 0
         CALL INDANG
      END IF
 
      CALL TWRITE(' ')
      WRITE (STR,6060)
      CALL TPROMP(STR)
      CALL TREAD(IYN,EOF)
      CALL TOUPPR(IYN)
      IF (IYN.EQ.'S') THEN
C
C====== Routine to read from the screen the coordinates of some nodal
C====== reflections.
C
         SUMMA = .FALSE.
 
      ELSE IF (IYN.EQ.'F') THEN
         SUMMA = .TRUE.
         WRITE (STR,6070)
         CALL TWRITE(STR)
 
      ELSE
 20      WRITE (STR,6080)
         CALL TPROMP(STR)
         CALL TREAD(FNAME,EOF)
         IF (FNAME.EQ.' ') RETURN
         OPEN (UNIT=9,FILE=FNAME,STATUS='OLD',ERR=40)
         READ (9,6010) XTALID , TTL
         READ (9,6020) NUMCURS
         NUMCURS = MIN(NUMCURS,20)
         DO 30 I = 1 , NUMCURS
            IF (IYNI.EQ.'Y') THEN
               READ (9,6030,END=50) (ISPOT(J,I),J=1,3) , XF , YF
 
            ELSE
               READ (9,6030,END=50) IDUMMY1 , IDUMMY2 , IDUMMY3 , XF , 
     +                              YF
            END IF
 
            XSPOT(1,I) = XF
            XSPOT(2,I) = YF
            XSPOT(3,I) = PI/2. - 0.5*ATAN2(SQRT(XF**2+YF**2),CTOF)
            XSPOT(4,I) = ATAN2(YF,XF)
            IF (IYNI.NE.'Y') THEN
               WRITE (STR,6120) I , (XSPOT(J,I),J=1,2)
               CALL TWRITE(STR)
            END IF
 30      CONTINUE
         N = NUMCURS
         CLOSE (UNIT=9)
         GO TO 90
 40      WRITE (STR,6360)
         CALL TWRITE(STR)
         GO TO 20
 
 50      N = I - 1
         CLOSE (UNIT=9)
         GO TO 90
 
      END IF
 
      IF (SUMMA) THEN
C
C====== Get the fiducial positions
C
         DO 60 I = 1 , 3
            CALL SUMMASPT(FID(1,I),FID(2,I))
 60      CONTINUE
         XCEN = (FID(1,1)+FID(1,3))/2.
         YCEN = (FID(2,1)+FID(2,3))/2.
         OM = -(FID(2,3)-FID(2,2))/(FID(1,3)-FID(1,2))
         COSW = COS(OM)
         SINW = SIN(OM)
         WRITE (STR,6090) XCEN , YCEN , OM
         CALL TWRITE(STR)
 
      END IF
 
      WRITE (STR,6100)
      CALL TWRITE(STR)
 
      N = 0
 70   IF (SUMMA) THEN
         CALL SUMMASPT(X,Y)
         XF = (X-XCEN)*COSW - (Y-YCEN)*SINW
         YF = (X-XCEN)*SINW + (Y-YCEN)*COSW
         IF (ABS(XF).GT.RADI) GO TO 90
         IF (ABS(YF).GT.RADI) GO TO 90
 
      ELSE
         CALL SPOTON(X,Y)
         CALL GUNPLT(X,Y,XF,YF)
         IF (XF.EQ.0.0 .AND. YF.EQ.0.0) GO TO 90
      END IF
 
      N = N + 1
      XSPOT(1,N) = XF
      XSPOT(2,N) = YF
      XSPOT(3,N) = PI/2. - 0.5*ATAN2(SQRT(XF**2+YF**2),CTOF)
      XSPOT(4,N) = ATAN2(YF,XF)
      IF (IYNI.EQ.'Y') THEN
         WRITE (STR,6110)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         CALL STRVAL(STR,' ,',3,VALUES,NVALS)
         DO 80 I = 1 , 3
            ISPOT(I,N) = 0
            IF (NVALS.GE.I) ISPOT(I,N) = NINT(VALUES(I))
 80      CONTINUE
      END IF
 
      IF (IYNI.NE.'Y') THEN
         WRITE (STR,6120) N , (XSPOT(J,N),J=1,2)
         CALL TWRITE(STR)
      END IF
      IF (N.LT.20) GO TO 70
C
C====== No more spots to enter - calculate the angles between them.
C
 90   DO 110 I = 2 , N
         DO 100 J = 1 , I - 1
            ANGL(I,J) = COS(XSPOT(4,J))*SIN(XSPOT(3,J))*COS(XSPOT(4,I))
     +                  *SIN(XSPOT(3,I)) + SIN(XSPOT(4,J))
     +                  *SIN(XSPOT(3,J))*SIN(XSPOT(4,I))*SIN(XSPOT(3,I))
     +                  + COS(XSPOT(3,J))*COS(XSPOT(3,I))
            ANGL(I,J) = ACOS(ANGL(I,J))
 100     CONTINUE
 110  CONTINUE
C
C====== If the user has supplied indices then check the angles and allow
C====== corrections - use indang to get the angles from the indices
C
      IF (IYNI.NE.'Y') THEN
C
C====== Now try to match these angles against the pre-calculated ones
C
         CALL INDMAT(N,ANGL,NSOL,IPSOL,MAX)
         IF (NSOL.EQ.0) THEN
            WRITE (STR,6180)
            CALL TWRITE(STR)
            GO TO 320
 
         END IF
 
         WRITE (STR,6190) NSOL , MAX
         CALL TWRITE(STR)
C
C====== Loop over all the solutions
C
         L = 0
      ELSE
         NREF = N
         DO 130 I = 1 , N
            DO 120 J = 1 , 3
               INDX(I,J) = ISPOT(J,I)
 120        CONTINUE
 130     CONTINUE
         CALL INDANG
         I = 1
         WRITE (STR,6140)
         CALL TWRITE(STR)
         WRITE (STR,6130) I , (XSPOT(K,I),K=1,2) , (ISPOT(K,I),K=1,3)
         CALL TWRITE(STR)
         DO 150 I = 2 , N
            DO 140 J = 1 , I - 1
               MANGL(I,J) = ABS(ANGL(I,J)-A(I,J))*57. + 0.5
 140        CONTINUE
            WRITE (STR,6130) I , (XSPOT(K,I),K=1,2) , (ISPOT(K,I),K=1,3)
     +                       , (MANGL(I,K),K=1,I-1)
            CALL TWRITE(STR)
 150     CONTINUE
 160     WRITE (STR,6150)
         CALL TPROMP(STR)
         CALL TREAD(IYN,EOF)
         CALL TOUPPR(IYN)
         IF (IYN.EQ.'Q') GO TO 320
         IF (IYN.EQ.'O') THEN
            NSOL = 1
            L = 1
            GO TO 220
 
         END IF
 
         IF (IYN.NE.'C') GO TO 160
         WRITE (STR,6160)
         CALL TWRITE(STR)
         WRITE (STR,6170)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         CALL STRVAL(STR,' ,',4,VALUES,NVALS)
         J = 0
         KK1 = 0
         KK2 = 0
         KK3 = 0
         IF (NVALS.GE.1) J = NINT(VALUES(1))
         IF (NVALS.GE.2) KK1 = NINT(VALUES(2))
         IF (NVALS.GE.3) KK2 = NINT(VALUES(3))
         IF (NVALS.GE.4) KK3 = NINT(VALUES(4))
         IF (KK1.EQ.0 .AND. KK2.EQ.0 .AND. KK3.EQ.0) THEN
            IF (J.NE.N) THEN
               DO 190 K = J + 1 , N
                  DO 170 L = 1 , 4
                     XSPOT(L,K-1) = XSPOT(L,K)
 170              CONTINUE
                  DO 180 L = 1 , 3
                     ISPOT(L,K-1) = ISPOT(L,K)
 180              CONTINUE
 190           CONTINUE
            END IF
            N = N - 1
 
         ELSE
            ISPOT(1,J) = KK1
            ISPOT(2,J) = KK2
            ISPOT(3,J) = KK3
C
C====== Loop round this process again with changed indices
C
         END IF
         GO TO 90
      END IF
 200  L = L + 1
      DO 210 I = 1 , N
         K = IPSOL(L,I)
         IF (K.EQ.0) THEN
            ISPOT(1,I) = 0
            ISPOT(2,I) = 0
            ISPOT(3,I) = 0
 
         ELSE
            ISPOT(1,I) = INDX(K,1)
            ISPOT(2,I) = INDX(K,2)
            ISPOT(3,I) = INDX(K,3)
         END IF
 
 210  CONTINUE
C
C====== Calculate orientation
C
 220  NOBS = 0
      DO 230 I = 1 , N
         IF (ISPOT(1,I).NE.0 .OR. ISPOT(2,I).NE.0 .OR. ISPOT(3,I).NE.0)
     +       THEN
            NOBS = NOBS + 1
            IHKL(1,NOBS) = ISPOT(1,I)
            IHKL(2,NOBS) = ISPOT(2,I)
            IHKL(3,NOBS) = ISPOT(3,I)
            XC(1,NOBS) = XSPOT(1,I)
            XC(2,NOBS) = XSPOT(2,I)
         END IF
 
 230  CONTINUE
      CALL EVANGL(NOBS,IHKL,XC,ANG,RMSD,DEV,SOL,IDET)
      IF (IDET.EQ.2) GO TO 300
      IF (RMSD.GT.0.06) THEN
         WRITE (STR,6200)
         CALL TWRITE(STR)
         WRITE (STR,6210) RMSD
         CALL TWRITE(STR)
      END IF
 
 240  WRITE (STR,6220)
      CALL TWRITE(STR)
      DO 250 I = 1 , NOBS
         XD = ABS(XC(1,I)-XC(3,I))
         YD = ABS(XC(2,I)-XC(4,I))
         WRITE (STR,6230) (IHKL(J,I),J=1,3) , (XC(J,I),J=1,4) , XD , YD
         CALL TWRITE(STR)
 250  CONTINUE
      WRITE (STR,6240) ANG , DEV
      CALL TWRITE(STR)
C
C====== Fiddle around with angles if user wishes.
C
      ADJ = DEV/20.
      WRITE (STR,6250)
      CALL TPROMP(STR)
      CALL TREAD(IYN,EOF)
      CALL TOUPPR(IYN)
      IF (IYN.NE.'Y') THEN
         IF (NSTORE.LT.NSTMAX) THEN
            NSTORE = NSTORE + 1
            STANG(NSTORE,1) = ANG(1)
            STANG(NSTORE,2) = ANG(2)
            STANG(NSTORE,3) = ANG(3)
            STDEV(NSTORE) = DEV
         ELSE
            DEVMAX = 0.0
            K = 1
            DO 260 I = 1 , NSTORE
               IF (STDEV(I).GT.DEVMAX) THEN
                  K = I
                  DEVMAX = STDEV(I)
               END IF
 260        CONTINUE
            IF (DEV.LT.DEVMAX) THEN
               STANG(K,1) = ANG(1)
               STANG(K,2) = ANG(2)
               STANG(K,3) = ANG(3)
               STDEV(K) = DEV
            END IF
         END IF
         GO TO 300
      END IF
      ITCNT = 0
 270  DO 290 K = 1 , 4
         I = K
         IF (I.GT.3) I = I - 3
         IDIR = 1
         ITIM = 0
 280     DEVSAV = DEV
         ITIM = ITIM + 1
         ANG(I) = ANG(I) - ADJ*(IDIR-2)
         CALL EROTMT(ANG,NEWSOL,SOL,RMSD)
         CALL EVCOOR(NEWSOL,XC,DEV,NOBS,IDET)
         WRITE (STR,6240) ANG , DEV
         CALL TWRITE(STR)
         ITCNT = ITCNT + 1
         IF (ITCNT.GE.50) GO TO 240
         IF (DEV.LT.DEVSAV) GO TO 280
         ANG(I) = ANG(I) + ADJ*(IDIR-2)
         DEV = DEVSAV
         IF (ITIM.LE.1) THEN
            IF (IDIR.LE.1) THEN
               IDIR = 3
               ITIM = 0
               GO TO 280
            END IF
         END IF
 
 290  CONTINUE
      IF (ADJ.LT.0.02) GO TO 240
      ADJ = ADJ/5.
      GO TO 270
 
 300  IF (L.NE.NSOL) THEN
 310     WRITE (STR,6260)
         CALL TPROMP(STR)
         CALL TREAD(IYN,EOF)
         CALL TOUPPR(IYN)
         IF (IYN.NE.'E') THEN
            IF (IYN.EQ.'N') GO TO 200
            GO TO 310
         END IF
      END IF
 320  IF (NSTORE.GT.1) THEN
         NMAX = NSTORE - 1
         DO 340 N = 1 , NMAX
            LMAX = NSTORE - N
            SWAP = .FALSE.
            DO 330 L = 1 , LMAX
               IF (STDEV(L).GT.STDEV(L+1)) THEN
                  SWAP = .TRUE.
                  TMP = STDEV(L)
                  STDEV(L) = STDEV(L+1)
                  STDEV(L+1) = TMP
                  TMP = STANG(L,1)
                  STANG(L,1) = STANG(L+1,1)
                  STANG(L+1,1) = TMP
                  TMP = STANG(L,2)
                  STANG(L,2) = STANG(L+1,2)
                  STANG(L+1,2) = TMP
                  TMP = STANG(L,3)
                  STANG(L,3) = STANG(L+1,3)
                  STANG(L+1,3) = TMP
               END IF
 330        CONTINUE
            IF (.NOT.SWAP) GO TO 350
 340     CONTINUE
      END IF
 350  IF (NSTORE.NE.0) THEN
 360     CALL TWRITE(' ')
         WRITE (STR,6280) NSTMAX
         CALL TWRITE(STR)
         WRITE (STR,6290)
         CALL TWRITE(STR)
         DO 370 N = 1 , NSTORE
            WRITE (STR,6300) N , STANG(N,1) , STANG(N,2) , STANG(N,3) , 
     +                       STDEV(N)
            CALL TWRITE(STR)
 370     CONTINUE
         WRITE (STR,6310)
         CALL TPROMP(STR)
         CALL TREAD(IYN,EOF)
         CALL TOUPPR(IYN)
         IF (IYN.EQ.'C') RETURN
         IF (IYN.NE.'R' .AND. IYN.NE.'W') THEN
            WRITE (STR,6320)
            CALL TWRITE(STR)
            GO TO 360
         END IF
         WRITE (STR,6330)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         ISOL = NINT(FLPVAL(STR,ERR))
         IF (ISOL.LT.1 .OR. ISOL.GT.NSTORE) THEN
            WRITE (STR,6340)
            CALL TWRITE(STR)
            GO TO 360
         END IF
         IF (IYN.EQ.'R') THEN
            SPNDLE = 0.0
            PHIS(1) = STANG(ISOL,1)
            PHIS(2) = STANG(ISOL,2)
            PHIS(3) = STANG(ISOL,3)
         ELSE IF (IYN.EQ.'W') THEN
            TMP = SPNDLE
            PHTEMP(1) = PHIS(1)
            PHTEMP(2) = PHIS(2)
            PHTEMP(3) = PHIS(3)
            SPNDLE = 0.0
            PHIS(1) = STANG(ISOL,1)
            PHIS(2) = STANG(ISOL,2)
            PHIS(3) = STANG(ISOL,3)
            FIL1 = ' '
            WRITE (FIL1,6350) ISOL
            CALL SAVDAT(0,LABEL,FIL1,FIL2)
            SPNDLE = TMP
            PHIS(1) = PHTEMP(1)
            PHIS(2) = PHTEMP(2)
            PHIS(3) = PHTEMP(3)
         END IF
         GO TO 360
      END IF
 380  WRITE (STR,6270)
      CALL TPROMP(STR)
      CALL TREAD(IYN,EOF)
      RETURN
C
C====== Format statements
C
 6010 FORMAT (1X,A6/1X,A20)
 6020 FORMAT (8X,I4)
 6030 FORMAT (8X,3I4,24X,2F6.1)
 6040 FORMAT ('>>> Do you wish to supply indices for ',
     +        'the nodal spots [n]: ')
 6050 FORMAT ('Pre-calculation of angles between reflections with',
     +        ' small indices.')
 6060 FORMAT ('>>> Mode for entering spots',
     +        '(i=input file, s=screen, f=film) [i]: ')
 6070 FORMAT ('Tape film to pad. First enter fiducials clockwise',
     +        ' from bottom left.')
 6080 FORMAT ('>>> Enter file name: ')
 6090 FORMAT ('Centre of film  ',2F8.3,'     tilt(rad) ',F7.5)
 6100 FORMAT ('Enter the nodal spots to be used,',
     +        ' point off the image/film to finish')
 6110 FORMAT ('>>> Enter indices for this nodal reflection: ')
 6120 FORMAT (I3,5F12.2)
 6130 FORMAT (I3,2F6.1,3I3,20I4)
 6140 FORMAT ('If indices are correct then the angle differences',
     +        ' (degrees) below should be small')
 6150 FORMAT ('>>> Try for orientation/change an index/quit ',
     +        '(o/c/q): ')
 6160 FORMAT ('>>> Enter number of reflection to change and its new ',
     +        'indices.')
 6170 FORMAT ('    New indices of 0 0 0 means delete it.: ')
 6180 FORMAT ('No solutions found unfortunately')
 6190 FORMAT ('Best result has ',I3,' solutions with',I3,' matches')
 6200 FORMAT ('Solution unacceptable - poor matrix agreement')
 6210 FORMAT ('The rmsd of the matrix is ',F10.5)
 6220 FORMAT ('  hkl(calc.)    actual       calc.     differences')
 6230 FORMAT (3I4,2F6.1,2X,4F6.1)
 6240 FORMAT ('Orientation angles are ',3F10.2,' rmsdev is ',F10.5)
 6250 FORMAT ('>>> Refine angles [n]: ')
 6260 FORMAT ('>>> Enter e=end, n=next solution: ')
 6270 FORMAT ('>>> Press <RET> to continue: ')
 6280 FORMAT ('Best solutions (maximum of',I3,')')
 6290 FORMAT ('No.      Phix      Phiy      Phiz    rmsdev')
 6300 FORMAT (I3,3F10.2,F10.5)
 6310 FORMAT ('>>> Enter w=write a data file, r=reset spindle and',
     +        ' phis or c=continue: ')
 6320 FORMAT ('!!! Invalid option')
 6330 FORMAT ('>>> Solution number: ')
 6340 FORMAT ('!!! Solution not stored')
 6350 FORMAT ('SAVE',I2.2)
 6360 FORMAT ('!!! Error in opening file')
 6370 FORMAT ('!!! START must be called before using AUTO')
      END
**==indmat.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INDMAT        **
C*************************
C
C
      SUBROUTINE INDMAT(NOBS,ANGL,NSOL,IPSOL,MAX)
C
      INCLUDE 'implicit_none.finc'
      INCLUDE 'newlaue_auto_params.finc'
C
C Purpose: Try to match the spots
C
C          target is at least 3 matches of nobs nodals against nref
C          calculated spots.
C
C          aim at 3 matches (max), with angles between spots agreeing with
C          pre-calculated angles to within delta (difference of cosines).
C
      INTEGER MAX,NOBS,NSOL
      REAL ANGL(20,20)
      INTEGER IPSOL(20,20)
      REAL CF,DMIN,SPNDLE,WVM,WVS,WVX
      INTEGER NREF,NUMA,NUMC
      REAL A(MAXARR,MAXARR),B(MAXARR),CCELL(6),CELL(6),PHIS(3)
      INTEGER INDX(MAXARR,3)
      COMMON /AUTO/NREF,INDX,B,A
      COMMON /DATA/CELL,WVM,WVX,WVS,CF,PHIS,SPNDLE,CCELL,NUMA,NUMC,DMIN
C
C====== LOCALS:
C
      CHARACTER*80 STR
      LOGICAL EOF,ERR
      REAL DELTA
      INTEGER I,IPJ,ITEST,J,K,MC,N
      CHARACTER IYN*1
      REAL DEL(20)
      INTEGER IP(20),KP(2,3),KPP(2)
 
      REAL FLPVAL
C
C-------------------------------------------------------------------------------
C
      CALL TWRITE(' ')
      WRITE (STR,6010)
      CALL TPROMP(STR)
      CALL TREAD(STR,EOF)
      DELTA = FLPVAL(STR,ERR)
      DELTA = 1.4*ATAN2(1.4*DELTA,CF)
      MAX = 4
C
C====== NSOL counts equivalent solutions (sets of matches having same max)
C====== I moves along the standard reflections (up to nref)
C====== MC counts matches so far in the solution being studied
C====== N moves along the user's measured spots (up to nobs)
C
      NSOL = 0
      I = 1
      MC = 0
      N = 1
C
C====== If there is no match so far then the present possible match must
C====== be assumed to be true
C
 20   IF (MC.EQ.0) THEN
C
C====== Before accepting this first match check that it is not going to
C====== introduce unnecessary ambiguities because of lattice symmetry.
C
         CALL INDCHK(I,ITEST)
         IF (ITEST.EQ.0) GO TO 70
         GO TO 40
 
      END IF
C
C====== Determine if this possible match is compatible with earlier ones
C====== the requirement is that all angle pairs involving this match must
C====== agree with the corresponding calculated standard pairs
C
      DO 30 J = 1 , N - 1
         IPJ = IP(J)
         IF (IPJ.NE.0) THEN
            IF (ABS(ANGL(N,J)-A(IPJ,I)).GT.DELTA) GO TO 70
         END IF
 30   CONTINUE
C
C====== All pairs agree so this match is acceptable - add to list
C====== IP is the array containing the matches for the current solution
C
 40   IP(N) = I
      MC = MC + 1
C
C====== Take the next of the spots in the input list
C====== try to match it first against the first standard
C
 50   IF (N.EQ.NOBS) THEN
C
C====== End of a solution - test how many matches
C
         IF (MC.GE.MAX) THEN
            IF (MC.GT.MAX) THEN
C
C====== The best solution so far
C
               NSOL = 1
               MAX = MC
 
            ELSE
C
C====== Another equally good solution
C
               NSOL = NSOL + 1
            END IF
C
C====== Add this solution to the list - but do not overflow the array
C
            IF (NSOL.LE.20) THEN
               DO 60 K = 1 , NOBS
                  IPSOL(NSOL,K) = IP(K)
 60            CONTINUE
            END IF
         END IF
         GO TO 80
      ELSE
         N = N + 1
         I = 1
         GO TO 20
      END IF
C
C====== Try the next of the standards as a possible match
C
 70   IF (I.EQ.NREF) THEN
C
C====== This spot can not be matched successfully
C
         IP(N) = 0
C
C====== To avoid wasting time - check that it is still possible to reach
C====== the target (max) even if all remaining spots can be matched
C
         IF ((MC+NOBS-N).GE.MAX) GO TO 50
      ELSE
         I = I + 1
         GO TO 20
      END IF
C
C====== This point is where the last step in the current solution is
C====== reversed and a new solution looked for
C
 80   I = IP(N)
      IF (I.GT.0) THEN
         MC = MC - 1
         GO TO 70
 
      ELSE
         N = N - 1
         IF (N.GT.0) GO TO 80
C
C====== The end
C
         RETURN
      END IF
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter estimated error (mm) in a coordinate: ')
      END
**==inperr.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INPERR        **
C*************************
C
C
      SUBROUTINE INPERR(MESS,STRING,LOC)
C
      CHARACTER*(*) MESS,STRING,BLANK*80
      CHARACTER*80 ERSTR
      SAVE BLANK
      DATA BLANK/'
     +                             '/
C
C-------------------------------------------------------------------------------
C
      ILOC = MIN(MAX(LOC,1),LEN(STRING),80)
      WRITE (ERSTR,'(''!!! '',A)') MESS
      CALL TWRITE(ERSTR)
      WRITE (ERSTR,'(A)') STRING
      CALL TWRITE(ERSTR)
      WRITE (ERSTR,'(A,''^'')') BLANK(1:ILOC)
      CALL TWRITE(ERSTR)
      CALL QSBELL
      CALL QSBELL
      CALL QSBELL
      RETURN
      END
**==inthch.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       INTHCH        **
C*************************
C
C
      INTEGER FUNCTION INTHCH(STRING)
C
C Purpose: Returns the location of the last non-blank
C          character in string or zero if string is blank
C
      CHARACTER*(*) STRING
C
C STRING : The character string in question
C
C====== LOCALS:
C
      INTEGER I
C
C I      : the single character index under scrutiny
C
C-------------------------------------------------------------------------------
C
      DO 20 I = LEN(STRING) , 1 , -1
         IF (STRING(I:I).NE.' ') THEN
            INTHCH = I
            GO TO 30
         END IF
 20   CONTINUE
      INTHCH = 0
 30   RETURN
      END
**==ipack.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       IPACK         **
C*************************
C
C
      FUNCTION IPACK(H,K,L)
C
      INTEGER H
C
C-------------------------------------------------------------------------------
C
      IPACK = 40000*(H+100) + 200*(K+100) + (L+100)
      RETURN
      END
**==item.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ITEM          **
C*************************
C
C
      SUBROUTINE ITEM (IOPT,ARRAY,LEN,VIDEO)
C
C Purpose: Displays charactere string on VDU at given line and column
C
      CHARACTER*(*) ARRAY
      INTEGER IOPT,LEN
      LOGICAL VIDEO
C
C====== LOCALS:
C
      INTEGER LINE,ICOL
C
C-------------------------------------------------------------------------------
C
      ICOL = (IOPT+16)/17
      LINE = IOPT - 17*(ICOL-1)
      CALL QSSETC(1,24)
      ICOL = ICOL*15 - 14
      LINE = LINE + 1
      CALL QSSETC(ICOL,LINE)
      IF (VIDEO) CALL QSREVV
      CALL TSTRNG(ARRAY(1:LEN))
      CALL QSNORV
      RETURN
      END
**==laueg.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       LAUEG         **
C*************************
C
C
      SUBROUTINE LAUEG (NSTART,NTYPE,USED)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Calculate and display the Laue photograph
C
C   NSTART is where to start plotting from in the large array
C   NTYPE=0 means no compression, leave arrays as are
C        =1 means compress the arrays down to contain only those
C           which are plotted
C        =-1 denotes end of a series of compress calls
C
C
      INTEGER NSTART,NTYPE
      LOGICAL USED
C
C USED   : Indicates whether or no a set of extinction classes are to
C          be observed
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'point.finc'
      INCLUDE 'histo.finc'
      INCLUDE 'laues.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'lambda.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'vsave.finc'
      INCLUDE 'project.finc'
 
      COMMON/SPOTS/ NR
      INTEGER       NR
      INTEGER IPACK,IHCF
C
C====== LOCALS:
C
      CHARACTER*80 STR
      INTEGER I,N,NN,IX,IY,IHT,IKT,ILT,IHCF1,IHCF2,IH,IK,IL
      REAL   WJUNK(15),X,Y,Z,XF,YF,RF,C1,S1,RMIN2,RMAX2,RMIN,RMAX,
     1       DD1,DD2,XJUNK,DELTA
      LOGICAL PROJCT,INCIRC
C
C-------------------------------------------------------------------------------
C
      IF (ABS(WVM).GE.1E-8) THEN
         IF (ABS(WVX).GE.1E-8) THEN
            IF (ABS(WVS).GE.1E-8) THEN
               IF (ABS(CTOF).GE.1E-8) THEN
 
                  C1 = SPNDLE*3.1415926536/180.0
                  S1 = SIN(C1)
                  C1 = COS(C1)
                  RMIN = WVS/WVX
                  RMAX = WVS/WVM
C
C====== Clear the histogram of wavelengths on first entry
C
                  IF (NSTART.EQ.1) THEN
                     DO 20 I = 1 , 15
                        NHOLD(I) = 0
                        HOLDW(I) = WVS/(WVM+I*(WVX-WVM)/15.)
                        NB = 0
 20                  CONTINUE
                  ELSE
                     NB = NSTART - 1
                  END IF
                  RMIN2 = RMIN*RMIN
                  RMAX2 = RMAX*RMAX
C
C====== Loop through the two hemispheres
C
C====== NB Program exploits centre of symmetry in lattice holohedry by only
C====== storing one of the symmetry-equiv pair (X,Y,Z) (-X,-Y,-Z). Only one of
C====== these can give rise to a spot, namely the one with X -ve AFTER spindle
C====== rotation.
C
                  DO 70 N = NSTART , NR
                     LAMBDA(N) = 0.
                     NN = 1
C
C====== Rotate rec lattice thro spndle
C
                     X = C1*XG(N) - S1*YG(N)
 30                  IF (X.GE.0.00001) GO TO 60
                     Y = S1*XG(N) + C1*YG(N)
                     Z = ZG(N)
                     IF (NN.EQ.2) THEN
                        Y = -Y
                        Z = -Z
                     END IF
                     IF (.NOT.PROJCT(X,Y,Z,XF,YF,PROJTYPE,CTOF,RMIN,
     +                   RMAX,RF)) GO TO 60
C
C====== Check that point is inside the circle requested by the user
C
                     IF (.NOT.INCIRC(XF,YF)) GO TO 60
                     DO 40 I = 1 , 15
                        IF (RF.GT.HOLDW(I)) GO TO 50
 40                  CONTINUE
                     I = 15
 50                  NHOLD(I) = NHOLD(I) + 1
                     NB = NB + 1
                     LAMBDA(N) = WVS/RF
C
C====== Display plot
C
                     IX = IFIX(XF+.5)
                     IY = IFIX(YF+.5)
                     XABS(NB) = XF
                     YORD(NB) = YF
                     IF (NN.EQ.1) THEN
C
C====== Use convention of -ve IRLPPOS if the rlp (-XG,-YG,-ZG) was plotted.
C
                        IRLPPOS(NB) = N
                     ELSE
                        IRLPPOS(NB) = -N
                     END IF
C
C====== Change multiplet check to be on indices rather
C====== than on position     23/10/87
C
                     CALL UNPACK(IHKL(N),IH,IK,IL)
                     IHCF1 = IHCF(IH,IK)
                     IHCF2 = IHCF(IHCF1,IL)
                     IHT = IH/IHCF2
                     IKT = IK/IHCF2
                     ILT = IL/IHCF2
                     IXY(NB) = IPACK(IHT,IKT,ILT)
C
C====== Compress if necessary
C
                     IF (NTYPE.NE.0) THEN
                        XG(NB) = XG(N)
                        YG(NB) = YG(N)
                        ZG(NB) = ZG(N)
                        LAMBDA(NB) = LAMBDA(N)
                        IHKL(NB) = IHKL(N)
                        IF (NN.EQ.1) THEN
                           IRLPPOS(NB) = NB
                        ELSE
                           IRLPPOS(NB) = -NB
                        END IF
C
C====== No need to check other sign combination if this one was plotted
C
                     END IF
                     GO TO 70
 
 60                  IF (NN.NE.2) THEN
                        NN = 2
                        X = -X
                        GO TO 30
                     END IF
 70               CONTINUE
C
C====== In compression mode reset nr and return, unless ntype=-1
C====== when the histogram should be output
C
                  IF (NTYPE.NE.0) NR = NB
                  WRITE (STR,6010) NR , NTYPE
                  CALL TWRITE(STR)
                  IF (NR.NE.INDPRM) THEN
                     IF (NTYPE.GT.0) RETURN
                  END IF
C
C====== Display statistics
C
                  CALL REPORT
 
                  RETURN
               END IF
            END IF
         END IF
      END IF
 
      CALL TWRITE('!!! Insufficient data for a display')
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('Laue gen ended nr =',I6,' ntype =',I3)
      END
**==legvar.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       LEGVAR        **
C*************************
C
C
C Purpose: Decides whether a real variable is lt or gt or eq to zero (within
C          a little) and assign to an integer the value -1 or 1 or 0
C
      INTEGER FUNCTION LEGVAR(R)
      REAL R
C
C-------------------------------------------------------------------------------
C
      IF (ABS(R).LE.0.00001) THEN
         LEGVAR = 0
      ELSE
         IF (R.LT.0.) LEGVAR = -1
         IF (R.GT.0.) LEGVAR = 1
      END IF
      END
**==lowind.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       LOWIND        **
C*************************
C
C
      SUBROUTINE LOWIND (IH, IK, IL, ILIMIT, BELOW)
C
C Purpose: Identifies hkl values of low index
C          the indices ih, ik, il have all common factors removed
C          if, after this, any index is greater than a specified
C          value, below is returned false, otherwise true
C
C Author: Simon Morris, Daresbury Laboratory
C
      INTEGER IH, IK, IL, ILIMIT
      LOGICAL BELOW
C
C     IH : the three indices
C     IK :
C     IL :
C ILIMIT : value the indices may be less than or equal to
C  BELOW : true on return iff the indices are less than or equal to
C          ILIMIT
C
C====== LOCALS:
C
      INTEGER IH1, IK1, IL1, IHA, IKA, ILA, IVAL1, IVAL2, IVAL3
      INTEGER IHCF
C
C   IHCF : function returning the hcf of two positive integers
C
C-------------------------------------------------------------------------------
C
      IHA = ABS(IH)
      IKA = ABS(IK)
      ILA = ABS(IL)
      IVAL1 = IHCF(IHA,IKA)
      IVAL2 = IHCF(IKA,ILA)
      IVAL3 = IHCF(IVAL1,IVAL2)
      IF (IVAL3.NE.0) THEN
         IH1 = IHA/IVAL3
         IK1 = IKA/IVAL3
         IL1 = ILA/IVAL3
      END IF
      IF ((IH1.LE.ILIMIT) .AND. (IK1.LE.ILIMIT) .AND. (IL1.LE.ILIMIT))
     +    THEN
         BELOW = .TRUE.
      ELSE
         BELOW = .FALSE.
      END IF
      IF (IHA.GT.9 .OR. IKA.GT.9 .OR. ILA.GT.9) BELOW = .FALSE.
      RETURN
      END
**==lstart.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       LSTART        **
C*************************
C
C
      SUBROUTINE LSTART (NRSTRT,ICHANG,USED,NCOND,IFLAG)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Calculate and display a laue picture
C
      INTEGER NRSTRT,ICHANG,NCOND,IFLAG
      LOGICAL USED
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'project.finc'
      INCLUDE 'radc.finc'
 
      COMMON/AMAT/ A(3,3),AMATX(3,3)
      REAL         A     ,AMATX
      COMMON/SPOTS/ NR
      INTEGER       NR
C
C====== LOCALS:
C
      LOGICAL EOF,ERR
      CHARACTER*80 STR
      REAL   DSTMAX,RMIN,THETAMIN
      CHARACTER*1 ANSWER
 
      REAL FLPVAL
C
C-------------------------------------------------------------------------------
C
C====== Code to handle projection option
C
 20   WRITE (STR,6010)
      CALL TPROMP(STR)
      CALL TREAD(ANSWER,EOF)
      CALL TOUPPR(ANSWER)
      IF (ANSWER.EQ.' ') ANSWER = 'L'
      IF (ANSWER.EQ.'L') PROJTYPE = PROJLAUE
      IF (ANSWER.EQ.'S') THEN
         PROJTYPE = PROJSTER
         RADISTER = CTOF
         RADISTER2 = RADISTER*RADISTER
         WRITE (STR,6020) RADISTER , 'Primitive circle'
         CALL TWRITE(STR)
      END IF
      IF (ANSWER.EQ.'G') THEN
         PROJTYPE = PROJGNOM
 30      WRITE (STR,6030)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (EOF) GO TO 50
         RMIN = FLPVAL(STR,ERR)
         IF (RMIN.LT.5.0) THEN
            WRITE (STR,6040)
            CALL TWRITE(STR)
            GO TO 30
         END IF
         THETAMIN = ATAN2(RMIN,CTOF)/2.0
         RADIGNOM = CTOF/TAN(THETAMIN)
         RADIGNOM2 = RADIGNOM*RADIGNOM
         WRITE (STR,6020) RADIGNOM , 'Minimum circle'
         CALL TWRITE(STR)
      END IF
      IF (ANSWER.NE.'L' .AND. ANSWER.NE.'S' .AND. ANSWER.NE.'G') THEN
         CALL TWRITE('!!! invalid option')
         GO TO 20
      END IF
C
C====== Determine maximum resolution. ichang denotes a change in a parameter
C====== which necessitates recalculating the reciprocal lattice coords.
C
C
C====== WVS is the standard wavelength in which reciprocal cell lengths and
C====== the resolution (dmin) values are expressed
C
      NCOND = 0
      DSTMAX = WVS/DMIN
C
C====== Calculate the master matrix, a, from the cell and phi angles.
C
      CALL TWRITE('=== Calculating master matrix ...')
      CALL ACALC
C
C====== Put the reciprocal lattice coords of possible reflections into /xyz/
C
C====== IFLAG=0 denotes first entry to hklxyz. nrstrt is array start
C
      IFLAG = 0
      NRSTRT = 1
 
 40   CALL TWRITE('=== calculating lattice coords ...')
      CALL HKLXYZ(DSTMAX,IFLAG,USED)
      IF (ABORT) RETURN
C
C====== If IFLAG=1 on return then user has requested compression
C
      IF (IFLAG.NE.0) NCOND = 1
C
C====== If IFLAG=0 on return in compression mode then this is the end
C====== and laue must be told with NCOND=-1
C
      IF (IFLAG.EQ.0 .AND. NCOND.EQ.1) NCOND = -1
C
C====== Calculate and display the laue pattern
C
      WRITE (STR,6050) NR
      CALL TWRITE(STR)
      CALL LAUEG(NRSTRT,NCOND,USED)
      IF (IFLAG.NE.0) THEN
         NRSTRT = NR + 1
         IF (NRSTRT.LE.INDPRM) THEN
            WRITE (STR,6060) NRSTRT
            CALL TWRITE(STR)
            GO TO 40
         END IF
      END IF
 
 50   RETURN
C
C====== Format Statements
C
 6010 FORMAT ('>>> Select Projection Option ',
     +        ' (Laue, Stereographic, Gnomonic [L]: ')
 6020 FORMAT ('Setting radius to ',F8.1,' (',A16,')')
 6030 FORMAT ('>>> Enter minimum radius for Gnomonic projection: ')
 6040 FORMAT ('!!! Value must be 5.0 or greater')
 6050 FORMAT ('=== Calculating spot coordinates ... NR =',I6,
     +        ' NRSTRT =',I6)
 6060 FORMAT ('Looping after calling laue with NRSTRT =',I6)
      END
**==matm33.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MATM33        **
C*************************
C
C
        SUBROUTINE MATM33(A,B,C)
C
        DIMENSION A(3,3),B(3,3),C(3,3)
C
C-------------------------------------------------------------------------------
C
      DO 40 I = 1 , 3
         DO 30 J = 1 , 3
            C(I,J) = 0.0
            DO 20 K = 1 , 3
               C(I,J) = C(I,J) + A(I,K)*B(K,J)
 20         CONTINUE
 30      CONTINUE
 40   CONTINUE
      RETURN
      END
**==mats.f  
C
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MATS          **
C*************************
C
C
      SUBROUTINE MATS (AM,AA,AB,AC,AD,AE,AF,CELL)
C
C Purpose:
C
C Generalised matrix and derivative builder
C the reciprocal cell parameters come in cell(1-6) but only the
C unique ones ... cell(1) is astar, cell(2) alphastar for rhombohedra
C for example.
C am returns the A matrix ... row 1 is components of reciprocal cell
C along X, row 2 along Y, row 3 along Z.
C aa, ab etc are the derivative matrices for A wrt the unique cell
C parameters in order ... thus aa is dA/dastar, ab dA/alphastar for
C rhombohedral.
C
C Modified by Pella Machin and T.Tjahjadi
C reset AM,AA,AB,AC,AD,AE,AF TO 0, otherwise problem arise if orientatio
C by poles is used after a triclinic case is run because only parameters
C relevant to a particular lattice type are reset, the rest remain
C unchanged.
C
      COMMON/MATRIX/ MSYS,MROT,MBEAM
      DIMENSION AM(3,3),AA(3,3),AB(3,3),AC(3,3),AD(3,3),CELL(6),
     1 AE(3,3),AF(3,3),RL(3),CC(3),SS(3)
      DIMENSION DA(3,3,3),DB(3,3,3)
C
C-------------------------------------------------------------------------------
C
C
C====== Reset matrix elements
C
      DO 30 I = 1 , 3
         DO 20 J = 1 , 3
            AM(I,J) = 0
            AA(I,J) = 0
            AB(I,J) = 0
            AC(I,J) = 0
            AD(I,J) = 0
            AE(I,J) = 0
            AF(I,J) = 0
 20      CONTINUE
 30   CONTINUE
C
C====== I refers to MROT, the crystal rotation axis, z
C
      I = IABS(MROT)
      SI = 1.0
      IF (MROT.LT.0) SI = -1.0
C
C====== J refers to MBEAM, the xray beam axis, x
C
      J = IABS(MBEAM)
      SJ = 1.0
      IF (MBEAM.LT.0) SJ = -1.0
C
C====== K is therefore the other axis, y
C
      K = 6 - I - J
C
C====== The sign of k relies on i,j,k and X,Y,Z being right-handed
C
      IF (K.EQ.J+1 .OR. K.EQ.J-2) THEN
         SK = SI*SJ
      ELSE
         SK = -SI*SJ
      END IF
 
      IF (MSYS.EQ.2) THEN
C
C====== Monoclinic
C
         RL(1) = CELL(1)
         RL(2) = CELL(2)
         RL(3) = CELL(3)
 
         CC(1) = 0.0
         CC(2) = COS(CELL(4))
         CC(3) = 0.0
 
         SS(1) = 1.0
         SS(2) = SIN(CELL(4))
         SS(3) = 1.0
C
C====== A matrix
C
         AM(1,J) = SJ*RL(J)*SS(K)
         AM(1,K) = SJ*RL(K)*CC(I)
         AM(2,K) = SK*RL(K)*SS(I)*SS(J)
         AM(3,I) = SI*RL(I)
         AM(3,J) = SI*RL(J)*CC(K)
         AM(3,K) = SI*RL(K)*CC(J)
C
C====== Derivatives wrt reciprocal cell lengths
C
         DO 60 N1 = 1 , 3
            DO 50 N2 = 1 , 3
               DO 40 N3 = 1 , 3
                  DA(N1,N2,N3) = 0.
 40            CONTINUE
 50         CONTINUE
 60      CONTINUE
 
         DA(3,I,I) = SI
         DA(1,J,J) = SJ*SS(K)
         DA(3,J,J) = SI*CC(K)
         DA(1,K,K) = SJ*CC(I)
         DA(2,K,K) = SK*SS(I)*SS(J)
         DA(3,K,K) = SI*CC(J)
 
         DO 90 N1 = 1 , 3
            DO 80 N2 = 1 , 3
               DO 70 N3 = 1 , 3
                  IF (DA(N1,N2,N3).NE.0.0) THEN
                     IF (N3.EQ.1) AA(N1,N2) = DA(N1,N2,N3)
                     IF (N3.EQ.2) AB(N1,N2) = DA(N1,N2,N3)
                     IF (N3.EQ.3) AC(N1,N2) = DA(N1,N2,N3)
                  END IF
 70            CONTINUE
 80         CONTINUE
 90      CONTINUE
C
C====== Derivatives wrt reciprocal cell angles (only ss(2) and cc(2))
C
         IF (I.EQ.2) THEN
            AD(1,K) = -SJ*RL(K)*SS(I)
            AD(2,K) = SK*RL(K)*CC(I)
         END IF
         IF (J.EQ.2) THEN
            AD(2,K) = SK*RL(K)*CC(J)
            AD(3,K) = -SI*RL(K)*SS(J)
         END IF
         IF (K.EQ.2) THEN
            AD(1,J) = SJ*RL(J)*CC(K)
            AD(3,J) = -SI*RL(J)*SS(K)
         END IF
         RETURN
      ELSE IF (MSYS.EQ.3) THEN
C
C====== Orthorhombic
C
         RL(1) = CELL(1)
         RL(2) = CELL(2)
         RL(3) = CELL(3)
         AM(1,J) = SJ*RL(J)
         AM(2,K) = SK*RL(K)
         AM(3,I) = SI*RL(I)
C
C====== Derivatives
C
         IF (J.EQ.1) AA(1,1) = SJ
         IF (K.EQ.1) AA(2,1) = SK
         IF (I.EQ.1) AA(3,1) = SI
 
         IF (J.EQ.2) AB(1,2) = SJ
         IF (K.EQ.2) AB(2,2) = SK
         IF (I.EQ.2) AB(3,2) = SI
 
         IF (J.EQ.3) AC(1,3) = SJ
         IF (K.EQ.3) AC(2,3) = SK
         IF (I.EQ.3) AC(3,3) = SI
         RETURN
      ELSE IF (MSYS.EQ.4) THEN
C
C====== Tetragonal
C
         RL(1) = CELL(1)
         RL(2) = CELL(1)
         RL(3) = CELL(2)
         AM(1,J) = SJ*RL(J)
         AM(2,K) = SK*RL(K)
         AM(3,I) = SI*RL(I)
C
C====== Derivatives
C
         IF (J.EQ.1) AA(1,1) = SJ
         IF (K.EQ.1) AA(2,1) = SK
         IF (I.EQ.1) AA(3,1) = SI
 
         IF (J.EQ.2) AA(1,2) = SJ
         IF (K.EQ.2) AA(2,2) = SK
         IF (I.EQ.2) AA(3,2) = SI
 
         IF (J.EQ.3) AB(1,3) = SJ
         IF (K.EQ.3) AB(2,3) = SK
         IF (I.EQ.3) AB(3,3) = SI
         RETURN
      ELSE IF (MSYS.EQ.5) THEN
C
C====== Hexagonal
C
         RL(1) = CELL(1)
         RL(2) = CELL(1)
         RL(3) = CELL(2)
 
         CC(1) = 0.0
         CC(2) = 0.0
         CC(3) = 0.5
 
         SS(1) = 1.0
         SS(2) = 1.0
         SS(3) = SQRT(3.)/2.
C
C====== A matrix
C
         AM(1,J) = SJ*RL(J)*SS(K)
         AM(1,K) = SJ*RL(K)*CC(I)
         AM(2,K) = SK*RL(K)*SS(I)*SS(J)
         AM(3,I) = SI*RL(I)
         AM(3,J) = SI*RL(J)*CC(K)
         AM(3,K) = SI*RL(K)*CC(J)
C
C======  Derivatives wrt reciprocal cell lengths
C
         DO 120 N1 = 1 , 3
            DO 110 N2 = 1 , 3
               DO 100 N3 = 1 , 3
                  DA(N1,N2,N3) = 0.
 100           CONTINUE
 110        CONTINUE
 120     CONTINUE
 
         DA(3,I,I) = SI
         DA(1,J,J) = SJ*SS(K)
         DA(3,J,J) = SI*CC(K)
         DA(1,K,K) = SJ*CC(I)
         DA(2,K,K) = SK*SS(I)*SS(J)
         DA(3,K,K) = SI*CC(J)
 
         DO 150 N1 = 1 , 3
            DO 140 N2 = 1 , 3
               DO 130 N3 = 1 , 3
                  IF (DA(N1,N2,N3).NE.0.0) THEN
                     IF (N3.EQ.1 .OR. N3.EQ.2) AA(N1,N2) = DA(N1,N2,N3)
                     IF (N3.EQ.3) AB(N1,N2) = DA(N1,N2,N3)
                  END IF
 130           CONTINUE
 140        CONTINUE
 150     CONTINUE
         RETURN
      ELSE IF (MSYS.EQ.6) THEN
C
C====== Rhombohedral
C
         A = CELL(1)
         C = COS(CELL(2))
         S = SIN(CELL(2))
         FUN = SQRT(1.-3.*C**2+2.*C**3)
         AM(1,J) = SJ*A*S
         AM(1,K) = SJ*A*C*(1.-C)/S
         AM(2,K) = SK*A*FUN/S
         AM(3,I) = SI*A
         AM(3,J) = SI*A*C
         AM(3,K) = SI*A*C
 
         AA(1,J) = SJ*S
         AA(1,K) = AM(1,K)/A
         AA(2,K) = AM(2,K)/A
         AA(3,I) = SI
         AA(3,J) = SI*C
         AA(3,K) = SI*C
 
         AB(1,J) = SJ*A*C
         AB(1,K) = SJ*A*(C-(1.-C)/S**2)
         AB(2,K) = SK*A*(3.*C*(1.-C)/FUN-FUN*C/S**2)
         AB(3,J) = -SI*A*S
         AB(3,K) = -SI*A*S
         RETURN
      ELSE IF (MSYS.EQ.7) THEN
C
C====== Cubic
C
         A = CELL(1)
         AM(1,J) = SJ*A
         AM(2,K) = SK*A
         AM(3,I) = SI*A
 
         AA(1,J) = SJ
         AA(2,K) = SK
         AA(3,I) = SI
         RETURN
      ELSE
C
C====== Triclinic
C
         RL(1) = CELL(1)
         RL(2) = CELL(2)
         RL(3) = CELL(3)
 
         CC(1) = COS(CELL(4))
         CC(2) = COS(CELL(5))
         CC(3) = COS(CELL(6))
 
         SS(1) = SIN(CELL(4))
         SS(2) = SIN(CELL(5))
         SS(3) = SIN(CELL(6))
C
C====== See Buerger's Xray Crystallography for the next formulae, p348
C
         COSPSI = (CC(I)-CC(K)*CC(J))/SS(K)
         TMPRT = ABS(1.-CC(I)**2-CC(J)**2-CC(K)**2+2.*CC(I)*CC(J)*CC(K))
         COSRHO = SQRT(TMPRT)/SS(K)
C
C====== A matrix
C
         AM(1,J) = SJ*RL(J)*SS(K)
         AM(1,K) = SJ*RL(K)*COSPSI
         AM(2,K) = SK*RL(K)*COSRHO
         AM(3,I) = SI*RL(I)
         AM(3,J) = SI*RL(J)*CC(K)
         AM(3,K) = SI*RL(K)*CC(J)
C
C====== Derivatives wrt reciprocal cell lengths
C
         DO 180 N1 = 1 , 3
            DO 170 N2 = 1 , 3
               DO 160 N3 = 1 , 3
                  DA(N1,N2,N3) = 0.
                  DB(N1,N2,N3) = 0.
 160           CONTINUE
 170        CONTINUE
 180     CONTINUE
 
         DA(3,I,I) = SI
         DA(1,J,J) = SJ*SS(K)
         DA(3,J,J) = SI*CC(K)
         DA(1,K,K) = SJ*COSPSI
         DA(2,K,K) = SK*COSRHO
         DA(3,K,K) = SI*CC(J)
 
         DO 210 N1 = 1 , 3
            DO 200 N2 = 1 , 3
               DO 190 N3 = 1 , 3
                  IF (DA(N1,N2,N3).NE.0.0) THEN
                     IF (N3.EQ.1) AA(N1,N2) = DA(N1,N2,N3)
                     IF (N3.EQ.2) AB(N1,N2) = DA(N1,N2,N3)
                     IF (N3.EQ.3) AC(N1,N2) = DA(N1,N2,N3)
                  END IF
 190           CONTINUE
 200        CONTINUE
 210     CONTINUE
C
C====== Derivatives wrt reciprocal cell angles
C
         DB(1,K,I) = -SJ*RL(K)*SS(I)/SS(K)
         DB(2,K,I) = SK*RL(K)*SS(I)*(CC(I)-CC(J)*CC(K))
     +               /(SS(K)**2*COSRHO)
         DB(1,K,J) = SJ*RL(K)*CC(K)*SS(J)/SS(K)
         DB(2,K,J) = SK*RL(K)*SS(J)*(CC(J)-CC(I)*CC(K))
     +               /(SS(K)**2*COSRHO)
         DB(3,K,J) = -SI*RL(K)*SS(J)
         DB(1,J,K) = SJ*RL(J)*CC(K)
         DB(1,K,K) = SJ*RL(K)*(CC(J)-CC(K)*CC(I))/SS(K)**2
         DB(2,K,K) = SK*RL(K)*((CC(K)-CC(I)*CC(J))/(COSRHO*SS(K))-CC(K)
     +               *COSRHO/SS(K))
         DB(3,J,K) = -SI*RL(J)*SS(K)
 
         DO 240 N1 = 1 , 3
            DO 230 N2 = 1 , 3
               DO 220 N3 = 1 , 3
                  IF (DB(N1,N2,N3).NE.0.0) THEN
                     IF (N3.EQ.1) AD(N1,N2) = DB(N1,N2,N3)
                     IF (N3.EQ.2) AE(N1,N2) = DB(N1,N2,N3)
                     IF (N3.EQ.3) AF(N1,N2) = DB(N1,N2,N3)
                  END IF
 220           CONTINUE
 230        CONTINUE
 240     CONTINUE
         RETURN
      END IF
      END
**==menu.f  
C LAST UPATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MENU          **
C*************************
C
C
      SUBROUTINE MENU (WORDS,NWORDS,VALUES,NVALS,IOPT)
C
      CHARACTER*4 WORDS(*)
      REAL   VALUES(*)
      INTEGER NWORDS,NVALS,IOPT
C
      INCLUDE 'pgstat.finc'
C
      CHARACTER*80 STR
      CHARACTER*4 OPTION(34)
      INTEGER KOPT,INOPT
 
      DATA OPTION /
     * 'A   ','B   ','C   ','ALPH','BETA','GAMM',
     * 'WMIN','WMAX','DIST','DMIN','RADI','SYST',
     * 'ORIE','PX  ','PY  ','PZ  ','SPIN','ABSE','SCAL',
     * 'DATS','DATG','STAR','PLOT','HARD','INDE','EXPA',
     * 'PICS','OVER','AUTO','HELP','STOP','    ','    ',
     * '    '/
 
      DATA NOPT/34/
C
C-------------------------------------------------------------------------------
C
      INOPT = IOPT
 20   CALL QSSETC(1,24)
      NWORDS = 0
      NVALS = 0
      CALL QSBELL
      WRITE (STR,6010) OPTION(INOPT)
      CALL TPROMP(STR)
      CALL TREAD(STR,ABORT)
      CALL TOUPPR(STR)
      CALL STRTKN(STR,' ,',2,WORDS,NWORDS,VALUES,NVALS)
      IF (NWORDS.GT.0) THEN
         KOPT = 0
         DO 30 I = 1 , NOPT
            IF (WORDS(1).EQ.OPTION(I)) THEN
               KOPT = I
               GO TO 40
            END IF
 30      CONTINUE
      END IF
 40   IF (.NOT.(ABORT)) THEN
         IF (NWORDS.EQ.0) KOPT = INOPT
         IOPT = KOPT
         IF (IOPT.LE.0) THEN
C
C====== Display error message
C
            CALL QSREVV
            WRITE (STR,6020) WORDS(1)
            CALL TWRITE(STR)
            CALL QSNORV
            GO TO 20
         END IF
      END IF
 
      NWORDS = NWORDS - 1
      IF (NWORDS.GE.1) WORDS(1) = WORDS(2)
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Select option [',A4,']: ')
 6020 FORMAT ('!!! Invalid option: ',A4)
      END
**==mhist.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MHIST         **
C*************************
C
C
      SUBROUTINE MHIST(NB)
C
C Purpose: Counts number of multiplets
C
      INTEGER NB
C
C
      INCLUDE 'progdim.finc'
      INCLUDE 'histo.finc'
C
C====== LOCALS:
C
      CHARACTER*80 STR
      INTEGER I,IP
C
C-------------------------------------------------------------------------------
C
C====== Sort multiplets
C
      CALL SORT(NB)
      DO 20 I = 1 , 21
         NMULT(I) = 0
 20   CONTINUE
 
      IP = 1
      MULTXY(IP) = 1
      N = 1
C
C====== Count them
C
 30   IP = IP + 1
      MULTXY(IP) = 1
      IF (IP.LE.NB) THEN
         IF (IXY(IP).EQ.IXY(IP-1)) THEN
            MULTXY(IP) = MULTXY(IP) + 1
            N = N + 1
            GO TO 30
         END IF
      END IF
      N = MIN0(N,21)
      NMULT(N) = NMULT(N) + 1
      N = 1
      IF (IP.LE.NB) GO TO 30
C
C====== Display count
C
      CALL QSREVV
      WRITE (STR,6010) NMULT(21)
      CALL TWRITE(STR)
      CALL QSNORV
      WRITE (STR,6030) (I,I=1,20)
      CALL TWRITE(STR)
      WRITE (STR,6020) (NMULT(I),I=1,20)
      CALL TWRITE(STR)
      CALL TWRITE(' ')
C
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('Number of multiplets M=1-20',40X,' M>20=',I6)
 6020 FORMAT (I5,18I4,I3)
 6030 FORMAT (I5,18I4,I3)
      END
**==minv.f  
C LAST UPDATE:
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MINV          **
C*************************
C
C
      SUBROUTINE MINV(A,AI,ICOD)
C
C Purpose: Any 3*3 matrix inverter(previously only for symmetric as not
C          transposed)
 
C     .. Scalar Arguments ..
      INTEGER ICOD
C     ..
C     .. Array Arguments ..
      REAL A(3,3),AI(3,3)
C     ..
C     .. Local Scalars ..
      REAL DET
      INTEGER I,J
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C     ..
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      DET = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)
     +      *A(3,2) - A(1,2)*A(2,1)*A(3,3) - A(1,1)*A(2,3)*A(3,2)
     +      - A(1,3)*A(2,2)*A(3,1)
      IF (ABS(DET).LT.0.2E-20) THEN
         WRITE (STR,6010)
         CALL TWRITE(STR)
         WRITE (STR,6020) DET
         CALL TWRITE(STR)
         DO 20 I = 1 , 3
            WRITE (STR,6030) (A(I,J),J=1,3)
            CALL TWRITE(STR)
 20      CONTINUE
         ICOD = 1
         RETURN
 
      ELSE
         ICOD = 0
      END IF
C
C ====== Set and transpose co-factors
C
      AI(1,1) = A(2,2)*A(3,3) - A(3,2)*A(2,3)
      AI(2,1) = A(2,3)*A(3,1) - A(2,1)*A(3,3)
      AI(3,1) = A(2,1)*A(3,2) - A(3,1)*A(2,2)
      AI(1,2) = A(1,3)*A(3,2) - A(1,2)*A(3,3)
      AI(2,2) = A(1,1)*A(3,3) - A(1,3)*A(3,1)
      AI(3,2) = A(3,1)*A(1,2) - A(1,1)*A(3,2)
      AI(1,3) = A(1,2)*A(2,3) - A(2,2)*A(1,3)
      AI(2,3) = A(1,3)*A(2,1) - A(1,1)*A(2,3)
      AI(3,3) = A(1,1)*A(2,2) - A(1,2)*A(2,1)
      DO 40 I = 1 , 3
         DO 30 J = 1 , 3
            AI(I,J) = AI(I,J)/DET
 30      CONTINUE
 40   CONTINUE
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('!!! Problem with least squares solution - skip')
 6020 FORMAT ('The matrix to be inverted follows. Its determinant is',
     +        E12.3)
 6030 FORMAT (3E12.3)
      END
**==monocl.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MONOCL        **
C*************************
C
C
      SUBROUTINE MONOCL(CELL)
C
      REAL CELL(6),STOR(6)
C
C-------------------------------------------------------------------------------
C
      FAC = SIN((3.1415926536/180.)*CELL(5))
      STOR(1) = 1.0/(CELL(1)*FAC)
      STOR(2) = 1.0/CELL(2)
      STOR(3) = 1.0/(CELL(3)*FAC)
      STOR(4) = 0.
      STOR(5) = 180. - CELL(5)
      STOR(6) = 0.
      DO 20 I = 1 , 6
         CELL(I) = STOR(I)
 20   CONTINUE
      RETURN
      END
**==muldanv.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       MULDANV       **
C*************************
C
C
      SUBROUTINE MULDANV(DMAT,AINV)
C
      REAL DMAT(3,3),AINV(3,3)
      REAL TEMP(3,3),ACC
      INTEGER I,J,K
C
C-------------------------------------------------------------------------------
C
      DO 40 I = 1 , 3
         DO 30 J = 1 , 3
            ACC = 0
            DO 20 K = 1 , 3
               ACC = ACC + DMAT(I,K)*AINV(K,J)
 20         CONTINUE
            TEMP(I,J) = ACC
 30      CONTINUE
 40   CONTINUE
      DO 60 I = 1 , 3
         DO 50 J = 1 , 3
            DMAT(I,J) = TEMP(I,J)
 50      CONTINUE
 60   CONTINUE
      RETURN
      END
**==nocdnl.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       NOCDNL        **
C*************************
C
C
      SUBROUTINE NOCDNL(PB,COS2B,COSZB,COS1B,V)
C
      REAL PB(3), COS2B , COSZB , COS1B , V
C
C====== No cardinal positions given  -  solve for pole b
C
C
C===== GLOBALS:
C
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
C
C====== LOCALS:
C
      REAL Z(3) , AA(3,3) , X , PNORM , DNORM
C
C-------------------------------------------------------------------------------
C
      IF (KP1.NE.4) THEN
         X = DNORM(D1)
         IF (KP2.NE.2) THEN
C
C====== 1 and 2 are directions
C
            X = DNORM(D2)
            Z(1) = V*(D2(2)*D1(3)-D2(3)*D1(2))
            Z(2) = V*(D2(3)*D1(1)-D2(1)*D1(3))
            Z(3) = V*(D2(1)*D1(2)-D2(2)*D1(1))
            X = PNORM(Z)
            CALL SETAA(AA,Z,1)
            PB(1) = V**2*COSZB
            DO 20 I = 1 , 3
               AA(2,I) = D1(I)
               AA(3,I) = D2(I)
 20         CONTINUE
            PB(2) = COS1B
            PB(3) = COS2B
         ELSE
C
C====== 1 is a direction , 2 is a pole
C
            X = PNORM(P2)
            CALL RST(P2,D1,Z,PB,3.)
            X = DNORM(Z)
            DO 30 I = 1 , 3
               AA(1,I) = Z(I)
               AA(2,I) = D1(I)
 30         CONTINUE
            CALL SETAA(AA,P2,3)
            PB(1) = COSZB
            PB(2) = COS1B
            PB(3) = COS2B*V**2
         END IF
      ELSE
         X = PNORM(P1)
         IF (KP2.NE.2) THEN
C
C====== 1 is a pole , 2 is a direction
C
            X = DNORM(D2)
            CALL RST(P1,D2,Z,PB,3.)
            X = DNORM(Z)
            DO 40 I = 1 , 3
               AA(1,I) = -Z(I)
               AA(3,I) = D2(I)
 40         CONTINUE
            CALL SETAA(AA,P1,2)
            PB(1) = COSZB
            PB(2) = V**2*COS1B
            PB(3) = COS2B
         ELSE
C
C====== 1 and 2 are poles
C
            X = PNORM(P2)
            Z(1) = (P2(2)*P1(3)-P2(3)*P1(2))/V
            Z(2) = (P2(3)*P1(1)-P2(1)*P1(3))/V
            Z(3) = (P2(1)*P1(2)-P2(2)*P1(1))/V
            X = DNORM(Z)
            DO 50 I = 1 , 3
               AA(1,I) = Z(I)
 50         CONTINUE
            PB(1) = COSZB
            PB(2) = COS1B*V**2
            PB(3) = COS2B*V**2
            CALL SETAA(AA,P1,2)
            CALL SETAA(AA,P2,3)
         END IF
      END IF
      CALL SOLVEQN(AA,PB,3,1,1,3,3)
      X = PNORM(PB)
      RETURN
      END
**==onegivn.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ONEGIVN       **
C*************************
C
C
      SUBROUTINE ONEGIVN(PA,DA,PB,DB,KPA,K1,KPB,KDB,K2,SIGN,V,KP2,SINZA,
     &SIN1B,KP1)
C
      REAL PA(3),DA(3),PB(3),DB(3),SIGN,V,SINZA,SIN1B
      INTEGER KPA , K1 , KPB , KDB , K2 , KP2 , KP1
C
C====== a and 1 are given.    solve for pole b or direction b.
C
C====== GLOBALS:
C
      COMMON/PD/P1(3),D1(3),P2(3),D2(3),DUM1,DUM2
      REAL P1,D1,P2,D2,DUM1,DUM2
      COMMON/SC/COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
      REAL COS1B,COS2B,SIN2B,SIN2ZA,COS2ZA
C
C====== LOCALS:
C
      REAL AA(3,3),BB(3),CC(3),Z(3) , COSZA , ZB , XPI , TZB , TH1 , THI
      REAL X , PNORM , DNORM
C
C-------------------------------------------------------------------------------
C
      IF (K1.EQ.1 .AND. SINZA.LE.0.) SIGN = -SIGN
      COSZA = COS(ASIN(SINZA))
      IF (K1.EQ.4) THEN
         IF (SINZA.NE.0.) THEN
            IF (COS1B.NE.0.) THEN
               TH1 = ATAN(SIN1B*SINZA/COS1B)
               IF (COS1B.LT.0.) TH1 = TH1 + XPI(1.)
            ELSE
               TH1 = XPI(1.)
               IF (SINZA.LT.0.) TH1 = -TH1
            END IF
C
C====== !!! THI changed to Th1 in next statement - may not be correct
C
            BB(2) = TH1*XPI(0.5)
            IF (SINZA.GT.0.) BB(2) = BB(2) - XPI(1.)
            IF (BB(2).GT.XPI(2.)) BB(2) = BB(2) - XPI(2.)
            BB(2) = COS(BB(2))
         ELSE
            BB(2) = 0.
         END IF
         GO TO 20
      ELSE IF (SINZA.NE.0.) THEN
         IF (ABS(SINZA).NE.1.) THEN
            TZB = -COS1B/(SIN1B*COSZA)
            ZB = ATAN(TZB)
         ELSE
            BB(2) = 0.
            GO TO 20
         END IF
      ELSE
         ZB = ASIN(SIN1B) - XPI(0.5)
         IF (ZB.LT.0.) ZB = ZB + XPI(1.)
      END IF
      BB(2) = COS(ZB)
      BB(2) = BB(2)*SIGN
      IF (SINZA.GT.0.) BB(2) = -BB(2)
      IF (BB(2).EQ.-1.) BB(2) = 1.
 20   IF (KPA.NE.K1) THEN
C
C====== a is a direction
C
         X = DNORM(DA)
         IF (SINZA.LT.0.) SIGN = -SIGN
         IF (K1.EQ.1 .AND. SINZA.LT.0. .AND. COS1B.EQ.0.) SIGN = -SIGN
         IF (KP1.EQ.4) X = PNORM(P1)
         CALL RST(P1,DA,Z,CC,3.)
         DO 30 I = 1 , 3
            AA(1,I) = CC(I)
 30      CONTINUE
         BB(1) = 0.
         IF (KP1.NE.4) THEN
C
C====== 1 is a direction
C
            X = DNORM(D1)
            Z(1) = (D1(2)*DA(3)-D1(3)*DA(2))*SIGN
            Z(2) = (D1(3)*DA(1)-D1(1)*DA(3))*SIGN
            Z(3) = (D1(1)*DA(2)-D1(2)*DA(1))*SIGN
            X = PNORM(Z)
            DO 40 I = 1 , 3
               AA(2,I) = Z(I)
 40         CONTINUE
            CALL RST(P1,D1,Z,CC,0.)
            X = PNORM(CC)
            DO 50 I = 1 , 3
               AA(3,I) = CC(I)
 50         CONTINUE
            BB(3) = COS1B
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 60 I = 1 , 3
               DB(I) = BB(I)
 60         CONTINUE
            KDB = K2
            RETURN
         ELSE
C
C====== 1 is a pole
C
            X = DNORM(Z)
            CALL RST(P1,Z,Z,CC,0.)
            DO 70 I = 1 , 3
               AA(2,I) = CC(I)*SIGN
 70         CONTINUE
            DO 80 I = 1 , 3
               AA(3,I) = P1(I)
 80         CONTINUE
            BB(3) = COS1B
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 90 I = 1 , 3
               DB(I) = BB(I)
 90         CONTINUE
            KDB = K2
            RETURN
         END IF
      ELSE
C
C====== a is a pole
C
         X = PNORM(PA)
         IF (SINZA.EQ.-1.) SIGN = -SIGN
         BB(1) = 0.
         CALL SETAA(AA,PA,1)
         IF (KP1.NE.4) THEN
C
C====== 1 is a direction
C
            X = DNORM(D1)
            CALL RST(PA,D1,Z,CC,3.)
            DO 100 I = 1 , 3
               PB(I) = -Z(I)*SIGN
 100        CONTINUE
            X = DNORM(PB)
            DO 110 I = 1 , 3
               AA(2,I) = PB(I)
 110        CONTINUE
            DO 120 I = 1 , 3
               AA(3,I) = D1(I)
 120        CONTINUE
            BB(3) = COS1B
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 130 I = 1 , 3
               PB(I) = BB(I)
 130        CONTINUE
            KPB = K2
            RETURN
         ELSE
C
C====== 1 is a pole
C
            X = PNORM(P1)
            IF (K1.EQ.4 .AND. SINZA.LT.0. .AND. COS1B.EQ.0.)
     +          SIGN = -SIGN
            Z(1) = (PA(3)*P1(2)-PA(2)*P1(3))*SIGN
            Z(2) = (PA(1)*P1(3)-PA(3)*P1(1))*SIGN
            Z(3) = (PA(2)*P1(1)-PA(1)*P1(2))*SIGN
            X = DNORM(Z)
            DO 140 I = 1 , 3
               AA(2,I) = Z(I)
 140        CONTINUE
            CALL SETAA(AA,P1,3)
            BB(3) = COS1B*V**2
            CALL SOLVEQN(AA,BB,3,1,1,3,3)
            DO 150 I = 1 , 3
               PB(I) = BB(I)
 150        CONTINUE
            KPB = K2
            RETURN
         END IF
      END IF
      END
**==orient.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ORIENT        **
C*************************
C
C
      SUBROUTINE ORIENT(ANGORI,LABEL)
C
      LOGICAL ANGORI
      CHARACTER*(*) LABEL(7,5),TEMP*15,A1*2,A2*2,AX(3)*1
C
C Purpose: Set orientation having decided which method to use
C
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'data.finc'
      INCLUDE 'vsave.finc'
      COMMON /PD/GVEC(12),KP1,KP2
      INTEGER KP1,KP2
 
      COMMON/CARDNL/CDVEC(18)
C
C====== CDVEC = PA(3) , PB , PC , DA , DB , DC
C
      COMMON/ANGLE/COSTY,COSTZ,ABC(3),COSA,COSB,COSG,SINA,SINB,SING
      REAL COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
C
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +RMAX,ULAM,LLAM,CL
C
      COMMON /FIDS/ FIDX(3),FIDY(3)
      REAL FIDX,FIDY
C
C====== LOCALS:
C
      REAL SIGN(3)
      REAL ENORM
      REAL FIDXC1(3),FIDYC1(3),FIDXC2(3),FIDYC2(3)
      LOGICAL ERROR
      INTEGER I,JJ,NWORDS,NVALS,ICAM
      CHARACTER*80 LINE
      CHARACTER*80 ERSTR
      CHARACTER*4 WORDS(10)
      REAL VALUES(10)
      REAL DMAT(3,3),BMAT(3,3),AINV(3,3)
      DATA SIGN/1.,-1.,-1./
      DATA AX/'A','B','C'/
      DATA FIDXC1/-5000,-5000,5000/
      DATA FIDYC1/-4000,4000,4000/
      DATA FIDXC2/-4000,-4000,4000/
      DATA FIDYC2/5000,-5000,-5000/
C
C-------------------------------------------------------------------------------
C
C====== Initialise FSLPIN
C
      DO 20 I = 1 , 45
         FSLPIN(I:I) = ' '
 20   CONTINUE
 
      A1 = '  '
      A2 = '  '
      TEMP = ' '
      DO 30 I = 1 , 12
         GVEC(I) = 0.0
 30   CONTINUE
      DO 40 I = 1 , 18
         CDVEC(I) = 0.0
 40   CONTINUE
 50   WRITE (LINE,6010)
      CALL TWRITE(LINE)
      WRITE (LINE,6020)
      CALL TWRITE(LINE)
      WRITE (LINE,6030)
      CALL TPROMP(LINE)
      CALL TREAD(LINE,ABORT)
      IF (ABORT) GO TO 110
      CALL REMOVE(LINE)
      CALL TOUPPR(LINE)
      IF (LINE(1:1).EQ.'V') THEN
         ANGORI = .FALSE.
         MBEAM = 1
         MROT = 3
         CALL AINVRS(AINV,ERROR,LABEL)
         IF (ABORT) GO TO 110
         IF (ERROR) GO TO 110
         CALL FSLP
         IF (ABORT) GO TO 110
         DO 70 I = 1 , 3
            DO 60 J = 1 , 3
               DMAT(I,J) = SIGN(I)*CDVEC(3*(I+2)+J)
 60         CONTINUE
 70      CONTINUE
         CALL MULDANV(DMAT,AINV)
C
C====== Invert to obtain the orientation matrix
C
         CALL FNDANG(DMAT,PHIS,BMAT,IDT,RDT)
C
C====== Don't forget  to unscramble the matrix
C
      ELSE IF (LINE(1:1).EQ.'A') THEN
         ANGORI = .TRUE.
         CALL SETOR(MROT,MBEAM)
         IF (ABORT) GO TO 110
      ELSE
         WRITE (ERSTR,6040) LINE(1:INTHCH(LINE))
         CALL TWRITE(ERSTR)
         CALL QSBELL
         GO TO 50
      END IF
 80   WRITE (LINE,6050)
      CALL TWRITE(LINE)
      WRITE (LINE,6060) (FIDX(I),FIDY(I),I=1,3)
      CALL TPROMP(LINE)
      CALL TREAD(LINE,ABORT)
      CALL STRTKN(LINE,' ,',10,WORDS,NWORDS,VALUES,NVALS)
      IF (NWORDS.GT.0) THEN
         CALL TOUPPR(WORDS(1))
         IF (WORDS(1).EQ.'C1') THEN
            DO 90 I = 1 , 3
               FIDX(I) = FIDXC1(I)
               FIDY(I) = FIDYC1(I)
 90         CONTINUE
            RETURN
         ELSE IF (WORDS(1).EQ.'C2') THEN
            DO 100 I = 1 , 3
               FIDX(I) = FIDXC2(I)
               FIDY(I) = FIDYC2(I)
 100        CONTINUE
            RETURN
         END IF
         WRITE (ERSTR,6070)
         CALL TWRITE(ERSTR)
         GO TO 80
      END IF
      IF (NVALS.GE.1) FIDX(1) = VALUES(1)
      IF (NVALS.GE.2) FIDY(1) = VALUES(2)
      IF (NVALS.GE.3) FIDX(2) = VALUES(3)
      IF (NVALS.GE.4) FIDY(2) = VALUES(4)
      IF (NVALS.GE.5) FIDX(3) = VALUES(5)
      IF (NVALS.GE.6) FIDY(3) = VALUES(6)
      RETURN
 
 110  ABORT = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Select Orientation Method - ')
 6020 FORMAT ('    V = VECTOR (Poles or Directions)')
 6030 FORMAT ('    A = MISSETTING ANGLES           : ')
 6040 FORMAT ('!!! Invalid input ',A)
 6050 FORMAT (' >>> Camera type (C1=Arndt-Wonacott, C2=Huber) or',
     +        ' fiducial values')
 6060 FORMAT ('[',6F8.1,']: ')
 6070 FORMAT ('!!! Invalid camera type')
      END
**==orthor.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ORTHOR        **
C*************************
C
C
      SUBROUTINE ORTHOR(CELL)
C
      REAL CELL(6)
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , 3
         CELL(I) = 1.0/CELL(I)
 20   CONTINUE
      RETURN
      END
**==parsex.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       PARSEX        **
C*************************
C
C
      SUBROUTINE PARSEX(USED)
C
      LOGICAL USED
C
C Purpose: Parse extinction classes
C
      COMMON /XTINCT/IFORM(3,50),HCOF(50),KCOF(50),LCOF(50),
     +               IA(50),IB(50),NX,NEWUSE,ITAG(50)
      COMMON /XALSO/JFORM(3,50),HCOFJ(50),KCOFJ(50),LCOFJ(50),
     +               IAJ(50),IBJ(50),NXJ,ITABLE(10,0:63)
      INTEGER JFORM,HCOFJ,KCOFJ,LCOFJ,IAJ,IBJ,NXJ
      INTEGER IFORM,HCOF,KCOF,LCOF,IA,IB,NX,ITABLE
      LOGICAL NEWUSE
      LOGICAL EOF,ERR
      CHARACTER*80 STR
      CHARACTER CHAR,C,RECORD*80,RESP*1,BLNK80*80,KEY(0:3)*1
      INTEGER INTHCH,I1STCH,ICVT
      DATA KEY/'0','H','K','L'/
      DATA BLNK80(1:40)/'                                        '/
      DATA BLNK80(41:80)/'                                        '/
C
C-------------------------------------------------------------------------------
C
C
C====== Read a line specifying an extinction class in the form
C
C====== ' hkl:h=2n+1 '
C====== which suggests that there is no reflection when H  is odd
C
C
C====== Add extinctions, or start again
C
      NEWUSE = .TRUE.
 20   WRITE (STR,6010)
      CALL TPROMP(STR)
      CALL TREAD(RESP,EOF)
      IF (EOF) GO TO 20
      IF (RESP.EQ.'a' .OR. RESP.EQ.'A') THEN
         IXNUM = NX
      ELSE
         IXNUM = 0
      END IF
C
C====== Read the next line , end if blank
C
      WRITE (STR,6020)
      CALL TWRITE(STR)
      IF (NEWUSE) THEN
         NEWUSE = .FALSE.
         WRITE (STR,6030)
         CALL TWRITE(STR)
         WRITE (STR,6040)
         CALL TWRITE(STR)
         CALL TWRITE(' ')
      END IF
 30   J = 0
      RECORD = BLNK80
      CALL TREAD(RECORD,EOF)
      IF (EOF) GO TO 110
      IF (RECORD.EQ.BLNK80) GO TO 110
      CALL REMOVE(RECORD)
C
C====== Get reflection class
C
      I = I1STCH(RECORD)
      N = INTHCH(RECORD)
      IXNUM = IXNUM + 1
      DO 40 ILOC = I , N
         LOC = ILOC
         LETT = INDEX(' hkl',RECORD(ILOC:ILOC)) - 1
         IF (LETT.LT.0) LETT = INDEX(' 0HKL',RECORD(ILOC:ILOC)) - 2
         IF (LETT.GT.-1) THEN
            J = J + 1
            IFLAG = 1
            IFORM(J,IXNUM) = LETT
            IF (J.EQ.3) GO TO 50
         END IF
 40   CONTINUE
      IF ((LOC.EQ.N) .AND. (IFLAG.EQ.0)) THEN
         CALL TWRITE('!!! Invalid record')
         CALL TWRITE(RECORD)
         WRITE (STR,6050) BLNK80(1:MAX(I-1,1))
         CALL TWRITE(STR)
         CALL QSBELL
         IXNUM = MAX(0,IXNUM-1)
         GO TO 30
      END IF
      IFLAG = 0
 50   ILOC = LOC + 1
C
C====== Get lhs of condition
C
      HCOF(IXNUM) = 0
      KCOF(IXNUM) = 0
      LCOF(IXNUM) = 0
      IPLUS = LOC
      DO 60 JLOC = ILOC , N
         LOC = JLOC
         LETT = INDEX('hkl',RECORD(JLOC:JLOC))
         IF (LETT.LE.0) LETT = INDEX('HKL',RECORD(JLOC:JLOC))
         IF (RECORD(JLOC:JLOC).EQ.'=') GO TO 70
         IF (LETT.GT.0) THEN
            INUM = INDEX('0123456789',RECORD(JLOC-1:JLOC-1)) - 1
            INUM = IABS(INUM)
            IF ((RECORD(JLOC-1:JLOC-1).EQ.'-') .OR. 
     +          (RECORD(JLOC-2:JLOC-2).EQ.'-')) INUM = -1*INUM
            IF (LETT.EQ.2) THEN
               KCOF(IXNUM) = INUM
            ELSE IF (LETT.EQ.3) THEN
               LCOF(IXNUM) = INUM
            ELSE
               HCOF(IXNUM) = INUM
            END IF
         END IF
 60   CONTINUE
      IF (LOC.EQ.N) THEN
         CALL TWRITE('!!! Invalid record')
         CALL TWRITE(RECORD)
         WRITE (STR,6050) BLNK80(1:MAX(I-1,1))
         CALL TWRITE(STR)
         CALL QSBELL
         IXNUM = MAX(0,IXNUM-1)
         GO TO 30
      END IF
 70   JLOC = LOC
      IB(IXNUM) = 0
      IA(IXNUM) = 0
 80   JLOC = JLOC + 1
C
C====== Get rhs of condition
C
      IF (JLOC.GT.N) THEN
         LOC = LOC + 1
         IB(IXNUM) = ICVT(RECORD(LOC:JLOC-1))
         GO TO 30
      ELSE
         IF (INDEX('hHiIjJkKlLmMnNpPqQrR',RECORD(JLOC:JLOC)).LE.0)
     +       GO TO 80
         IA(IXNUM) = ICVT(RECORD(LOC+1:JLOC-1))
         ILOC1 = JLOC
 90      JLOC = JLOC + 1
         IF (RECORD(JLOC:JLOC).EQ.'-') THEN
            LOC = LOC
            GO TO 100
         END IF
         IF (RECORD(JLOC:JLOC).NE.'+') GO TO 90
         LOC = JLOC + 1
      END IF
 100  JLOC = JLOC + 1
      IF (INDEX('-0123456789',RECORD(JLOC:JLOC)).GE.1) GO TO 100
      IB(IXNUM) = ICVT(RECORD(LOC:JLOC-1))
      GO TO 30
 110  NX = IXNUM
      IF (RESP.EQ.'a' .OR. RESP.EQ.'A') THEN
         IXNUM = NXJ
      ELSE
         IXNUM = 0
      END IF
      WRITE (STR,6110)
      CALL TWRITE(STR)
 120  RECORD = BLNK80
      J = 0
      CALL TREAD(RECORD,EOF)
      IF (EOF) GO TO 200
      IF (RECORD.EQ.BLNK80) GO TO 200
      CALL REMOVE(RECORD)
C
C====== Get reflection class
C
      I = I1STCH(RECORD)
      N = INTHCH(RECORD)
      IXNUM = IXNUM + 1
      DO 130 ILOC = I , N
         LOC = ILOC
         LETT = INDEX('hkl',RECORD(ILOC:ILOC))
         IF (LETT.LT.0) LETT = INDEX('0HKL',RECORD(ILOC:ILOC)) - 1
         IF (LETT.GT.-1) THEN
            J = J + 1
            IFLAG = 1
            JFORM(J,IXNUM) = LETT
            IF (J.EQ.3) GO TO 140
         END IF
 130  CONTINUE
      IF ((LOC.EQ.N) .AND. (IFLAG.EQ.0)) THEN
         CALL TWRITE('!!! Invalid record')
         CALL TWRITE(RECORD)
         WRITE (STR,6050) BLNK80(1:MAX(I-1,1))
         CALL TWRITE(STR)
         CALL QSBELL
         IXNUM = MAX(0,IXNUM-1)
         GO TO 120
      END IF
      IFLAG = 0
 140  ILOC = LOC + 1
C
C====== Get lhs of condition
C
      HCOFJ(IXNUM) = 0
      KCOFJ(IXNUM) = 0
      LCOFJ(IXNUM) = 0
      IPLUS = LOC
      DO 150 JLOC = ILOC , N
         LOC = JLOC
         LETT = INDEX('hkl',RECORD(JLOC:JLOC))
         IF (LETT.LE.0) LETT = INDEX('HKL',RECORD(JLOC:JLOC))
         IF (RECORD(JLOC:JLOC).EQ.'=') GO TO 160
         IF (LETT.GT.0) THEN
            INUM = INDEX('0123456789',RECORD(JLOC-1:JLOC-1)) - 1
            INUM = IABS(INUM)
            IF ((RECORD(JLOC-1:JLOC-1).EQ.'-') .OR. 
     +          (RECORD(JLOC-2:JLOC-2).EQ.'-')) INUM = -1*INUM
            IF (LETT.EQ.2) THEN
               KCOFJ(IXNUM) = INUM
            ELSE IF (LETT.EQ.3) THEN
               LCOFJ(IXNUM) = INUM
            ELSE
               HCOFJ(IXNUM) = INUM
            END IF
         END IF
 150  CONTINUE
      IF (LOC.EQ.N) THEN
         CALL TWRITE('!!! Invalid record')
         CALL TWRITE(RECORD)
         WRITE (STR,6050) BLNK80(1:MAX(I-1,1))
         CALL TWRITE(STR)
         CALL QSBELL
         IXNUM = MAX(0,IXNUM-1)
         GO TO 120
      END IF
 160  JLOC = LOC
      IBJ(IXNUM) = 0
      IAJ(IXNUM) = 0
 170  JLOC = JLOC + 1
C
C====== Get rhs of condition
C
      IF (JLOC.GT.N) THEN
         LOC = LOC + 1
         IBJ(IXNUM) = ICVT(RECORD(LOC:JLOC-1))
         GO TO 120
      ELSE
         IF (INDEX('hHiIjJkKlLmMnNpPqQrR',RECORD(JLOC:JLOC)).LE.0)
     +       GO TO 170
         IAJ(IXNUM) = ICVT(RECORD(LOC+1:JLOC-1))
         ILOC1 = JLOC
 180     JLOC = JLOC + 1
         IF (RECORD(JLOC:JLOC).NE.'+') GO TO 180
         LOC = JLOC + 1
 190     JLOC = JLOC + 1
         IF (INDEX('-0123456789',RECORD(JLOC:JLOC)).GE.1) GO TO 190
         IBJ(IXNUM) = ICVT(RECORD(LOC:JLOC-1))
         GO TO 120
      END IF
 200  WRITE (STR,6060) NX
      CALL TWRITE(STR)
      WRITE (STR,6070)
      CALL TWRITE(STR)
      CALL TWRITE(' ')
      CALL TWRITE(' ')
      DO 210 I = 1 , NX
         WRITE (STR,6080) I , (KEY(IFORM(J,I)),J=1,3) , HCOF(I) , 
     +                    KCOF(I) , LCOF(I) , IA(I) , IB(I)
         CALL TWRITE(STR)
 210  CONTINUE
      NXJ = IXNUM
      CALL TWRITE(' ')
      CALL TWRITE(' ')
      WRITE (STR,6090) NXJ
      CALL TWRITE(STR)
      WRITE (STR,6100)
      CALL TWRITE(STR)
      CALL TWRITE(' ')
      CALL TWRITE(' ')
      DO 220 I = 1 , NXJ
         WRITE (STR,6080) I , (KEY(JFORM(J,I)),J=1,3) , HCOFJ(I) , 
     +                    KCOFJ(I) , LCOFJ(I) , IAJ(I) , IBJ(I)
         CALL TWRITE(STR)
 220  CONTINUE
      CALL SORTAL
      NEWUSE = .FALSE.
      USED = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Do you wish to ADD more classes or START again',
     +        ' (ADD/START) [START]: ')
 6020 FORMAT ('>>> Enter a set of extinction classes ',
     +        '(blank line to finish)')
 6030 FORMAT ('    for example')
 6040 FORMAT ('    ''hhl:k+l=2n+1'' or ''H0L K+L=2N+1 ''')
 6050 FORMAT (A,'^')
 6060 FORMAT ('=== Number of records read = ',I3)
 6070 FORMAT ('=== These are Records understood')
 6080 FORMAT (1X,I4,1X,3A1,':',I2,'H+',I2,'K+',I2,'L=',I2,'N+',I2)
 6090 FORMAT ('=== Number of special cases  read = ',I3)
 6100 FORMAT ('=== These are Records understood')
 6110 FORMAT ('>>> Enter any special conditions in the same format')
      END
**==pnorm.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       PNORM         **
C*************************
C
C
      REAL FUNCTION PNORM(P)
C
      REAL P(3)
C
      INCLUDE 'pgstat.finc'
 
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
C
C====== LOCALS:
C
      REAL X
C
C-------------------------------------------------------------------------------
C
      SQUARE = (S11*P(1)**2+S22*P(2)**2+S33*P(3)**2+2.*S12*P(1)*P(2)
     +         +2.*S23*P(2)*P(3)+2.*S13*P(1)*P(3))
      IF (SQUARE.LE.0.0) THEN
 
         CALL QSSETC(1,24)
         CALL QSREVV
         CALL TWRITE('!!! Invalid poles or directions')
         CALL QSNORV
         ABORT = .TRUE.
         RETURN
      ELSE
         X = V/SQRT(SQUARE)
         DO 20 I = 1 , 3
            P(I) = P(I)*X
 20      CONTINUE
         PNORM = X
         RETURN
      END IF
      END
**==poldir.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       POLDIR        **
C*************************
C
C
      SUBROUTINE POLDIR(PA,DA,KPA,KDA,K,SIGN,P,D,KP)
C
      REAL PA(3) , DA(3) , P(3) , D(3) , SIGN
      INTEGER KPA , KDA , K , KP
C
C Purpose: Sets  PA=P  or  DA=D
C
C-------------------------------------------------------------------------------
C
      IF (KP.EQ.0) THEN
         DO 20 I = 1 , 3
            DA(I) = D(I)
 20      CONTINUE
         KDA = K
         RETURN
      ELSE
         DO 30 I = 1 , 3
            PA(I) = P(I)*SIGN
 30      CONTINUE
         KPA = K
         RETURN
      END IF
      END
**==projct.f  
C LAST UPDATE:
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       PROJCT        **
C*************************
C
C
      LOGICAL FUNCTION PROJCT(X,Y,Z,XP,YP,IPROJ,DIST,RMIN,RMAX,RAD)
C
C Purpose: Given the cartesian coords (x,y,z) of a reciprocal lattice point
C          find the coordinates of:
C          iproj = 0 The position on a film at distance dist of the
C             corresponding Laue reflection.
C          iproj = 1 The position on the polar projection plane of the
C             gnomonic projection of the intersection of the
C             corresponding crystal face pole and a projection sphere
C             of radius dist.
C          iproj = 2 The position on the equatorial projection plane of the
C             stereographic projection of the intersection of the
C             corresponding crystal face pole and a projection sphere
C             of radius dist.
C Returns: .FALSE. if the rlp can't reflect or is outside the Ewald
C           sphere radius bounds [rmin,rmax].
C           Also returns rad, the radius of the Ewald sphere on which the rlp
C           lies (=1/lambda).
C NB These are not strictly true gnomonic & stereographic projections,
C   because for easy comparison the projected spots are plotted on the
C   same side of the centre as the Laue reflection would be (ie. the
C   projected pattern is inverted through the centre). This is done by
C   calculating, for each projection, a scaling factor that is applied
C   to the Laue coordinates.
C
C     .. Parameters ..
      INTEGER PROJLAUE, PROJGNOM, PROJSTER
      PARAMETER (PROJLAUE=0,PROJGNOM=1,PROJSTER=2)
C     ..
C     .. Scalar Arguments ..
      REAL DIST, RAD, RMAX, RMIN, XP, X, YP, Y, Z
      INTEGER IPROJ
C     ..
C     .. Local Scalars ..
      REAL D2, HEIGHT, RATIO, TAN2T, TANHT, TWOTHETA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ASIN, SQRT, TAN
C     ..
C
C-------------------------------------------------------------------------------
C
C====== NB Recall that x points along X-rays, and x & y on the film
C====== point along y & z resp. (see AJ Wonacott's MOSFLM manual)
C
C====== First check that point lies between limiting spheres.
C
      IF (((RMIN+X)**2+Y*Y+Z*Z).GE.RMIN*RMIN) THEN
         IF (((RMAX+X)**2+Y*Y+Z*Z).LE.RMAX*RMAX) THEN
C
C====== -d^2/2x is the radius of the sphere on which the point lies.
C====== NB x should be -ve.
C
            D2 = (X*X+Y*Y+Z*Z)
            RAD = -D2/(2*X)
            IF (DIST.GT.0.) THEN
C
C====== In this case radius should be more than x.
C
               IF (RAD+X.LE.0.) GO TO 20
C
C====== Draw line from (rad,0,0) until it hits the film at dist.
C
               XP = DIST*Y/(RAD+X)
               YP = DIST*Z/(RAD+X)
            ELSE IF (DIST.LT.0.) THEN
C
C====== In this case radius should be LESS than x.
C
               IF (RAD+X.GT.0.) GO TO 20
C
C====== Draw line from (-rad,0,0) until it hits the film at dist.
C
               XP = -DIST*Y/(-X-RAD)
               YP = -DIST*Z/(-X-RAD)
            ELSE
               STOP ' C-to-f distance was 0'
 
            END IF
 
            IF (IPROJ.EQ.PROJLAUE) THEN
               PROJCT = .TRUE.
               RETURN
 
            END IF
C
C====== Calculate 2-theta
C
            HEIGHT = SQRT(D2-X*X)
            TWOTHETA = ASIN(HEIGHT/RAD)
            IF (IPROJ.EQ.PROJGNOM) THEN
C
C====== Gnomonic scaling.
C====== Calc tan^2(theta)
C
               TAN2T = TAN(TWOTHETA/2.)
               TAN2T = TAN2T*TAN2T
               RATIO = 1/(2*TAN2T) - .5
 
            ELSE
C
C====== Stereographic scaling.
C====== Calc tan(theta/2)
C
               TANHT = TAN(TWOTHETA/4.)
               RATIO = (1-TANHT)/(1+TANHT)/TAN(TWOTHETA)
            END IF
 
            XP = XP*RATIO
            YP = YP*RATIO
            PROJCT = .TRUE.
            RETURN
         END IF
      END IF
 
 20   PROJCT = .FALSE.
      RETURN
 
      END
**==remove.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       REMOVE        **
C*************************
C
C
      SUBROUTINE REMOVE(STRING)
 
      CHARACTER*(*) STRING,TEMP*100,EMPTY*100
      INTEGER ILENS,ILOC
      DATA EMPTY(1:33)/'                                 '/,
     +     EMPTY(34:66)/'                                 '/,
     +     EMPTY(67:100)/'                                  '/
C
C-------------------------------------------------------------------------------
C
      ILOC = 1
      TEMP = EMPTY
      ILENS = INTHCH(STRING)
      DO 20 I = 1 , ILENS
         IF (STRING(I:I).NE.' ') THEN
            TEMP(ILOC:ILOC) = STRING(I:I)
            ILOC = ILOC + 1
         END IF
 20   CONTINUE
      STRING(1:ILENS) = EMPTY(1:ILENS)
      STRING(1:ILOC) = TEMP(1:ILOC)
      RETURN
      END
**==replot.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       REPLOT        **
C*************************
C
C
      SUBROUTINE REPLOT
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: To replot section of the generated laue pattern
C          section defined by two opposite corners of box
C          Added a check to ensure that user selects two
C          different diagonal points, otherwise program
C          will crash
C
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'lambda.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'laues.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'data.finc'
      INCLUDE 'spots.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'project.finc'
      LOGICAL PROJCT
C
C====== LOCALS:
C
      CHARACTER*80 STR
      REAL   C1,S1,RX,RY,X1,Y1,X2,Y2,YFE,XFE,X,Y,Z,RF,RMIN,RMAX
      INTEGER I,N,IX,IY,ILOOP
C
C-------------------------------------------------------------------------------
C
      C1 = SPNDLE*3.1415926536/180.0
      S1 = SIN(C1)
      C1 = COS(C1)
C
C====== Set ISWIT=1 to refer to full plot
C
      ISWIT = 1
      CALL QGALPH
      CALL QSSETC(1,24)
      WRITE (STR,6010)
      CALL TWRITE(STR)
C
C====== Get area to replot from full plot
C
      CALL SPOTON(RX,RY)
      CALL GUNPLT(RX,RY,X1,Y1)
      WRITE (STR,6020)
      CALL TWRITE(STR)
      CALL SPOTON(RX,RY)
      CALL GUNPLT(RX,RY,X2,Y2)
C
C====== If diagonal points are identical ask for a different second
C====== trap bugs that make it loop for ever
C
      ILOOP = 0
 20   IF (X1.EQ.X2 .AND. Y2.EQ.Y2) THEN
         ILOOP = ILOOP + 1
         WRITE (STR,6030)
         CALL TWRITE(STR)
         CALL QSSETC(1,24)
         CALL SPOTON(RX,RY)
         CALL GUNPLT(RX,RY,X2,Y2)
         IF (ILOOP.GT.3) GO TO 70
         GO TO 20
      END IF
 
      XSUB = (X2+X1)/2.
      YSUB = (Y2+Y1)/2.
      RSUB = MAX(ABS(X2-X1)/2.,ABS(Y2-Y1)/2.)
      SSUB = MIN(5.,RADI/RSUB)
C
C====== Clear the histograms
C
      DO 30 I = 1 , 15
         NHOLD(I) = 0
         HOLDW(I) = WVS/(WVM+I*(WVX-WVM)/15.)
         NB = 0
 30   CONTINUE
 
      RMIN = WVS/WVX
      RMAX = WVS/WVM
C
C====== Loop over the spots
C
      NB = 0
      DO 60 N = 1 , NR
         IF (LAMBDA(N).EQ.0.) GO TO 60
         X = C1*XG(N) - S1*YG(N)
         Y = S1*XG(N) + C1*YG(N)
         Z = ZG(N)
         IF (X.GT.0.) THEN
            X = -X
            Y = -Y
            Z = -Z
         END IF
         IF (.NOT.PROJCT(X,Y,Z,XFE,YFE,PROJTYPE,CTOF,RMIN,RMAX,RF))
     +       GO TO 60
C
C====== Check that spot is in window
C
         IF (ABS(XFE-XSUB).GT.RSUB) GO TO 60
         IF (ABS(YFE-YSUB).GT.RSUB) GO TO 60
C
C====== Move to centre and expand
C
         XFE = SSUB*(XFE-XSUB)
         YFE = SSUB*(YFE-YSUB)
C
C====== Add to histogram
C
         NB = NB + 1
         IX = XFE + 0.5
         IY = YFE + 0.5
         XABS(NB) = XFE
         YORD(NB) = YFE
         DO 40 I = 1 , 15
            IF (RF.GT.HOLDW(I)) GO TO 50
 40      CONTINUE
         I = 15
 50      NHOLD(I) = NHOLD(I) + 1
 60   CONTINUE
C
C====== Output histograms and return
C
      ISWIT = 2
      CALL REPORT
 70   RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Set cursor at first corner and hit the SPACE bar')
 6020 FORMAT ('>>> Set cursor at second corner and hit the SPACE bar')
 6030 FORMAT ('>>> Select a different second diagonal extreme')
      END
**==report.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       REPORT        **
C*************************
C
C
      SUBROUTINE REPORT
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'histo.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'laues.finc'
 
      COMMON /DATA/ CELL(6),WVM,WVX,WVS,CTOF,PHIS(3),SPNDLE,CCELL(6),
     *              NUMA,NUMC,DMIN
      REAL          CELL,WVM,WVX,WVS,CTOF,PHIS,SPNDLE,CCELL,DMIN
      INTEGER       NUMA,NUMC
 
      COMMON/SPOTS/ NR
C
C====== LOCALS:
C
      LOGICAL EOF
      CHARACTER*80  STR
      REAL   XJUNK,DELTA
      INTEGER I
C
C-------------------------------------------------------------------------------
C
      XJUNK = WVM
      DELTA = (WVX-WVM)/15.
 
      CALL QSREVV
      WRITE (STR,6010) NB
      CALL TWRITE(STR)
      CALL QSNORV
      DO 20 I = 1 , 15
         WMULT(I) = XJUNK + DELTA
         XJUNK = WMULT(I)
 20   CONTINUE
      WRITE (STR,6020) (NHOLD(I),WMULT(I),I=1,5)
      CALL TWRITE(STR)
      WRITE (STR,6020) (NHOLD(I),WMULT(I),I=6,10)
      CALL TWRITE(STR)
      WRITE (STR,6020) (NHOLD(I),WMULT(I),I=11,15)
      CALL TWRITE(STR)
 
      CALL QSREVV
      CALL QSBELL
      WRITE (STR,6030) NR
      CALL TPROMP(STR)
      CALL TREAD(STR,EOF)
      IF (.NOT.(EOF)) THEN
         CALL QSNORV
C
C====== Do the multiple occurrence histogram
C
         CALL MHIST(NB)
      END IF
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('Number of spots at wavelength: ',36X,'Total:',I6)
 6020 FORMAT (5(I5,F9.3,' ,'))
 6030 FORMAT (I6,' Reflections stored.',7X,
     +        'Press <CR> for multiple occurrence statistics: ')
      END
**==rhombo.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       RHOMBO        **
C*************************
C
C
C Purpose: Calculate reciprocal cell from direct (Rhombo case).
C
      SUBROUTINE RHOMBO(CELL)
C
      REAL CELL(*)
      REAL TEMP, ALPHA
C
C-------------------------------------------------------------------------------
C
      ALPHA = 3.1415927/180.*CELL(4)
      TEMP = 1. + 2.*COS(ALPHA)**3 - 3.0*COS(ALPHA)**2
      TEMP = SQRT(TEMP)*CELL(1)
      CELL(1) = SIN(ALPHA)/TEMP
      TEMP = -COS(ALPHA)/(1+COS(ALPHA))
      CELL(4) = 180.*ACOS(TEMP)/3.1415927
      RETURN
      END
**==rst.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       RST           **
C*************************
C
C
      SUBROUTINE RST(P,D,Z,CC,R)
C
C Purpose:
C
C        R=0.    constants of type C1,C2,C3, are returned in CC
C        R=1.    also, constants of type R3,S3,T3, are returned in Z
C        R=2.    also, constants of type R2,S2,T2, are returned in Z
C        R=3.    also, constants of type E1,E2,E3, are returned in Z
C
      REAL P(3),D(3),Z(3),R,CC(3)
C
C====== GLOBALS:
C
      COMMON/ANGLE/COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      REAL COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
C
C====== LOCALS:
C
      REAL AA(3,3) , C1 , C2 , C3
C
C-------------------------------------------------------------------------------
C
      IF (R.NE.0.) THEN
         C1 = A*B*COSG
         C2 = B*C*COSA
         C3 = A*C*COSB
         AA(1,1) = P(2)*C3 - P(3)*C1
         AA(1,2) = P(3)*A**2 - P(1)*C3
         AA(1,3) = P(1)*C1 - P(2)*A**2
         AA(2,1) = P(2)*C2 - P(3)*B**2
         AA(2,2) = P(3)*C1 - P(1)*C2
         AA(2,3) = P(1)*B**2 - P(2)*C1
         AA(3,1) = P(2)*C**2 - P(3)*C2
         AA(3,2) = P(3)*C3 - P(1)*C**2
         AA(3,3) = P(1)*C2 - P(2)*C3
      END IF
      CC(1) = A*(A*D(1)+B*COSG*D(2)+C*COSB*D(3))
      CC(2) = B*(A*COSG*D(1)+B*D(2)+C*COSA*D(3))
      CC(3) = C*(A*COSB*D(1)+B*COSA*D(2)+C*D(3))
      IF (R.EQ.0.) RETURN
      IF (R.EQ.1.) THEN
         DO 30 I = 1 , 3
            Z(I) = 0.
            DO 20 J = 1 , 3
               Z(I) = Z(I) - AA(I,J)*CC(J)
 20         CONTINUE
 30      CONTINUE
         RETURN
      ELSE IF (R.NE.2.) THEN
         DO 50 I = 1 , 3
            Z(I) = 0.
            DO 40 J = 1 , 3
               Z(I) = Z(I) + AA(J,I)*D(J)
 40         CONTINUE
 50      CONTINUE
         RETURN
      ELSE
         Z(1) = D(1)*AA(2,2) - D(2)*AA(2,1)
         Z(2) = D(2)*AA(3,3) - D(3)*AA(3,2)
         Z(3) = D(3)*AA(1,1) - D(1)*AA(1,3)
         RETURN
      END IF
      END
**==rstrseq.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       RSTRSEQ       **
C*************************
C
C
      SUBROUTINE RSTRSEQ(STRING,P1,P2,P3)
C
      CHARACTER *(*) STRING
      REAL P1,P2,P3
      COMMON/SCUNIT/ISCRAT
      INTEGER ISCRAT
      INCLUDE 'pgstat.finc'
      CHARACTER*80 TEXT, ERSTR
C
C-------------------------------------------------------------------------------
C
      ISCRAT = 0
      IF (ISCRAT.EQ.0) ISCRAT = 12
      OPEN (UNIT=ISCRAT,FILE='WRK01.DAT',ERR=20,STATUS='NEW',
     +      IOSTAT=IFAIL)
      WRITE (ISCRAT,6010) STRING
      REWIND (ISCRAT)
      READ (ISCRAT,*,ERR=30,END=40) P1 , P2 , P3
      CLOSE (UNIT=ISCRAT,STATUS='DELETE')
      RETURN
 
 20   WRITE (ERSTR,6020) ISCRAT
      CALL TWRITE(ERSTR)
      CALL UGERR(IFAIL,ERSTR)
      CALL TWRITE(ERSTR)
      GO TO 50
 
 30   CALL TWRITE('!!! Error reading scratch file ')
      GO TO 50
 
 40   CALL TWRITE('!!! End of record reading scratch file ')
 50   ABORT = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT (A)
 6020 FORMAT ('!!! Can not open scratch file WRK01.DAT on unit ',I2)
      END
**==savdat.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SAVDAT        **
C*************************
C
C
      SUBROUTINE SAVDAT (IOPT,LABEL,INPFLE,DATFLE)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Write crystal parameters to file
C
      INTEGER IOPT
      CHARACTER*6 LABEL
      CHARACTER*12 INPFLE,DATFLE
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
 
      COMMON /GENCH/ COMPND,CRYSID
      CHARACTER*76 COMPND
      CHARACTER*6  CRYSID
 
      COMMON /GENPAR/ XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,
     1                FILMW,FIDBOX,N1OD,BASEOD,G1OD,CURVE,
     2                NXRAST,NYRAST,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     3                IFLIP,XLOW,XHIGH,YLOW,YHIGH,IRD
      REAL XC,YC,WC,TWIST,TILT,BULGE,YSCALE,XREJ,YREJ,FILMW,FIDBOX,
     1     BASEOD,G1OD,CURVE,DSCAL,XCEN_IN,YCEN_IN,RASTSZ,
     2     XLOW,XHIGH,YLOW,YHIGH
      INTEGER N1OD,NXRAST,NYRAST,IFLIP,IRD
 
      COMMON /FIDS/ FIDX(3),FIDY(3)
      REAL FIDX,FIDY
C
C====== LOCALS:
C
      LOGICAL CELLZ
      LOGICAL EOF
      CHARACTER*80 STR
      CHARACTER*15 TEMP
      CHARACTER*12 DUMFLE
      CHARACTER*1 LATTYP
      INTEGER ISAV,I,IFAIL,IS,ICAM
      CHARACTER*80 CELINF
      INTEGER NUMPAR(7)
      REAL VALUES(10)
      CHARACTER*4 WORDS(10)
      INTEGER NWORDS,NVALS
      INTEGER LENSTR
      REAL CELTMP(6),RCELL(6),CELLC(6)
      REAL DEF(3),CEA(3)
      CHARACTER*5 SYSTYP(7)
      CHARACTER*4 AXTYP(7)
      CHARACTER*1 YESNO
      CHARACTER*1 FLIP(2)
      CHARACTER*1 FLIPCH
      REAL FIDXC1(3),FIDYC1(3),FIDXC2(3),FIDYC2(3)
      DATA NUMPAR /6,4,3,2,2,2,1/
      DATA SYSTYP/'TRICL','MONOC','ORTHO','TETRA','HEXAG','RHOMB',
     *            'CUBIC'/
      DATA AXTYP/'-cst','-bst','-ast',' ','+ast','+bst','+cst'/
      DATA DEF/0.05,2.4,0.06/
      DATA CEA/0.04,2.3,0.07/
      DATA FIDXC1/-5000,-5000,5000/
      DATA FIDYC1/-4000,4000,4000/
      DATA FIDXC2/-4000,-4000,4000/
      DATA FIDYC2/5000,-5000,-5000/
      DATA FLIP/'f','i'/
C
C-------------------------------------------------------------------------------
C
      CALL QSSETC(1,24)
      WRITE (STR,6010) INPFLE(1:LENSTR(INPFLE))
      CALL TPROMP(STR)
      CALL TREAD(DUMFLE,EOF)
      IF (.NOT.(EOF)) THEN
         IF (DUMFLE.EQ.' ') DUMFLE = INPFLE
         DATFLE = DUMFLE
C
C====== Look for first blank, append .gen
C
         I = 0
 20      I = I + 1
         IF (DATFLE(I:I).NE.' ') GO TO 20
         INPFLE = DATFLE
         DATFLE(I:I+3) = '.gen'
         ISAV = I - 1
         OPEN (UNIT=3,FILE=DATFLE,STATUS='NEW',FORM='FORMATTED',ERR=120,
     +         IOSTAT=IFAIL)
 
         IF (IOPT.GT.0) THEN
            WRITE (TEMP,6020) LABEL , DATFLE(1:ISAV)
            CALL ITEM(IOPT,TEMP,15,.FALSE.)
         END IF
C
C====== Change gen file specific parameters if needed
C
         CALL QSSETC(1,24)
         IF (IRD.EQ.1) THEN
            WRITE (STR,6025) 'current'
         ELSE
            WRITE (STR,6025) 'default'
         END IF
         CALL TPROMP(STR)
         CALL TREAD(YESNO,EOF)
         IF (YESNO.EQ.'N'.OR.YESNO.EQ.'n') THEN
            WRITE (STR,6030) FLIP(IFLIP)
            CALL TPROMP(STR)
            CALL TREAD(FLIPCH,EOF)
            IF (FLIPCH.EQ.'F' .OR. FLIPCH.EQ.'f') IFLIP = 1
            IF (FLIPCH.EQ.'I' .OR. FLIPCH.EQ.'i') IFLIP = 2
            WRITE (STR,6040) XC , YC , WC
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) XC = VALUES(1)
            IF (NVALS.GE.2) YC = VALUES(2)
            IF (NVALS.GE.3) WC = VALUES(3)
            WRITE (STR,6050) TWIST , TILT , BULGE
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) TWIST = VALUES(1)
            IF (NVALS.GE.2) TILT = VALUES(2)
            IF (NVALS.GE.3) BULGE = VALUES(3)
            WRITE (STR,6060) YSCALE
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) YSCALE = VALUES(1)
            WRITE (STR,6070) XREJ , YREJ
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) XREJ = VALUES(1)
            IF (NVALS.GE.2) YREJ = VALUES(2)
            IF (IFLIP.EQ.1) THEN
 30            WRITE (STR,6080)
               CALL TWRITE(STR)
               WRITE (STR,6090) (FIDX(I),FIDY(I),I=1,3)
               CALL TWRITE(STR)
               CALL TREAD(STR,EOF)
               CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
               IF (NWORDS.GT.0) THEN
                  CALL TOUPPR(WORDS(1))
                  IF (WORDS(1).EQ.'C1') THEN
                     DO 40 I = 1 , 3
                        FIDX(I) = FIDXC1(I)
                        FIDY(I) = FIDYC1(I)
 40                  CONTINUE
                     GO TO 60
                  ELSE IF (WORDS(1).EQ.'C2') THEN
                     DO 50 I = 1 , 3
                        FIDX(I) = FIDXC2(I)
                        FIDY(I) = FIDYC2(I)
 50                  CONTINUE
                     GO TO 60
                  END IF
                  WRITE (STR,6100)
                  CALL TWRITE(STR)
                  GO TO 30
               END IF
               IF (NVALS.GE.1) FIDX(1) = VALUES(1)
               IF (NVALS.GE.2) FIDY(1) = VALUES(2)
               IF (NVALS.GE.3) FIDX(2) = VALUES(3)
               IF (NVALS.GE.4) FIDY(2) = VALUES(4)
               IF (NVALS.GE.5) FIDX(3) = VALUES(5)
               IF (NVALS.GE.6) FIDY(3) = VALUES(6)
            ELSE
               FIDX(1) = 0.0
               FIDY(1) = 0.0
               FIDX(2) = 0.0
               FIDY(2) = 0.0
               FIDX(3) = 0.0
               FIDY(3) = 0.0
            END IF
 60         WRITE (STR,6110) FILMW , FIDBOX
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) FILMW = VALUES(1)
            IF (NVALS.GE.2) FIDBOX = VALUES(2)
            IF (IFLIP.EQ.1) THEN
               WRITE (STR,6120) N1OD
               CALL TPROMP(STR)
               CALL TREAD(STR,EOF)
               CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
               IF (NVALS.GE.1) N1OD = NINT(VALUES(1))
 70            WRITE (STR,6130)
               CALL TWRITE(STR)
               WRITE (STR,6140) BASEOD , G1OD , CURVE
               CALL TPROMP(STR)
               CALL TREAD(STR,EOF)
               CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
               IF (NWORDS.GT.0) THEN
                  CALL TOUPPR(WORDS(1))
                  IF (WORDS(1).EQ.'CEA') THEN
                     BASEOD = CEA(1)
                     G1OD = CEA(2)
                     CURVE = CEA(3)
                     GO TO 80
                  ELSE IF (WORDS(1).EQ.'DEF') THEN
                     BASEOD = DEF(1)
                     G1OD = DEF(2)
                     CURVE = DEF(3)
                     GO TO 80
                  ELSE
                     WRITE (STR,6150)
                     CALL TWRITE(STR)
                     GO TO 70
                  END IF
               END IF
               IF (NVALS.GE.1) BASEOD = VALUES(1)
               IF (NVALS.GE.2) G1OD = VALUES(2)
               IF (NVALS.GE.3) CURVE = VALUES(3)
            END IF
 80         WRITE (STR,6160) NXRAST , NYRAST , DSCAL
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,' ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) NXRAST = NINT(VALUES(1))
            IF (NVALS.GE.2) NYRAST = NINT(VALUES(2))
            IF (NVALS.GE.3) DSCAL = VALUES(3)
            WRITE (STR,6165) XCEN_IN, YCEN_IN, RASTSZ
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,'  ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) XCEN_IN = VALUES(1)
            IF (NVALS.GE.2) YCEN_IN = VALUES(2)
            IF (NVALS.GE.3) RASTSZ = VALUES(3)
            WRITE (STR,6166) XLOW, XHIGH, YLOW, YHIGH
            CALL TPROMP(STR)
            CALL TREAD(STR,EOF)
            CALL STRTKN(STR,'  ,',10,WORDS,NWORDS,VALUES,NVALS)
            IF (NVALS.GE.1) XLOW = VALUES(1)
            IF (NVALS.GE.2) XHIGH = VALUES(2)
            IF (NVALS.GE.3) YLOW = VALUES(3)
            IF (NVALS.GE.4) YHIGH = VALUES(4)
         END IF
C
C====== Write control data records
C
         WRITE (3,'(1X,A)') COMPND
         WRITE (3,'(1X,A)') CRYSID
         CELINF = ' '
         LATTYP = LATT
         IF (LATTYP.EQ.' ') LATTYP = 'P'
         IS = MSYS
         IF (IS.EQ.0) IS = 1
         DO 90 I = 1 , 6
            CELTMP(I) = CELL(I)
            RCELL(I) = 0.0
 90      CONTINUE
         IF (IS.EQ.2) THEN
            CELTMP(4) = 90
            CELTMP(6) = 90
         ELSE IF (IS.EQ.3) THEN
            CELTMP(4) = 90
            CELTMP(5) = 90
            CELTMP(6) = 90
         ELSE IF (IS.EQ.4) THEN
            CELTMP(2) = CELTMP(1)
            CELTMP(4) = 90
            CELTMP(5) = 90
            CELTMP(6) = 90
         ELSE IF (IS.EQ.5) THEN
            CELTMP(2) = CELTMP(1)
            CELTMP(4) = 90
            CELTMP(5) = 90
            CELTMP(6) = 120
         ELSE IF (IS.EQ.6) THEN
            CELTMP(2) = CELTMP(1)
            CELTMP(3) = CELTMP(1)
            CELTMP(5) = CELTMP(4)
            CELTMP(6) = CELTMP(4)
         ELSE IF (IS.EQ.7) THEN
            CELTMP(2) = CELTMP(1)
            CELTMP(3) = CELTMP(1)
            CELTMP(4) = 90
            CELTMP(5) = 90
            CELTMP(6) = 90
         END IF
         CELLZ = .FALSE.
         DO 100 I = 1 , 6
            IF (CELTMP(I).EQ.0.) CELLZ = .TRUE.
 100     CONTINUE
         IF (.NOT.CELLZ) CALL RECCEL(RCELL,CELTMP,WVS)
         CALL CELLCX(IS,CELLC,RCELL,2,2)
         IF (IS.EQ.1) THEN
            WRITE (CELINF(1:60),6170) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.2) THEN
            WRITE (CELINF(1:60),6180) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.3) THEN
            WRITE (CELINF(1:60),6190) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.4) THEN
            WRITE (CELINF(1:60),6200) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.5) THEN
            WRITE (CELINF(1:60),6210) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.6) THEN
            WRITE (CELINF(1:60),6220) (CELLC(I),I=1,NUMPAR(IS))
         ELSE IF (IS.EQ.7) THEN
            WRITE (CELINF(1:60),6230) (CELLC(I),I=1,NUMPAR(IS))
         ELSE
            STOP ' Illegal system code'
         END IF
         CELINF = CELINF(1:60)//' '//SYSTYP(IS)
     +            //' '//LATTYP//' '//AXTYP(MROT+4)//' '//AXTYP(MBEAM+4)
         WRITE (3,'(1X,A)') CELINF
         WRITE (3,*) PHIS
         WRITE (3,*) WVS , WVM , WVX
         WRITE (3,*) CTOF , DMIN , RADI
         WRITE (3,*) SPNDLE
         WRITE (3,*) XC , YC , WC
         WRITE (3,*) TWIST , TILT , BULGE
         WRITE (3,*) YSCALE
         WRITE (3,*) XREJ , YREJ
         IF (IFLIP.EQ.1) THEN
            WRITE (3,6240) 3 , FIDX(1) , FIDY(1) , FIDX(2) , FIDY(2) , 
     +                     FIDX(3) , FIDY(3)
         ELSE
            WRITE (3,6240) 0 , FIDX(1) , FIDY(1) , FIDX(2) , FIDY(2) , 
     +                     FIDX(3) , FIDY(3)
         END IF
         WRITE (3,6250) FILMW , FIDBOX , N1OD , BASEOD , G1OD , CURVE
         IF (IFLIP.EQ.1) THEN
            WRITE (3,6260) NXRAST , NYRAST , DSCAL , 
     +      XCEN_IN , YCEN_IN , RASTSZ , 
     +      XLOW , XHIGH , YLOW , YHIGH , 'film'
         ELSE
            WRITE (3,6260) NXRAST , NYRAST , DSCAL , 
     +      XCEN_IN , YCEN_IN , RASTSZ , 
     +      XLOW , XHIGH , YLOW , YHIGH , 'image-plate'
         END IF
      END IF
 110  CLOSE (UNIT=3)
      RETURN
C
C====== Display error messages
C
 120  CALL QSSETC(1,24)
      CALL TWRITE('!!! Cannot open file ')
      CALL UGERR(IFAIL,STR)
      CALL TWRITE(STR)
      GO TO 110
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter name of .gen file for saving control',
     +        ' data [',A,']: ')
 6020 FORMAT (A6,A8,1X)
 6025 FORMAT ('>>> Use ',A,' .gen file specific parameter values [y]: ') 
 6030 FORMAT ('>>> Film (f) or image-plate (i) [',A,']: ')
 6040 FORMAT ('>>> xc, yc, wc [',3F7.3,']: ')
 6050 FORMAT ('>>> twist, tilt, bulge [',3F7.3,']: ')
 6060 FORMAT ('>>> yscale [',F8.4,']: ')
 6070 FORMAT ('>>> xrej, yrej [',2F8.2,']: ')
 6080 FORMAT ('>>> Camera type (C1=Arndt-Wonacott, C2=Huber) or',
     +        'fiducial values')
 6090 FORMAT ('[',6F8.1,']: ')
 6100 FORMAT ('!!! Invalid camera type')
 6110 FORMAT ('>>> wfilm,fidbox [',F8.1,F7.3,']: ')
 6120 FORMAT ('>>> n1od [',I4,']: ')
 6130 FORMAT ('>>> Film type (CEA or DEF) or baseod, g1od,curve')
 6140 FORMAT ('[',3F6.3,']: ')
 6150 FORMAT ('!!! Invalid film type')
 6160 FORMAT ('>>> nxrast, nyrast, dscal [',2I5,F8.2,']: ')
 6165 FORMAT ('>>> xcen_in, ycen_in, rastsiz [',2F8.1,F7.2,']: ')
 6166 FORMAT ('>>> xlow, xhigh, ylow, yhigh [',4F8.1,']: ')
 6170 FORMAT (3F10.7,3F10.5)
 6180 FORMAT (3F10.7,F10.5)
 6190 FORMAT (3F10.7)
 6200 FORMAT (2F10.7)
 6210 FORMAT (2F10.7)
 6220 FORMAT (F10.7,F10.5)
 6230 FORMAT (F10.7)
 6240 FORMAT (I2,3(2F8.1))
 6250 FORMAT (F6.1,F4.1,I4,3E10.3)
 6260 FORMAT (2I5,F4.1,2F8.2,F7.2,F6.1,F8.1,F6.1,F8.1,1X,A)
      END
**==savpic.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SAVPIC        **
C*************************
C
C
      SUBROUTINE SAVPIC (IOPT,LABEL,INPFLE,SPTFLE)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Save spot coordinates
C
      INTEGER IOPT
      CHARACTER*12 INPFLE,SPTFLE
      CHARACTER*6 LABEL(*)
C
      INCLUDE 'progdim.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'data.finc'
      INCLUDE 'lambda.finc'
      INCLUDE 'graph.finc'
 
      COMMON/SPOTS/ NR
      INTEGER       NR
C
C====== LOCALS:
C
      LOGICAL EOF
      CHARACTER*80 STR
      CHARACTER*60 TITLE
      CHARACTER*15 TEMP
      CHARACTER*12 MYSYST(7),DUMFLE
      REAL XPOS,YPOS,WAVE
      INTEGER N,IH,IK,IL,IFAIL,I
      INTEGER LENSTR
      DATA MYSYST/'TRICLINIC   ','MONOCLINIC  ','ORTHORHOMBIC',
     *            'TETRAGONAL  ','HEXAGONAL   ','RHOMBOHEDRAL',
     *            'CUBIC       '/
C
C-------------------------------------------------------------------------------
C
      CALL QSSETC(1,24)
      WRITE (STR,6010) INPFLE(1:LENSTR(INPFLE))
      CALL TPROMP(STR)
      CALL TREAD(DUMFLE,EOF)
      IF (.NOT.(EOF)) THEN
         IF (DUMFLE.EQ.' ') DUMFLE = INPFLE
         SPTFLE = DUMFLE
C
C====== Look for first blank,append .spt
C
         I = 0
 20      I = I + 1
         IF (SPTFLE(I:I).NE.' ') GO TO 20
         DUMFLE = SPTFLE
         SPTFLE(I:I+3) = '.spt'
         I = I - 1
 
         OPEN (UNIT=3,FILE=SPTFLE,STATUS='NEW',FORM='FORMATTED',ERR=70,
     +         IOSTAT=IFAIL)
 
         WRITE (TEMP,6270) LABEL(IOPT) , SPTFLE(1:I)
         CALL ITEM(IOPT,TEMP,15,.FALSE.)
C
C====== Get title of picture
C
         CALL QSSETC(1,24)
         WRITE (STR,6020)
         CALL TPROMP(STR)
         CALL TREAD(TITLE,EOF)
         IF (.NOT.(EOF)) THEN
C
C====== Write intro to file
C
            WRITE (3,6030)
            WRITE (3,6040)
C
C====== Write minimum,maximum data
C
            IF (ISWIT.EQ.1) THEN
               WRITE (3,6050) -RADI , RADI , -RADI , RADI
            ELSE
               WRITE (3,6050) XSUB - RSUB , XSUB + RSUB , YSUB - RSUB , 
     +                        YSUB + RSUB
            END IF
C
C====== Get data on each dot
C
            DO 30 N = 1 , NR
C
C====== If reflection not plotted, forget it
C
               IF (LAMBDA(N).EQ.0.0) GO TO 30
C
C====== Calculate position of dot
C
               YPOS = YORD(N)
               XPOS = XABS(N)
C
C====== If we are in subplot, check dot lies in window
C
               IF (ISWIT.EQ.2) THEN
                  IF (ABS(XPOS-XSUB).GT.RSUB) GO TO 30
                  IF (ABS(YPOS-YSUB).GT.RSUB) GO TO 30
               END IF
C
C====== Get (h,k,l) plane values
C
               CALL UNPACK(IHKL(N),IH,IK,IL)
C
C====== Calculate wavelength
C
               WAVE = LAMBDA(N)
C
C====== Write it all to file
C
               WRITE (3,6060) IH , IK , IL , WAVE , XPOS , YPOS
 30         CONTINUE
C
C====== Write dummy end-of-data marker
C
            WRITE (3,6060) 0 , 0 , 0 , 0.0 , 0.0 , 0.0
C
C====== Write number of character items
C
            WRITE (3,6070) 21
C
C====== Write character items
C
            WRITE (3,6080) TITLE
            DO 40 N = 1 , 3
               IF (N.EQ.1) THEN
                  WRITE (3,6090) LABEL(N) , CELL(N)
               ELSE
                  WRITE (3,6100) LABEL(N) , CELL(N)
               END IF
 40         CONTINUE
            DO 50 N = 4 , 6
               IF (N.EQ.4) THEN
                  WRITE (3,6110) LABEL(N) , CELL(N)
               ELSE
                  WRITE (3,6120) LABEL(N) , CELL(N)
               END IF
 50         CONTINUE
            WRITE (3,6130) WVM
            WRITE (3,6140) WVX
            WRITE (3,6150) WVS
            WRITE (3,6160) CTOF
            WRITE (3,6170) SPNDLE
            WRITE (3,6180) PHIS(1)
            WRITE (3,6190) PHIS(2)
            WRITE (3,6200) PHIS(3)
            WRITE (3,6210) DMIN
            IF (ISWIT.EQ.1) THEN
               WRITE (3,6220) -RADI , RADI
               WRITE (3,6230) -RADI , RADI
            ELSE
               WRITE (3,6220) XSUB - RSUB , XSUB + RSUB
               WRITE (3,6230) YSUB - RSUB , YSUB + RSUB
            END IF
            WRITE (3,6240) MYSYST(MSYS)
            WRITE (3,6250) MAXIS(MROT+4)
            WRITE (3,6260) MAXIS(MBEAM+4)
            CLOSE (UNIT=3)
         END IF
      END IF
 60   RETURN
C
C====== Display error messages
C
 70   CALL QSSETC(1,24)
      CALL TWRITE('!!! Cannot open file ')
      CALL UGERR(IFAIL,STR)
      CALL TWRITE(STR)
      GO TO 60
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter name of file in which to save spot',' data [',
     +        A,']: ')
 6020 FORMAT ('>>> Enter title of picture (up to 60 chars) : ')
 6030 FORMAT ('TO READ THE DATA IN THIS FILE, FIRST READ ',
     +        'THESE WORDS WITH AN (A) SPECIFIER'/
     +        'UNTIL YOU COME TO A CHARACTER VARIABLE ',
     +        '''DATA:''. THEN USE THE SPECIFIER'/
     +        '(F7.2,X,F7.2,X,F7.2,X,F7.2)'/
     +        'TO READ THE MINIMUM, THEN MAXIMUM VALUES OF ',
     +        'THE X CO-ORDINATES, THEN'/
     +        'THE MINIMUM AND MAXIMUM VALUES OF THE Y ',
     +        'CO-ORDINATES'/'THEN USE THE SPECIFIER'/
     +        '(I3,X,I3,X,I3,X,F5.3,X,F7.2,X,F7.2)'/
     +        'TO READ THE (H,K,L) VALUES, THE WAVELENGTH, ',
     +        'AND THE (X,Y) CO-ORDINATES OF THE'/'RESULTANT DOT.')
 6040 FORMAT ('KEEP READING RECORDS UNTIL YOU GET A DUMMY ',
     +        '(H,K,L)=(0,0,0) MARKER, AT WHICH'/
     +        'POINT READ AN INTEGER WITH AN (I2) SPECIFIER. ',
     +        'THIS INTEGER IS THE NUMBER OF'/
     +        'CHARACTER CONSTANTS TO FOLLOW. THEN READ ',
     +        'THIS NUMBER OF RECORDS WITH THE'/
     +        'SPECIFIER (A80). THESE CHARACTER CONSTANTS ',
     +        'SHOULD BE DISPLAYED SOMEWHERE'/
     +        'ON ANY PRINTOUT OF THE LAUE PATTERN.'/'DATA:')
 6050 FORMAT (1X,F7.2,1X,F7.2,1X,F7.2,1X,F7.2)
 6060 FORMAT (1X,I3,1X,I3,1X,I3,1X,F5.3,1X,F7.2,1X,F7.2)
 6070 FORMAT (1X,I2)
 6080 FORMAT (1X,A60)
 6090 FORMAT (1X,'Reciprocal lattice length (std. wavelength) ',A6,': ',
     +        F11.6)
 6100 FORMAT (1X,'    "         "      "      "       "     ) ',A6,': ',
     +        F11.6)
 6110 FORMAT (1X,'Reciprocal lattice angle (degrees) ',A6,': ',F11.6)
 6120 FORMAT (1X,'    "         "      "   (   "   ) ',A6,': ',F11.6)
 6130 FORMAT (1X,'Minimum wavelength (angstroms): ',F8.4)
 6140 FORMAT (1X,'Maximum     "      (    "    ): ',F8.4)
 6150 FORMAT (1X,'Standard wavelength (   "    ): ',F8.4)
 6160 FORMAT (1X,'Crystal to film distance (mm): ',F8.4)
 6170 FORMAT (1X,'Spindle setting (degrees): ',F6.1)
 6180 FORMAT (1X,'Rotation about beam axis (degrees): ',F8.4)
 6190 FORMAT (1X,'   "       "   VERTICAL AXIS (DEGREES): ',F8.4)
 6200 FORMAT (1X,'   "       "   HORIZONTAL AXIS (DEGREES): ',F8.4)
 6210 FORMAT (1X,'Minimum interplanar distance used (angstroms): ',F6.1)
 6220 FORMAT (1X,'X co-ordinates vary from ',F7.2,' to ',F7.2)
 6230 FORMAT (1X,'Y      "        "    "   ',F7.2,' to ',F7.2)
 6240 FORMAT (1X,'Crystal system is ',A12)
 6250 FORMAT (1X,'Reciprocal axis lying along crystal rotation axis is '
     +        ,A3)
 6260 FORMAT (1X,'    "       "     "   nearest to X-ray beam axis is ',
     +        A3)
 6270 FORMAT (A6,A8,1X)
      END
**==screen.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SCREEN        **
C*************************
C
C
      SUBROUTINE SCREEN
C
      INCLUDE 'implicit_none.finc'
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
 
      COMMON /STDONE/ STDONE
      LOGICAL STDONE
C
C====== LOCALS:
C
      CHARACTER*80 STR
      CHARACTER*4 WORDS(2)
      REAL   VALUES(2),RAPI
      REAL   OUTCEL(6),AMATRIX(3,3)
      INTEGER ICHANG,NCOND,IFLAG,I,IOK,J,NRSTRT
      INTEGER NWORDS,NVALS,IOPT
      INTEGER IVECLOC(10)
      LOGICAL LDATEX,LSTIEX,CHANGED
      LOGICAL USED
      LOGICAL ANGORI
      CHARACTER*60 TITLE
      CHARACTER*80 BANNER
      CHARACTER*6 LABEL(34)
      CHARACTER*15 TEMP,BLANK
      CHARACTER*12 INPFLE,DATFLE,SPTFLE
      CHARACTER*2  DIR(10)
 
      DATA DIR
     */'PA','PB','PC','P1','P2','DA','DB','DC','D1','D2'/
 
      DATA LABEL /
     * 'A     ','B     ','C     ','ALPHA ','BETA  ','GAMMA ',
     * 'WMIN  ','WMAX  ','DISTAN','DMIN  ','RADIUS','SYSTEM',
     * 'ORIENT','PX    ','PY    ','PZ    ','SPINDL','ABSENC','SCALE ',
     * 'DATSAV','DATGET','START ','PLOT  ','HARD  ','INDEX ','EXPAND',
     * 'PICSAV','OVERLY','AUTO  ','HELP  ','STOP  ',
     * '      ','      ','      '/
C
C====== NB !!! NB !!! NB 3 slots are always needed on the menu for the FSLP
C====== orientation display.
C
      DATA IVECLOC/1,2,3,-1,-3,4,5,6,-2,-4/
C
C LATT   : lattice type
C
      DATA INPFLE/'control'/
      DATA BLANK /'               '/
C
C-------------------------------------------------------------------------------
C
      CALL QSSCRL(20,24)
C
C====== Default option set datget
C
      IOPT = 20
      WORDS(1) = 'DATG'
C
C====== Display menu. highlight overlay mode if on.
C
 20   CALL QSREVV
      CALL QSSETC(1,1)
      WRITE (BANNER,6010)
      CALL TSTRNG(BANNER)
      CALL QSNORV
      CALL QSSETC(1,19)
      CALL QSREVV
      CALL TSTRNG('                            ')
      CALL QSNORV
 
      DO 30 I = 1 , 34
         CALL ITEM(I,LABEL(I),6,.FALSE.)
 30   CONTINUE
C
C====== Display default values
C
      CALL UPDMEN(LABEL)
 40   IOPT = IOPT + 1
      IF (IOPT.GT.34) IOPT = 1
      NWORDS = 0
      NVALS = 0
      ABORT = .FALSE.
      CALL MENU(WORDS,NWORDS,VALUES,NVALS,IOPT)
      IF (ABORT) GO TO 20
      CALL ITEM(IOPT,LABEL(IOPT),6,.TRUE.)
      CALL QSSETC(1,24)
C
C====== Trap spot identification request and avoid clearing laue
C====== same for dump plot to toshiba and spotin (measur command) and
C====== replot (expand command).
C
      IF (IOPT.EQ.1) THEN
      ELSE IF (IOPT.EQ.2) THEN
      ELSE IF (IOPT.EQ.3) THEN
      ELSE IF (IOPT.EQ.4) THEN
      ELSE IF (IOPT.EQ.5) THEN
      ELSE IF (IOPT.EQ.6) THEN
      ELSE IF (IOPT.EQ.7) THEN
C
C====== Set min wavelength
C
         IF (NVALS.GT.0) GO TO 70
         CALL QSSETC(1,24)
         WRITE (STR,6020) WVM
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = WVM
            GO TO 70
         END IF
      ELSE IF (IOPT.EQ.8) THEN
C
C====== Set max wavelength
C
         IF (NVALS.GT.0) GO TO 80
         CALL QSSETC(1,24)
         WRITE (STR,6030) WVX
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = WVX
            GO TO 80
         END IF
      ELSE IF (IOPT.EQ.9) THEN
C
C====== Set crystal to film distance
C
         IF (NVALS.GT.0) GO TO 90
         CALL QSSETC(1,24)
         WRITE (STR,6040) CTOF
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = CTOF
            GO TO 90
         END IF
      ELSE IF (IOPT.EQ.10) THEN
C
C====== Set resolution limit
C
         IF (NVALS.GT.0) GO TO 140
         CALL QSSETC(1,24)
         WRITE (STR,6050) DMIN
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = DMIN
            GO TO 140
         END IF
      ELSE IF (IOPT.EQ.11) THEN
C
C====== Set radius limit for plot
C
         IF (NVALS.GT.0) GO TO 150
         CALL QSSETC(1,24)
         WRITE (STR,6060) RADI
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = RADI
            GO TO 150
         END IF
      ELSE IF (IOPT.EQ.12) THEN
C
C====== Enter crystal system parameters
C
         CALL SYSPRM(VALUES,NVALS,IOPT,LABEL(IOPT))
         CHANGED = .TRUE.
         IF (MSYS.GT.0) CALL CELLTEST(MSYS,CELL,LABEL,IOK,OUTCEL,WVS)
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.13) THEN
C
C====== Orient
C
         ANGORI = .FALSE.
         CALL ORIENT(ANGORI,LABEL)
         CALL ITEM(13,BLANK,15,.FALSE.)
         CALL ITEM(32,BLANK,15,.FALSE.)
         CALL ITEM(33,BLANK,15,.FALSE.)
         CALL ITEM(34,BLANK,15,.FALSE.)
         IF (.NOT.(ABORT)) THEN
C
C====== Output orient information into menu
C
            WRITE (TEMP,6070) LABEL(13) , MAXIS(MROT+4) , MAXIS(MBEAM+4)
            CALL ITEM(13,TEMP,15,.FALSE.)
 
            DO 50 I = 1 , 3
               WRITE (TEMP,6180) LABEL(13+I) , PHIS(I)
               CALL ITEM(13+I,TEMP,15,.FALSE.)
 50         CONTINUE
            IF (.NOT.(ANGORI)) THEN
C
C====== Output vectors saved from fslp input
C
               CALL ITEM(32,FSLPIN(1:1),15,.FALSE.)
               CALL ITEM(33,FSLPIN(16:16),15,.FALSE.)
               CALL ITEM(34,FSLPIN(31:31),15,.FALSE.)
               CALL VECTOR
            END IF
         END IF
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.14) THEN
C
C====== Set raotation about beam axis angle
C
         IF (NVALS.GT.0) GO TO 100
         CALL QSSETC(1,24)
         WRITE (STR,6080) PHIS(1)
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = PHIS(1)
            GO TO 100
         END IF
      ELSE IF (IOPT.EQ.15) THEN
C
C====== Set rotation about vertical axis angle
C
         IF (NVALS.GT.0) GO TO 110
         CALL QSSETC(1,24)
         WRITE (STR,6090) PHIS(2)
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = PHIS(2)
            GO TO 110
         END IF
      ELSE IF (IOPT.EQ.16) THEN
C
C====== Set rotation about horizontal axis angle
C
         IF (NVALS.GT.0) GO TO 120
         CALL QSSETC(1,24)
         WRITE (STR,6100) PHIS(3)
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = PHIS(3)
            GO TO 120
         END IF
      ELSE IF (IOPT.EQ.17) THEN
C
C====== Set spindle value. next option set to start
C
         IF (NVALS.GT.0) GO TO 130
         CALL QSSETC(1,24)
         WRITE (STR,6110) SPNDLE
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) THEN
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         ELSE
            IF (NVALS.LE.0) VALUES(1) = SPNDLE
            GO TO 130
         END IF
      ELSE IF (IOPT.EQ.18) THEN
C
C====== Set systematic absences
C
         CALL PARSEX(USED)
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         IOPT = 21
         GO TO 40
      ELSE IF (IOPT.EQ.19) THEN
C
C====== Set plotting device scale
C
         CALL SELPLT(VALUES,NVALS)
         WRITE (TEMP,6120) LABEL(IOPT) , DEVICE
         CALL ITEM(IOPT,TEMP,15,.TRUE.)
         IOPT = 22
         GO TO 40
      ELSE IF (IOPT.EQ.20) THEN
C
C====== Save file for control data
C
         CALL SAVDAT(IOPT,LABEL(IOPT),INPFLE,DATFLE)
         IOPT = 21
         GO TO 40
      ELSE IF (IOPT.EQ.21) THEN
C
C====== Get control data file name
C
         CALL GETDAT(IOPT,LABEL(IOPT),INPFLE,DATFLE)
         CALL UPDMEN(LABEL)
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.22) THEN
C
C====== Check things before proceeding
C
         IOK = 0
         IF (CTOF.EQ.0.) THEN
            CALL QSSETC(1,24)
            WRITE (STR,6130)
            CALL TWRITE(STR)
            IOK = 1
         END IF
C
C====== Check cell parameters compatible with lattice type
C
         IF (MSYS.GT.0) CALL CELLTEST(MSYS,CELL,LABEL,IOK,OUTCEL,WVS)
C
C====== Copy cell parameters to contiguous array
C
         RAPI = 3.14159265/180.
         NUMC = 0
         NUMA = 0
         J = 0
         DO 60 I = 1 , 6
            IF (OUTCEL(I).NE.0.) THEN
               J = J + 1
               CCELL(J) = OUTCEL(I)
               NUMC = NUMC + 1
               IF (I.GT.3) THEN
                  NUMA = NUMA + 1
                  CCELL(J) = CCELL(J)*RAPI
               END IF
            END IF
 60      CONTINUE
 
         IF (NUMC.EQ.0) THEN
            CALL QSSETC(1,24)
            WRITE (STR,6140)
            CALL TWRITE(STR)
            IOK = 1
         END IF
C
C====== Check for matrix
C
         IF (MSYS.EQ.0 .OR. MROT.EQ.0 .OR. MBEAM.EQ.0) THEN
            CALL QSSETC(1,24)
            WRITE (STR,6150)
            CALL TWRITE(STR)
            IOK = 1
         END IF
 
         IF (IOK.EQ.0) THEN
C
C====== Start calculation
C
            NCOND = 0
            IFLAG = 0
            ICHANG = 1
            USED = .FALSE.
            CALL LSTART(NRSTRT,ICHANG,USED,NCOND,IFLAG)
            CHANGED = .FALSE.
            EREPLOT = .FALSE.
            STDONE = .TRUE.
         END IF
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.23) THEN
C
C====== Plot current diagram
C
         IF (EREPLOT .OR. CHANGED) THEN
            CALL QSSETC(1,24)
            CALL QSREVV
            CALL QSBELL
            WRITE (STR,6160)
            CALL TWRITE(STR)
            CALL QSNORV
            CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
            GO TO 40
         END IF
         ISWIT = 1
         CALL GPLOT
         CALL QGALPH
         IF (OVERLAY) THEN
            WRITE (STR,6170)
            CALL TWRITE(STR)
         END IF
         EREPLOT = .FALSE.
         GO TO 20
      ELSE IF (IOPT.EQ.24) THEN
C
C====== Get hard copy. next option set to plot
C
         CALL HARD(LABEL)
         CALL QGALPH
         GO TO 20
      ELSE IF (IOPT.EQ.25) THEN
C
C====== Index spot
C
         CALL QSCLRA
         CALL QSSCRL(2,24)
         CALL QSSETC(1,24)
         CALL INDESPOT
         CALL QGALPH
         CALL QSCLRA
         CALL QSSCRL(20,24)
         GO TO 20
      ELSE IF (IOPT.EQ.26) THEN
C
C====== Input spot coords?
C
COLD          CALL SPOTIN
COLD          GO TO 80
C
C====== Replot diagram. next option set to hard copy
C
         IF (EREPLOT) THEN
            CALL QSSETC(1,24)
            CALL QSREVV
            CALL QSBELL
            WRITE (STR,6160)
            CALL TWRITE(STR)
            CALL QSNORV
            IOPT = IOPT + 1
            GO TO 20
         END IF
         CALL REPLOT
         EREPLOT = .TRUE.
         ISWIT = 2
         CALL GPLOT
         CALL QGALPH
         CHANGED = .TRUE.
         IOPT = IOPT + 1
         GO TO 20
      ELSE IF (IOPT.EQ.27) THEN
C
C====== Save spot coordinates
C
         CALL SAVPIC(IOPT,LABEL,INPFLE,SPTFLE)
         IOPT = 21
         GO TO 40
      ELSE IF (IOPT.EQ.29) THEN
C
C====== Auto-indexing
C
         CALL QSCLRA
         CALL QSSCRL(2,24)
         CALL INDEXL
         CALL QSCLRA
         CALL QSSCRL(20,24)
         GO TO 20
      ELSE IF (IOPT.EQ.30) THEN
C
C====== List help info. next option set to start
C
         CALL QSCLRA
         CALL QSSCRL(2,24)
         CALL QSSETC(1,24)
         CALL TWRITE('!!! Help not currently available')
CXXX        CALL VAXHLP(WORDS,NWORDS,'newlaue',2,24)
         CALL QSCLRA
         CALL QSSCRL(20,24)
         IOPT = 21
         GO TO 20
      ELSE IF (IOPT.EQ.31) THEN
C
C====== End program
C
         RETURN
      ELSE IF (IOPT.EQ.32) THEN
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.33) THEN
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE IF (IOPT.EQ.34) THEN
         CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
         GO TO 40
      ELSE
C
C====== Process overlayed pattern
C
         OVERLAY = .NOT.OVERLAY
         IF (OVERLAY) CALL TWRITE('=== Overlay mode set ON')
         IF (.NOT.OVERLAY) CALL TWRITE('=== Overlay mode set OFF')
         CALL ITEM(28,LABEL(28),6,OVERLAY)
         IOPT = 21
         GO TO 40
      END IF
C
C====== Set reciprocal cell parameters
C
      CALL CELPRM(VALUES,NVALS,IOPT,LABEL)
      CHANGED = .TRUE.
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 70   WVM = VALUES(1)
      WRITE (TEMP,6190) LABEL(IOPT) , WVM
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 80   WVX = VALUES(1)
      WRITE (TEMP,6190) LABEL(IOPT) , WVX
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 90   CTOF = VALUES(1)
      WRITE (TEMP,6200) LABEL(IOPT) , CTOF
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 100  PHIS(1) = VALUES(1)
      WRITE (TEMP,6180) LABEL(IOPT) , PHIS(1)
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CHANGED = .TRUE.
      CALL ITEM(32,BLANK,15,.FALSE.)
      CALL ITEM(33,BLANK,15,.FALSE.)
      CALL ITEM(34,BLANK,15,.FALSE.)
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 110  PHIS(2) = VALUES(1)
      WRITE (TEMP,6180) LABEL(IOPT) , PHIS(2)
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL ITEM(32,BLANK,15,.FALSE.)
      CALL ITEM(33,BLANK,15,.FALSE.)
      CALL ITEM(34,BLANK,15,.FALSE.)
      CHANGED = .TRUE.
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 120  PHIS(3) = VALUES(1)
      WRITE (TEMP,6180) LABEL(IOPT) , PHIS(3)
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL ITEM(32,BLANK,15,.FALSE.)
      CALL ITEM(33,BLANK,15,.FALSE.)
      CALL ITEM(34,BLANK,15,.FALSE.)
      CHANGED = .TRUE.
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 130  SPNDLE = VALUES(1)
      WRITE (TEMP,6190) LABEL(IOPT) , SPNDLE
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CHANGED = .TRUE.
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 140  DMIN = VALUES(1)
      WRITE (TEMP,6210) LABEL(IOPT) , DMIN
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CHANGED = .TRUE.
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
 
 150  RADI = VALUES(1)
      WRITE (TEMP,6210) LABEL(IOPT) , RADI
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      RADI2 = RADI*RADI
      CHANGED = .TRUE.
C
C====== Select menu option
C
      CALL ITEM(IOPT,LABEL(IOPT),6,.FALSE.)
      GO TO 40
C
C====== Format statements
C
 6010 FORMAT ('Program NEWLAUE')
 6020 FORMAT ('>>> Enter minimum wavelength [',F8.4,'] A: ')
 6030 FORMAT ('>>> Enter maximum wavelength [',F8.4,'] A: ')
 6040 FORMAT ('>>> Enter crystal-to-film distance [',F6.1,'] mm : ')
 6050 FORMAT ('>>> Enter resolution limit ',
     +        '(real cell length / maximum index) [',F6.1,'] A: ')
 6060 FORMAT ('>>> Enter radius limit for plot [',F6.1,']  mm: ')
 6070 FORMAT (A6,1X,A3,',',A3,1X)
 6080 FORMAT ('>>> Enter rotation about beam axis, phi(x) ','[',F7.2,
     +        ']  Deg: ')
 6090 FORMAT ('>>> Enter rotation about horizontal axis, phi(y) ','[',
     +        F7.2,']  Deg: ')
 6100 FORMAT ('>>> Enter rotation about vertical axis, phi(z)','[',F7.2,
     +        ']  Deg: ')
 6110 FORMAT ('>>> Enter Spindle value [',F7.2,']  Deg: ')
 6120 FORMAT (A6,1X,A8)
 6130 FORMAT ('!!! No value for crystal to film distance')
 6140 FORMAT ('!!! No cell parameters')
 6150 FORMAT ('!!! No matrix information. use orient')
 6160 FORMAT ('!!! Coordinates need to be recalculated. use START')
 6170 FORMAT ('=== Overlay mode is on. hard copy will superimpose ',
     +        'on previous plot')
 6180 FORMAT (A6,F8.2,1X)
 6190 FORMAT (A6,F8.4,1X)
 6200 FORMAT (A6,F8.3,1X)
 6210 FORMAT (A6,F8.2,1X)
      END
**==selplt.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SELPLT        **
C*************************
C
C
      SUBROUTINE SELPLT (VALUES,NVALS)
 
      INCLUDE 'implicit_none.finc'
C
C Purpose: Set scale of plot for given device
C
      REAL   VALUES(1)
      INTEGER NVALS
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
C
C====== LOCALS:
C
      LOGICAL EOF
      CHARACTER*80 STR
      CHARACTER*8 ANSWER,DEVNAM(6),CHARDEV
      REAL   DEVLEN(6)
      INTEGER I
C
C ANSWER : user selected option
C DEVNAM : device names
C DEVLEN : device calibration factor
C
      DATA DEVNAM /
     *             'SELANAR ',
     *             'PERICOM ',
     *             'VT100   ',
     *             'A4PSCRIP',
     *             'FULL    ',
     *             'USERSET '/
C
      DATA DEVLEN /
     *             16.0,
     *             18.55,
     *             14.0,
     *             18.00,
     *              1.0,
     *              1.0/
C
C-------------------------------------------------------------------------------
C
      WRITE (CHARDEV,6040) DEVICE
C
C====== Prompt for device name
C
 20   WRITE (STR,6010)
      CALL TWRITE(STR)
      WRITE (STR,6020)
      CALL TWRITE(STR)
      WRITE (STR,6030) CHARDEV
      CALL TPROMP(STR)
      CALL TREAD(ANSWER,EOF)
      IF (EOF) GO TO 50
      IF (ANSWER.EQ.' ') ANSWER = CHARDEV
      CALL TOUPPR(ANSWER)
      DO 30 I = 1 , 5
         IF (ANSWER.EQ.DEVNAM(I)) GO TO 40
 30   CONTINUE
 
      IF (ANSWER.EQ.'USERSET ') THEN
C
C====== Set scale for unknown device
C
         SQLEN = 1.0
         WRITE (STR,6060) ANSWER , SQLEN
         CALL TPROMP(STR)
         IF (NVALS.GE.1) SQLEN = VALUES(1)
         CALL TREAD(STR,EOF)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (NVALS.LE.0) VALUES(1) = SQLEN
         SQLEN = VALUES(1)
         GO TO 50
      ELSE
         CALL QSREVV
         WRITE (STR,6050) ANSWER
         CALL TWRITE(STR)
         CALL QSNORV
         GO TO 20
      END IF
C
C====== Set device name and scaling factor
C
 40   READ (ANSWER,6040) DEVICE
      SQLEN = DEVLEN(I)
 
 50   WRITE (STR,6070) ANSWER , SQLEN
      CALL TWRITE(STR)
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('    SELANAR  terminal ','     PERICOM  terminal ')
 6020 FORMAT ('    VT100    terminal ','     A4PSCRIP printer ')
 6030 FORMAT ('>>> Select plotting device for absolute scaling',' [',A8,
     +        ']: ')
 6040 FORMAT (A8)
 6050 FORMAT ('!!! Invalid device name ',A8)
 6060 FORMAT ('>>> Scaling factor for device ',A8,
     +        ' not known. Enter guess [',F5.2,']: ')
 6070 FORMAT ('=== ',A8,' scaling factor set to ',F5.2)
      END
**==setaa.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SETAA         **
C*************************
C
C
      SUBROUTINE SETAA(AA,PA,I)
C
      REAL AA(3,3),PA(3)
      INTEGER I
C
C====== GLOBALS:
C
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
C
C====== LOCALS:
C
C-------------------------------------------------------------------------------
C
      AA(I,1) = PA(1)*S11 + PA(2)*S12 + PA(3)*S13
      AA(I,2) = PA(1)*S12 + PA(2)*S22 + PA(3)*S23
      AA(I,3) = PA(1)*S13 + PA(2)*S23 + PA(3)*S33
      RETURN
      END
**==setabc.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SETABC        **
C*************************
C
C
      SUBROUTINE SETABC(A,B,C,AL,BE,GA)
C
      COMMON/MATRIX/MSYS,MROT,MBEAM
      COMMON/DATA/CELL(6),WVM,WVX,WVS,CF,PHIS(3),SPNDLE,CCELL(6),
     +            NUMA,NUMC,DMIN
C
C-------------------------------------------------------------------------------
C
      IF (MSYS.EQ.2) THEN
         A = CELL(1)
         B = CELL(2)
         C = CELL(3)
         AL = 90
         BE = CELL(5)
         GA = 90
      ELSE IF (MSYS.EQ.3) THEN
         A = CELL(1)
         B = CELL(2)
         C = CELL(3)
         AL = 90
         BE = 90
         GA = 90
      ELSE IF (MSYS.EQ.4) THEN
         A = CELL(1)
         B = CELL(1)
         C = CELL(3)
         AL = 90
         BE = 90
         GA = 90
      ELSE IF (MSYS.EQ.5) THEN
         A = CELL(1)
         B = CELL(1)
         C = CELL(3)
         AL = 90
         BE = 90
         GA = 120
      ELSE IF (MSYS.EQ.6) THEN
         A = CELL(1)
         B = CELL(1)
         C = CELL(1)
         AL = CELL(4)
         BE = CELL(4)
         GA = CELL(4)
      ELSE IF (MSYS.EQ.7) THEN
         A = CELL(1)
         B = CELL(1)
         C = CELL(1)
         AL = 90
         BE = 90
         GA = 90
      ELSE
         A = CELL(1)
         B = CELL(2)
         C = CELL(3)
         AL = CELL(4)
         BE = CELL(5)
         GA = CELL(6)
      END IF
      RETURN
      END
**==setor.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SETOR         **
C*************************
C
C
      SUBROUTINE SETOR(MROT,MBEAM)
C
      INCLUDE 'pgstat.finc'
C
      COMMON/VSAVE/FSLPIN
      CHARACTER*45 FSLPIN
C
      LOGICAL EOF,ERR
      CHARACTER*80 STR
      CHARACTER*15 BLANK
C
C-------------------------------------------------------------------------------
C
 20   WRITE (STR,6010)
      CALL TWRITE(STR)
      WRITE (STR,6020)
      CALL TPROMP(STR)
      CALL TREAD(STR,EOF)
      IF (.NOT.(EOF)) THEN
         MROT = NINT(FLPVAL(STR,ERR))
         IF (ERR) GO TO 20
         IF (IABS(MROT).GT.3 .OR. MROT.EQ.0) THEN
            WRITE (STR,6050) MROT
            CALL TWRITE(STR)
            GO TO 20
         END IF
 30      WRITE (STR,6030)
         CALL TWRITE(STR)
         WRITE (STR,6040)
         CALL TPROMP(STR)
         CALL TREAD(STR,EOF)
         IF (.NOT.(EOF)) THEN
            MBEAM = NINT(FLPVAL(STR,ERR))
            IF (ERR) GO TO 30
            IF (IABS(MROT).EQ.IABS(MBEAM) .OR. MBEAM.EQ.0 .OR. 
     +          IABS(MBEAM).GT.3) THEN
               WRITE (STR,6060) MBEAM
               CALL TWRITE(STR)
               GO TO 30
            END IF
            RETURN
         END IF
      END IF
 
      ABORT = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Enter the number corresponding to the reciprocal',
     +        ' axis lying along ')
 6020 FORMAT ('    the rotation axis ( -2 is -b*, 3 is c* , etc.): ')
 6030 FORMAT ('>>> Enter the number of the reciprocal axis nearest',
     +        ' to the x-ray beam axis ')
 6040 FORMAT ('    in the plane defined by the beam axis and the',
     +        ' rotation axis: ')
 6050 FORMAT ('!!! Invalid input ',I3)
 6060 FORMAT ('!!! Invalid input ',I3)
      END
**==setpar.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SETPAR        **
C*************************
C
C
      SUBROUTINE SETPAR (IOPT,LABEL,PARAM)
C
C Purpose: Sets menu parameter to new value
C
      REAL   PARAM
      CHARACTER*6 LABEL
      INTEGER IOPT
C
C====== LOCALS:
C
      CHARACTER*15 TEMP
C
C-------------------------------------------------------------------------------
C
      IF (PARAM.NE.0.0) WRITE (TEMP,6010) LABEL , PARAM
      IF (PARAM.EQ.0.0) WRITE (TEMP,6020) LABEL
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
      CALL QSSETC(1,24)
      RETURN
C
C====== Format statements
C
 6010 FORMAT (A6,1X,F8.4)
 6020 FORMAT (A6,9X)
      END
**==solveqn.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SOLVEQN       **
C*************************
C
C
      SUBROUTINE SOLVEQN(A,B,N,NR,M,NRA,NRB)
C
C
C Purpose: Routine for solving linear equations and matrix inversion
C
      INTEGER N , NR , M , NRA , NRB
      REAL A(NRA,N),B(NRB,NR)
C
C====== GLOBALS:
C
C
C====== LOCALS:
C
      REAL    TERM , RM
      INTEGER NN , II1 , K , NEGN1 , NEG1
C
C-------------------------------------------------------------------------------
C
      IF (M.EQ.0) THEN
         DO 30 I = 1 , N
            DO 20 J = 1 , NR
               IF (I.NE.J) THEN
                  B(I,J) = 0.0
               ELSE
                  B(I,J) = 1.0
               END IF
 20         CONTINUE
 30      CONTINUE
      END IF
      NN = N - 1
      IF (N.NE.1) THEN
         DO 100 I = 1 , NN
            TERM = ABS(A(I,I))
            II1 = I + 1
            K = I
            DO 40 J = II1 , N
               IF (ABS(A(J,I)).GT.TERM) THEN
                  TERM = ABS(A(J,I))
                  K = J
               END IF
 40         CONTINUE
            IF (TERM.EQ.0.0) GO TO 140
            DO 50 J = I , N
               TERM = A(K,J)
               A(K,J) = A(I,J)
               A(I,J) = TERM
 50         CONTINUE
            DO 60 J = 1 , NR
               TERM = B(K,J)
               B(K,J) = B(I,J)
               B(I,J) = TERM
 60         CONTINUE
            DO 90 J = II1 , N
               RM = -A(J,I)/A(I,I)
               DO 70 K = II1 , N
                  A(J,K) = A(J,K) + RM*A(I,K)
 70            CONTINUE
               DO 80 K = 1 , NR
                  B(J,K) = B(J,K) + RM*B(I,K)
 80            CONTINUE
 90         CONTINUE
 100     CONTINUE
      END IF
      DO 130 K = 1 , NR
         NEGN1 = -(N-1)
         NEG1 = -1
         B(N,K) = B(N,K)/A(N,N)
         IF (N.NE.1) THEN
            DO 120 II = NEGN1 , NEG1
               I = -II
               II1 = I + 1
               DO 110 J = II1 , N
                  B(I,K) = B(I,K) - A(I,J)*B(J,K)
 110           CONTINUE
               B(I,K) = B(I,K)/A(I,I)
 120        CONTINUE
         END IF
 130  CONTINUE
      GO TO 150
 140  CALL TWRITE('!!! Solve equations fails')
 150  RETURN
      END
**==sort.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SORT          **
C*************************
C
C
      SUBROUTINE SORT (N)
C
      INCLUDE 'progdim.finc'
      INCLUDE 'histo.finc'
C
C Purpose: Sort routine from guckmal, where it was called heap.
C
C    Altered by Simon Morris 10 December 1985 : previously crashed if
C    N=1
C
C-------------------------------------------------------------------------------
C
      IF (N.LT.2) RETURN
      M = N
      K = N/2
 20   I = K
      IHEAD = IXY(K)
      GO TO 40
 30   IF (IHEAD.GE.IXY(J)) GO TO 50
      IXY(I) = IXY(J)
      I = J
 40   J = I + I
      IF (J.LT.M) THEN
         IF (IXY(J).LT.IXY(J+1)) J = J + 1
         GO TO 30
      ELSE IF (J.EQ.M) THEN
         GO TO 30
      END IF
 50   IXY(I) = IHEAD
      K = K - 1
      IF (K.GT.0) GO TO 20
 
      IHEAD = IXY(M)
      IXY(M) = IXY(1)
      IXY(1) = IHEAD
      I = 1
      M = M - 1
      IF (M.GT.1) GO TO 40
      RETURN
      END
**==sortal.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SORTAL        **
C*************************
C
C
      SUBROUTINE SORTAL
C
      COMMON /XTINCT/IFORM(3,50),HCOF(50),KCOF(50),LCOF(50),
     +               IA(50),IB(50),NX,NOVICE,ITAG(50)
      COMMON /XALSO/JFORM(3,50),HCOFJ(50),KCOFJ(50),LCOFJ(50),
     +               IAJ(50),IBJ(50),NXJ,ITABLE(10,0:63)
      INTEGER ILOC(50),INUMP(50)
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , NX
         ITAG(I) = 16*IFORM(1,I) + 4*IFORM(2,I) + IFORM(3,I)
 20   CONTINUE
      DO 30 I = 1 , NXJ
         ILOC(I) = 16*JFORM(1,I) + 4*JFORM(2,I) + JFORM(3,I)
 30   CONTINUE
      DO 40 I = 1 , NXJ
         IK = ILOC(I)
         INUMP(IK) = INUMP(IK) + 1
         IN = INUMP(IK)
         ITABLE(INUMP(IK),IK) = I
         ITABLE(INUMP(IK)+1,IK) = 0
 40   CONTINUE
      DO 50 I = 1 , NX
         IF (IA(I).NE.0) THEN
            IB(I) = MOD(IB(I),IA(I))
         END IF
 50   CONTINUE
      DO 60 I = 1 , NXJ
         IF (IAJ(I).NE.0) THEN
            IBJ(I) = MOD(IBJ(I),IAJ(I))
         END IF
 60   CONTINUE
      RETURN
      END
**==spec.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SPEC          **
C*************************
C
C
      SUBROUTINE SPEC(PB,DB,KPB,KDB,V,K)
C
      REAL PB(3),DB(3),V
      INTEGER KPB , KDB , K
C
C Purpose: Calculate pole or direction b in special case for no cardinal
C          positions given
C
C
C====== GLOBALS:
C
      COMMON/PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
C
C====== LOCALS:
C
      REAL C(3) , X , PNORM , DNORM
C
C-------------------------------------------------------------------------------
C
      IF (KP1.NE.4) THEN
         X = DNORM(D1)
         IF (KP2.NE.2) THEN
C
C====== 1 and 2 are directions
C
            X = DNORM(D2)
            PB(1) = V*(D2(2)*D1(3)-D2(3)*D1(2))
            PB(2) = V*(D2(3)*D1(1)-D2(1)*D1(3))
            PB(3) = V*(D2(1)*D1(2)-D2(2)*D1(1))
            X = PNORM(PB)
            KPB = K
            RETURN
         ELSE
C
C====== 1 is a direction , 2 is a pole
C
            X = PNORM(P2)
            CALL RST(P2,D1,DB,C,3.)
            X = DNORM(DB)
            KDB = K
            RETURN
         END IF
      ELSE
         X = PNORM(P1)
         IF (KP2.NE.2) THEN
C
C====== 1 is a pole , 2 is a direction
C
            X = DNORM(D2)
            CALL RST(P1,D2,DB,C,3.)
            DO 20 I = 1 , 3
               DB(I) = -DB(I)
 20         CONTINUE
            X = DNORM(DB)
            KDB = K
            RETURN
         ELSE
C
C====== 1 and 2 are poles
C
            X = PNORM(P2)
            DB(1) = (P2(2)*P1(3)-P2(3)*P1(2))/V
            DB(2) = (P2(3)*P1(1)-P2(1)*P1(3))/V
            DB(3) = (P2(1)*P1(2)-P2(2)*P1(1))/V
            X = DNORM(DB)
            KDB = K
            RETURN
         END IF
      END IF
      END
**==spotid.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SPOTID        **
C*************************
C
C
      SUBROUTINE SPOTID (IOPT)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose:
C
C    Called from the screen control routine when there is a Laue plot
C    on the screen, this routine reads the cursor position when the
C    button is pressed and attempts to tell the user the hkl values
C    for spots at or very near the position. There may be more than 1.
C
      INTEGER IOPT
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'subp.finc'
C
C====== LOCALS:
C
      LOGICAL EOF
      CHARACTER*80 STR
      REAL   XF,YF,RX,RY,XFE,YFE
      INTEGER IH,IK,IL
      CHARACTER*12 HKLLAB
      CHARACTER*1 TEXT
C
C-------------------------------------------------------------------------------
C
 20   CALL QGALPH
      CALL QSSETC(1,24)
      WRITE (STR,6010)
      CALL TWRITE(STR)
C
C====== Integer values changed to real in vax implementation to give
C====== a more accurate postion of cursor
C
      CALL SPOTON(RX,RY)
C
C====== Convert cursor coords to mm (check for out-of-range to finish)
C
      CALL GUNPLT(RX,RY,XF,YF)
      IF (XF.EQ.0.0 .AND. YF.EQ.0.0) RETURN
C
C====== For expanded plots, scale and shift
C
      IF (ISWIT.EQ.2) THEN
         XF = XF/SSUB + XSUB
         YF = YF/SSUB + YSUB
      END IF
C
C====== Find the spot on the laue (maybe)
C
      CALL QGALPH
      CALL QSSETC(1,24)
      WRITE (STR,6020)
      CALL TWRITE(STR)
      CALL UNLAUE(XF,YF,IH,IK,IL)
 
      IF (IOPT.GE.1) THEN
         IF (IH.NE.0 .OR. IK.NE.0 .OR. IL.NE.0) THEN
C
C====== Encode indices for annotation
C
            WRITE (HKLLAB,6030) IH , IK , IL
            CALL STRIPB(HKLLAB,12)
            IF (ISWIT.EQ.2) THEN
               XF = (XF-XSUB)*SSUB
               YF = (YF-YSUB)*SSUB
            END IF
            XF = XF*SCALE + XM
            YF = YF*SCALE + YM + 0.05
            CALL QGENTR
            CALL QGTEXT(XF,YF,8.0,HKLLAB)
         END IF
      END IF
C
C====== Repeat ?
C
 30   CALL QGALPH
      CALL QSSETC(1,24)
      WRITE (STR,6040)
      CALL TPROMP(STR)
      CALL TREAD(TEXT,EOF)
      IF (.NOT.(EOF)) THEN
         IF (TEXT.EQ.' ') TEXT = 'N'
         IF (TEXT.EQ.'Y' .OR. TEXT.EQ.'y') GO TO 20
         IF (TEXT.NE.'N' .AND. TEXT.NE.'n') GO TO 30
      END IF
      CALL QSSETC(1,24)
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('>>> Set cursor on spot and hit the SPACE bar')
 6020 FORMAT ('   POSITION        H  K  L(WAVELENGTH)')
 6030 FORMAT (I3,',',I3,',',I3)
 6040 FORMAT ('>>> Another spot to index ? [N]: ')
      END
**==spotin.f  
C LAST UPDATE:
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SPOTIN        **
C*************************
C
C
      SUBROUTINE SPOTIN
C
C Purpose:
C
C    Routine to read from the tablet the coordinates of some nodal
C    reflections and to match them to the display presently on the
C    screen. The output file is lgen.out and contains spots to be
C    used for refinement of orientation on the VAX.
C    New file format - Just title & crys id in header.
C
C     .. Arrays in Common ..
      REAL A(3,3),CCELL(6),CELL(6),DUMMY(3,3),PHIS(3)
C     ..
C     .. Local Scalars ..
      REAL CONV,COSW,OM,SINW,WAVEL,X,XCEN,XF,XFSCR,Y,YCEN,YF,YFSCR
      INTEGER I,ICOMFAC,IH,IK,IL,J,N
      CHARACTER IYN*1,CRID*20,FOUTN*20,TITLE*20
C     ..
C     .. Local Arrays ..
      REAL FID(2,3),XSPOT(5,800)
      INTEGER ISPOT(3,800)
C     ..
C     .. External Subroutines ..
      EXTERNAL SUMMASPT,UNLAUE
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,COS,SIN,FLOAT
C     ..
C     .. Common blocks ..
      COMMON /AMAT/DUMMY,A
      COMMON /DATA/CELL,WVM,WVX,WVS,CTOF,PHIS,SPNDLE,CCELL,NUMA,NUMC,
     1       DMIN
      COMMON /RADC/RADI,RADI2
C     ..
C====== Conversion from Summagraphics coordinates to mm
C !!!! Probably needs changing when Summagraphics not available.!!!!
C     .. Scalars in Common ..
      REAL CTOF,DMIN,RADI,RADI2,SPNDLE,WVM,WVS,WVX
      INTEGER NUMA,NUMC
C     ..
C     .. External Functions ..
      INTEGER IHCF
      EXTERNAL IHCF
C     ..
      LOGICAL EOF,ERR
      CHARACTER*80 STR
C
C-------------------------------------------------------------------------------
C
      CONV = 1.0
      WAVEL = 1.0
      XFSCR = 0.0
      YFSCR = 0.0
 
      WRITE (STR,6010)
      CALL TWRITE(STR)
      WRITE (STR,6020)
      CALL TWRITE(STR)
C
C====== Get the fiducial positions
C
      DO 20 I = 1 , 3
         CALL SUMMASPT(FID(1,I),FID(2,I))
 20   CONTINUE
      XCEN = (FID(1,1)+FID(1,3))/2.
      YCEN = (FID(2,1)+FID(2,3))/2.
      OM = -(FID(2,3)-FID(2,2))/(FID(1,3)-FID(1,2))
      COSW = COS(OM)
      SINW = SIN(OM)
      WRITE (STR,6030) XCEN , YCEN , OM
      CALL TWRITE(STR)
 
      WRITE (STR,6040)
      CALL TWRITE(STR)
      WRITE (STR,6050)
      CALL TWRITE(STR)
 
      N = 0
 30   CALL SUMMASPT(X,Y)
      XF = CONV*((X-XCEN)*COSW-(Y-YCEN)*SINW)
      YF = -CONV*((X-XCEN)*SINW+(Y-YCEN)*COSW)
      WRITE (STR,6060) XF , YF
      CALL TWRITE(STR)
      IF (ABS(XF).LE.RADI) THEN
         IF (ABS(YF).LE.RADI) THEN
            CALL UNLAUE(XF,YF,IH,IK,IL)
            IF (IH.EQ.0 .AND. IK.EQ.0 .AND. IL.EQ.0) THEN
               WRITE (STR,6070)
               CALL TWRITE(STR)
 
            ELSE
               N = N + 1
C
C====== Make indices simple.
C
               ICOMFAC = IHCF(IH,IK)
               ICOMFAC = IHCF(ICOMFAC,IL)
               IH = IH/ICOMFAC
               IK = IK/ICOMFAC
               IL = IL/ICOMFAC
 
               ISPOT(1,N) = IH
               ISPOT(2,N) = IK
               ISPOT(3,N) = IL
               XSPOT(1,N) = XF
               XSPOT(2,N) = YF
               XSPOT(3,N) = WAVEL
               XSPOT(4,N) = XFSCR
               XSPOT(5,N) = YFSCR
               WRITE (STR,6080) N , (ISPOT(J,N),J=1,3) , 
     +                          (XSPOT(J,N),J=1,5)
               CALL TWRITE(STR)
 
            END IF
            GO TO 30
         END IF
      END IF
C
C====== No more spots to enter
C
      WRITE (STR,6090)
      CALL TPROMP(STR)
      CALL TREAD(IYN,EOF)
      IF (IYN.NE.'n') THEN
         WRITE (STR,6100)
         CALL TPROMP(STR)
         CALL TREAD(FOUTN,EOF)
         WRITE (STR,6110)
         CALL TPROMP(STR)
         CALL TREAD(CRID,EOF)
         WRITE (STR,6120)
         CALL TPROMP(STR)
         CALL TREAD(TITLE,EOF)
         OPEN (UNIT=12,FILE=FOUTN,STATUS='unknown',FORM='formatted')
         WRITE (12,6130) CRID
         WRITE (12,6140) TITLE
      END IF
 
      WRITE (12,6150) N
      DO 40 I = 1 , N
         IF (IYN.NE.'n') THEN
            WRITE (12,6160) (ISPOT(J,I),J=1,3) , (XSPOT(J,I),J=1,2)
         END IF
 
 40   CONTINUE
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('Tape laue film to tablet then input fiducials')
 6020 FORMAT ('Orient the film so that it matches the display.')
 6030 FORMAT ('Centre of film  ',2F8.3,'     tilt(rad) ',F7.5)
 6040 FORMAT ('Enter the nodal spots to be used for refinement')
 6050 FORMAT ('point off the film to finish')
 6060 FORMAT ('Coords(mm) ',2F8.2)
 6070 FORMAT ('No match for this spot with simple indices, try another')
 6080 FORMAT (I3,3I4,5F12.3)
 6090 FORMAT ('>>> Output the spots to file (y/n): ')
 6100 FORMAT ('>>> Enter output filename: ')
 6110 FORMAT ('>>> Crystal identifier for the file (6 chars): ')
 6120 FORMAT ('>>> Title for this film(max 20 chars): ')
 6130 FORMAT (1X,A6)
 6140 FORMAT (1X,A20)
 6150 FORMAT (' Number=',I4)
 6160 FORMAT (' h k l  ',3I4,T40,'x y  ',2F6.1)
      END
**==spoton.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SPOTON        **
C*************************
C
C
      SUBROUTINE SPOTON(XPOS,YPOS)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Return cursor position when space is return
C
C Author : Tardi Tjahjadi
C
      REAL XPOS,YPOS
C
C XPOS  : x coordinate of cursor
C YPOS  : y coordinate of cursor
C
C
C====== LOCALS:
C
      CHARACTER*1 KCHAR
C
C-------------------------------------------------------------------------------
C
C====== Set terminal to graphic mode
C
      CALL QGENTR
C
C====== Get coordinate position of cursor
C
      CALL QGCURS(XPOS,YPOS,KCHAR)
C
C====== Set terminal to alpha mode
C
      CALL QGALPH
      RETURN
      END
**==stripb.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       STRIPB        **
C*************************
C
C
      SUBROUTINE STRIPB (STRING,NCHARS)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Removes embedded blanks in hkl character string
C
      CHARACTER*1 STRING(1)
      INTEGER NCHARS
C
C====== LOCALS:
C
      INTEGER K,I
C
C-------------------------------------------------------------------------------
C
      K = 1
      DO 20 I = 2 , NCHARS
         IF (STRING(I).NE.' ') THEN
            K = K + 1
            STRING(K) = STRING(I)
            STRING(I) = ' '
         END IF
 20   CONTINUE
      RETURN
      END
**==summaspt.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SUMMASPT      **
C*************************
C
C
      SUBROUTINE SUMMASPT(X,Y)
C
C Purpose: Read spot coordinates from the terminal and convert to mm.
C
C           NB This routine is meant for input from Summagraphics, don't
C              use GUNPLT to convert because Summagraphics coords will
C              have an unknown slant and centre.
C
      REAL   X,Y
C
C X,Y    : spot coordinates
C
      INCLUDE 'progdim.finc'
      INCLUDE 'graph.finc'
C
C====== LOCALS:
C
      REAL RX,RY
      CHARACTER*1 KCHAR
C
C-------------------------------------------------------------------------------
C
C====== X,Y are returned mm coordinates of point
C====== SCALE converts point coords from device to Laue spot coords
C
      CALL QGCURS(RX,RY,KCHAR)
      X = RX/SCALE
      Y = RY/SCALE
      RETURN
      END
**==sysabs.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SYSABS        **
C*************************
C
C
        SUBROUTINE SYSABS(IH,IK,IL,ABSNT)
C
        COMMON/SYS/ISYS,KSYS(3)
        INTEGER H(3)
        LOGICAL ABSNT
C
C-------------------------------------------------------------------------------
C
      H(1) = IH
      H(2) = IK
      H(3) = IL
      IF (ISYS.EQ.4) THEN
 
         ABSNT = .TRUE.
         DO 20 I = 1 , 2
            IF (MOD(H(I)+H(I+1),2).NE.0) RETURN
 20      CONTINUE
         ABSNT = .FALSE.
         RETURN
      ELSE
C
C====== This version for a,b,c,r,i & f lattice absences
C
         ABSNT = .FALSE.
         J = 0
         DO 30 I = 1 , 3
            J = J + H(I)*KSYS(I)
 30      CONTINUE
         IF (MOD(J,ISYS).NE.0) ABSNT = .TRUE.
         RETURN
      END IF
      END
**==sysabsf.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SYSABSF       **
C*************************
C
C
      LOGICAL FUNCTION SYSABSF(IH,IK,IL)
C
      COMMON /XTINCT/IFORM(3,50),HCOF(50),KCOF(50),LCOF(50),
     +               IA(50),IB(50),NX,NOVICE,ITAG(50)
      COMMON /XALSO/JFORM(3,50),HCOFJ(50),KCOFJ(50),LCOFJ(50),
     +               IAJ(50),IBJ(50),NXJ,ITABLE(10,0:63)
      INTEGER JFORM,HCOFJ,KCOFJ,LCOFJ,IAJ,IBJ,NXJ
      INTEGER IFORM,HCOF,KCOF,LCOF,IA,IB,NX,ITABLE
      LOGICAL NOVICE
C
C-------------------------------------------------------------------------------
C
      INTEGER INDEX(0:3)
      IMARK = 0
      INDEX(0) = 0
      INDEX(1) = IH
      INDEX(2) = IK
      INDEX(3) = IL
      DO 40 I = 1 , NX
         DO 20 J = 1 , 3
            IF (INDEX(IFORM(J,I)).NE.INDEX(J)) GO TO 40
 20      CONTINUE
         IEXP = IH*HCOF(I) + IK*KCOF(I) + IL*LCOF(I)
         IF (IA(I).EQ.0) THEN
            IF (IEXP.NE.IB(I)) GO TO 40
         ELSE IF (MOD(IEXP,IA(I)).NE.IB(I)) THEN
            GO TO 40
         END IF
         IF (ITABLE(1,ITAG(I)).EQ.0) THEN
            SYSABSF = .TRUE.
            GO TO 50
         END IF
         K = 1
 30      ILOC = ITABLE(K,ITAG(I))
         IF ((K.LE.10) .AND. (ILOC.GT.0)) THEN
            K = K + 1
            IEXP = IH*HCOFJ(ILOC) + IK*KCOFJ(ILOC) + IL*LCOFJ(ILOC)
            IF (IAJ(ILOC).EQ.0) THEN
               IF (IEXP.NE.IBJ(ILOC)) GO TO 30
               SYSABSF = .TRUE.
               GO TO 50
            ELSE
               IF (MOD(IEXP,IAJ(ILOC)).NE.IBJ(ILOC)) GO TO 30
               SYSABSF = .TRUE.
               GO TO 50
            END IF
         END IF
 40   CONTINUE
      SYSABSF = .FALSE.
 50   RETURN
      END
**==sysahk.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SYSAHK        **
C*************************
C
C
        SUBROUTINE SYSAHK(IH,IK,ABSNT)
C
C Purpose: This variant of sysabs checks to see if a given h,k is absent,
C           whatever the l value
C
        COMMON/SYS/ISYS,KSYS(3)
        LOGICAL ABSNT
C
C-------------------------------------------------------------------------------
C
      ABSNT = .FALSE.
      IF ((ISYS.EQ.2 .OR. ISYS.EQ.4) .AND. KSYS(3).EQ.0) THEN
         IF (MOD(IH+IK,2).NE.0) ABSNT = .TRUE.
      END IF
      RETURN
      END
**==sysprm.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       SYSPRM        **
C*************************
C
C
      SUBROUTINE SYSPRM (VALUES,NVALS,IOPT,LABEL)
C
      INCLUDE 'implicit_none.finc'
C
      REAL   VALUES(1)
      INTEGER IOPT,NVALS
      CHARACTER*6 LABEL
C
      INCLUDE 'pgstat.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
C
C====== LOCALS:
C
      LOGICAL EOF
      CHARACTER*80 STR
      CHARACTER*15 TEMP
      CHARACTER*1 ICHAR
C
C-------------------------------------------------------------------------------
C
 20   IF (NVALS.LE.0) THEN
         CALL QSSETC(1,24)
         WRITE (STR,6010)
         CALL TWRITE(STR)
         WRITE (STR,6020)
         CALL TWRITE(STR)
         WRITE (STR,6030)
         CALL TWRITE(STR)
         WRITE (STR,6040)
         CALL TPROMP(STR)
         CALL TREAD(STR,ABORT)
         CALL STRVAL(STR,' ,',1,VALUES,NVALS)
         IF (ABORT) GO TO 50
         IF (NVALS.LE.0) VALUES(1) = MSYS
      END IF
 
      MSYS = NINT(VALUES(1))
      IF (MSYS.LT.1 .OR. MSYS.GT.7) THEN
         CALL QSSETC(1,24)
         WRITE (STR,6050)
         CALL TWRITE(STR)
         GO TO 20
      END IF
 30   CALL QSSETC(1,24)
      WRITE (STR,6060)
      CALL TPROMP(STR)
      CALL TREAD(ICHAR,EOF)
      IF (EOF) GO TO 50
C
C====== Default lattice type is p
C
      IF (ICHAR.EQ.' ') ICHAR = 'P'
      LATT = ICHAR
C
C====== r only applies to rhombohedral indexed on hexagonal lattice
C
      IF (ICHAR.EQ.'r' .AND. MSYS.NE.5) ICHAR = 'P'
      IF (ICHAR.EQ.'R' .AND. MSYS.NE.5) ICHAR = 'P'
      ISYS = 0
      KSYS(1) = 0
      KSYS(2) = 0
      KSYS(3) = 0
      IF (ICHAR.NE.'p' .AND. ICHAR.NE.'P') THEN
         IF (ICHAR.EQ.'a' .OR. ICHAR.EQ.'A') THEN
            ISYS = 2
            KSYS(2) = 1
            KSYS(3) = 1
            GO TO 40
         END IF
         IF (ICHAR.EQ.'b' .OR. ICHAR.EQ.'B') THEN
            ISYS = 2
            KSYS(1) = 1
            KSYS(3) = 1
            GO TO 40
         END IF
         IF (ICHAR.EQ.'c' .OR. ICHAR.EQ.'C') THEN
            ISYS = 2
            KSYS(1) = 1
            KSYS(2) = 1
            GO TO 40
         END IF
         IF (ICHAR.EQ.'i' .OR. ICHAR.EQ.'I') THEN
            ISYS = 2
            KSYS(1) = 1
            KSYS(2) = 1
            KSYS(3) = 1
            GO TO 40
         END IF
         IF (ICHAR.EQ.'f' .OR. ICHAR.EQ.'F') THEN
            ISYS = 4
            GO TO 40
         END IF
         IF (ICHAR.EQ.'r' .OR. ICHAR.EQ.'R') THEN
            ISYS = 3
            KSYS(1) = -1
            KSYS(2) = 1
            KSYS(3) = 1
            GO TO 40
         END IF
         CALL QSSETC(1,24)
         WRITE (STR,6070)
         CALL TWRITE(STR)
         GO TO 30
      END IF
 
 40   WRITE (TEMP,6080) LABEL , MSYST(MSYS+1) , LATT
      CALL ITEM(IOPT,TEMP,15,.FALSE.)
 
 50   RETURN
C
C====== Format statements
C
 6010 FORMAT ('CRYSTAL SYSTEM : 1=TRICLINIC    2=MONOCLINIC',
     +        '  3=ORTHORHOMBIC')
 6020 FORMAT ('                 4=TETRAGONAL   5=HEXAGONAL',
     +        '   6=RHOMBOHEDRAL')
 6030 FORMAT ('                 7=CUBIC')
 6040 FORMAT ('>>> Enter a number for the crystal system (1-7): ')
 6050 FORMAT ('!!! Invalid crystal system')
 6060 FORMAT ('>>> Enter lattice type : P,A,B,C,I,F OR R    [P]: ')
 6070 FORMAT ('!!! Invalid lattice type')
 6080 FORMAT (A6,1X,A3,1X,',',1X,A1,1X)
      END
**==tetrag.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TETRAG        **
C*************************
C
C
      SUBROUTINE TETRAG(CELL)
C
      REAL CELL(6)
C
C-------------------------------------------------------------------------------
C
      CELL(1) = 1./CELL(1)
      CELL(3) = 1./CELL(3)
      RETURN
      END
**==touppr.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TOUPPR        **
C*************************
C
C
      SUBROUTINE TOUPPR(STRING)
C
      CHARACTER*(*) STRING
      CHARACTER*26 LOWER,UPPER
      DATA LOWER/'abcdefghijklmnopqrstuvwxyz'/,
     +     UPPER/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , LEN(STRING)
         ISIN = INDEX(LOWER,STRING(I:I))
         IF (ISIN.GT.0) STRING(I:I) = UPPER(ISIN:ISIN)
 20   CONTINUE
      RETURN
      END
**==tricln.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TRICLN        **
C*************************
C
C
      SUBROUTINE TRICLN(CELL)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Calculate reciprocal cell from direct (Triclinic case).
C
C====== GLOBALS:
C
      REAL CELL(6)
C
C====== LOCALS:
C
      INTEGER I
      REAL A,B,C,ALPHA,BETA,GAMMA,VOL,S,DEGRAD,TMPCOS,DENO
      PARAMETER (DEGRAD = 3.1415926536/180.)
C
C-------------------------------------------------------------------------------
C
C====== See Int. Tab. Vol.II p.106
C
      A = CELL(1)
      B = CELL(2)
      C = CELL(3)
C
C====== Get the cell angles in rad.
C
      ALPHA = DEGRAD*CELL(4)
      BETA = DEGRAD*CELL(5)
      GAMMA = DEGRAD*CELL(6)
C
C====== Calculate cell volume
C
      S = (ALPHA+BETA+GAMMA)/2.
      VOL = 2.*A*B*C*SQRT
     +      (ABS(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA)))
      IF (ABS(VOL).LT.1.0E-4) STOP ' Bad cell volume'
C
C====== Overwrite direct with recip cell lengths
C
      CELL(1) = B*C*SIN(ALPHA)/VOL
      CELL(2) = A*C*SIN(BETA)/VOL
      CELL(3) = B*A*SIN(GAMMA)/VOL
C
C====== Overwrite direct with recip cell angles.
C
      DENO = SIN(BETA)*SIN(GAMMA)
      IF (ABS(DENO).LT.1E-5) STOP ' Bad cell angles'
      TMPCOS = (COS(GAMMA)*COS(BETA)-COS(ALPHA))
      IF (TMPCOS.GT.DENO) THEN
         TMPCOS = DENO - (1E-6)
      ELSE IF (TMPCOS.LT.-DENO) THEN
         TMPCOS = (1E-6) - DENO
      END IF
      CELL(4) = ACOS(TMPCOS/DENO)
 
      DENO = SIN(ALPHA)*SIN(GAMMA)
      IF (ABS(DENO).LT.1E-5) STOP ' Bad cell angles'
      TMPCOS = (COS(GAMMA)*COS(ALPHA)-COS(BETA))
      IF (TMPCOS.GT.DENO) THEN
         TMPCOS = DENO - (1E-6)
      ELSE IF (TMPCOS.LT.-DENO) THEN
         TMPCOS = (1E-6) - DENO
      END IF
      CELL(5) = ACOS(TMPCOS/DENO)
 
      DENO = SIN(ALPHA)*SIN(BETA)
      IF (ABS(DENO).LT.1E-5) STOP ' Bad cell angles'
      TMPCOS = (COS(ALPHA)*COS(BETA)-COS(GAMMA))
      IF (TMPCOS.GT.DENO) THEN
         TMPCOS = DENO - (1E-6)
      ELSE IF (TMPCOS.LT.-DENO) THEN
         TMPCOS = (1E-6) - DENO
      END IF
      CELL(6) = ACOS(TMPCOS/DENO)
C
C====== Back to degrees.
C
      DO 20 I = 4 , 6
         CELL(I) = CELL(I)/DEGRAD
 20   CONTINUE
      RETURN
      END
**==tstdat.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TSTDAT        **
C*************************
C
C
      SUBROUTINE TSTDAT
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Sets parameter values for a face centered cubic system
C          Data supplied by G.Clark 01/07/87
C
      INCLUDE 'systyp.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
C
C====== LOCALS:
C
      CHARACTER*15 TEMP
      INTEGER I
C
C-------------------------------------------------------------------------------
C
      CELL(1) = 5.4282
      CELL(2) = 5.4282
      CELL(3) = 5.4282
      CELL(4) = 90.0
      CELL(5) = 90.0
      CELL(6) = 90.0
 
      WVM = 0.3
      WVX = 2.6
 
      CTOF = 30.0
 
      DMIN = 0.3
 
      RADI = 100.0
      RADI2 = RADI*RADI
 
      PHIS(1) = 153.4350
      PHIS(2) = -24.0948
      PHIS(3) = 50.7685
      FSLPIN(1:15) = 'DA=1,1,1'
      FSLPIN(16:30) = 'DB=-1,1,0'
      FSLPIN(31:45) = '         '
 
      SPNDLE = 0.0
      MSYS = 7
      MROT = 3
      MBEAM = 1
      ISYS = 4
      KSYS(1) = 0
      KSYS(2) = 0
      KSYS(3) = 0
      LATT = 'F'
      MSYST(MSYS+1) = 'CUB'
 
      RETURN
 
      END
**==twodir.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TWODIR        **
C*************************
C
C
      SUBROUTINE TWODIR (DA,DB,PA,PB,PC,IE)
C
C
      REAL DA(3),DB(3),PA(3),PB(3),PC(3)
      INTEGER IE
C
C Purpose: a and b are directions ,c is a pole .   solve for poles a an
C
      INCLUDE 'pgstat.finc'
C
      COMMON/CHK/DEL1,DEL2
      REAL DEL1,DEL2
C
C====== LOCALS:
C
      CHARACTER*80 STR
      REAL AA(3,3),BB(3), XX, YY, XA , XB , PNORM
      LOGICAL CHECK,LL
      CHECK(XX,YY) = (DEL1.LT.XX) .AND. (DEL2.GT.XX) .AND. (DEL1.LT.YY)
     +               .AND. (DEL2.GT.YY)
C
C-------------------------------------------------------------------------------
C
      CALL SETAA(AA,PC,1)
      DO 20 I = 1 , 3
         AA(2,I) = DA(I)
         AA(3,I) = DB(I)
 20   CONTINUE
      BB(3) = 0.
      BB(1) = BB(3)
      BB(2) = 1.
      CALL SOLVEQN(AA,BB,3,1,1,3,3)
      DO 30 I = 1 , 3
         PA(I) = BB(I)
 30   CONTINUE
      CALL SETAA(AA,PA,1)
      CALL SETAA(AA,PC,2)
      DO 40 I = 1 , 3
         AA(3,I) = DB(I)
 40   CONTINUE
      BB(2) = 0.
      BB(1) = BB(2)
      BB(3) = 1.
      CALL SOLVEQN(AA,BB,3,1,1,3,3)
      DO 50 I = 1 , 3
         PB(I) = BB(I)
 50   CONTINUE
      XA = PNORM(PA)
      XB = PNORM(PB)
      LL = CHECK(XA,XB)
      IF (LL) RETURN
      WRITE (STR,6010) IE , XA , XB
      CALL TWRITE(STR)
      ABORT = .TRUE.
      RETURN
C
C====== Format statements
C
 6010 FORMAT ('!!! Error in TWODIR: ',I2,2F10.5)
      END
**==twogivn.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       TWOGIVN       **
C*************************
C
C
      SUBROUTINE TWOGIVN(DA,DB,DC,PA,PB,PC,IE,KDA,KDB,KDC,KPA,KPB,KPC,
     +K1,K2,K3)
C
      REAL DA(3),DB(3),DC(3),PA(3),PB(3),PC(3)
      INTEGER IE,KDA,KDB,KDC,KPA,KPB,KPC,K1,K2,K3
C
C Purpose: a and b are given.  check whether they are poles or directions
C          or combination, and jump to appropiate section
C
C
C====== GLOBALS:
C
      INCLUDE 'pgstat.finc'
C
      COMMON/CONST/V,S11,S22,S33,S12,S23,S13
      REAL V,S11,S22,S33,S12,S23,S13
      COMMON/ANGLE/COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      REAL COSTY,COSTZ,A,B,C,COSA,COSB,COSG,SINA,SINB,SING
      COMMON/CHK/DEL1,DEL2
      REAL DEL1,DEL2
      COMMON/EXIT/JOUT
      INTEGER JOUT
C
C====== LOCALS:
C
      CHARACTER*80 STR
      REAL AA(3,3),BB(3),Z(3),XA,XB,XC,DNORM,PNORM,X,C1,C2,C3,C4,C5
      REAL C6,X1,X2,X3
      LOGICAL LL,CHECK1
      CHECK1(XA,XB,XC) = (DEL1.LT.XA) .AND. (DEL2.GT.XA) .AND. 
     +                   (DEL1.LT.XB) .AND. (DEL2.GT.XB) .AND. 
     +                   (DEL1.LT.XC) .AND. (DEL2.GT.XC)
C
C-------------------------------------------------------------------------------
C
C
C====== Are a and b both directions
C
      IF ((KDA.EQ.K1) .AND. (KDB.EQ.K2)) THEN
         XA = DNORM(DA)
         XB = DNORM(DB)
C
C====== a and b are directions,  solve for pole c
C
         Z(1) = DA(2)*DB(3) - DA(3)*DB(2)
         Z(2) = DA(3)*DB(1) - DA(1)*DB(3)
         Z(3) = DA(1)*DB(2) - DA(2)*DB(1)
         XA = PNORM(Z)
         DO 20 I = 1 , 3
            PC(I) = Z(I)
 20      CONTINUE
         KPC = K3
         JOUT = 1
         RETURN
C
C====== are a and b both poles
C
      ELSE IF ((KPA.EQ.K1) .AND. (KPB.EQ.K2)) THEN
C
C====== a and b are poles ,  solve for pole c (and direction c if not kn
C
         XA = PNORM(PA)
         XB = PNORM(PB)
         IF (KDC.NE.K3) THEN
            Z(1) = PA(2)*PB(3) - PA(3)*PB(2)
            Z(2) = PA(3)*PB(1) - PA(1)*PB(3)
            Z(3) = PA(1)*PB(2) - PA(2)*PB(1)
            X = DNORM(Z)
            DO 30 I = 1 , 3
               DC(I) = Z(I)
 30         CONTINUE
            KDC = K3
         END IF
         CALL SETAA(AA,PA,1)
         CALL SETAA(AA,PB,2)
         DO 40 I = 1 , 3
            AA(3,I) = DC(I)
 40      CONTINUE
         BB(2) = 0.
         BB(1) = BB(2)
         BB(3) = 1.
         CALL SOLVEQN(AA,BB,3,1,1,3,3)
         DO 50 I = 1 , 3
            PC(I) = BB(I)
 50      CONTINUE
         KPC = K3
         XA = PNORM(PA)
         XB = PNORM(PB)
         XC = PNORM(PC)
         LL = CHECK1(XA,XB,XC)
         JOUT = 2
         IF (LL) RETURN
         WRITE (STR,6010) IE , XA , XB , XC
         CALL TWRITE(STR)
         ABORT = .TRUE.
         RETURN
      ELSE
C
C====== One pole ,one direction.  solve for direction c.
C
         C1 = A*B*COSG
         C2 = B*C*COSA
         C3 = A*C*COSB
         C4 = A**2.
         C5 = B**2.
         C6 = C**2.
C
C====== Is a a pole
C
         IF (KPA.EQ.K1) THEN
            XA = PNORM(PA)
            XB = DNORM(DB)
            X1 = DB(1)*C1 + DB(2)*C5 + DB(3)*C2
            X2 = DB(1)*C3 + DB(2)*C2 + DB(3)*C6
            X3 = DB(1)*C4 + DB(2)*C1 + DB(3)*C3
            DC(1) = -(PA(3)*X1-PA(2)*X2)/V
            DC(2) = -(PA(1)*X2-PA(3)*X3)/V
            DC(3) = -(PA(2)*X3-PA(1)*X1)/V
            JOUT = 4
         ELSE
            XA = DNORM(DA)
            XB = PNORM(PB)
            X1 = DA(1)*C3 + DA(2)*C2 + DA(3)*C6
            X2 = DA(1)*C1 + DA(2)*C5 + DA(3)*C2
            X3 = DA(1)*C4 + DA(2)*C1 + DA(3)*C3
            DC(1) = -(PB(2)*X1-PB(3)*X2)/V
            DC(2) = -(PB(3)*X3-PB(1)*X1)/V
            DC(3) = -(PB(1)*X2-PB(2)*X3)/V
            JOUT = 3
         END IF
         XC = DNORM(DC)
         KDC = K3
         RETURN
      END IF
C
C====== Format statements
C
 6010 FORMAT ('!!! Error in TWOGIVN: ',I3,3F10.5)
      END
**==unlaue.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       UNLAUE        **
C*************************
C
C
      SUBROUTINE UNLAUE (XF,YF,IH,IK,IL)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose : Output matches to XF,YF (approx) already plotted on Laue
C
      REAL   XF,YF
      INTEGER IH,IK,IL
C
C XF,YF  : point coordinates
C IH,IK,IL : point indices. in case of multiples first one returned
C
C
      INCLUDE 'progdim.finc'
      INCLUDE 'subp.finc'
      INCLUDE 'data.finc'
      INCLUDE 'xyz.finc'
      INCLUDE 'lambda.finc'
      INCLUDE 'spots.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'point.finc'
      INCLUDE 'project.finc'
C
C====== LOCALS:
C
      INTEGER NLIN,NL,J1,J2
      CHARACTER*80 STR
      REAL   C1,S1,CON,YFE,XFE,X,RF,XFS,YFS,WAVES(20),XGE,YGE,ZGE
      INTEGER NHKLS(3,20),I,J,N,NH,NSPOT,ICOMFAC
      INTEGER IHCF
C
C-------------------------------------------------------------------------------
C
      NHKLS(1,1) = 0
      NHKLS(2,1) = 0
      NHKLS(3,1) = 0
      IH = 0
      IK = 0
      IL = 0
      C1 = SPNDLE*3.1415926536/180.0
      S1 = SIN(C1)
      C1 = COS(C1)
      CON = 0.5
C
C====== But impose greater accuracy if plot has been expanded
C
      IF (ISWIT.EQ.2) CON = CON/SSUB
      CALL QGALPH
      NH = 0
      DO 30 N = 1 , NB
C
C====== Retrieve coords of plotted spot
C
         YFE = YORD(N)
C
C====== Exact yf must be near observed yf
C
         IF (ABS(YFE-YF).LE.CON) THEN
            XFE = XABS(N)
C
C====== Exact xf must also be near observed xf
C
            IF (ABS(XFE-XF).LE.CON) THEN
C
C====== Get the position and coords of the rlp
C
               NSPOT = IABS(IRLPPOS(N))
               CALL UNPACK(IHKL(NSPOT),IH,IK,IL)
               IF (IRLPPOS(N).LT.0) THEN
                  XGE = -XG(NSPOT)
                  YGE = -YG(NSPOT)
                  ZGE = -ZG(NSPOT)
                  IH = -IH
                  IK = -IK
                  IL = -IL
               ELSE
                  XGE = XG(NSPOT)
                  YGE = YG(NSPOT)
                  ZGE = ZG(NSPOT)
               END IF
 
               X = C1*XGE - S1*YGE
               NH = NH + 1
               NHKLS(1,NH) = IH
               NHKLS(2,NH) = IK
               NHKLS(3,NH) = IL
               WAVES(NH) = LAMBDA(NSPOT)
C
C====== Save the exact coords of the first spot for output
C
               IF (NH.EQ.1) THEN
                  XFS = XFE
                  YFS = YFE
               END IF
C
C====== If a projection, only interested in lattice plane indices-
C====== non-simple indices and lambda overlaps irelevant
C
               IF (PROJTYPE.NE.PROJLAUE) THEN
                  ICOMFAC = IHCF(IH,IK)
                  ICOMFAC = IHCF(ICOMFAC,IL)
                  DO 20 I = 1 , 3
                     NHKLS(I,1) = NHKLS(I,1)/ICOMFAC
 20               CONTINUE
                  GO TO 40
               END IF
C
C====== Only room for first 20 equivalents
C
               IF (NH.EQ.20) GO TO 40
            END IF
         END IF
 
 30   CONTINUE
 
 40   IH = NHKLS(1,1)
      IK = NHKLS(2,1)
      IL = NHKLS(3,1)
      IF (NH.EQ.0) THEN
         WRITE (STR,6010) XF , YF
         CALL TWRITE(STR)
      END IF
      IF (NH.LE.4) THEN
         WRITE (STR,6020) XFS , YFS , 
     +                    ((NHKLS(I,J),I=1,3),WAVES(J),J=1,NH)
         CALL TWRITE(STR)
      END IF
      IF (NH.GT.4) THEN
         WRITE (STR,6020) XFS , YFS , 
     +                    ((NHKLS(I,J),I=1,3),WAVES(J),J=1,4)
         CALL TWRITE(STR)
         NLIN = (NH+3)/4
         DO 50 NL = 2 , NLIN
            J1 = 4*(NL-1) + 1
            J2 = J1 + 3
            IF (J2.GT.NH) J2 = NH
            WRITE (STR,6030) XFS , YFS , 
     +                       ((NHKLS(I,J),I=1,3),WAVES(J),J=J1,J2)
            CALL TWRITE(STR)
 50      CONTINUE
      END IF
      RETURN
C
C====== Format statements
C
 6010 FORMAT (2F7.2,': NONE')
 6020 FORMAT (2F7.2,': ',4(3I3,'(',F5.2,')'))
 6030 FORMAT (16X,4(3I3,'(',F5.2,')'))
      END
**==unpack.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       UNPACK        **
C*************************
C
C
      SUBROUTINE UNPACK(N,H,K,L)
C
      INTEGER H
C
C-------------------------------------------------------------------------------
C
      L = MOD(N,200) - 100
      K = MOD(N/200,200) - 100
      H = N/40000 - 100
      RETURN
      END
**==updata.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       UPDATA        **
C*************************
C
C
      BLOCK DATA UPDATA
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
      COMMON /DATFLG/PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      LOGICAL PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      COMMON/CARDNL/PA(3),PB(3),PC(3),DA(3),DB(3),DC(3)
      REAL PA,PB,PC,DA,DB,DC
      DATA PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET/10*.FALSE./
      DATA DA,DB,DC,PA,PB,PC,D1,D2,P1,P2/30*0.0/
      END
**==update.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       UPDATE        **
C*************************
C
C
      SUBROUTINE UPDATE(V1,I1,I2,I3,I4)
C
      INCLUDE 'pgstat.finc'
C
      COMMON /PD/P1(3),D1(3),P2(3),D2(3),KP1,KP2
      REAL P1,D1,P2,D2
      INTEGER KP1,KP2
      COMMON /ANGLE/COSTY,COSTZ,CLENS(3),COSA,COSB,COSG,SINA,SINB,SING
      COMMON/CARDNL/PA(3),PB(3),PC(3),DA(3),DB(3),DC(3)
      REAL PA,PB,PC,DA,DB,DC
      COMMON /DATFLG/PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      LOGICAL PASET,PBSET,PCSET,P1SET,P2SET,DASET,DBSET,DCSET
     +,D1SET,D2SET
      LOGICAL PSET,DSET,GSET,CSET
      CHARACTER*(*) V1,SIGNAL*132
      INTEGER I1,I2,I3,I4,I5
C
C I5 : introduced so as not to repeat len(v1)
C
      DATA SIGNAL/'This is not a valid pole or direction'/
C
C-------------------------------------------------------------------------------
C
      PSET = .FALSE.
      DSET = .FALSE.
      CSET = .FALSE.
      GSET = .FALSE.
      CALL TOUPPR(V1)
      I5 = LEN(V1)
      I = I1STCH(V1)
      IF (V1(I:I).EQ.'P') THEN
         IF (V1(I:I+1).EQ.'PA') THEN
            PSET = .TRUE.
            CSET = .TRUE.
            PASET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),PA(1),PA(2),PA(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'PB') THEN
            PSET = .TRUE.
            CSET = .TRUE.
            PBSET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),PB(1),PB(2),PB(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'PC') THEN
            PSET = .TRUE.
            CSET = .TRUE.
            PCSET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),PC(1),PC(2),PC(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'P1') THEN
            PSET = .TRUE.
            GSET = .TRUE.
            P1SET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),P1(1),P1(2),P1(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'P2') THEN
            PSET = .TRUE.
            GSET = .TRUE.
            P2SET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),P2(1),P2(2),P2(3))
            IF (ABORT) GO TO 20
         END IF
         IF (PSET .AND. GSET) THEN
            I3 = I3 + 1
         ELSE IF (PSET .AND. CSET) THEN
            I1 = I1 + 1
         END IF
      END IF
      IF (V1(I:I).EQ.'D') THEN
         IF (V1(I:I+1).EQ.'DA') THEN
            DSET = .TRUE.
            CSET = .TRUE.
            DASET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),DA(1),DA(2),DA(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'DB') THEN
            DSET = .TRUE.
            CSET = .TRUE.
            DBSET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),DB(1),DB(2),DB(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'DC') THEN
            DSET = .TRUE.
            CSET = .TRUE.
            DCSET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),DC(1),DC(2),DC(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'D1') THEN
            DSET = .TRUE.
            GSET = .TRUE.
            D1SET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),D1(1),D1(2),D1(3))
            IF (ABORT) GO TO 20
         ELSE IF (V1(I:I+1).EQ.'D2') THEN
            DSET = .TRUE.
            GSET = .TRUE.
            D2SET = .TRUE.
            J = INDEX(V1(I+2:I5),'=') + I + 2
            CALL RSTRSEQ(V1(J:I5),D2(1),D2(2),D2(3))
            IF (ABORT) GO TO 20
         END IF
         IF (DSET .AND. GSET) THEN
            I4 = I4 + 1
         ELSE IF (DSET .AND. CSET) THEN
            I2 = I2 + 1
         END IF
      END IF
      IF (.NOT.(DSET .OR. PSET)) CALL INPERR(SIGNAL(1:37),V1,I-1)
      RETURN
 
 20   ABORT = .TRUE.
      RETURN
      END
**==updmen.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       UPDMEN        **
C*************************
C
C
      SUBROUTINE UPDMEN (LABEL)
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Updates option menu with associated values
C
      CHARACTER*6 LABEL(34)
C
C LABEL  : names of options
C
C
      INCLUDE 'progdim.finc'
      INCLUDE 'repeat.finc'
      INCLUDE 'graph.finc'
      INCLUDE 'matrix.finc'
      INCLUDE 'sys.finc'
      INCLUDE 'systyp.finc'
      INCLUDE 'data.finc'
      INCLUDE 'radc.finc'
      INCLUDE 'vsave.finc'
C
C====== LOCALS:
C
      CHARACTER*15 TEMP
      INTEGER I
C
C-------------------------------------------------------------------------------
C
      DO 20 I = 1 , 6
C
C====== Modified, otherwise it will not update if values of previous
C====== menu are not blank
C
         IF (CELL(I).EQ.0.) THEN
            WRITE (TEMP,6040) LABEL(I)
            CALL ITEM(I,TEMP,15,.FALSE.)
         ELSE
            WRITE (TEMP,6050) LABEL(I) , CELL(I)
            CALL ITEM(I,TEMP,15,.FALSE.)
         END IF
 
 20   CONTINUE
 
      WRITE (TEMP,6060) LABEL(7) , WVM
      CALL ITEM(7,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6060) LABEL(8) , WVX
      CALL ITEM(8,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6070) LABEL(9) , CTOF
      CALL ITEM(9,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6020) LABEL(10) , DMIN
      CALL ITEM(10,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6020) LABEL(11) , RADI
      CALL ITEM(11,TEMP,15,.FALSE.)
      RADI2 = RADI*RADI
 
      WRITE (TEMP,6080) LABEL(12) , MSYST(MSYS+1) , LATT
      CALL ITEM(12,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6030) LABEL(13) , MAXIS(MROT+4) , MAXIS(MBEAM+4)
      CALL ITEM(13,TEMP,15,.FALSE.)
 
      DO 30 I = 1 , 3
         WRITE (TEMP,6020) LABEL(13+I) , PHIS(I)
         CALL ITEM(13+I,TEMP,15,.FALSE.)
 30   CONTINUE
 
      WRITE (TEMP,6020) LABEL(17) , SPNDLE
      CALL ITEM(17,TEMP,15,.FALSE.)
 
      WRITE (TEMP,6010) LABEL(19) , DEVICE
      CALL ITEM(19,TEMP,15,.TRUE.)
 
      CALL ITEM(28,LABEL(28),6,OVERLAY)
 
      CALL ITEM(32,FSLPIN(1:1),15,.FALSE.)
      CALL ITEM(33,FSLPIN(16:16),15,.FALSE.)
      CALL ITEM(34,FSLPIN(31:31),15,.FALSE.)
 
      RETURN
C
C====== Format statements
C
 6010 FORMAT (A6,1X,A8)
 6020 FORMAT (A6,F8.2,1X)
 6030 FORMAT (A6,1X,A3,',',A3,1X)
 6040 FORMAT (A6,9X)
 6050 FORMAT (A6,F8.4,1X)
 6060 FORMAT (A6,F8.4,1X)
 6070 FORMAT (A6,F8.3,1X)
 6080 FORMAT (A6,1X,A3,1X,',',1X,A1,1X)
      END
**==vector.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       VECTOR        **
C*************************
C
C
      SUBROUTINE VECTOR
C
      COMMON/CARDNL/CRD(3,6)
C
      CHARACTER*80 STR
      CHARACTER*2 NAMES(6)
      SAVE NAMES
      DATA NAMES/'PA','PB','PC','DA','DB','DC'/
C
C-------------------------------------------------------------------------------
C
      CALL QSSETC(1,24)
      CALL TWRITE('=== Vectors set to:')
      DO 20 I = 1 , 3
         II = 3 + I
         WRITE (STR,6010) NAMES(I) , (CRD(J,I),J=1,3) , NAMES(II) , 
     +                    (CRD(J,II),J=1,3)
         CALL TWRITE(STR)
 20   CONTINUE
      RETURN
 6010 FORMAT (2(1X,A,'=',3G9.2E1,8X))
      END
**==volume.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       VOLUME        **
C*************************
C
C
      FUNCTION VOLUME(A,B,C,AL,BE,GA)
C
      IMPLICIT REAL(A-Z)
C
C-------------------------------------------------------------------------------
C
      VOLUME = A*B*C*(1-COS(AL)*COS(AL)-COS(BE)*COS(BE)-COS(GA)*COS(GA)
     +         +(2*COS(AL)*COS(BE)*COS(GA)))
      RETURN
      END
**==xpi.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       XPI           **
C*************************
C
C Purpose: Derives multiples of Pi
C
      REAL FUNCTION XPI(R)
C
      REAL R
C
C====== LOCALS:
C
      REAL X
C
C-------------------------------------------------------------------------------
C
      X = 3.1415927
      XPI = X*R
      END
**==zoneax.f  
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**       ZONEAX        **
C*************************
C
C
      SUBROUTINE ZONEAX(PHIZA,PHIB,PHIZB,CONV)
C
C
      COMMON/OTHERS/PHI1ZA,PHI2ZA,PHI1B,PHI2B,ALPHA,BETA,GAMMA,HKL,
     +RMAX,ULAM,LLAM,CL
C
      REAL PHIZA,PHIB,PHIZB,CONV
C
C Purpose: Subroutine for calculating the position of the zone axis
C
C====== LOCALS:
C
      REAL R , ZZA , SIGN , TZB , TZZA , C1 , SGN , STEP , XPI,R1,ZP,BP
C
C-------------------------------------------------------------------------------
C
      R = 0.0001
      IF (PHIB.NE.90. .AND. PHI2B.NE.90.) THEN
         IF (PHIZA.EQ.0. .AND. ABS(PHI2ZA).EQ.90.) THEN
            TZZA = COS(PHI2B*CONV)*TAN(PHIB*CONV)/SIN(PHI2B*CONV)
            SIGN = 1.
            IF (PHI2ZA.LT.0.) SIGN = -1.
            ZZA = SIGN*ATAN(TZZA)
            TZB = -1./(TAN(PHIB*CONV)*COS(ZZA))
            PHIZB = ATAN(TZB)
            GO TO 30
         ELSE IF (PHI2ZA.EQ.0. .AND. ABS(PHIZA).EQ.90.) THEN
            TZZA = COS(PHIB*CONV)*TAN(PHI2B*CONV)/SIN(PHIB*CONV)
            ZZA = ATAN(TZZA)
            TZB = -1./(TAN(PHI2B*CONV)*COS(ZZA))
            PHIZB = ATAN(TZB)
            GO TO 30
         ELSE IF (PHIB.EQ.PHI2B) THEN
            TZZA = (COS(PHI2ZA*CONV)-COS(PHIZA*CONV))
     +             /(SIN(PHIZA*CONV)-SIN(PHI2ZA*CONV))
            ZZA = ATAN(TZZA)
            C1 = SIN(PHIZA*CONV)*SIN(ZZA) + COS(PHIZA*CONV)*COS(ZZA)
            TZB = -COS(PHIB*CONV)/(C1*SIN(PHIB*CONV))
            PHIZB = ATAN(TZB)
            GO TO 30
         ELSE IF (ABS(PHIZA).EQ.90.) THEN
            SGN = SIN(PHIZA*CONV)
            STEP = (SGN*TAN(PHI2B*CONV)*SIN(PHI2ZA*CONV)-TAN(PHIB*CONV))
     +             /(COS(PHI2ZA*CONV)*TAN(PHI2B*CONV))
            STEP = STEP**2 + 1.
            STEP = SQRT(STEP/TAN(PHIB*CONV)**2)
            PHIZB = ATAN(STEP)
            IF (SGN.GT.0.) PHIZB = XPI(1.) - PHIZB
            RETURN
         ELSE IF (ABS(PHI2ZA).NE.90.) THEN
            R1 = TAN(PHIB*CONV)/TAN(PHI2B*CONV)
            TZZA = (COS(PHI2ZA*CONV)-R1*COS(PHIZA*CONV))
     +             /(R1*SIN(PHIZA*CONV)-SIN(PHI2ZA*CONV))
            ZZA = ATAN(TZZA)
            IF (ZZA.EQ.0. .AND. PHIB.EQ.PHI2B) THEN
               TZB = COS(PHIB*CONV)/(SIN(PHIB*CONV)*COS(PHIB*CONV))
               PHIZB = ATAN(-TZB)
               GO TO 30
            ELSE IF (ZZA.EQ.0. .AND. ABS(PHIZA*PHI2ZA).EQ.0.) THEN
               GO TO 20
            END IF
         ELSE
            SGN = SIN(PHI2ZA*CONV)
            STEP = (SGN*TAN(PHIB*CONV)*SIN(PHIZA*CONV)-TAN(PHI2B*CONV))
     +             /(COS(PHIZA*CONV)*TAN(PHIB*CONV))
            STEP = STEP**2 + 1.
            STEP = SQRT(STEP/TAN(PHI2B*CONV)**2)
            PHIZB = ATAN(STEP)
            IF (SGN.LT.0.) PHIZB = XPI(1.) - PHIZB
            RETURN
         END IF
      ELSE IF (PHI2B.EQ.90.) THEN
         ZZA = (PHI2ZA+90.)*CONV
         IF (PHI2ZA.GT.0.) ZZA = (PHI2ZA-90.)*CONV
         IF (PHIZA.GE.(-PHI2ZA-R) .AND. PHIZA.LE.(-PHI2ZA+R)) THEN
            IF (PHIB.LT.90.) PHIZB = (PHIB+90.)*CONV
            IF (PHIB.GT.90.) PHIZB = (PHIB-90.)*CONV
            RETURN
         ELSE IF (ABS(PHIZA).EQ.90.) THEN
            SIGN = -1.
            IF (PHIZA.EQ.-90.) SIGN = 1.
            TZB = COS(PHIB*CONV)/(SIGN*SIN(PHIB*CONV)*SIN(ZZA))
            PHIZB = ATAN(TZB)
            GO TO 30
         END IF
      ELSE
         ZZA = (PHIZA+90.)*CONV
         IF (PHIZA.GT.0.) ZZA = (PHIZA-90.)*CONV
         IF (PHI2ZA.GE.(-PHIZA-R) .AND. PHI2ZA.LE.(-PHIZA+R)) THEN
            IF (PHI2B.LT.90.) PHIZB = (PHI2B+90.)*CONV
            IF (PHI2B.GT.90.) PHIZB = (PHI2B-90.)*CONV
            RETURN
         ELSE IF (ABS(PHI2ZA).EQ.90.) THEN
            SIGN = -1.
            IF (PHI2ZA.EQ.-90.) SIGN = 1.
            TZB = COS(PHI2B*CONV)/(SIGN*SIN(PHI2B*CONV)*SIN(ZZA))
            PHIZB = ATAN(TZB)
            GO TO 30
         END IF
      END IF
C
C====== Calculation of phi(b) for the zone axis
C
      IF (PHIZA.EQ.PHI2ZA) THEN
         PHIZB = XPI(0.5)
         RETURN
      END IF
 20   IF (PHIZA*PHI2ZA.NE.0.) THEN
         ZP = PHIZA
         BP = PHIB
         IF (PHIB.EQ.90.) THEN
            ZP = PHI2ZA
            BP = PHI2B
         END IF
         R1 = COS(ZP*CONV)*COS(ZZA) + SIN(ZP*CONV)*SIN(ZZA)
         TZB = 1./(TAN(BP*CONV)*R1)
         PHIZB = ATAN(-TZB)
      ELSE
         IF (PHIZA.EQ.0.) TZB = -1./(TAN(PHIB*CONV)*COS(ZZA))
         IF (PHI2ZA.EQ.0.) TZB = -1./(TAN(PHI2B*CONV)*COS(ZZA))
         PHIZB = ATAN(TZB)
      END IF
 30   IF (PHIZB.LT.0.) PHIZB = XPI(1.) + PHIZB
      RETURN
      END
