
CD-Section: Create .ge1/.ge2 files
C These routines are for creating .ge1/.ge2 files from a Laue Integrated
C Reflection List (LIRL) containing integrated intensities.
CD-end

C LAST UPDATE: 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*************************
C**     LFN_LIRLGE      **
C*************************
C
CD-Routine: Create .ge1/.ge2 Files from LIRL - LFN_LIRLGE
C This routine is used to create a pair of  .ge1/.ge2 files from a Laue 
C Integrated Reflection List (LIRL) containing integrated intensities.
C The output files must be opened prior to calling the routine and
C will be closed by the routine.
CD-end
CD-Fortran:
      SUBROUTINE LFN_LIRLGE (MINDX, IUN_GE1, IUN_GE2, KPACK, SCAL,
     +                     LAMBDA_BINS, NUM_SPOTS, NUM_MULTIPLETS,
     +                     NUM_SPATIALS, NUM_BOTH, NUM_NODALS,
     +                     RESCALE, SCALOUT, KERR)
CD-end
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Write .ge1/.ge2 files from a Laue Integrated Reflections List
C          (LIRL) 
C
C          NOTES: This routine does the required sorting of the LIRL
C
C                 Coordinates in LIRL must be in mm wrt the centre and
C                 NOT distortion corrected.    
C                 
C
C Author:  John W. Campbell, November 1995
C
C Note:    Output .ge1/.ge2 files must be opened before calling this
C          routine. They will be closed within this routine.
C
C Arguments:
C
      INTEGER MINDX
      INTEGER IUN_GE1
      INTEGER IUN_GE2
      INTEGER KPACK
      REAL SCAL
      INTEGER LAMBDA_BINS(16)
      INTEGER NUM_SPOTS
      INTEGER NUM_MULTIPLETS
      INTEGER NUM_SPATIALS
      INTEGER NUM_NODALS
      INTEGER NUM_BOTH
      LOGICAL RESCALE
      REAL SCALOUT
      INTEGER KERR
C
CD-Parameters:
C MINDX          i (R)   Index for LIRL
C IUN_GE1        i (R)   Unit no. for .ge1 file (already opened)
C IUN_GE2        i (R)   Unit no. for .ge2 file (already opened)
C KPACK          i (R)   Pack number
C SCAL           r (R)   Scale factor to apply to intensities 
C LAMBDA_BINS    i (R)   Lambda bins histogram
C NUM_SPOTS      i (W)   No. of spots written
C NUM_MULTIPLETS i (W)   No. of multiplets
C NUM_SPATIALS   i (W)   No. of spatials
C NUM_NODALS     i (W)   No. nodals
C NUM_BOTH       i (W)   No. both spatial & multiple
C RESCALE        l (W)   O/p scale factor recalculated flag
C SCALOUT        r (W)   O/p scale factor actually used
C KERR           i (W)   Error flag = 0 OK
C                                   = 1 error in sorting - unable to 
C                                       allocate memory(file not written)
CD-end
C
C====== Parameter statements
C

C
C====== Function types
C
      REAL STHLSQ 
      INTEGER LRL_HCF
C
C====== LOCALS:
C
      LOGICAL SPAT 
      LOGICAL CLOS
      LOGICAL NODFLG
      LOGICAL STORED
      LOGICAL EOL
      INTEGER I
      INTEGER II
      INTEGER JJ
      INTEGER KK
      INTEGER LASTH 
      INTEGER LASTK
      INTEGER LASTL
      INTEGER IERR
      INTEGER IFLAG
      INTEGER ND
      INTEGER NIDX
      INTEGER PACK_ID
      INTEGER IPACK
      INTEGER IPLATE
      INTEGER KSYM
      INTEGER KEYPLATE
      INTEGER MULT
      INTEGER MINHARM
      INTEGER MAXHARM
      INTEGER INCHARM
      INTEGER ISPAT
      INTEGER ICLOS
      INTEGER IMEAS
      INTEGER IOVLD
      INTEGER IBAD
      INTEGER ICODE
      INTEGER ISPOT
      INTEGER NUMSPOTS
      INTEGER IBEAM
      INTEGER IROT
      INTEGER DISTOR_TYPE
      INTEGER LINK_REC
      INTEGER BINTENS(6)
      INTEGER BSIGS(6)
      INTEGER PINTENS(6)
      INTEGER PSIGS(6)
      INTEGER M_FLAG
      INTEGER H
      INTEGER K
      INTEGER L
      INTEGER NODIDX
      INTEGER H2
      INTEGER K2
      INTEGER L2
      INTEGER IREAL
      INTEGER IH
      INTEGER IK
      INTEGER IL
      INTEGER GE1_REC
      INTEGER GE2_REC
      INTEGER MULTIPLICITY
      INTEGER MULTI_BINS(21)
      INTEGER BUFFER(19)
      INTEGER BUFFER2(2)
      INTEGER MHKL(4)
      INTEGER HKL2(4)
      INTEGER NODAL_BINS(12)
      INTEGER BOX(5)
      INTEGER ISYLAT(2)
      INTEGER ISL
      INTEGER NSING
      INTEGER ISYST
      INTEGER LATT
      INTEGER H_N
      INTEGER K_N
      INTEGER L_N
      INTEGER HCF1
      INTEGER HCF2
      INTEGER MININT
      INTEGER NODMAX
      REAL ALNOD
      REAL CTOF_RATS(6)
      REAL CTOF
      REAL PHIS(3)
      REAL SPINDLE
      REAL CTOF_KEYPLATE
      REAL DELTA
      REAL EPSILON
      REAL X_C(6)
      REAL Y_C(6)
      REAL W_C(6)
      REAL Y_SCALE(6)
      REAL TWIST(6)
      REAL TILT(6)
      REAL BULGE(6)
      REAL WMIN
      REAL WMAX
      REAL DMIN
      REAL FILMR
      REAL RINT
      REAL BX
      REAL BY
      REAL BDMIN2
      REAL LAMBDA1
      REAL LAMBDA2
      REAL LAMGE2
      REAL X_CEN_FS(6)
      REAL Y_CEN_FS(6)
      REAL W_FS(6)
      REAL RCELL(6)
      REAL CELLC(6)
      REAL CELL(6)
      REAL MM_RAST_X
      REAL MM_RAST_Y
      REAL AI_MAX
      REAL XFD
      REAL YFD
      REAL ALAM
      REAL AI
      REAL SIGI
      REAL FP
      CHARACTER*80 COMPOUND
      CHARACTER*6 CRYST
      CHARACTER*2 VALSTR
      CHARACTER*2 ERRSTR

C     LOGICAL SPAT                !Spatially overlapped flag
C     LOGICAL CLOS                !Too close to integrate flag
C     LOGICAL NODFLG              !Non-overlapped nodal flag
C     LOGICAL STORED              !Data stored for a previous spot flag
C     LOGICAL EOL                 !End of reflection list flag
C     INTEGER I                   !Temp/loop variable
C     INTEGER II                  !Temp/loop variable
C     INTEGER JJ                  !Temp/loop variable
C     INTEGER KK                  !Temp/loop variable
C     INTEGER LASTH               !'h' index of last spot
C     INTEGER LASTK               !'k' index of last spot
C     INTEGER LASTL               !'l' index of last spot
C     INTEGER IERR                !Error flag
C     INTEGER IFLAG               !Parameter status flag
C     INTEGER ND                  !No. of decimal places flag
C     INTEGER NIDX                !Nodal index
C     INTEGER PACK_ID             !Pack id.
C     INTEGER IPACK               !Pack number
C     INTEGER IPLATE              !Plate number
C     INTEGER KSYM                !Symmetry number/flag
C     INTEGER KEYPLATE            !Key plate
C     INTEGER MULT                !Multiplicity
C     INTEGER MINHARM             !Minimum harmonic
C     INTEGER MAXHARM             !Maximum harmonic
C     INTEGER INCHARM             !Harmonic increment
C     INTEGER ISPAT               !Spatial overlap flag
C     INTEGER ICLOS               !Spots too close to integrate flag
C     INTEGER IMEAS               !Intensity measured flag
C     INTEGER IOVLD               !Overload flag
C     INTEGER IBAD                !Bad spot flag
C     INTEGER ICODE               !Integration routine specific  code
C     INTEGER ISPOT               !Spot number
C     INTEGER NUMSPOTS            !Number of spots
C     INTEGER IBEAM               !Axis along beam flag
C     INTEGER IROT                !Rotation axis flag
C     INTEGER DISTOR_TYPE         !Distortion type flag
C     INTEGER LINK_REC            !Link record to .ge2 file
C     INTEGER BINTENS(6)          !Box integrated intensities
C     INTEGER BSIGS(6)            !Sigmas of box integrated intensities
C     INTEGER PINTENS(6)          !Profile fitted intensities
C     INTEGER PSIGS(6)            !Sigmas of profile fitted intensities
C     INTEGER M_FLAG              !Multiplicity etc. flag
C     INTEGER H                   !'h' index
C     INTEGER K                   !'k' index
C     INTEGER L                   !'l' index
C     INTEGER NODIDX              !Nodal index
C     INTEGER H2                  !'h' index for 2'nd entry
C     INTEGER K2                  !'k' index for 2'nd entry
C     INTEGER L2                  !'l' index for 2'nd entry
C     INTEGER IREAL               !Integer/real equivalence (to RINT)
C     INTEGER IH                  !'h' index
C     INTEGER IK                  !'k' index
C     INTEGER IL                  !'l' index
C     INTEGER GE1_REC             !Current record number in .ge1 file
C     INTEGER GE2_REC             !Current record number in .ge2 file
C     INTEGER MULTIPLICITY        !Multiplicity
C     INTEGER MULTI_BINS(21)      !Counts for multiplicity bins
C     INTEGER BUFFER(19)          !Buffer for .ge1 file record
C     INTEGER BUFFER2(2)          !Buffer for .ge2 file record
C     INTEGER MHKL(4)             !Array for packing indices & M_FLAG
C     INTEGER HKL2(4)             !Array for packing inices & nodal index
C     INTEGER NODAL_BINS(12)      !Bins for nodal counts
C     INTEGER BOX(5)              !Integration box parameters (default values)
C     INTEGER ISYLAT(2)           !Crystal system and lattice type
C     INTEGER ISL                 !Packed values from ISYLAT
C     INTEGER NSING               !No. of single spots
C     INTEGER ISYST               !Crystal system 1-7
C     INTEGER LATT                !Lattice type 1-7
C     INTEGER H_N                 !Nodal 'h' index
C     INTEGER K_N                 !Nodal 'k' index
C     INTEGER L_N                 !Nodal 'l' index
C     INTEGER HCF1                !Highest common factor 1
C     INTEGER HCF2                !Highest common factor 2
C     INTEGER MININT              !Minimum intensity for subsequent plates
C     INTEGER NODMAX              !Maximum nodal index recognised
C     REAL ALNOD                  !Nodal lambda value
C     REAL CTOF_RATS(6)           !Crystal to detector distance ratios
C     REAL CTOF                   !Crystal to detector distance
C     REAL PHIS(3)                !Missetting angles
C     REAL SPINDLE                !Spindle angle
C     REAL CTOF_KEYPLATE          !Crystal to detector distance for key plate
C     REAL DELTA                  !Spot overlap distance criterion
C     REAL EPSILON                !Spot too close to integrate distance
C     REAL X_C(6)                 !x_c values
C     REAL Y_C(6)                 !y_c values
C     REAL W_C(6)                 !w_c values
C     REAL Y_SCALE(6)             !y_scale values
C     REAL TWIST(6)               !Distortion twist values
C     REAL TILT(6)                !Distortion tilt values
C     REAL BULGE(6)               !Distortion bulge values
C     REAL WMIN                   !Lambda-min
C     REAL WMAX                   !Lambda-max
C     REAL DMIN                   !'dmin'
C     REAL FILMR                  !Film radius (RMAX)
C     REAL RINT                   !Real equivalenced to integer (IREAL)
C     REAL BX                     !Spot 'x' coordinate
C     REAL BY                     !Spot 'y' coordinate
C     REAL BDMIN2                 !Dmin-threshold**2
C     REAL LAMBDA1                !Wavelength for lowest harmonic
C     REAL LAMBDA2                !Wavelength for 2'nd lowest harmonic
C     REAL LAMGE2                 !Wavelength for .ge2 file entry
C     REAL X_CEN_FS(6)            !x_cen_f values
C     REAL Y_CEN_FS(6)            !y_cen_f values
C     REAL W_FS(6)                !Omega_f values set to 0.0)
C     REAL RCELL(6)               !Reciprocal cell parameters
C     REAL CELLC(6)               !Unique cell parameters
C     REAL CELL(6)                !Real cell parameters
C     REAL MM_RAST_X              !Conversion factor mm to x-rasters
C     REAL MM_RAST_Y              !Conversion factor mm to y-rasters
C     REAL AI_MAX                 !Maximum integated intensity ('good' spots)
C     REAL XFD                    !Spot 'x' coordinate (mm from centre)
C     REAL YFD                    !Spot 'y' coordinate (mm from centre)
C     REAL ALAM                   !Wavelength for spot (lowest harmonic)
C     REAL AI                     !Integrated intensity
C     REAL SIGI                   !sigma(AI)
C     REAL FP                     !Dummy real value
C     CHARACTER*80 COMPOUND       !Compound string
C     CHARACTER*6 CRYST           !Crystal string
C     CHARACTER*2 VALSTR          !Dummy parameter value string
C     CHARACTER*2 ERRSTR          !Dummy error string

      EQUIVALENCE (IREAL, RINT)
      EQUIVALENCE (BUFFER(1),BX)
      EQUIVALENCE (BUFFER(2),BY)
      EQUIVALENCE (BUFFER(16),LAMBDA1)
      EQUIVALENCE (BUFFER(18),LAMBDA2)
      EQUIVALENCE (BUFFER(19),BDMIN2)

      EQUIVALENCE (MHKL(1),M_FLAG)
      EQUIVALENCE (MHKL(2),H)
      EQUIVALENCE (MHKL(3),K)
      EQUIVALENCE (MHKL(4),L)

      EQUIVALENCE (HKL2(1),NODIDX)
      EQUIVALENCE (HKL2(2),H2)
      EQUIVALENCE (HKL2(3),K2)
      EQUIVALENCE (HKL2(4),L2)

      EQUIVALENCE (BUFFER2(2), LAMGE2)

      DATA  BINTENS/6*-9999/
      DATA  BSIGS /6*-9999/
      DATA  PINTENS/6*-9999/
      DATA  PSIGS /6*-9999/
C
C------------------------------------------------------------------------------
C
      KERR = 0
      RESCALE = .FALSE.
      CALL LRL_NODMAX (NODMAX)
      MININT = 100
      CALL LDM_GET_PID (KPACK, PACK_ID, IFLAG, IERR, ERRSTR)
      CALL LDM_GET_KEYP (KPACK, KEYPLATE, IFLAG, IERR, ERRSTR)
C
C====== Get cell for resolution calculations & for later use
C
      CALL LDM_GET_A (CELL(1), IFLAG, ND)
      CALL LDM_GET_B (CELL(2), IFLAG, ND)
      CALL LDM_GET_C (CELL(3), IFLAG, ND)
      CALL LDM_GET_ALPHA (CELL(4),IFLAG, ND)
      CALL LDM_GET_BETA (CELL(5), IFLAG, ND)
      CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND)
      CALL SETRSL (CELL(1), CELL(2), CELL(3), CELL(4), CELL(5), CELL(6))
C
C====== Put initialised intensity/sigma values in reflection record buffer
C       for box intensities.
C
      CALL CCPII2(BUFFER(3),BINTENS,6,.TRUE.,.FALSE.)
      CALL CCPII2(BUFFER(6),BSIGS,6,.TRUE.,.FALSE.)
C
C====== Zero histograms
C
      NUM_SPOTS = 0
      NUM_SPATIALS = 0
      NUM_MULTIPLETS = 0
      NUM_BOTH = 0
      NUM_NODALS = 0
      DO 20 I = 1 , 21
         MULTI_BINS(I) = 0
 20   CONTINUE
      NSING = 0
      DO 30 I = 1 , 12
         NODAL_BINS(I) = 0
 30   CONTINUE
C
C====== Now write .ge1/.ge2 files 
C
      GE1_REC = 10
      GE2_REC = 0
C
C====== Get no. of spots in LIRL
C
      CALL LIRLF_NUMREFS (MINDX, NUMSPOTS)
      IF (NUMSPOTS.EQ.0) GO TO 90
C
C====== Sort spot data on Plate no., then index to bring together all
C       plates data for a given reflection
C
      CALL LIRLF_SORT (MINDX, 4, IERR)
      IF (IERR.NE.0) THEN
         KERR = 1
         CLOSE (UNIT=IUN_GE1)
         CLOSE (UNIT=IUN_GE2)
         RETURN
      END IF
      CALL LIRLF_SORT (MINDX, 1, IERR)
      IF (IERR.NE.0) THEN
         KERR = 1
         CLOSE (UNIT=IUN_GE1)
         CLOSE (UNIT=IUN_GE2)
         RETURN
      END IF
C
C====== Check o/p scale factor & reset if needed
C
      SCALOUT = SCAL
      AI_MAX = 0.0
      DO 35 ISPOT = 1, NUMSPOTS
         CALL LIRLF_GETREF (MINDX, ISPOT, IH, IK, IL, IPACK, IPLATE,
     +              KSYM, XFD, YFD, ALAM, 
     +              MULT, MINHARM, MAXHARM, INCHARM,
     +              AI, SIGI, ISPAT, ICLOS, IMEAS, IBAD, IOVLD,
     +              ICODE, IERR)
         IF (IPACK.NE.KPACK) GO TO 35
         IF (IMEAS.EQ.0) GO TO 35
         IF (IOVLD.EQ.1) GO TO 35
         IF (IBAD.EQ.1) GO TO 35
         IF (AI.GT.AI_MAX) AI_MAX = AI
 35   CONTINUE
      IF (AI_MAX*SCALOUT.GT.32767.0) THEN
         SCALOUT = 32767.0/AI_MAX
         RESCALE = .TRUE.
      END IF

C
C====== Step through reflection data
C
      LASTH = -999999
      LASTK = -999999
      LASTL = -999999
      ISPOT = 0
      STORED = .FALSE.
      EOL = .FALSE.
 40   ISPOT = ISPOT + 1
      IF (ISPOT.GT.NUMSPOTS) THEN
         EOL = .TRUE.         
      ELSE
         CALL LIRLF_GETREF (MINDX, ISPOT, IH, IK, IL, IPACK, IPLATE,
     +              KSYM, XFD, YFD, ALAM, 
     +              MULT, MINHARM, MAXHARM, INCHARM,
     +              AI, SIGI, ISPAT, ICLOS, IMEAS, IBAD, IOVLD,
     +              ICODE, IERR)
         IF (IPACK.NE.KPACK) GO TO 40
         IF (IH.EQ.LASTH.AND.IK.EQ.LASTK.AND.IL.EQ.LASTL) THEN
            IF (IPLATE.LE.6) THEN
               IF (IMEAS.EQ.0) GO TO 40
               IF (IOVLD.EQ.1) THEN
                  PINTENS (IPLATE) = 9999
                  GO TO 40
               END IF
               IF (IBAD.EQ.1) THEN
                   PINTENS (IPLATE) = NINT (SCALOUT*AI)
                   IF (PINTENS(IPLATE).EQ.9999) PINTENS(IPLATE) = 9998
                   GO TO 40
               END IF
               PINTENS (IPLATE) = NINT (SCALOUT*AI)
               PSIGS (IPLATE) = NINT (SCALOUT*SIGI)
            END IF
            GO TO 40
         END IF
      END IF
      IF (STORED) THEN
         CALL CCPII2(BUFFER(9),PINTENS,6,.TRUE.,.FALSE.)
         CALL CCPII2(BUFFER(12),PSIGS,6,.TRUE.,.FALSE.)
         GE1_REC = GE1_REC + 1
         WRITE (IUN_GE1,REC=GE1_REC) BUFFER
      END IF
      IF (.NOT.EOL) THEN
         LASTH = IH
         LASTK = IK
         LASTL = IL
         NODFLG = .FALSE.
         CALL LRL_NODIDX (IH, IK, IL, NIDX)
         IF (NIDX.LE.NODMAX.AND.ISPAT.EQ.0) NODFLG = .TRUE.
         DO 50 I = 1, 6
            PINTENS(I) = -9999
            PSIGS(I) = -9999
 50      CONTINUE
         H = IH
         K = IK
         L = IL
         M_FLAG = 0
         CALL STBITS (M_FLAG,0,5,MULT)
         IF (ISPAT.EQ.1.OR.ICLOS.EQ.1) CALL STBITS (M_FLAG,6,1,1)
         IF (ICLOS.EQ.1) CALL STBITS (M_FLAG,7,1,1)
         IF (NODFLG) CALL STBITS (M_FLAG,5,1,1)
         BX = XFD
         BY = YFD
         LAMBDA1 = ALAM
         BDMIN2 = 4.0*STHLSQ (IH, IK, IL)
         H2 = 0
         K2 = 0
         L2 = 0
         STORED = .FALSE.
         IF (IPLATE.EQ.1) THEN
            STORED = .TRUE.
            IF (IMEAS.EQ.1.AND.IOVLD.EQ.0.AND.IBAD.EQ.0) THEN
               PINTENS(1) = NINT (SCALOUT*AI)
               PSIGS(1) = NINT (SCALOUT*SIGI)
            END IF
            IF (MULT.EQ.1) THEN
               IF (NODFLG) THEN
                  NUM_NODALS = NUM_NODALS + 1
                  IH = H
                  IK = K
                  IL = L
                  CALL LRL_NODIDX (IH, IK, IL, NODIDX)
                  NODAL_BINS(NODIDX) = NODAL_BINS(NODIDX) + 1
               ELSE
                  NODIDX = 0
               END IF
               LAMBDA2 = 0.0
               CALL CCPIBY(BUFFER(15),MHKL,-4)
               CALL CCPIBY(BUFFER(17),HKL2,-4)
               MULTI_BINS(1) = MULTI_BINS(1) + 1
               NSING = NSING + 1
               IF (ISPAT.EQ.1) NUM_SPATIALS = NUM_SPATIALS + 1
            ELSE
C
C====== Multiple
C
               HCF1 = LRL_HCF(IH,IK)
               HCF2 = LRL_HCF(HCF1,IL)
               H_N = ISIGN(IH/HCF2,IH)
               K_N = ISIGN(IK/HCF2,IK)
               L_N = ISIGN(IL/HCF2,IL)
               H2 = (MINHARM+INCHARM)*H_N
               K2 = (MINHARM+INCHARM)*K_N
               L2 = (MINHARM+INCHARM)*L_N
               ALNOD = LAMBDA1*MINHARM
               LAMBDA2 = ALNOD/(MINHARM+INCHARM)
C
C====== Update histogram
C
               I = MIN(MULT,21)
               MULTI_BINS(I) = MULTI_BINS(I) + 1
               NUM_MULTIPLETS = NUM_MULTIPLETS + 1
               IF (NODFLG) THEN
                  NUM_NODALS = NUM_NODALS + 1
                  IH = H
                  IK = K
                  IL = L
                  CALL LRL_NODIDX (IH, IK, IL, NODIDX)
                  NODAL_BINS(NODIDX) = NODAL_BINS(NODIDX) + 1
               ELSE
                  NODIDX = 0
               END IF
               IF (ISPAT.EQ.1) THEN
                  NUM_SPATIALS = NUM_SPATIALS + 1
                  IF (MULTIPLICITY.GT.1) NUM_BOTH = NUM_BOTH + 1
               END IF
               CALL CCPIBY(BUFFER(15),MHKL,-4)
               CALL CCPIBY(BUFFER(17),HKL2,-4)
               IF (MULT.GT.2) THEN
                  LINK_REC = GE2_REC + 1
                  IREAL = LINK_REC
                  LAMBDA2 = RINT
C
C====== Write out consecutive records to .ge2 file
C
                  DO 80 I = 2 , MULT
                     H = (MINHARM+(I-1)*INCHARM)*H_N
                     K = (MINHARM+(I-1)*INCHARM)*K_N
                     L = (MINHARM+(I-1)*INCHARM)*L_N
                     GE2_REC = GE2_REC + 1
                     CALL CCPIBY(BUFFER2(1),MHKL,-4)
                     LAMGE2 = ALNOD/(MINHARM+(I-1)*INCHARM)
                     WRITE (IUN_GE2,REC=GE2_REC) BUFFER2
 80               CONTINUE
               END IF
            END IF
         END IF
         GO TO 40
      END IF
C
C====== Finally write out header info, number of spots output
C
 90   NUM_SPOTS = GE1_REC - 10
C
C====== Calc cumulative totals
C
      DO 110 I = 1 , 11
         NODAL_BINS(I+1) = NODAL_BINS(I+1) + NODAL_BINS(I)
 110  CONTINUE
C
C====== Now write out header
C
      CALL LDM_MMRAST (KPACK, 1, MM_RAST_X, MM_RAST_Y)

      DO 660 II=1,19
         BUFFER(I) = 0
660   CONTINUE

      DO 666 II=1,6
         CALL LDM_GET_XCENF (KPACK, II, X_CEN_FS(II), IFLAG, ND,
     +                       IERR, ERRSTR)
         CALL LDM_GET_YCENF (KPACK, II, Y_CEN_FS(II), IFLAG, ND,
     +                       IERR, ERRSTR)
         W_FS(II) = 0.0
666   CONTINUE
      CALL LDM_GET_TITLE(COMPOUND, IFLAG)
      WRITE (IUN_GE1,REC=1) COMPOUND(1:76)
      CALL LDM_GET_CRYST (CRYST, IFLAG)
      WRITE (IUN_GE1,REC=2) CRYST , 
     +                      (X_CEN_FS(II)/MM_RAST_X,II=1,6),
     +                      (Y_CEN_FS(JJ)/MM_RAST_Y,JJ=1,6),
     +                      (W_FS(I),I=1,5)

      CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG)
      CALL LDM_GET_LATT (VALSTR, LATT, IFLAG)
      ISYLAT(1) = ISYST
      ISYLAT(2) = LATT
      CALL CCPII2(ISL,ISYLAT,2,.TRUE.,.FALSE.)
      CALL RECCEL(RCELL,CELL,1.0)
      CALL CELLCX(ISYST,CELLC,RCELL,2,2)
      CALL LDM_GET_BEAM (VALSTR, IBEAM, IFLAG)
      CALL LDM_GET_ROT (VALSTR, IROT, IFLAG)
      WRITE (IUN_GE1,REC=3) W_FS(6) , (BUFFER(I),I=1,9) , CELLC , 
     +                      ISL, IBEAM, IROT
C
C====== Initialise integration box parameters
C
      CALL LDM_GET_SPOTD (KPACK, KEYPLATE, DELTA, IFLAG, ND, 
     +                    IERR, ERRSTR)
      BOX(1) = DELTA*MM_RAST_X + 1
C
C====== Force box size to be odd.
C
      IF (MOD(BOX(1),2).EQ.0) BOX(1) = BOX(1) + 1
      BOX(2) = BOX(1)
C
C====== Cut off a corner 1/4 way along.
C
      BOX(3) = BOX(1)/4
      BOX(4) = 1
      BOX(5) = BOX(4)
      CALL LDM_GET_PHIX (KPACK, PHIS(1), IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_PHIY (KPACK, PHIS(2), IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_PHIZ (KPACK, PHIS(3), IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_LMIN (KPACK, WMIN, IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_LMAX (KPACK, WMAX, IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_DMIN (KPACK, DMIN, IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_SPIN (KPACK, SPINDLE, IFLAG, ND, IERR, ERRSTR)
      CALL LDM_GET_RMAX (FILMR, IFLAG, ND)
      WRITE (IUN_GE1,REC=4) 1.0/MM_RAST_X, BOX , 
     +                      (BUFFER(I),I=1,4) , PHIS , 
     +                      1.0 , WMIN , WMAX , DMIN , 
     +                      FILMR , SPINDLE
      DO 777 II = 1, 6
         CALL LDM_GET_XC (KPACK, II, X_C(II), IFLAG, ND,
     +                       IERR, ERRSTR)
         CALL LDM_GET_YC (KPACK, II, Y_C(II), IFLAG, ND,
     +                       IERR, ERRSTR)
         CALL LDM_GET_WC (KPACK, II, W_C(II), IFLAG, ND,
     +                       IERR, ERRSTR)
777   CONTINUE
      WRITE (IUN_GE1,REC=5) (X_C(II),II=1,6), 
     +                      (Y_C(JJ),JJ=1,6),
     +                      (W_C(KK),KK=1,6),
     +                      DELTA
C
C====== Calculate cryst-film ratios
C
      CTOF_RATS(KEYPLATE) = 1.0
      CALL LDM_GET_CTOF (KPACK, KEYPLATE, CTOF_KEYPLATE, IFLAG, ND, 
     +                   IERR, ERRSTR)
      DO 330 I = 1 , 6
         CALL LDM_GET_CTOF (KPACK, I, CTOF, IFLAG, ND, IERR, ERRSTR)
         CTOF_RATS(I) = CTOF/CTOF_KEYPLATE
330   CONTINUE
      CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, IFLAG)
      DO 333 I = 1, 6
         CALL LDM_GET_TWIST (KPACK, I, TWIST(I), IFLAG, ND, 
     +                       IERR, ERRSTR)
         CALL LDM_GET_TILT (KPACK, I, TILT(I), IFLAG, ND, IERR, ERRSTR)
         IF (DISTOR_TYPE.EQ.1) THEN
            CALL LDM_GET_BULGE (KPACK, I, BULGE(I), IFLAG, ND, 
     +                          IERR, ERRSTR)
         ELSE
            BULGE(I) = 0.0
         END IF
333   CONTINUE
      WRITE (IUN_GE1,REC=6) (TWIST(II),II=1,6),
     +                      (TILT(JJ),JJ=1,6),
     +                      (BULGE(KK),KK=1,6),
     +                      CTOF_KEYPLATE
      DO 334 I = 1, 6
         CALL LDM_GET_YSCAL (KPACK, I, Y_SCALE(I), IFLAG, ND, 
     +                       IERR, ERRSTR)
334   CONTINUE
      CALL LDM_GET_EPS (EPSILON, IFLAG, ND)
      WRITE (IUN_GE1,REC=7) (Y_SCALE(II),II=1,6), 
     +                      CTOF_RATS , MININT , EPSILON
      WRITE (IUN_GE1,REC=8) (MULTI_BINS(I),I=1,19)
      WRITE (IUN_GE1,REC=9) (MULTI_BINS(I),I=20,21) , 
     +                       (LAMBDA_BINS(I),I=1,16) , 2
      WRITE (IUN_GE1,REC=10) PACK_ID , NUM_SPOTS , NUM_MULTIPLETS , 
     +                       NUM_SPATIALS, NUM_BOTH , NUM_NODALS,
     +                       NODAL_BINS
C
C====== Close .ge1/.ge2 files
C
      CLOSE (UNIT=IUN_GE1)
      CLOSE (UNIT=IUN_GE2)
      RETURN
      END
