**==aa0001.f  
C
C PROGRAM 'LAUEDIFF'
C ==================
C
C THE PROGRAM LAUEDIFF IS USED TO PREPARE A FILE CONTAINING
C DIFFERENCE LAUE DATA SCALED TO A MONOCHROMATIC DATA SET (FOR
C USE IN DIFFERENCE FOURIERS IN DYNAMIC STUDIES OF PROTEIN
C STRUCTURES ETC.
C
C
C THE PROGRAM READS TWO LAUE DATA SETS COLLECTED FROM THE SAME
C CRYSTAL IN THE SAME ORIENTATION AND SCALES THES TWO SETS
C TOGETHER AS TWO SETS OF UNMERGED REFLECTION DATA USING
C SUBROUTINES DERIVED FROM THE SCALING PROGRAM 'ANISOSC'. (CHECKS
C ARE MADE TO ENSURE THAT THE REFLECTIONS BEING MATCHED HAVE
C WAVELENGTHS WITHIN 0.1 ANGSTROM OF EACH OTHER). THE SCALED
C DATA ARE THEN MERGED AND COMBINED WITH A MERGED REFERENCE SET
C OF DATA TO GIVE AN OUTPUT FILE IN WHICH THE LAUE DATA ARE
C RESCALED. IN THIS RESCALING, A SCALE FACTOR IS CALCULATED FOR
C EACH REFLECTION BEING THE SCALE FACTOR REQUIRED TO MAKE THE 'F'
C VALUE OF THE LAUE MEASUREMENT FROM THE FIRST LAUE FILE EQUAL
C TO THE 'F' VALUE IN THE MONOCHROMATIC DATA
C
C
C THE ARRAYS IA1 AND IA2 ARE USED TO HOLD THE TWO INPUT SETS OF
C LAUE DATA USING 4 INTEGER WORDS/REFLECTION AS FOLLOWS
C
C        WORD 1  H,K,L PACKED  2**16(H+128)+2**8(K+128)+L+128
C        WORD 2  10000*S
C        WORD 3  INTENSITY
C        WORD 4  SIG(I) + 2**16(L100)    L100=100*LAMBDA
C
C THE ARRAY IA3 IS USED TO HOLD THE LAUE DATA AFTER THE TWO SETS
C HAVE BEEN SCALED TOGETHER AND IN WHICH THE REFLECTION INDICES HAVE
C CONVERTED TO THE UNIQUE SET USING 4 INTEGER WORDS/REFLECTION AS
C FOLLOWS
C
C        WORD 1  H,K,L PACKED  2**16(H+128)+2**8(K+128)+L+128
C        WORD 2  INTENSITY FROM FIRST LAUE FILE I1
C        WORD 3  INTENSITY FROM 2ND   LAUE FILE I2
C        WORD 4  SIG(I1) + 2**16(SIG(I2))
C
C PARAMETER STATEMENT. (MXR = MAX. NO. OF LAUE REFLNS. ALLOWED)
      PARAMETER(MXR=25000)
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IA1(4*MXR),IA2(4*MXR),IA3(4*MXR)
      CHARACTER*10 PGNAME
      DIMENSION CELL(6)
      COMMON /KRW/IPOINT(10),IDATA(100)
      COMMON /INPUT/ JN,JD,NCYC,CONV,JAN
      COMMON /SCALES/ SC(2),BETA(6)
      COMMON /SYMM1/PGNAME
      COMMON /SCIN/SCALIN
      COMMON /GTRF/NREJL,NMATCH
      COMMON /COL/ICPHI,ICW
      COMMON /RANGES/ IMIN(3),IMAX(3),SMAX
C
C INITIALISATIONS
C ---------------
C
      MAXREF = MXR
      IAMAX = 4*MXR
      IFAIL = 0
      CALL CCPOPN(5,'DATA',5,1,LDUM,IFAIL)
      CALL CCPOPN(6,'PRINTER',6,1,LDUM,IFAIL)
      CALL CCPVRS(6,'LAUEDIFF','15/10/92')
      CALL CCPOPN(1,'LAUE1',5,1,LDUM,IFAIL)
      CALL CCPOPN(2,'LAUE2',5,1,LDUM,IFAIL)
      CALL MTZINI
C
C PROCESS DATA
C ------------
C
C READ CONTROL DATA AND OPEN MTZ FILES
C
      CALL DATAIN
C
C READ AND SORT FIRST LAUE FILE (UNMERGED)
C
      CALL RDLAU(1,IA1,SCALIN,MAXREF,NREF1)
      CALL REFSRT(IA1,NREF1,4,IAMAX)
C
C READ AND SORT SECOND LAUE FILE (UNMERGED)
C
      CALL RDLAU(2,IA2,SCALIN,MAXREF,NREF2)
      CALL REFSRT(IA2,NREF2,4,IAMAX)
C
C FIND INITIAL SCALES
C
      CALL SCINIT(IA1,NREF1,IA2,NREF2)
C
C REFINE SCALE FACTORS
C
      CALL SCAREF(IA1,NREF1,IA2,NREF2)
C
C APPLY SCALE FACTORS AND STORE SCALED LAUE DATA IN ARRAY IA3
C
      CALL SCAPLY(IA1,NREF1,IA2,NREF2,IA3,NREF3)
C
C SORT SCALED LAUE DATA (NOW BASED ON UNIQUE INDICES)
C
      CALL REFSRT(IA3,NREF3,4,IAMAX)
C
C SCALE DATA TO MONOCHROMATIC AND WRITE OUTPUT FILE
C
      CALL SCALOP(IA3,NREF3)
      STOP
      END
**==datain.f  
C
C SUBROUTINE 'DATAIN'
C ===================
C
C INITIALISE SCALE FACTORS, READ CONTROL DATA AND OPEN MTZ FILES
C FOR THE PROGRAM 'LAUEDIFF'
C
      SUBROUTINE DATAIN
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL EOF
      INTEGER MTOK
      PARAMETER (MTOK=20)
      CHARACTER*4 KEY, CVAL(MTOK)
      CHARACTER*400 LINE
      INTEGER NTOK, IBEG(MTOK), IEND(MTOK), ITYP(MTOK), IDEC(MTOK)
      REAL FVAL(MTOK)
      INTEGER IPOINT,IDATA
      CHARACTER*70 TITL
      CHARACTER*72 ITEXT
      CHARACTER*30 LABLOP(9)
      CHARACTER*80 LABIN
      CHARACTER*10 SPGNAM
      CHARACTER*6 PGN
      CHARACTER*1 LTYPE
      CHARACTER*10 PGNAME
      CHARACTER*30 PRGLAB(7)
      CHARACTER*1 CTYP(7),CTYPO(9)
      CHARACTER*15 TYP(2)
      CHARACTER*80 HSTR(2)
      INTEGER ISORT(5)
      DIMENSION CELL(6)
      REAL RSYMM(4,4,96)
      COMMON /KRW/IPOINT(10),IDATA(100)
      COMMON /INPUT/ JN,JD,NCYC,CONV,JAN
      COMMON /SCALES/ SC(2),BETA(6)
      COMMON /SYMM1/PGNAME
      COMMON /SCIN/SCALIN
      COMMON /COL/ICPHI,ICW
      DATA PRGLAB/'H','K','L','FP','SIGFP','PHI','W'/
      DATA CTYP/'H','H','H','F','Q','P','W'/
      DATA LABLOP/'H','K','L','FL1','SIGL1','FL2','SIGL2',' ',' '/
      DATA CTYPO/'H','H','H','F','Q','F','Q',' ',' '/
      DATA HSTR/'Created by the program LAUEDIFF',' '/
C
C INITIALISATIONS
C ---------------
C
      DO 20 I = 1 , 2
         SC(I) = 1.0
 20   CONTINUE
      DO 30 I = 1 , 6
         BETA(I) = 0.0
 30   CONTINUE
      JAN = 0
      JN = 1
      JD = 3
      WRITE (6,6020)
C
C DATA CARD 1     NSPGRP NCYC CONV SCALIN
C -----------
C
      CALL FFREAD(5,ITEXT,72,6,.TRUE.)
      CALL IVALUE(NSPGRP)
      CALL IVALUE(NCYC)
      IF (NCYC.EQ.0) NCYC = 4
      CALL FVALUE(CONV)
      CALL FVALUE(SCALIN)
      IF (SCALIN.LE.0) SCALIN = 1.0
      WRITE (6,6030) NSPGRP
      WRITE (6,6040) NCYC
      WRITE (6,6050) CONV
      WRITE (6,6060) SCALIN
      CALL MSYMLB (10,NSPGRP,SPGNAM,PGN,NSYMP,NSYMM,RSYMM)
      LTYPE = SPGNAM(1:1)
      PGNAME = PGN(3:)
      CALL SYMMAT
C
C DATA CARD 2    TITLE FOR O/P FILE
C -----------
C
      READ (5,6010) TITL
C
C DATA CARDS 3   MTZ ASIGNMENTS - OPEN INPUT MTZ FILE
C ------------
      LINE = ' '
      NTOK = MTOK
      CALL PARSER (KEY,LINE,IBEG,IEND,ITYP,FVAL,CVAL,
     +                         IDEC,NTOK,EOF,.FALSE.)
      CALL CCPUPC(KEY)
      IF (KEY.NE.'LABI') GO TO 50
      CALL LKYIN(1,PRGLAB,7,NTOK,LINE,IBEG,IEND)
      DO 40 I = 1 , 5
         IPOINT(I) = -1
 40   CONTINUE
      IPOINT(6) = 0
      IPOINT(7) = 0
      CALL LROPEN (1,'HKLIN',1,IFAIL)
      IF (IFAIL.EQ.1) STOP
      CALL LRASSN (1,PRGLAB,7,IPOINT,CTYP)
      CALL LRCELL (1,CELL)
      NCOLO = 7
      ICPHI = 0
      ICW = 0
      IF (IPOINT(6).GT.0) THEN
         NCOLO = NCOLO + 1
         ICPHI = NCOLO
         LABLOP(NCOLO) = 'PHI'
         CTYPO(NCOLO) = 'P'
      END IF
      IF (IPOINT(7).GT.0) THEN
         NCOLO = NCOLO + 1
         ICW = NCOLO
         LABLOP(NCOLO) = 'W'
         CTYPO(NCOLO) = 'W'
      END IF
C
C DATA CARD 4    LABELS FOR O/P MTZ FILE H K L FL1 SIGFL1 FL2 SIGL2 (PHI) (W)
C -----------
C
      LINE = ' '
      NTOK = MTOK
      CALL PARSER (KEY,LINE,IBEG,IEND,ITYP,FVAL,CVAL,
     +                         IDEC,NTOK,EOF,.FALSE.)
      IF (.NOT.EOF) THEN
         CALL CCPUPC(KEY)
         IF (KEY.NE.'LABO') GO TO 60
         CALL LKYOUT (2,LABLOP,NCOLO,NTOK,LINE,IBEG,IEND)
      END IF
C
C OPEN OUTPUT MTZ FILE
C --------------------
C
      ISORT(1) = 1
      ISORT(2) = 2
      ISORT(3) = 3
      ISORT(4) = 0
      ISORT(5) = 0
      CALL LWOPEN (2,'HKLOUT')
      CALL LWTITL (2,TITL,0)
      CALL LWCLAB (2,LABLOP,NCOLO,CTYPO,0)
      CALL LWHIST (2,HSTR,1)
      CALL LWCELL (2,CELL)
      CALL LWSYMM (2,NSYMM,NSYMP,RSYMM,LTYPE,NSPGRP,SPGNAM,PGNAME)
      CALL LWSORT (2,ISORT)
      RETURN
C
C ERROR CONDITIONS
C ----------------
C
 50   WRITE (6,6070)
      STOP
 60   WRITE (6,6080)
      STOP
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (A)
 6020 FORMAT (//,' CONTROL DATA ITEMS',//)
 6030 FORMAT (/,' SPACE GROUP NUMBER:',I4)
 6040 FORMAT (/,' NUMBER OF CYCLES FOR SCALE FACTOR REFINEMENT =',I3)
 6050 FORMAT (/,' STOP REFINEMENT IF PARAMETER SHIFTS LESS THAN',F7.2,
     +        ' STANDARD DEVIATIONS')
 6060 FORMAT (/,' SCALE FACTOR FOR INPUT DATA =',F7.3)
C
 6070 FORMAT (/,' **KEYWORD ''LABIN'' EXPECTED**')
 6080 FORMAT (/,' **KEYWORD ''LABOUT'' EXPECTED**')
      END
**==rdlau.f  
C
C SUBROUTINE 'RDLAU'
C ==================
C
C READ IN AND STORE A LAUE DATA SET
C
      SUBROUTINE RDLAU(IUN,IA,SCALIN,MAXREF,NREF)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER FOR READING DATA SET
C          IA (O)   ARRAY  TO STORE LAUE DATA (SEE MAIN PROGRAM
C                   FOR DETAILS)
C      SCALIN (I)   SCALE FACTOR TO BE APPLIED TO INPUT LAUE DATA
C      MAXREF (I)   MAXIMUM REFLECTION CAPACITY OF ARRAY IA
C        NREF (O)   NUMBER OF REFLECTIONS READ AND ACCEPTED
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IA(*)
      DATA NTWO16/65536/
      DATA NTWO8/256/
C
C INITIALISE COUNTS
C -----------------
C
      NREF = 0
      NSIGRJ = 0
      NNEG = 0
      NTOT = 0
      WRITE (6,6070) IUN
C
C READ LAUE RECORDS, CHECK AND STORE DATA
C ---------------------------------------
C
 20   READ (IUN,6010,END=30) IH , IK , IL , ALBDA , THETA , II , ISIG
      NTOT = NTOT + 1
      IF (ISIG.LE.0) THEN
         NSIGRJ = NSIGRJ + 1
         GO TO 20
      END IF
      IF (II.LT.0) THEN
         NNEG = NNEG + 1
         GO TO 20
      END IF
      II = NINT(SCALIN*II)
      ISIG = NINT(SCALIN*ISIG)
      IF (ISIG.EQ.0) ISIG = 1
      NREF = NREF + 1
      IF (NREF.GT.MAXREF) THEN
C
C ERROR CONDITIONS
C ----------------
C
         WRITE (6,6080) MAXREF
         STOP
      ELSE
         IF (IH.LT.-127 .OR. IH.GT.127) GO TO 40
         IF (IK.LT.-127 .OR. IK.GT.127) GO TO 40
         IF (IL.LT.-127 .OR. IL.GT.127) GO TO 40
         I = 4*(NREF-1)
         IA(I+1) = NTWO16*(IH+128) + NTWO8*(IK+128) + IL + 128
         STL = SIN(THETA)/ALBDA
         IA(I+2) = NINT(40000.0*STL*STL)
         IA(I+3) = II
         IF (ISIG.GT.32767) THEN
            WRITE (6,6100) IH , IK , IL , ISIG
            STOP
         ELSE
            L100 = 100*ALBDA
            IF (L100.LT.0 .OR. L100.GT.32767) THEN
               WRITE (6,6110) ALBDA
               STOP
            ELSE
               IA(I+4) = NTWO16*L100 + ISIG
               GO TO 20
            END IF
         END IF
      END IF
C
C END OF FILE REACHED
C -------------------
C
 30   IF (NREF.EQ.0) THEN
         WRITE (6,6120)
         STOP
      ELSE
         WRITE (6,6020) NTOT
         WRITE (6,6030) NREF
         NREJ = NTOT - NREF
         WRITE (6,6040) NREJ
         WRITE (6,6050) NNEG
         WRITE (6,6060) NSIGRJ
         RETURN
      END IF
 40   WRITE (6,6090) IH , IK , IL
      STOP
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (3I5,2F10.5,2I10)
 6020 FORMAT (//,' NUMBER OF LAUE REFLECTIONS READ:',I6)
 6030 FORMAT (/,' NUMBER OF REFLECTIONS ACCEPTED: ',I6)
 6040 FORMAT (/,' NUMBER OF REFLECTIONS REJECTED: ',I6)
 6050 FORMAT (/,' NUMBER OF NEGATIVE INTENSITIES: ',I6)
 6060 FORMAT (/,' NUMBER OF SIGMA REJECTS       : ',I6)
 6070 FORMAT (///,' READING LAUE DATA FOR FILE',I2)
C
 6080 FORMAT (/,' **NUMBER OF REFLECTIONS MAY NOT EXCEED',I6,' **')
 6090 FORMAT (/,' **INDICES OUT OF RANGE -127 TO 127, HKL=',3I4,' **')
 6100 FORMAT (/,' **SIGMA OUT OF RANGE 0-32767 FOR REFLECTION HKL=',3I4,
     +        '  SIGMA =',I10,' **')
 6110 FORMAT (/,' **LAMBDA = ',F8.1,' LESS THAN 0 OR GREATER THAN',
     +        ' 327.6 ANGSTROMS**')
 6120 FORMAT (/,' **NO LAUE REFLECTIONS ACCEPTED**')
      END
**==refsrt.f  
C
C SUBROUTINE 'REFSRT'
C ===================
C
C THIS SUBROUTINE IS USED TO SORT THE REFLECTION DATA HELD IN CORE. IT
C IS A MODIFIED VERSION OF THE SUBROUTINE 'AHVSOR' FROM ELEANOR DODSON'S
C VERSION OF THE PROGRAM 'CAD'. THIS VERSION SORTS ON A WORD CONTAINING
C THE PACKED INDICES.
C
      SUBROUTINE REFSRT(IA,NREF,NWRD,IDIM)
C
C PARAMETERS
C
C         IA (I/O)  INTEGER ARRAY CONTAINING THE REFLECTION DATA WITH
C                   NWRD WORDS FOR REFLN 1 FOLLOWED BY NWRD WORDS FOR
C                   EACH REFLECTION UP TO NREF REFLECTIONS  (NWRD <=10)
C       NREF (I)    THE NO. OF REFLECTIONS TO BE SORTED
C       NWRD (I)    NUMBER OF WORDS/REFLECTION (INDICES PACKED IN FIRST
C                   WORD FOR EACH REFLECTION)
C       IDIM (I)    THE NUMBER OF ELEMENTS IN THE ARRAY IA
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      IMPLICIT INTEGER(A-Z)
      INTEGER IA(IDIM),ITEMP,CUT(10)
      INTEGER SAVE(2,16)
      DATA CUTOFF/20/
C
C SORT DATA
C ---------
C
      STACK = 0
      LOW = 1
      HIGH = NREF
 20   CHUNK = HIGH - LOW
      IF (CHUNK.GT.CUTOFF) THEN
         MIDDLE = (LOW+HIGH)/2
         IF (ICMP(IA,LOW,IA,MIDDLE).GT.0) THEN
            J1 = NWRD*(LOW-1)
            J2 = NWRD*(MIDDLE-1)
            DO 30 I = 1 , NWRD
               J1 = J1 + 1
               J2 = J2 + 1
               ITEMP = IA(J1)
               IA(J1) = IA(J2)
               IA(J2) = ITEMP
 30         CONTINUE
         END IF
         IF (ICMP(IA,MIDDLE,IA,HIGH).GT.0) THEN
            J1 = NWRD*(MIDDLE-1)
            J2 = NWRD*(HIGH-1)
            DO 40 I = 1 , NWRD
               J1 = J1 + 1
               J2 = J2 + 1
               ITEMP = IA(J1)
               IA(J1) = IA(J2)
               IA(J2) = ITEMP
 40         CONTINUE
            IF (ICMP(IA,LOW,IA,MIDDLE).GT.0) THEN
               J1 = NWRD*(LOW-1)
               J2 = NWRD*(MIDDLE-1)
               DO 50 I = 1 , NWRD
                  J1 = J1 + 1
                  J2 = J2 + 1
                  ITEMP = IA(J1)
                  IA(J1) = IA(J2)
                  IA(J2) = ITEMP
 50            CONTINUE
            END IF
         END IF
         J = NWRD*(MIDDLE-1)
         DO 60 I = 1 , NWRD
            J = J + 1
            CUT(I) = IA(J)
 60      CONTINUE
         UP = LOW
         DOWN = HIGH
 70      DOWN = DOWN - 1
         IF (ICMP(CUT,1,IA,DOWN).LT.0) GO TO 70
 80      UP = UP + 1
         IF (ICMP(CUT,1,IA,UP).GT.0) GO TO 80
         IF (UP.LT.DOWN) THEN
            J1 = NWRD*(UP-1)
            J2 = NWRD*(DOWN-1)
            DO 90 I = 1 , NWRD
               J1 = J1 + 1
               J2 = J2 + 1
               ITEMP = IA(J1)
               IA(J1) = IA(J2)
               IA(J2) = ITEMP
 90         CONTINUE
            GO TO 70
         ELSE IF (UP.EQ.DOWN) THEN
            DOWN = DOWN - 1
            UP = UP + 1
         END IF
      ELSE
         IF (CHUNK.GE.2) THEN
            MM = HIGH - 1
            DO 120 M = LOW , MM
               MIN = M
               MMM = M + 1
               DO 100 N = MMM , HIGH
                  IF (ICMP(IA,MIN,IA,N).GT.0) THEN
                     MIN = N
                  END IF
 100           CONTINUE
               IF (MIN.NE.M) THEN
                  J1 = NWRD*(M-1)
                  J2 = NWRD*(MIN-1)
                  DO 110 I = 1 , NWRD
                     J1 = J1 + 1
                     J2 = J2 + 1
                     ITEMP = IA(J1)
                     IA(J1) = IA(J2)
                     IA(J2) = ITEMP
 110              CONTINUE
               END IF
 120        CONTINUE
         END IF
         IF (STACK.EQ.0) RETURN
         LOW = SAVE(1,STACK)
         HIGH = SAVE(2,STACK)
         STACK = STACK - 1
         GO TO 20
      END IF
      STACK = STACK + 1
      IF (STACK.GT.16) THEN
C
C ERROR CONDITION
C ----------------
C
         WRITE (6,6010) STACK
         STOP
      ELSE
         BOTTOM = DOWN - LOW
         TOP = HIGH - UP
         IF (BOTTOM.GT.TOP) THEN
            SAVE(1,STACK) = LOW
            SAVE(2,STACK) = DOWN
            LOW = UP
         ELSE
            SAVE(1,STACK) = UP
            SAVE(2,STACK) = HIGH
            HIGH = DOWN
         END IF
         GO TO 20
      END IF
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (' **STACK LIMIT OF 16 EXCEEDED IN REFSOR**')
      END
**==icmp.f  
C
C FUNCTION 'ICMP'
C ===============
C
C THIS FUNCTION IS USED TO COMPARE THE VALUES OF THE SORT KEYS
C FOR 2 REFLECTIONS  (ASSUMES 4 WORDS/REFLECTION)
C
      FUNCTION ICMP(IARR1,I1,IARR2,I2)
C
C PARAMETERS
C
C        IARR1 (I)   ARRAY CONTAINING 1ST REFLN
C           I1 (I)   POINTER TO REFLECTION IN IARR1
C        IARR2 (I)   ARRAY CONTAINING 2ND REFLN
C           I2 (I)   POINTER TO REFLECTIONIIN IARR2
C
C FUNCTION RETURN VALUES  -1  REFLN 1 LT REFLN 2
C                          0  REFLN 1 EQ REFLN 2
C                          1  REFLN 1 GT REFLN 2
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      INTEGER IARR1(*),IARR2(*)
C
C COMPARE KEYS
C ------------
C
      J1 = 4*I1 - 3
      J2 = 4*I2 - 3
      IF (IARR1(J1).LT.IARR2(J2)) THEN
         ICMP = -1
         RETURN
      ELSE IF (IARR1(J1).EQ.IARR2(J2)) THEN
         ICMP = 0
         RETURN
      ELSE
         ICMP = 1
         RETURN
      END IF
      END
**==scinit.f  
C
C SUBROUTINE 'SCINIT'
C ===================
C
C CALCULATE INITIAL SCALE FACTORS
C
C A MODIFIED VERSION OF THE SUBROUTINE FROM 'ANISOSC'
C
      SUBROUTINE SCINIT(IA1,NREF1,IA2,NREF2)
C
C GET INITIAL SCALE FACTOR BY MAKING SUM(FP**2) = SUM(FPH**2)
C
      DIMENSION IA1(*),IA2(*)
      COMMON /INPUT/ JN,JD,NCYC,CONV,JAN
      COMMON /SCALES/ SC(2),BETA(6)
      COMMON /RANGES/ IMIN(3),IMAX(3),SMAX
      COMMON /GTRF/ NREJL,NMATCH
      INTEGER IN(3),IA(50)
C
C
      SMAX = 0.
      SN = 0.
      SD = 0.
      NR = 0
      DO 20 I = 1 , 3
         IMAX(I) = -999
         IMIN(I) = 999
 20   CONTINUE
      NR1 = 0
      NR2 = 0
C
C   START FILE
C
C  ---------------  LOOP FOR REFLECTIONS  ----------------
C
 30   CALL GETREF(IA1,NREF1,NR1,IA2,NREF2,NR2,IN,S,IA,*50)
      IF (IA(JD+1).GT.0) THEN
         IF (IA(JN+1).GT.0) THEN
C
C  GET INDEX & 4(SINTHETA/LAMBDA)**2 LIMITS
            SMAX = AMAX1(SMAX,S)
            DO 40 I = 1 , 3
               J = IN(I)
               IMIN(I) = MIN0(IMIN(I),J)
               IMAX(I) = MAX0(IMAX(I),J)
 40         CONTINUE
C
            NR = NR + 1
            FFF = IA(JN)
            FFN = SQRT(FFF)
            FFF = IA(JD)
            FFD = SQRT(FFF)
            SN = SN + FFN*FFN
            SD = SD + FFD*FFD
         END IF
      END IF
      GO TO 30
C
C  ---------------  END OF FILE  -----------------
C
 50   SC(2) = SN/SD
      WRITE (6,6020) NMATCH
      WRITE (6,6030) NREJL
      WRITE (6,6010) SC(2) , NR
      RETURN
 6010 FORMAT (//' INITIAL LAUE2 SCALE FACTOR (FOR F**2)  = ',F10.4,
     +        '  FROM',I8,'  REFLECTIONS'//)
 6020 FORMAT (/,' NUMBER OF MATCHING LAUE REFLECTIONS FOUND =',I6)
 6030 FORMAT (/,' NUMBER REJECTED BECAUSE WAVELENGTH DIFFERENCE WAS',
     +        ' GREATER THAN 0.1 ANGSTROMS =',I6)
      END
**==scaref.f  
C
C SUBROUTINE 'SCAREF'
C ===================
C
C REFINE SCALING PARAMETERS
C
C
C THIS IS A MODIFIED VERSION OF THE SUBROUTINE FROM 'ANISOSC'
C
      SUBROUTINE SCAREF(IA1,NREF1,IA2,NREF2)
C
C REFINE SCALES & ANISOTROPIC TEMPERATURE FACTORS
C RECYCLE TILL CONVERGENCE OR NCYC
C
      DIMENSION IA1(*),IA2(*)
      COMMON /INPUT/ JN,JD,NCYC,CONV,JAN
      COMMON /SCALES/ SC(2),BETA(6)
      INTEGER IN(3),IA(50)
      DIMENSION A(8,8),R(8),VAL(8),VEC(8,8),WK(40),PAR(8),DG(8)
      EQUIVALENCE (PAR(1),SC(1))
C
C  LOOP FOR CYCLES
      DO 170 JC = 1 , NCYC
C
C
C  CLEAR MATRIX ETC
         DO 30 I = 1 , 8
            R(I) = 0.0
            DO 20 J = 1 , 8
               A(I,J) = 0.0
 20         CONTINUE
 30      CONTINUE
C
         G1 = 1./SC(1)
         WD2 = 0.0
         NR = 0
C
C START READING FILE
         NR1 = 0
         NR2 = 0
C
C  LOOP FOR EACH REFLECTION
C
 40      CALL GETREF(IA1,NREF1,NR1,IA2,NREF2,NR2,IN,S,IA,*80)
C
C CHECK THAT BOTH NATIVE & DERIVATIVE MEASURMENTS ARE PRESENT
         IF (IA(JD+1).GT.0) THEN
            IF (IA(JN+1).GT.0) THEN
C**--DL--** ALSO OMIT REFLNS WITH ZERO F VALUES FROM SCALING
               IF (IA(JD).GT.0) THEN
                  IF (IA(JN).GT.0) THEN
C**------**
                     NR = NR + 1
                     AH = IN(1)
                     AK = IN(2)
                     AL = IN(3)
                     T = 2.*(AH*(AH*BETA(1)+2.*AK*BETA(4))
     +                   +AK*(AK*BETA(2)+2.*AL*BETA(6))
     +                   +AL*(AL*BETA(3)+2.*AH*BETA(5)))
                     G2 = EXP(T)/SC(2)
C
C GET OBSERVATIONS
                     FFN = IA(JN)
                     SN = IA(JN+1)
                     SN = 1./(SN*SN)
                     FFD = IA(JD)
                     SD = IA(JD+1)
                     SD = 1./(SD*SD)
C
C  MEAN INTENSITY IH = F
                     F = SN*G1*FFN + SD*G2*FFD
                     W = SN*G1*G1 + SD*G2*G2
                     F = F/W
C TERMS FOR MATRIX & RHS
                     F2 = F*F
                     H11 = SN*(F2+SN/W*FFN*(FFN-2.*G1*F))
                     H12 = SN*SD/W*(FFD*(FFN-G1*F)-G2*FFN*F)
                     H22 = SD*(F2+SD/W*FFD*(FFD-2.*G2*F))
                     D1 = FFN - G1*F
                     D2 = FFD - G2*F
                     WD2 = WD2 + SN*D1*D1 + SD*D2*D2
                     D1 = D1*F*SN
                     D2 = D2*F*SD
C
C PARTIAL DERIVATIVES DG/DP
                     GG = G2 + G2
                     DG(1) = -G1*G1
                     DG(2) = -G2/SC(2)
                     DG(3) = GG*AH*AH
                     DG(4) = GG*AK*AK
                     DG(5) = GG*AL*AL
                     GG = GG + GG
                     DG(6) = GG*AH*AK
                     DG(7) = GG*AH*AL
                     DG(8) = GG*AK*AL
C
C SET UP MATRIX A (LOWER TRIANGLE) & RHS R
                     DO 70 J = 1 , 8
                        IF (J.GT.1) THEN
C
C  J.GT.1  REST OF MATRIX & RHS
                           R(J) = R(J) + D2*DG(J)
                           HD = H22*DG(J)
                           DO 50 I = J , 8
                              A(I,J) = A(I,J) + HD*DG(I)
 50                        CONTINUE
                        ELSE
C
C J=1, RELATIONS TO SCALE 1
                           R(1) = R(1) + D1*DG(1)
                           A(1,1) = A(1,1) + H11*DG(1)*DG(1)
                           HD = H12*DG(1)
                           DO 60 I = 2 , 8
                              A(I,1) = A(I,1) + HD*DG(I)
 60                        CONTINUE
                        END IF
C
C
C  ------------------  END REFLECTION LOOP  --------------------
C
 70                  CONTINUE
                  END IF
               END IF
            END IF
         END IF
         GO TO 40
C
C  ------------------
C
C SOLVE EQUATIONS
C
 80      CALL EA06C(A,VAL,VEC,8,8,8,WK)
         WRITE (6,6010) JC , VAL
C
C  FIND SMALLEST EIGENVALUE  (SHOULD BE 0.0)
         V = VAL(1)
         JM = 1
         DO 90 I = 2 , 8
            IF (VAL(I).LE.V) THEN
               V = VAL(I)
               JM = I
            END IF
 90      CONTINUE
         VAL(JM) = 0.0
C
C  MULTIPLY RHS R BY VEC TRANSPOSE AND DIVIDE BY VAL (IE. MULTIPLY BY
C INVERSE DIAGONAL MATRIX) TO GET TRANSFORMED SHIFT VECTOR
C
         DO 110 I = 1 , 8
            WK(I) = 0.0
            IF (I.NE.JM) THEN
               DO 100 J = 1 , 8
                  WK(I) = WK(I) + VEC(J,I)*R(J)
 100           CONTINUE
               WK(I) = WK(I)/VAL(I)
            END IF
 110     CONTINUE
C
C MEAN WD**2
         WD2 = 0.5*WD2/FLOAT(NR-8)
C
C TRANSFORM SHIFT VECTOR BACK TO TRUE FRAME, CALCULATE VARIANCE/COVARIAN
C  MATRIX
C IN A
         DO 140 I = 1 , 8
            R(I) = 0.0
            DO 130 J = 1 , 8
               R(I) = R(I) + VEC(I,J)*WK(J)
C
C VAR/COVAR MATRIX = VEC * (D**-1) *VEC TRANSPOSE
               V = 0.
               DO 120 K = 1 , 8
                  IF (K.NE.JM) THEN
                     V = V + VEC(I,K)*VEC(J,K)/VAL(K)*WD2
                  END IF
 120           CONTINUE
               A(I,J) = V
 130        CONTINUE
 140     CONTINUE
C
C  SD'S FROM MATRIX
         DO 150 I = 1 , 8
            WK(I) = SQRT(A(I,I))
 150     CONTINUE
C
C SCALE FACTOR FOR SHIFTS SO THAT SC(1) == 1.0
         V = SC(1)/(SC(1)+R(1))
         R(1) = 0.0
         NTEST = 0
         DO 160 I = 2 , 8
            S = (PAR(I)+R(I))*V
            R(I) = S - PAR(I)
            PAR(I) = S
C
C TEST FOR CONVERGENCE, ALL SHIFTS .LT. CONV * SD (PAR(I))
            IF (R(I).GT.CONV*WK(I)) NTEST = NTEST + 1
 160     CONTINUE
C
C
C
         WRITE (6,6020) WD2 , NR
         WRITE (6,6030) PAR , R , (WK(I),I=1,8)
C
C      WRITE(6,162) A
C162   FORMAT(' VARIANCE/COVARIANCE MATRIX'//8(8E12.3/))
C
C END REFINEMENT IF CONVERGED
         IF (NTEST.EQ.0) GO TO 180
 170  CONTINUE
C
 180  RETURN
 6010 FORMAT (//' REFINEMENT CYCLE  ',I5//' EIGENVALUES OF MATRIX ',
     +        8E12.3/)
 6020 FORMAT (/' MEAN RESIDUAL  W D**2/( M - N) :',F15.4,15X,'  FOR ',
     +        I8,'   REFLECTIONS'//)
 6030 FORMAT (17X,'SCALES'//14X,' NATIVE  DERIVATIVE    B11   ',
     +        '    B22       B33       B12       B13       B23   '//
     +        ' NEW VALUES',2F10.4,6F10.6/' SHIFTS    ',2F10.4,
     +        6F10.6/' SD ''S     ',2F10.4,6F10.6//)
      END
**==scaply.f  
C
C SUBROUTINE 'SCAPLY'
C ===================
C
C APPLY SCALING FACTORS CALCULATED BY ANISOSC SCALING ROUTINES
C
C THIS IS A MODIFIED VERSION OF THE SUBROUTINE FROM 'ANISOSC'
C
      SUBROUTINE SCAPLY(IA1,NREF1,IA2,NREF2,IA3,NREF3)
C
C APPLY SCALES & TEMPERATURE FACTORS
C
C  WRITE NEW FILE, ANALYSE OUTPUT SCALE AGAINST H,K,L, 4(SINTHETA/LAMBDA
C
      DIMENSION IA1(*),IA2(*),IA3(*)
      INTEGER IPOINT,IDATA
      CHARACTER*1 JHKL(3)
      COMMON /INPUT/ JN,JD,NCYC,CONV,JAN
      COMMON /SCALES/ SC(2),BETA(6)
      COMMON /RANGES/ IMIN(3),IMAX(3),SMAX
      COMMON /KRW/IPOINT(10),IDATA(100)
      CHARACTER*10 PGNAME
      COMMON /SYMM1/PGNAME
      INTEGER IN(3),IA(50)
      DIMENSION SN(120,5),SD(120,4),NR(120,4),SCALEX(2),SCALEY(2),
     . ICY(1)
C
      DATA JHKL/'H','K','L'/
      DATA NTWO16/65536/,NTWO8/256/
C
C
      NREF3 = 0
      DO 30 I = 1 , 120
         SN(I,5) = 0.0
         DO 20 J = 1 , 4
            SN(I,J) = 0.
            SD(I,J) = 0.
            NR(I,J) = 0
 20      CONTINUE
 30   CONTINUE
C SCALE IS FOR F**2
      SC(2) = SQRT(SC(2))
      NS = 20
      DS = FLOAT(NS)/SMAX
      NF = 0
      NC = 2
      IF (JAN.NE.0) NC = 4
C
      NR1 = 0
      NR2 = 0
C
C  --------------------  LOOP FOR REFLECTIONS  ------------------
C
 40   CALL GETREF(IA1,NREF1,NR1,IA2,NREF2,NR2,IN,S,IA,*60)
      IF (IA(JD+1).GT.0) THEN
         NF = NF + 1
         AH = IN(1)
         AK = IN(2)
         AL = IN(3)
         T = AH*(AH*BETA(1)+2.*AK*BETA(4))
     +       + AK*(AK*BETA(2)+2.*AL*BETA(6))
     +       + AL*(AL*BETA(3)+2.*AH*BETA(5))
         S2 = SC(2)*EXP(-T)
C
C APPLY SCALES
         IA(JD) = S2*S2*IA(JD)
         IA(JD+1) = S2*S2*IA(JD+1)
         IF (IA(JD+1).GT.32767) IA(JD+1) = 32767
         IF (IA(JN+1).GT.0) THEN
            FFN = IA(JN)
            FFD = IA(JD)
C
C SUMS FOR ANALYSES
            DO 50 I = 1 , 3
               J = IN(I) - IMIN(I) + 1
               SN(J,I) = SN(J,I) + FFN
               SD(J,I) = SD(J,I) + FFD
               NR(J,I) = NR(J,I) + 1
 50         CONTINUE
            J = S*DS + 1.
            J = MAX0(1,J)
            J = MIN0(J,NS)
            SN(J,4) = SN(J,4) + FFN
            SD(J,4) = SD(J,4) + FFD
            NR(J,4) = NR(J,4) + 1
         END IF
      END IF
C
C  SAVE SCALED DATA
      IF (IA(JN).NE.0 .AND. IA(JD).NE.0) THEN
         NREF3 = NREF3 + 1
         II = 4*NREF3 - 3
         IF (PGNAME(1:1).EQ.'3' .OR. PGNAME(1:1).EQ.'6' .OR. PGNAME(1:1)
     +       .EQ.'4') THEN
            CALL TURN3(IN(1),IN(2),IN(3),ISYM)
         ELSE
            CALL TURNIP(IN(1),IN(2),IN(3),ISYM)
         END IF
         IA3(II) = NTWO16*(IN(1)+128) + NTWO8*(IN(2)+128) + IN(3) + 128
         IA3(II+1) = IA(JN)
         IA3(II+2) = IA(JD)
         IA3(II+3) = NTWO16*IA(JD+1) + IA(JN+1)
      END IF
      GO TO 40
C
C  ---------------  END OF FILE  -----------------
C
 60   WRITE (6,6010) NF
C
C  ANALYSES AGAINST INDICES
      DO 80 I = 1 , 3
         WRITE (6,6020) JHKL(I)
         S2 = 0.
         NF = IMAX(I) - IMIN(I) + 1
C
         DO 70 J = 1 , NF
            IF (NR(J,I).NE.0) THEN
               K = J + IMIN(I) - 1
               S = SN(J,I)
               SN(J,I) = S/SD(J,I)
               S2 = AMAX1(S2,SN(J,I))
               SN(J,5) = K
               T = NR(J,I)
               S = S/T
               U = SD(J,I)/T
               WRITE (6,6030) K , NR(J,I) , S , U , SN(J,I)
            END IF
 70      CONTINUE
C
C
         WRITE (6,6040)
         SCALEX(1) = IMIN(I)
         SCALEX(2) = IMAX(I)
         SCALEY(1) = 0.
         SCALEY(2) = S2*1.3
         ICY(1) = I
         IND = 2
         CALL SCATPL(SN,120,5,NF,ICY,1,5,50,110,SCALEX,SCALEY,IND)
 80   CONTINUE
C
C
C
C  ANALYSIS AGAINST 4(SIN THETA/LAMBDA)**2
C
      DS = 1./DS
      WRITE (6,6050) DS
      S2 = 0.
C
      DO 90 J = 1 , NS
         IF (NR(J,4).GT.0) THEN
            S1 = SN(J,4)
            SN(J,4) = S1/SD(J,4)
            S2 = AMAX1(S2,SN(J,4))
            S = (FLOAT(J)-0.5)*DS
            SN(J,5) = S
            T = NR(J,4)
            S1 = S1/T
            U = SD(J,4)/T
            WRITE (6,6060) S , NR(J,4) , S1 , U , SN(J,4)
         END IF
 90   CONTINUE
C
      WRITE (6,6040)
      SCALEX(1) = 0.
      SCALEX(2) = SMAX
      SCALEY(1) = 0.
      SCALEY(2) = S2*1.3
      ICY(1) = 4
      IND = 2
      CALL SCATPL(SN,120,5,NS,ICY,1,5,50,110,SCALEX,SCALEY,IND)
C
      RETURN
 6010 FORMAT (///1X,I8,' REFLECTIONS SCALED AND SAVED'/////31X,
     +        'ANALYSES OF SCALE FACTOR ON INTENSITIES AFTER CORRECTION'
     +        /31X,
     +        '========================================================'
     +        ///)
 6020 FORMAT (/'1ANALYSIS AGAINST INDEX ',
     +        A1//'    INDEX    NUMBER    <FL1**2> <FL2**2>    SCALE'/)
 6030 FORMAT (1X,I7,3X,I8,2X,2F10.0,F10.4)
 6040 FORMAT ('1'////)
 6050 FORMAT (///'1ANALYSIS AGAINST 4(SIN THETA/LAMBDA)**2',15X,
     +        'WIDTH OF RANGES = ',
     +        F10.6//' 4(ST/L)**2  NUMBER    <FL1**2> <FL2**2>    SCALE'
     +        /)
 6060 FORMAT (1X,F10.5,I8,2X,2F10.0,F10.4)
      END
**==scatpl.f  
C
C SUBROUTINE 'SCATPL'
C ===================
C
C SUBROUTINE FROM THE PROGRAM 'ANISOSC' TO OUTPUT A SCATTER PLOT
C ON THE PRINTER
C
      SUBROUTINE SCATPL(A,N,M,N1,ICY,NCY,ICX,NY,NX,SCALEX,SCALEY,IND)
      CHARACTER*1 ICHAR(12),IOUT(161)
      DIMENSION XPR(17),A(N,M),ICY(NCY)
      DIMENSION SCALEX(2),SCALEY(2)
      DATA ICHAR(1),ICHAR(2),ICHAR(3),ICHAR(4),ICHAR(5),ICHAR(6),
     1ICHAR(7),ICHAR(8),ICHAR(9),ICHAR(10),ICHAR(11),ICHAR(12)/'*','+',
     2'X','-','=','1','2','3','4',' ','0','.'/
      DATA IWRITE/6/,ETA/0.0/,IWIDTH/125/
      IF (N.LE.1) THEN
         IND = 3
         RETURN
      ELSE
         NLY = (NY/10)*10
         IF (NLY.LE.0) NLY = 50
         NLX = (NX/10)*10
         IX = IWIDTH - 20
         IF (NLX.LE.0 .OR. NLX.GT.IX) NLX = IX
         LX = (NLX/10)
         LY = (NLY/10)
         XAXIS = IX
         ETAX = ETA*FLOAT(NX)
         ETAY = ETA*FLOAT(NY)
         IF (IND.LE.1) THEN
            FMIN = A(1,ICX)
            FMAX = FMIN
            DO 20 I = 2 , N1
               AI = A(I,ICX)
               IF (AI.LT.FMIN) FMIN = AI
               IF (AI.GT.FMAX) FMAX = AI
 20         CONTINUE
            IF (FMAX-FMIN.LT.ETAX) GO TO 180
            INDEX = 1
            FM = FLOAT(LX)
            GO TO 140
         ELSE
            XMIN = SCALEX(1)
            XAXIS = SCALEX(2) - XMIN
            IF (XAXIS.LT.ETAX) GO TO 180
            XSTEP = XAXIS/FLOAT(LX)
            IF (IND.EQ.3) GO TO 40
         END IF
      END IF
 30   YMIN = SCALEY(1)
      YAXIS = SCALEY(2) - YMIN
      IF (YAXIS.LT.ETAY) GO TO 190
      YSTEP = YAXIS/FLOAT(LY)
      GO TO 70
 40   K = ICY(1)
      FMIN = A(1,K)
      FMAX = FMIN
      DO 60 J = 1 , NCY
         K = ICY(J)
         DO 50 I = 1 , N1
            AI = A(I,K)
            IF (AI.LT.FMIN) FMIN = AI
            IF (AI.GT.FMAX) FMAX = AI
 50      CONTINUE
 60   CONTINUE
      IF (FMAX-FMIN.LT.ETAY) GO TO 190
      INDEX = 2
      FM = FLOAT(LY)
      GO TO 140
 70   YINT = 10.0/YSTEP
      XINT = 10.0/XSTEP
      NLY = NLY + 1
      NLX = NLX + 1
      LX = LX + 1
      RKN = 0.0
      DO 80 KN = 1 , LX
         XPR(KN) = XMIN + RKN*XSTEP
         RKN = RKN + 1.0
 80   CONTINUE
      DO 130 I = 1 , NLY
         I1 = I - 1
         ILY = NLY - I1
         DO 90 IX = 1 , NLX
            IOUT(IX) = ICHAR(10)
 90      CONTINUE
         DO 120 L = 1 , N1
            INDX = ((A(L,ICX)-XMIN)*XINT) + 1.0
            IF (INDX.GE.1 .AND. INDX.LE.NLX) THEN
               DO 100 J = 1 , NCY
                  K = ICY(J)
                  INDY = ((A(L,K)-YMIN)*YINT) + 1.0
                  IF (INDY.EQ.ILY) THEN
                     IF (IOUT(INDX).NE.ICHAR(10)) GO TO 110
                     IOUT(INDX) = ICHAR(J)
                  END IF
 100           CONTINUE
            END IF
            GO TO 120
 110        IOUT(INDX) = ICHAR(11)
 120     CONTINUE
         IF (MOD(I1,10).NE.0) THEN
            WRITE (IWRITE,6020) (IOUT(IX),IX=1,NLX)
         ELSE
            RLY = LY - I1/10
            YPR = YMIN + RLY*YSTEP
            WRITE (IWRITE,6010) YPR , (IOUT(IX),IX=1,NLX)
         END IF
 130  CONTINUE
      WRITE (IWRITE,6020) (ICHAR(2),I=1,NLX)
      WRITE (IWRITE,6030) (ICHAR(12),I=1,LX)
      WRITE (IWRITE,6040) XPR(1) , (ICHAR(12),XPR(I),I=3,LX,2)
      WRITE (IWRITE,6050) (XPR(I),I=2,LX,2)
      IND = 0
      RETURN
 140  KEY = 1
      KOUNT = 0
 150  R = FMAX - FMIN
      B = FMIN
 160  IF (R.GT.1.0) THEN
 170     IF (R.GT.10.0) THEN
            KOUNT = KOUNT - 1
            R = R/10.0
            GO TO 170
         ELSE IF (KEY.GT.2) THEN
            FSTEP = AINT(R)
            IF (FSTEP.NE.R) FSTEP = FSTEP + 1.0
            IF (R.LT.1.5) FSTEP = FSTEP - 0.5
            FSTEP = FSTEP/(10.0**KOUNT)
            IF (KEY.NE.4) THEN
               RATIO = (FMAX-FMIN)/(FM*FSTEP)
               IF (RATIO.LE.0.8) THEN
                  KOUNT = 1
                  KEY = 2
                  GO TO 150
               END IF
            END IF
         ELSE
            B = B*10.0**KOUNT
            IF (B.LT.0.0 .AND. B.NE.AINT(B)) B = B - 1.0
            B = AINT(B)/(10.0**KOUNT)
            R = (FMAX-B)/FM
            KOUNT = 0
            KEY = KEY + 2
            GO TO 160
         END IF
      ELSE
         KOUNT = KOUNT + 1
         R = R*10.0
         GO TO 160
      END IF
      FMIN = B
      C = FSTEP*AINT(B/FSTEP)
      IF (C.LT.0.0 .AND. C.NE.B) C = C - FSTEP
      IF ((C+FM*FSTEP).GE.FMAX) FMIN = C
      IF (INDEX.EQ.1) THEN
         XMIN = FMIN
         XSTEP = FSTEP
         IF (IND.NE.1) GO TO 40
         GO TO 30
      ELSE IF (INDEX.EQ.2) THEN
         YSTEP = FSTEP
         YMIN = FMIN
         GO TO 70
      END IF
 180  IND = 1
      RETURN
 190  IND = 2
      RETURN
 6010 FORMAT (' ',G13.6,'+',141A1)
 6020 FORMAT (' ',13X,'+',141A1)
 6030 FORMAT (' ',5X,15(9X,A1))
 6040 FORMAT (' ',G22.6,7(2X,A1,G17.6))
 6050 FORMAT (' ',12X,7(G20.6))
      END
**==ea06c.f  
      SUBROUTINE EA06C(A,VALUE,VECTOR,M,IA,IV,W)
C       18/03/70 LAST LIBRARY UPDATE
      REAL A(IA,M),VALUE(M),VECTOR(IV,M),W(*)
      M1 = M + 1
      W(1) = A(1,1)
      IF (M.LT.2) THEN
      ELSE IF (M.EQ.2) THEN
         W(2) = A(2,2)
         W(4) = A(2,1)
      ELSE
         CALL MC04B(A,W,W(M1),M,IA,W(M+M1))
      END IF
      CALL EA08C(W,W(M1),VALUE,VECTOR,M,IV,W(M+M1))
      IF (M.LE.2) RETURN
      DO 50 L = 1 , M
         DO 40 II = 3 , M
            I = M - II + 1
            IF (W(M1+I).NE.0.0) THEN
               PP = 0.
               I1 = I + 1
               DO 20 K = I1 , M
                  PP = PP + A(I,K)*VECTOR(K,L)
 20            CONTINUE
               PP = PP/(A(I,I+1)*W(M1+I))
               DO 30 K = I1 , M
                  VECTOR(K,L) = VECTOR(K,L) + PP*A(I,K)
 30            CONTINUE
            END IF
 40      CONTINUE
 50   CONTINUE
      RETURN
      END
**==mc04b.f  
      SUBROUTINE MC04B(A,ALPHA,BETA,M,IA,Q)
      DIMENSION A(IA,*),ALPHA(*),BETA(*),Q(*)
      ALPHA(1) = A(1,1)
      DO 30 J = 2 , M
         J1 = J - 1
         DO 20 I = 1 , J1
            A(I,J) = A(J,I)
 20      CONTINUE
         ALPHA(J) = A(J,J)
 30   CONTINUE
      M1 = M - 1
      M2 = M - 2
      DO 120 I = 1 , M2
         PP = 0.0
         I1 = I + 1
         DO 40 J = I1 , M
            PP = PP + A(I,J)**2
 40      CONTINUE
         PP1 = SQRT(PP)
         IF (A(I,I+1).LT.0) THEN
            BETA(I+1) = PP1
         ELSE
            BETA(I+1) = -PP1
         END IF
         IF (PP.GT.0) THEN
            H = PP - BETA(I+1)*A(I,I+1)
            A(I,I+1) = A(I,I+1) - BETA(I+1)
            DO 70 KI = I1 , M
               QJ = 0.0
               DO 50 KJ = I1 , KI
                  QJ = QJ + A(KJ,KI)*A(I,KJ)
 50            CONTINUE
               IF (KI.LT.M) THEN
                  I2 = KI + 1
                  DO 60 KJ = I2 , M
                     QJ = QJ + A(KI,KJ)*A(I,KJ)
 60               CONTINUE
               END IF
               Q(KI) = QJ/H
 70         CONTINUE
            BIGK = 0.0
            DO 80 KJ = I1 , M
               BIGK = BIGK + A(I,KJ)*Q(KJ)
 80         CONTINUE
            BIGK = BIGK/(2.0*H)
            DO 90 KJ = I1 , M
               Q(KJ) = Q(KJ) - BIGK*A(I,KJ)
 90         CONTINUE
            DO 110 KI = I1 , M
               DO 100 KJ = KI , M
                  A(KI,KJ) = A(KI,KJ) - Q(KI)*A(I,KJ) - Q(KJ)*A(I,KI)
 100           CONTINUE
 110        CONTINUE
         END IF
 120  CONTINUE
      DO 130 I = 2 , M
         H = ALPHA(I)
         ALPHA(I) = A(I,I)
         A(I,I) = H
 130  CONTINUE
      BETA(M) = A(M-1,M)
      RETURN
      END
**==ea08c.f  
      SUBROUTINE EA08C(A,B,VALUE,VEC,M,IV,W)
C       19/03/70 LAST LIBRARY UPDATE
      REAL A(M),B(M),VALUE(M),VEC(*),W(*)
      DATA EPS/  9.6E-7/,A34/0./
C     THIS USES QR ITERATION TO FIND THE EIGENVALUES AND EIGENVECTORS
C  OF THE SYMMETRIC TRIDIAGONAL MATRIX WHOSE DIAGONAL ELEMENTS ARE
C  A(I),I=1,M AND OFF-DIAGONAL ELEMENTS ARE B(I),I=2,M.  THE ARRAY
C  W IS USED FOR WORKSPACE AND MUST HAVE DIMENSION AT LEAST 2*M.
C  WE TREAT VEC AS IF IT HAD DIMENSIONS (IV,M).
      CALL EA09C(A,B,W(M+1),M,W)
C     SET VEC TO THE IDENTITY MATRIX.
      DO 30 I = 1 , M
         VALUE(I) = A(I)
         W(I) = B(I)
         K = (I-1)*IV + 1
         L = K + M - 1
         DO 20 J = K , L
            VEC(J) = 0.
 20      CONTINUE
         VEC(K+I-1) = 1.
 30   CONTINUE
      ITER = 0
      IF (M.EQ.1) RETURN
      N2 = M
C     EACH QR ITERATION IS PERFORMED OF ROWS AND COLUMNS N1 TO N2
 40   DO 50 II = 2 , N2
         N1 = 2 + N2 - II
         IF (ABS(W(N1)).LE.(ABS(VALUE(N1-1))+ABS(VALUE(N1)))*EPS)
     +       GO TO 60
 50   CONTINUE
      N1 = 1
 60   IF (N2.NE.N1) THEN
         ROOT = W(M+N2)
         ITER = ITER + 1
         N2M1 = N2 - 1
         A22 = VALUE(N1)
         A12 = A22 - ROOT
         A23 = W(N1+1)
         A13 = A23
         DO 80 I = N1 , N2M1
            A33 = VALUE(I+1)
            IF (I.NE.N2M1) A34 = W(I+2)
            S = SIGN(SQRT(A12*A12+A13*A13),A12)
            SI = A13/S
            CO = A12/S
            JK = I*IV + 1
            J1 = JK - IV
            J2 = J1 + MIN0(M,I+ITER) - 1
            DO 70 JI = J1 , J2
               V1 = VEC(JI)
               V2 = VEC(JK)
               VEC(JI) = V1*CO + V2*SI
               VEC(JK) = V2*CO - V1*SI
               JK = JK + 1
 70         CONTINUE
            IF (I.NE.N1) W(I) = S
            A11 = CO*A22 + SI*A23
            A12 = CO*A23 + SI*A33
            A13 = SI*A34
            A21 = CO*A23 - SI*A22
            A22 = CO*A33 - SI*A23
            A23 = CO*A34
            VALUE(I) = A11*CO + A12*SI
            A12 = -A11*SI + A12*CO
            W(I+1) = A12
            A22 = A22*CO - A21*SI
 80      CONTINUE
         VALUE(N2) = A22
         GO TO 40
      ELSE
         N2 = N2 - 1
         IF (N2.GT.1) GO TO 40
C     RAYLEIGH QUOTIENT
         DO 100 J = 1 , M
            K = (J-1)*IV
            XX = VEC(K+1)**2
            XAX = XX*A(1)
            DO 90 I = 2 , M
               XX = XX + VEC(K+I)**2
               XAX = XAX + VEC(K+I)*(2.*B(I)*VEC(K+I-1)+A(I)*VEC(K+I))
 90         CONTINUE
            VALUE(J) = XAX/XX
 100     CONTINUE
         RETURN
      END IF
      END
**==ea09c.f  
      SUBROUTINE EA09C(A,B,VALUE,M,OFF)
C       18/03/70 LAST LIBRARY UPDATE
      REAL A(M),B(M),VALUE(M),OFF(M)
      DATA A34/0./,EPS/9.6E-7/
      VALUE(1) = A(1)
      IF (M.EQ.1) RETURN
      DO 20 I = 2 , M
         VALUE(I) = A(I)
         OFF(I) = B(I)
 20   CONTINUE
C     EACH QR ITERATION IS PERFORMED OF ROWS AND COLUMNS N1 TO N2
      N2 = M
 30   IF (N2.LE.1) RETURN
      DO 40 II = 2 , N2
         N1 = 2 + N2 - II
         IF (ABS(OFF(N1)).LE.(ABS(VALUE(N1-1))+ABS(VALUE(N1)))*EPS)
     +       GO TO 50
 40   CONTINUE
      N1 = 1
 50   IF (N2.NE.N1) THEN
C     ROOT  IS THE EIGENVALUE OF THE BOTTOM 2*2 MATRIX THAT IS NEAREST
C     TO THE LAST MATRIX ELEMENT AND IS USED TO ACCELERATE THE
C     CONVERGENCE
         BB = (VALUE(N2)-VALUE(N2-1))*0.5
         CC = OFF(N2)*OFF(N2)
         SBB = 1.
         IF (BB.LT.0.) SBB = -1.
         ROOT = VALUE(N2) + CC/(BB+SBB*SQRT(BB*BB+CC))
         N2M1 = N2 - 1
         A22 = VALUE(N1)
         A12 = A22 - ROOT
         A23 = OFF(N1+1)
         A13 = A23
         DO 60 I = N1 , N2M1
            A33 = VALUE(I+1)
            IF (I.NE.N2M1) A34 = OFF(I+2)
            S = SQRT(A12*A12+A13*A13)
            SI = A13/S
            CO = A12/S
            IF (I.NE.N1) OFF(I) = S
            A11 = CO*A22 + SI*A23
            A12 = CO*A23 + SI*A33
            A13 = SI*A34
            A21 = CO*A23 - SI*A22
            A22 = CO*A33 - SI*A23
            A23 = CO*A34
            VALUE(I) = A11*CO + A12*SI
            A12 = -A11*SI + A12*CO
            OFF(I+1) = A12
            A22 = A22*CO - A21*SI
 60      CONTINUE
         VALUE(N2) = A22
      ELSE
         N2 = N2 - 1
      END IF
      GO TO 30
      END
**==getref.f  
C
C SUBROUTINE 'GETREF'
C ===================
C
C THIS SUBROUTINE GETS THE NEXT REFLECTION COMMON TO THE
C TWO LAUE DATA SETS  (BOTH SETS MUST BE SORTED BEFORE THIS
C ROUTINE MAY BE CALLED)
C
      SUBROUTINE GETREF(IA1,NREF1,NR1,IA2,NREF2,NR2,IN,S,IA,*)
C
C PARAMETERS
C
C         IA1 (I)   ARRAY HOLDING 1ST SET OF LAUE DATA
C       NREF1 (I)   THE NUMBER OF REFLECTIONS IN  IA1
C         NR1 (I/O) CURRENT POSITION POINTER FOR 1ST LAUE SET
C                   (SET TO 0 BEFORE 1ST CALL OR FOR A REWIND)
C         IA2 (I)   ARRAY HOLDING 2ND SET OF LAUE DATA
C       NREF2 (I)   THE NUMBER OF REFLECTIONS IN  IA2
C         NR2 (I/O) CURRENT POSITION POINTER FOR 2ND LAUE SET
C                   (SET TO 0 BEFORE 1ST CALL OR FOR A REWIND)
C          IN (O)   3 WORD ARRAY RETURNING INDICES
C           S (O)   RETURNS 4 SIN**2 THETA / LAMBDA**2
C          IA (O)   RETURNS I1 SIGI1 I2 SIGI2 IN 1ST 4 WORDS
C
C  RETURN 1  END OF DATA REACHED
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IA1(*),IA2(*),IN(3),IA(4)
      COMMON /GTRF/NREJL,NMATCH
      DATA NTWO16/65536/
C
C FIND MATCHING REFLECTIONS
C -------------------------
C
      IF (NR1.GT.0 .AND. NR2.GT.0) GO TO 30
      NREJL = 0
      NMATCH = 0
      NR1 = 1
      NR2 = 1
      IHKL1 = IA1(1)
      IHKL2 = IA2(1)
C
C COMPARE REFLECTIONS
C
 20   IF (IHKL1.LT.IHKL2) THEN
      ELSE IF (IHKL1.EQ.IHKL2) THEN
C
C MATCH FOUND, CHECK WAVELENGTH AND RETURN REFLN DETAILS IF OK
C
         L100 = IA1(4*NR1)/NTWO16
         LL100 = IA2(4*NR2)/NTWO16
         IF (ABS(L100-LL100).GT.10) THEN
            NREJL = NREJL + 1
            GO TO 30
         END IF
         I = 4*NR1 - 3
         CALL GETHKL(IA1(I),IN)
         S = IA1(I+1)/10000.0
         IA(1) = IA1(I+2)
         IA(2) = IA1(I+3) - NTWO16*L100
         I = 4*NR2 - 3
         IA(3) = IA2(I+2)
         IA(4) = IA2(I+3) - NTWO16*LL100
         NMATCH = NMATCH + 1
         RETURN
      ELSE
C
C NO MATCH LAUE1 > LAUE2 - GET NEXT LAUE2 REFLN
C
         NR2 = NR2 + 1
         IF (NR2.GT.NREF2) GO TO 40
         IHKL2 = IA2(4*NR2-3)
         GO TO 20
      END IF
C
C NO MATCH LAUE1 < LAUE2 - GET NEXT LAUE1 REFLN
 30   NR1 = NR1 + 1
      IF (NR1.LE.NREF1) THEN
         IHKL1 = IA1(4*NR1-3)
         GO TO 20
      END IF
C
C END OF REFLECTIONS REACHED
C
 40   RETURN 1
      END
**==scalop.f  
C
C SUBROUTINE 'SCALOP'
C ===================
C
C SCALE LAUE DATA TO MONOCHROMATIC DATA AND WRITE OUTPUT FILE
C
      SUBROUTINE SCALOP(IA3,NREF3)
C
C PARAMETERS
C
C         IA3 (I)   ARRAY HOLDING THE TWO SETS OF LAUE DATA WHICH
C                   HAVE BEEN SCALED TO EACH OTHER (SEE MAIN PROGRAM)
C       NREF3 (I)   THE NUMBER OF REFLECTIONS IN IA3
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL EOF
      DIMENSION IA3(*),IDATA(3),ADATA(100),BDATA(9)
      COMMON /COL/ICPHI,ICW
      DIMENSION IDXOLD(3),IDXL(3)
      DATA NTWO16/65536/
C
C INITIALISATIONS
C ---------------
C
      CALL LRREFF(1,RESOL,ADATA,EOF)
      IDATA(1) = NINT(ADATA(1))
      IDATA(2) = NINT(ADATA(2))
      IDATA(3) = NINT(ADATA(3))
 20   DO 30 I = 1 , 3
         IDXOLD(I) = 0
 30   CONTINUE
      DO 40 I = 1 , 9
         BDATA(I) = 0.0
 40   CONTINUE
      NR = 0
      NUSED = 0
      NROUT = 0
      ICOUNT = 0
C
C STEP THROUGH LAUE REFLECTIONS
C -----------------------------
C
 50   NR = NR + 1
      IF (NR.LE.NREF3) THEN
         IB = 4*(NR-1)
         CALL GETHKL(IA3(IB+1),IDXL)
         IF (ICMPR(IDXL,IDXOLD).EQ.0) THEN
            ICOUNT = ICOUNT + 1
            GO TO 50
         END IF
      END IF
C
C NEW REFLECTION FOUND - PROCESS THE DATA FROM THE PREVIOUS ONE
C -------------------------------------------------------------
C
      IF (ICOUNT.NE.0) THEN
 60      IF (ICMPR(IDXOLD,IDATA).LT.0) GO TO 100
         IF (ICMPR(IDXOLD,IDATA).EQ.0) THEN
C
C MATCH FOUND
C
            SUMWI1 = 0.0
            SUMW1 = 0.0
            SUMWI2 = 0.0
            SUMW2 = 0.0
            IF (ADATA(4).LE.0.0) GO TO 100
            FSQSTD = ADATA(4)*ADATA(4)
            DO 70 IC = 1 , ICOUNT
               NUSED = NUSED + 1
               IB = 4*(NR-ICOUNT+IC-2)
               FSQ1 = IA3(IB+2)
               SC = FSQSTD/FSQ1
               FSQ1 = FSQSTD
               FSQ2 = IA3(IB+3)*SC
               ISIG2 = IA3(IB+4)/NTWO16
               ISIG1 = IA3(IB+4) - NTWO16*ISIG2
               IF (ISIG1.EQ.0) ISIG1 = 1
               IF (ISIG2.EQ.0) ISIG2 = 1
               S1 = ISIG1*SC
               W1 = 1/(S1*S1)
               S2 = ISIG2*SC
               W2 = 1/(S2*S2)
               SUMWI1 = SUMWI1 + W1*FSQ1
               SUMW1 = SUMW1 + W1
               SUMWI2 = SUMWI2 + W2*FSQ2
               SUMW2 = SUMW2 + W2
 70         CONTINUE
            FSQ1 = SUMWI1/SUMW1
            FSQ2 = SUMWI2/SUMW2
            W1 = SUMW1/ICOUNT
            W2 = SUMW2/ICOUNT
            S1 = SQRT(1/W1)
            S2 = SQRT(1/W2)
            F1 = SQRT(FSQ1)
            S1 = S1/(2*F1)
            F2 = SQRT(FSQ2)
            S2 = S2/(2*F2)
            DO 80 I = 1 , 3
               BDATA(I) = ADATA(I)
 80         CONTINUE
            BDATA(4) = F1
            BDATA(5) = S1
            BDATA(6) = F2
            BDATA(7) = S2
            IF (ICPHI.GT.0) BDATA(ICPHI) = ADATA(6)
            IF (ICW.GT.0) BDATA(ICW) = ADATA(7)
         ELSE
            CALL LRREFF(1,RESOL,ADATA,EOF)
            IF (EOF) GO TO 110
            IDATA(1) = NINT(ADATA(1))
            IDATA(2) = NINT(ADATA(2))
            IDATA(3) = NINT(ADATA(3))
            GO TO 60
         END IF
      END IF
      IF (ICOUNT.GT.0) THEN
         CALL LWREFL(2,BDATA)
         NROUT = NROUT + 1
      END IF
 100  ICOUNT = 1
      IF (NR.LE.NREF3) THEN
         IDXOLD(1) = IDXL(1)
         IDXOLD(2) = IDXL(2)
         IDXOLD(3) = IDXL(3)
         GO TO 50
      END IF
C
C END OF DATA REACHED
C -------------------
C
 110  CALL LWCLOS(2,1)
      WRITE (6,6010) NUSED
      WRITE (6,6020) NROUT
      RETURN
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (///,' NUMBER OF LAUE MEASUREMENTS MATCHED AND SCALED =',
     +        I6)
 6020 FORMAT (//,' NUMBER OF MERGED REFLECTIONS MATCHED AND SCALED TO',
     +        ' REFERENCE SET AND OUTPUT =',I6)
      END
**==gethkl.f  
C
C SUBROUTINE 'GETHKL'
C ===================
C
C THIS SUBROUTINE UNPACKS THE INDICES FOR A LAUE REFLECTION
C
      SUBROUTINE GETHKL(IDX,IDXL)
C
C PARAMETERS
C
C      IDX (I)   WORD CONTAINING PACKED INDICES
C     IDXL (O)   3 WORD ARRAY CONTAINING H, K, L.
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IDXL(3)
      DATA NTWO16/65536/,NTWO8/256/
C
C UNPACK INDICES
C --------------
C
      I = IDX
      IDXL(1) = I/NTWO16
      I = I - NTWO16*IDXL(1)
      IDXL(1) = IDXL(1) - 128
      IDXL(2) = I/NTWO8
      IDXL(3) = I - NTWO8*IDXL(2) - 128
      IDXL(2) = IDXL(2) - 128
      RETURN
      END
**==icmpr.f  
C
C FUNCTION 'ICMPR'
C ================
C
C THIS FUNCTION COMPARES THE INDICES OF A LAUE REFLECTION WITH THE
C INDICES OF A STANDARD REFLECTION
C
      FUNCTION ICMPR(IHKL1,IHKL2)
C
C PARAMETERS
C
C       IHKL1 (I)   3 WORD ARRAY HOLDING LAUE REFLN INDICES
C       IHKL2 (I)   3 WORD ARRAY HOLDING STANDARD REFLN INDICES
C
C RETURNS  -1  LAUE < STANDARD
C           0  LAUE = STANDARD
C           1  LAUE > STANDARD
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IHKL1(3),IHKL2(3)
C
C COMPARE INDICES
C ---------------
C
      ICMPR = 0
      DO 20 I = 1 , 3
         IF (IHKL1(I).LT.IHKL2(I)) GO TO 30
         IF (IHKL1(I).NE.IHKL2(I)) GO TO 40
 20   CONTINUE
      RETURN
C
C LAUE < STANDARD
C
 30   ICMPR = -1
      RETURN
C
C LAUE > STANDARD
C
 40   ICMPR = 1
      RETURN
      END
**==ffread.f  
C
C
C SUBROUTINE 'FFREAD'  ENTRIES: 'IVALUE' 'FVALUE' 'TEXLIM'
C ========================================================
C
C THIS SUBROUTINE ENABLES FREE FORMAT INPUT OF DATA. IT IS CALLED
C ONCE TO READ IN THE TEXT BUFFER  AND CALLED VIA AN ENTRY POINT
C FOR EACH INTEGER, FLOATING POINT OR TEXT FIELD IN TURN.
C
      SUBROUTINE FFREAD(IUN,LTEXT,LMAX,LLP,LSTOP)
C
C PARAMETERS
C
C       IUN (I)   UNIT NUMBER FOR READ (MAY BE SET TO ZERO IF THE TEXT
C                 TO BE INTERPRETED IS ALREADY IN THE ARRAY 'ITEXT')
C     LTEXT (I/O) CHARACTER ARRAY FOR TEXT BUFFER
C      LMAX (I)   THE MAXIMUM NO. OF CHARS IN 'ITEXT' (UP TO 150)
C       LLP (I)   UNIT NUMBER FOR ERROR MESSAGES (0 IF NONE REQUIRED)
C     LSTOP (I)   LOGICAL FLAG =TRUE, STOP IF ERROR, =FALSE CONTINUE.
C
C ENTRY IVALUE(IVAL)       RETURN INTEGER VALUE 'IVAL' FROM NEXT FIELD
C -----------------
C
C ENTRY FVALUE(FVAL)       RETURN F.P. VALUE 'FVAL' FROM NEXT FIELD
C -----------------
C
C ENTRY TEXLIM(MIN,MAX)    RETURN NOS. OF FIRST AND FINAL CHARACTERS IN
C ---------------------    FIELD IN 'MIN' AND 'MAX'
C
C NOTE: ENTRY PARAMETER VALUES ARE RETURNED AS ZERO FOR BLANK FIELDS
C       OR IF CONTINUING AFTER A SYNTAX ERROR.
C
C
C SPECIFICATION STATEMENTS
C
      CHARACTER*1 ITEXT
      CHARACTER*1 ISP,IPLUS,IMINUS,IDEC,ICOMMA
      CHARACTER*1 LTEXT(*),INUM(10)
      LOGICAL LSTOP,ISTOP,ERR
      COMMON /FFRDXX/ITEXT(150)
      COMMON /FFRDYY/NMAX,ILP,ISTOP,IFLD,M
      SAVE /FFRDXX/,/FFRDYY/
      DATA ISP/' '/,IPLUS/'+'/,IMINUS/'-'/,IDEC/'.'/,ICOMMA/','/
      DATA INUM/'0','1','2','3','4','5','6','7','8','9'/
C
C SAVE VARIABLES FOR ENTRY POINTS
C
      NMAX = LMAX
      IF (LMAX.GT.150) THEN
         IF (ILP.GT.0) WRITE (ILP,6030)
         STOP 810
      ELSE
         ILP = LLP
         ISTOP = LSTOP
C
C INITIAL ENTRY
C
         M = 0
         IFLD = 0
         IF (IUN.GT.0) READ (IUN,6010) (LTEXT(N),N=1,NMAX)
         DO 20 I = 1 , LMAX
            ITEXT(I) = LTEXT(I)
 20      CONTINUE
         RETURN
      END IF
C
C ENTRIES FOR INTEGER AND FLOATING POINT VALUES
C
      ENTRY IVALUE(IVAL)
C     ==================
C
      ITYP = 0
      IVAL = 0
      GO TO 30
      ENTRY FVALUE(FVAL)
C     ==================
C
      ITYP = 1
      FVAL = 0.0
 30   S = 1.0
      X = 0.0
      ERR = .FALSE.
      IFDEC = 0
      ID = 0
      IFLD = IFLD + 1
 40   M = M + 1
      IF (M.GT.NMAX) GO TO 100
      IF (ITEXT(M).EQ.ISP) GO TO 40
      IF (ITEXT(M).EQ.ICOMMA) GO TO 40
      IF (ITEXT(M).NE.IPLUS) THEN
         IF (ITEXT(M).NE.IMINUS) GO TO 60
         S = -1.0
      END IF
 50   M = M + 1
      IF (M.GT.NMAX) GO TO 90
      IF (ITEXT(M).EQ.ISP) GO TO 90
      IF (ITEXT(M).EQ.ICOMMA) GO TO 90
 60   IF (ITEXT(M).NE.IDEC) THEN
         DO 70 I = 1 , 10
            N = I - 1
            IF (ITEXT(M).EQ.INUM(I)) GO TO 80
 70      CONTINUE
         ERR = .TRUE.
      ELSE
         IF (IFDEC.EQ.1) ERR = .TRUE.
         IFDEC = 1
      END IF
      GO TO 50
 80   ID = ID + IFDEC
      X = 10.0*X + N
      GO TO 50
 90   X = S*X/(10.0**ID)
      IF (ERR) GO TO 130
 100  IF (ITYP.NE.0) THEN
         FVAL = X
         RETURN
      ELSE
         IF (IFDEC.NE.0) GO TO 130
         IVAL = X + 0.1*S
         RETURN
      END IF
C
C TEXT STRINGS ENTRY
C
      ENTRY TEXLIM(MIN,MAX)
C     =====================
C
      MIN = 0
      MAX = 0
      IFLD = IFLD + 1
 110  M = M + 1
      IF (M.GT.NMAX) RETURN
      IF (ITEXT(M).EQ.ISP) GO TO 110
      MIN = M
 120  MAX = M
      M = M + 1
      IF (M.GT.NMAX) RETURN
      IF (ITEXT(M).NE.ISP) GO TO 120
      RETURN
C
C ERROR FOUND
C
 130  IF (ILP.GT.0) WRITE (ILP,6020) IFLD , (ITEXT(I),I=1,NMAX)
      IF (ISTOP) STOP
      RETURN
C
C FORMAT STATEMENTS
C
 6010 FORMAT (255A1)
 6020 FORMAT (' **SYNTAX ERROR IN FIELD',I3,' **'/(1X,130A1/))
 6030 FORMAT (' **MAXIMUM LENGTH OF TEXT ALLOWED IN FFREAD IS 150',
     +        ' CHARACTERS**')
      END
