**==aa0001.f  
C PROGRAM 'INTANAL'
C ================
C
C ANALYSE INTENSITY DATA FROM LAUE 'GE' AND AFSCALE/UNSCRAM 'S(CALED)'
C FILES
C
C JOHN W. CAMPBELL, AUGUST 1987
C
C PARAMETERS     MAXF  MAXIMUM NO. OF COMBINATIONS OF FILMS (>7)
C                MAXB  MAXIMUM NUMBER OF LAMBDA BINS
C                MAXI  MAXIMUM NUMBER OF INTENSITY RANGES (>8)
C                MAXS  MAXIMUM NUMBER OF SIGMA RANGES (>11)
C                MAXR  MAXIMUM NUMBER OF RESOLUTION RANGES (>10)
      PARAMETER (MAXF=10,MAXB=30,MAXI=12,MAXS=15,MAXR=15)
C
      PARAMETER (NPADF=MAXF-7,NPADI=MAXI-8,NPADS=MAXS-11,NPADR=MAXR-10)
      PARAMETER (MAXIFB=MAXI*MAXF*MAXB,MAXSFB=MAXS*MAXF*MAXB)
      PARAMETER (MAXRFB=MAXR*MAXF*MAXB)
      PARAMETER (MAXBF=MAXB*MAXF)
C
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IFMIN(MAXF),IFMAX(MAXF)
      DIMENSION NII(MAXB,MAXI,MAXF),IIMAX(MAXI)
      DIMENSION NSIG(MAXB,MAXS,MAXF),SIGR(MAXS)
      DIMENSION SUMI(MAXB,MAXF),SUMSIG(MAXB,MAXF),NUMR(MAXB,MAXF)
      DIMENSION RESR(MAXR),NRES(MAXB,MAXR,MAXF),SUMRI(MAXB,MAXR,MAXF)
      DIMENSION CELL(6)
      DIMENSION IRSUM(MAXB),IICSUM(MAXI),ISCSUM(MAXS),IRCSUM(MAXR),
     * CAVE(MAXR),RAVE(MAXB)
      LOGICAL REJ,ONL,CCPONL,SFILE,GIVEN
      CHARACTER*128 LPBUF
      CHARACTER*80 TEXT
      CHARACTER*1 CHA(6)
      DATA IFMIN/1,2,3,4,5,6,1,NPADF*0/
      DATA IFMAX/1,2,3,4,5,6,6,NPADF*0/
      DATA IIMAX/0,50,100,200,400,800,1600,3200,NPADI*0/
      DATA SIGR/0.0,2.0,4.0,6.0,8.0,10.0,12.0,14.0,16.0,18.0,
     *20.0,NPADS*0.0/
      DATA RESR/20.0,10.0,7.0,5.0,4.0,3.33,2.9,2.6,2.4,0,NPADR*0.0/
      DATA NII/MAXIFB*0/
      DATA NSIG/MAXSFB*0/
      DATA NUMR/MAXBF*0/
      DATA SUMI/MAXBF*0.0/,SUMSIG/MAXBF*0.0/
      DATA NRES/MAXRFB*0/,SUMRI/MAXRFB*0.0/
      DATA CHA/'A','B','C','D','E','F'/
C
C INITIALISATIONS
C ---------------
C
      NRI = 9
      NF = 7
      NS = 11
      NRR = 10
      INTYP = 1
      IREJ = 3
      ALAM1 = 0.5
      ALAM2 = 2.0
      DLAM = 0.1
      NLAM = 15
      IUN = 1
      ITERM = 6
      ILP = 6
      ONL = CCPONL(IDUM)
      IFAIL = 0
      CALL CCPOPN(5,'DATA',5,1,LDUM,IFAIL)
      CALL CCPOPN(6,'PRINTER',ILP,1,LDUM,IFAIL)
      CALL CCPVRS(ILP,'INTANAL','23/12/88')
C
C READ IN CONTROL DATA
C --------------------
C
C
C READ IN INTEGRATION TYPE BOX/PROFILE
C
      IF (ONL) WRITE (ITERM,6340)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      CALL IVALUE(INTYP)
      IF (INTYP.NE.1 .AND. INTYP.NE.2) THEN
         WRITE (6,6310) TEXT
         STOP
      ELSE
C
C READ LIST OF FILMS (OR 'S' FOR SCALED-TOGETHER FILMS)
C
         IF (ONL) WRITE (ITERM,6350)
         CALL FFREAD(5,TEXT,80,6,.TRUE.)
         CALL CCPUPC(TEXT)
         IF (TEXT.EQ.' ') GO TO 40
         NF = 0
C SEE IF THE FIRST (ONLY) SYMBOL IS 'S'
         CALL TEXLIM(M1,M2)
         IF (TEXT(M1:M1).EQ.'S') THEN
            NF = 1
            IFMIN(NF) = 1
            IFMAX(NF) = 1
            SFILE = .TRUE.
            GO TO 40
         ELSE
            SFILE = .FALSE.
            GO TO 30
         END IF
      END IF
C LOOK FOR THE NEXT FIELD
 20   CALL TEXLIM(M1,M2)
      IF (M1.LT.1) GO TO 40
 30   IF (M1.EQ.M2) THEN
         II = INDEX('ABCDEF',TEXT(M1:M1))
         IF (II.EQ.0) GO TO 250
         NF = NF + 1
         IFMIN(NF) = II
         IFMAX(NF) = II
         IF (NF.LT.MAXF) GO TO 20
      ELSE IF (M2-M1.EQ.2) THEN
         IF (TEXT(M1+1:M1+1).NE.'-') GO TO 250
         II = INDEX('ABCDEF',TEXT(M1:M1))
         JJ = INDEX('ABCDEF',TEXT(M2:M2))
         IF (II.EQ.0 .OR. JJ.EQ.0) GO TO 250
         IF (JJ.LT.II) GO TO 250
         NF = NF + 1
         IFMIN(NF) = II
         IFMAX(NF) = JJ
         IF (NF.LT.MAXF) GO TO 20
      ELSE
         GO TO 250
      END IF
C
C OPEN APPROPRIATE TYPE OF FILE
 40   IF (SFILE) THEN
         CALL CCPOPN(IUN,'LAUEHKL',5,1,75,IFAIL)
      ELSE
         CALL CCPOPN(IUN,'LAUEHKL',5,4,19,IFAIL)
      END IF
C
C READ IN SPOT REJECTION TYPE
C
      IF (ONL) WRITE (ITERM,6400)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      IF (TEXT.NE.' ') THEN
         CALL IVALUE(IREJ)
         IF (IREJ.LT.0 .OR. IREJ.GT.3) THEN
            WRITE (6,6330) TEXT
            STOP
         END IF
      END IF
C
C READ IN LAMBDA RANGE AND WIDTH
C
      IF (ONL) WRITE (ITERM,6360)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      IF (TEXT.NE.' ') THEN
         CALL IVALUE(NLAM)
         CALL FVALUE(ALAM1)
         CALL FVALUE(DLAM)
         IF (NLAM.GT.MAXB) THEN
            WRITE (6,6300) MAXB
            STOP
         ELSE
            IF (NLAM.LT.1) NLAM = 1
            IF (DLAM.LE.0.0) DLAM = 0.1
            ALAM2 = ALAM1 + NLAM*DLAM
         END IF
      END IF
C
C READ IN INTENSITY RANGES
C
      IF (ONL) WRITE (ITERM,6370)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      IF (TEXT.NE.' ') THEN
         NRI = NFIELD(TEXT) + 1
         DO 50 I = 1 , NRI - 1
            CALL FVALUE(X)
            IIMAX(I) = NINT(X)
 50      CONTINUE
      END IF
C
C READ IN SIGMA RANGES
C
      IF (ONL) WRITE (ITERM,6380)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      IF (TEXT.NE.' ') THEN
         NS = NFIELD(TEXT)
         DO 60 I = 1 , NS
            CALL FVALUE(SIGR(I))
 60      CONTINUE
      END IF
C
C READ IN RESOLUTION RANGES
C
      IF (ONL) WRITE (ITERM,6390)
      CALL FFREAD(5,TEXT,80,6,.TRUE.)
      IF (TEXT.NE.' ') THEN
         NRR = NFIELD(TEXT)
         DO 70 I = 1 , NRR
            CALL FVALUE(RESR(I))
 70      CONTINUE
      END IF
C TRY AND READ CELL DIMENSIONS - IF NOT GIVEN BY USER GET THEM FROM .GE
C FILE.
      CALL READCL(ITERM,5,ONL,CELL,GIVEN)
      IF (SFILE .AND. .NOT.GIVEN) THEN
         WRITE (6,6320)
         STOP
      ELSE
         IF (.NOT.GIVEN) THEN
C GET CELL DIMENSIONS
            CALL GECELL(IUN,CELL,WAVMIN,WAVMAX)
         END IF
C SET UP 'S' CALCULATION
         CALL SETRSL(CELL(1),CELL(2),CELL(3),CELL(4),CELL(5),CELL(6))
C
C READ IN DATA AND ACCUMULATE STATS
C ---------------------------------
C
C
C READ AND PROCESS DATA
C
         KFMIN = 6
         KFMAX = 1
         DO 80 N = 1 , NF
            IF (IFMIN(N).LT.KFMIN) KFMIN = IFMIN(N)
            IF (IFMAX(N).GT.KFMAX) KFMAX = IFMAX(N)
 80      CONTINUE
         IF (SFILE) THEN
C NO. OF SPOTS NOT GIVEN IN FILE SO SET TO 'INFINITY'
            NRCMAX = 1000000
         ELSE
C GET NUMBER OF SPOTS FROM GE FILE
            READ (IUN,REC=10) IPACK , NSPOT
            IF (NSPOT.LE.0) READ (IUN,REC=9) I , J , NSPOT
            WRITE (ILP,6010) NSPOT
            NRCMAX = NSPOT + 10
         END IF
         DO 160 IREC = 11 , NRCMAX
            DO 150 KFILM = KFMIN , KFMAX
               IF (SFILE) THEN
                  READ (IUN,6410,END=170) IH , IK , IL , ALBDA , THETA , 
     +                  II , ISIG
               ELSE
                  CALL GETINT(IUN,IREC,KFILM,INTYP,IH,IK,IL,ALBDA,II,
     +                        ISIG,IREJ,REJ)
               END IF
               IF (.NOT.(REJ)) THEN
                  LB = IRANGE(ALBDA,ALAM1,ALAM2,NLAM)
                  DO 140 N = 1 , NF
                     IF (KFILM.LT.IFMIN(N) .OR. KFILM.GT.IFMAX(N))
     +                   GO TO 140
C
C TOTAL FOR THIS BIN AND FILM
C
                     NUMR(LB,N) = NUMR(LB,N) + 1
C
C INTENSITIES
C
                     DO 90 IR = 1 , NRI - 1
                        IF (II.LE.IIMAX(IR)) GO TO 100
 90                  CONTINUE
                     IR = NRI
 100                 NII(LB,IR,N) = NII(LB,IR,N) + 1
C
C SIGMAS
C
                     DO 110 IS = NS , 1 , -1
                        IF (II.GT.SIGR(IS)*ISIG) THEN
                           NSIG(LB,IS,N) = NSIG(LB,IS,N) + 1
                           GO TO 120
                        END IF
 110                 CONTINUE
C
C I/SIG(I)
C
 120                 SUMI(LB,N) = SUMI(LB,N) + II
                     SUMSIG(LB,N) = SUMSIG(LB,N) + ISIG
C
C RESOLUTION ANALYSIS
C
                     S = 4*STHLSQ(IH,IK,IL)
                     D = SQRT(1/S)
                     DO 130 IR = 1 , NRR
                        IF (D.GT.RESR(IR)) THEN
                           NRES(LB,IR,N) = NRES(LB,IR,N) + 1
                           SUMRI(LB,IR,N) = SUMRI(LB,IR,N) + II
                           GO TO 140
                        END IF
 130                 CONTINUE
C
 140              CONTINUE
               END IF
 150        CONTINUE
 160     CONTINUE
      END IF
C
C PRINT TABLES
C ------------
C
 170  DO 240 N = 1 , NF
         IF (SFILE) THEN
            WRITE (ILP,6100)
         ELSE IF (IFMIN(N).EQ.IFMAX(N)) THEN
            WRITE (ILP,6020) CHA(IFMIN(N))
         ELSE
            WRITE (ILP,6030) CHA(IFMIN(N)) , CHA(IFMAX(N))
         END IF
C
C REFLECTIONS AS A FUNCTION OF WAVELENGTH AND INTENSITY
C
         WRITE (ILP,6040)
         LPBUF = ' '
         WRITE (LPBUF,6050) (IIMAX(I)+1,I=1,NRI-2)
         JJ = 29 + 7*NRI
         LPBUF(JJ:JJ+7) = '> TOTALS'
         WRITE (ILP,6060) LPBUF
         WRITE (ILP,6070) (IIMAX(I),I=1,NRI-1) , IIMAX(NRI-1)
         WRITE (ILP,6080)
         CALL TABTOT(NII,MAXB,MAXI,MAXF,IICSUM,IRSUM,N)
         DO 180 LB = 1 , NLAM
            AL1 = ALAM1 + (LB-1)*DLAM
            AL2 = AL1 + DLAM
            WRITE (ILP,6090) LB , AL1 , AL2 , (NII(LB,I,N),I=1,NRI) , 
     +                       IRSUM(LB)
 180     CONTINUE
         WRITE (ILP,6110) (IICSUM(I),I=1,NRI)
C
C REFLECTIONS AS A FUNCTION OF WAVELENGTH AND SIGMA
C
         WRITE (ILP,6150)
         WRITE (ILP,6160)
         LPBUF = ' '
         WRITE (LPBUF,6170) (I,I=1,NS)
         JJ = 29 + 7*NS + 2
         LPBUF(JJ:JJ+6) = ' TOTALS'
         WRITE (ILP,6060) LPBUF
         WRITE (ILP,6180) (SIGR(I),I=1,NS)
         WRITE (ILP,6080)
         CALL TABTOT(NSIG,MAXB,MAXS,MAXF,ISCSUM,IRSUM,N)
         DO 190 LB = 1 , NLAM
            AL1 = ALAM1 + (LB-1)*DLAM
            AL2 = AL1 + DLAM
            WRITE (ILP,6190) LB , AL1 , AL2 , (NSIG(LB,I,N),I=1,NS) , 
     +                       IRSUM(LB)
 190     CONTINUE
         WRITE (ILP,6120) (ISCSUM(I),I=1,NS)
C
C MEAN I/SIG(I) ANALYSIS AS A FUNCTION OF WAVELENGTH
C
         WRITE (ILP,6200)
         WRITE (ILP,6210)
         DO 200 LB = 1 , NLAM
            AL1 = ALAM1 + (LB-1)*DLAM
            AL2 = AL1 + DLAM
            IF (SUMSIG(LB,N).GT.0) THEN
               AVISIG = SUMI(LB,N)/SUMSIG(LB,N)
            ELSE
               AVISIG = 0.0
            END IF
            IF (NUMR(LB,N).GT.0) THEN
               AVI = SUMI(LB,N)/NUMR(LB,N)
            ELSE
               AVI = 0.0
            END IF
            WRITE (ILP,6220) LB , AL1 , AL2 , AVISIG , AVI , NUMR(LB,N)
 200     CONTINUE
C
C REFLECTIONS AS A FUNCTION OF WAVELENGTH AND RESOLUTION
C
         DO 220 IR = 1 , NRR
            DO 210 LB = 1 , NLAM
               IF (NRES(LB,IR,N).GT.0) SUMRI(LB,IR,N) = SUMRI(LB,IR,N)
     +             /NRES(LB,IR,N)
 210        CONTINUE
 220     CONTINUE
         WRITE (ILP,6230)
         WRITE (ILP,6240)
         LPBUF = ' '
         WRITE (LPBUF,6250) (I,I=1,NRR)
         JJ = 29 + NRR*7 + 2
         LPBUF(JJ:JJ+7) = ' TOT/AVE'
         WRITE (ILP,6060) LPBUF
         WRITE (ILP,6260) (RESR(I),I=1,NRR)
         CALL TABTOT(NRES,MAXB,MAXR,MAXF,IRCSUM,IRSUM,N)
         CALL TABAVE(SUMRI,NRES,MAXB,MAXR,MAXF,NLAM,NRR,CAVE,RAVE,N)
         DO 230 LB = 1 , NLAM
            AL1 = ALAM1 + (LB-1)*DLAM
            AL2 = AL1 + DLAM
            WRITE (ILP,6270) LB , AL1 , AL2 , (NRES(LB,I,N),I=1,NRR) , 
     +                       IRSUM(LB)
            WRITE (ILP,6280) (NINT(SUMRI(LB,I,N)),I=1,NRR) , 
     +                       NINT(RAVE(LB))
 230     CONTINUE
         WRITE (ILP,6130) (IRCSUM(I),I=1,NRR)
         WRITE (ILP,6140) (NINT(CAVE(I)),I=1,NRR)
 240  CONTINUE
      STOP
C
C ERROR CONDITIONS
C ----------------
C
 250  WRITE (6,6290) TEXT
      STOP
C
C FORMAT STATEMENTS
C -----------------
C
 6010 FORMAT (//,' NUMBER OF REFLECTION RECORDS IN FILE =',I6,///)
 6020 FORMAT ('1',//,' ANALYSES FOR FILM ',A)
 6030 FORMAT ('1',//,' ANALYSES FOR FILMS ',A,' TO ',A)
 6040 FORMAT (//,' ANALYSIS OF NUMBERS OF INTENSITIES IN LAMBDA BINS',/)
 6050 FORMAT ('BIN     LAMBDA    INTENSITIES:    <=',20(I6,'-'))
 6060 FORMAT (' ',A)
 6070 FORMAT (' NO.      RANGE               ',20(I7))
 6080 FORMAT (' ')
 6090 FORMAT (' ',I3,F6.2,' TO ',F6.2,10X,20(I7))
 6100 FORMAT ('1',//,' ANALYSES FOR SCALED-TOGETHER FILMS')
 6110 FORMAT ('0TOTALS:',22X,20I7)
 6120 FORMAT ('0TOTALS:',22X,20I7)
 6130 FORMAT (//' TOTALS:',22X,20I7)
 6140 FORMAT ('0AVERAGES:',20X,20I7)
 6150 FORMAT (//,' ANALYSIS OF NUMBERS OF INTENSITIES AS A FUNCION',
     +        ' OF WAVELENGTH AND SIG(I)',/)
 6160 FORMAT (' NUMBERS ARE FOR  I>=S(N)*SIG(I) AND I<S(N+1)*SIG(I)',/)
 6170 FORMAT ('BIN     LAMBDA               ',20('  S(',I2,')',:))
 6180 FORMAT (' NO.      RANGE               ',20(F7.1))
 6190 FORMAT (' ',I3,F6.2,' TO ',F6.2,10X,20(I7))
 6200 FORMAT (//,' ANALYSIS OF MEAN I/SIG(I) AS A FUNCTION OF ',
     +        'WAVELENGTH',/)
 6210 FORMAT (' BIN     LAMBDA         MEAN     MEAN  TOTAL',/,
     +        ' NO.      RANGE        I/SIG(I)    I   REFLS',/)
 6220 FORMAT (' ',I3,F6.2,' TO ',F6.2,2F9.2,I6)
 6230 FORMAT (//,' ANALYSIS OF NUMBERS OF INTENSITIES AND AVERAGE ',
     +        'INTENSITY AS A FUNCION OF WAVELENGTH AND RESOLUTION',/)
 6240 FORMAT (' NUMBERS ARE FOR  RESOL>R(I) AND RESOL<=R(I-1) ',
     +        '(IF PRESENT)',/)
 6250 FORMAT ('BIN     LAMBDA               ',20('  R(',I2,')',:))
 6260 FORMAT (' NO.      RANGE               ',20(F7.2))
 6270 FORMAT (/,' ',I3,F6.2,' TO ',F6.2,10X,20(I7))
 6280 FORMAT (' ',29X,20(I7))
C
 6290 FORMAT (/,' **INVALID FILM CODES OR RANGES**: ',A)
 6300 FORMAT (/,' **MAX OF',I3,' LAMBDA BINS ALLOWED**')
 6310 FORMAT (/,' **INVALID INTEGRATION TYPE CODE**: ',A)
 6320 FORMAT (/,' **NO CELL PARAMETERS SUPPLIED**')
 6330 FORMAT (/,' **INVALID REJECTION TYPE CODE**: ',A)
C
 6340 FORMAT (' Integration type (1=Box, 2=Profile)? ')
 6350 FORMAT (' Film codes or ranges (A,B,C,D,E,F or S)'/
     +        '(default is A B C D E F A-F)? ')
 6360 FORMAT (' Number of bins, Lambda min, Lambda bin width? ')
 6370 FORMAT (' Intensity range limits? ')
 6380 FORMAT (' Sigma range limits? ')
 6390 FORMAT (' Resolution range limits? ')
 6400 FORMAT (' Spot rejection type code? '/
     +        ' 1=reject spatials, 2=reject multiplets, 3=reject both '/
     +        ' (Default 3) ')
 6410 FORMAT (3I5,2F10.5,2I10)
      END
**==irange.f  
C
C FUNCTION 'IRANGE'
C =================
C
C FIND A RANGE NUMBER
C
      FUNCTION IRANGE(X,XMIN,XMAX,NX)
C
C PARAMETERS
C
C           X (I)   THE VALUE FOR WHICH THE RANGE NO. IS TO BE FOUND
C        XMIN (I)   THE MINIMUM X VALUE
C        XMAX (I)   THE MAXIMUM X VALUE
C          NX (I)   THE NUMBER OR RANGES (FROM XMIN TO XMAX)
C
C  RETURNS  IRANGE = THE RANGE NUMBER
C
C CALCULATE THE RANGE NUMBER
C --------------------------
C
      IRANGE = 1
      IF (XMAX.LE.XMIN) RETURN
      IRANGE = NX*(X-XMIN)/(XMAX-XMIN) + 1
      IF (IRANGE.LT.1) IRANGE = 1
      IF (IRANGE.GT.NX) IRANGE = NX
      RETURN
      END
**==getint.f  
C
C SUBROUTINE 'GETINT'
C ===================
C
C READ A REFLECTION FROM A LAUE 'GE' FILE
C
      SUBROUTINE GETINT(IUN,IREC,KFILM,INTYP,IH,IK,IL,ALBDA,II,ISIG,
     *IREJ,REJ)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER OF 'GE' FILE
C        IREC (I)   RECORD NUMBER OF REFLECTION
C       KFILM (I)   NO. OF THE FILM FOR WHICH THE INTENSITY IS TO
C                   BE RETURNED
C       INTYP (I)   INTEGRATION TYPE 1=BOX, 2=PROFILE FITTED
C          IH (O)   INDICES
C          IK (O)   "
C          IL (O)   "
C       ALBDA (O)   WAVELENGTH
C          II (O)   INTENSITY
C        ISIG (O)   SIGMA(INTENSITY)
C        IREJ (I)   TYPE TO REJECT (1=REJ. SPATIALS 2=MULTI 3=BOTH)
C         REJ (O)   REJECT FLAG = .TRUE. REJECT, = .FALSE. DO NOT
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL REJ
      INTEGER MHKL(4), MULTF(1)
      INTEGER IBUFF(12)
      INTEGER INTB(6),ISIGB(6),INTP(6),ISIGP(6)
C
C READ AND INTERPRET RECORD
C -------------------------
C
      KUN = 6
      REJ = .FALSE.
      READ (IUN,REC=IREC) X , Y , IBUFF , IMULT , ALBDA
C
C CHECK MULTIPLE REFLECTION, SPATIAL OVERLAP FLAGS
C
      CALL CCPBYI(MULTF,IMULT,1)
      CALL CCPBYI(MHKL,IMULT,-4)
      IMULT = NBITST(MULTF(1),0,5)
      IF (IMULT.GT.1 .AND. IREJ.GE.2) REJ = .TRUE.
      IF ((IREJ.EQ.1 .OR. IREJ.EQ.3) .AND. NBITST(MULTF(1),6,1).NE.0)
     +    REJ = .TRUE.
      IH = MHKL(2)
      IK = MHKL(3)
      IL = MHKL(4)
      IF (INTYP.EQ.1) THEN
         CALL CCPI2I(INTB,IBUFF(1),6,.TRUE.,.FALSE.)
         CALL CCPI2I(ISIGB,IBUFF(4),6,.TRUE.,.FALSE.)
         II = INTB(KFILM)
         ISIG = ISIGB(KFILM)
      ELSE
         CALL CCPI2I(INTP,IBUFF(7),6,.TRUE.,.FALSE.)
         CALL CCPI2I(ISIGP,IBUFF(10),6,.TRUE.,.FALSE.)
         II = INTP(KFILM)
         ISIG = ISIGP(KFILM)
      END IF
      IF (ISIG.EQ.-9999) REJ = .TRUE.
      RETURN
      END
**==readcl.f  
C
C SUBROUTINE 'READCL'
C ===================
C
C GET CELL DIMENSIONS FROM DATA CARD (IF SUPPLIED)
C
        SUBROUTINE READCL(ITERM,INUNIT,ONL,CELL,GIVEN)
C PARAMETERS
C
C      ITERM (I)   UNIT NUMBER FOR OUTPUT ON TERMINAL (INTEGER)
C     INUNIT (I)   UNIT NUMBER FOR INPUT FROM DATA FILE
C        ONL (I)   LOGICAL SWITCH, IF .TRUE. INTERACTIVE MODE ELSE BATCH
C       CELL (O)   6 ELEMENT ARRAY CONTAINING CELL PARAMETERS (REAL)
C      GIVEN (O)   LOGICAL FLAG, .TRUE. IF PARAMETERS WERE GIVEN.
      REAL CELL(6)
      LOGICAL ONL,GIVEN
C
      CHARACTER*80 TEXT
C
C START OF EXECUTABLE CODE
C ------------------------
C
      IF (ONL) WRITE (ITERM,6010)
      CALL FFREAD(INUNIT,TEXT,80,ITERM,.TRUE.)
      IF (TEXT.EQ.' ') THEN
         GIVEN = .FALSE.
         RETURN
      END IF
      DO 20 I = 1 , 6
         CALL FVALUE(CELL(I))
 20   CONTINUE
      GIVEN = .TRUE.
      RETURN
 6010 FORMAT (' Enter the 6 cell parameters - (default is read',
     +        ' cell parameters from .GE file)')
      END
**==gecell.f  
C
C SUBROUTINE 'GECELL'
C ===================
C
C GET CELL DIMENSIONS FROM 'GE' FILE
C
      SUBROUTINE GECELL(IUN,CP,WAVMIN,WAVMAX)
C
C PARAMETERS
C
C        IUN (I)   UNIT NUMBER ON WHICH 'GE' FILE HAS BEEN OPENED
C         CP (O)   6 WORD ARRAY RETURNING CELL PARAMETERS (REAL)
C     WAVMIN (O)   MINIMUM WAVELENGTH
C     WAVMAX (O)   MAXIMUM WAVELENGTH
C
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      REAL WAVE, WAVMIN, WAVMAX
      REAL CP(6), BUFF (10), BUFF2(3)
      REAL PARAMS(6)
      INTEGER ISYLAT(2), ISL
      INTEGER XALNO
      CHARACTER*40 BUF
C
C READ RECORDS FROM 'GE' FILE
C ---------------------------
C
      READ (IUN,REC=3) BUFF , CP , ISL
      CALL CCPI2I(ISYLAT,ISL,2,.TRUE.,.FALSE.)
      XALNO = ISYLAT(1)
      READ (IUN,REC=4) BUF , BUFF2 , WAVE , WAVMIN , WAVMAX
C
C PROCESS CELL DIMENSIONS
C -----------------------
C
      IF (XALNO.EQ.1) THEN
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.2) THEN
         CP(5) = CP(4)
         CP(4) = 90
         CP(6) = 90
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.3) THEN
         CP(4) = 90
         CP(5) = 90
         CP(6) = 90
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.4) THEN
         CP(3) = CP(2)
         CP(2) = CP(1)
         CP(4) = 90
         CP(5) = 90
         CP(6) = 90
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.5) THEN
         CP(3) = CP(2)
         CP(2) = CP(1)
         CP(4) = 90
         CP(5) = 90
         CP(6) = 60
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.6) THEN
         CP(4) = CP(2)
         CP(5) = CP(2)
         CP(6) = CP(2)
         CP(2) = CP(1)
         CP(3) = CP(1)
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE IF (XALNO.EQ.7) THEN
         CP(2) = CP(1)
         CP(3) = CP(1)
         CP(4) = 90
         CP(5) = 90
         CP(6) = 90
         CALL RECCEL(PARAMS,CP,WAVE)
      ELSE
         STOP ' ***ERROR IN HEADER DATA*** '
      END IF
      DO 20 I = 1 , 6
         CP(I) = PARAMS(I)
 20   CONTINUE
      RETURN
      END
**==ffread.f  
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
**==nfield.f  
C
C FUNCTION 'NFIELD'
C =================
C
C&&& ROTAVATA VERSION ALLOWS COMMA SEPARATORS
C&&& CHANGED TO USE A LENGTH (*) CHAR VARIABLE INSTEAD OF A CHAR ARRAY
C
C RETURNS THE NUMBER OF CHARACTER FIELDS PRESENT IN A TEXT STRING
C (CHARACTER STRINGS ARE ASSUMED TO BE SEPARATED BY ONE OR MORE SPACES
C  OR BY COMMAS)
C
      FUNCTION NFIELD(ITEXT)
C
C PARAMETERS
C
C       ITEXT (I) CHARACTER VARIABLE CONTAINING THE TEXT STRING
C
C
C SPECIFICATION STATEMENTS
C
      CHARACTER*(*) ITEXT
      CHARACTER*1 ISP,ICOMMA
      DATA ISP/' '/,ICOMMA/','/
C
C CODE
C
      IMAX = LEN(ITEXT)
      NFIELD = 0
      I = 0
 20   I = I + 1
      IF (I.GT.IMAX) RETURN
      IF (ITEXT(I:I).EQ.ISP .OR. ITEXT(I:I).EQ.ICOMMA) GO TO 20
      NFIELD = NFIELD + 1
 30   I = I + 1
      IF (I.GT.IMAX) RETURN
      IF (ITEXT(I:I).EQ.ISP .OR. ITEXT(I:I).EQ.ICOMMA) GO TO 20
      GO TO 30
      END
**==tabtot.f  
C
C     SUBROUTINE 'TABTOT'
C     ===================
C
C CACULATE ROW AND COLUMN TOTALS FOR 3D ARRAY IARR (THIRD INDEX GIVEN BY
C PARAMETER IL)
      SUBROUTINE TABTOT(IARR,N,M,L,ICSUM,IRSUM,IL)
C
C PARAMETERS
C
C      IARR (I)   ARRAY TO BE TOTALLED
C         N (I)   FIRST,
C         M (I)   SECOND,
C         L (I)   AND THIRD DIMENSIONS OF IARR
C     ICSUM (O)   THE SUMS OF THE COLUMNS
C     IRSUM (O)   THE SUMS OF THE ROWS
C        IL (I)   INDEX OF THE THIRD DIMENSION OF IARR
      INTEGER IARR(N,M,L),ICSUM(M),IRSUM(N)
C ROWS
      DO 30 I = 1 , N
         ITOT = 0
         DO 20 J = 1 , M
            ITOT = ITOT + IARR(I,J,IL)
 20      CONTINUE
         IRSUM(I) = ITOT
 30   CONTINUE
C COLS
      DO 50 I = 1 , M
         ITOT = 0
         DO 40 J = 1 , N
            ITOT = ITOT + IARR(J,I,IL)
 40      CONTINUE
         ICSUM(I) = ITOT
 50   CONTINUE
      RETURN
      END
**==tabave.f  
C
C     SUBROUTINE 'TABAVE'
C     ===================
C
C CACULATE ROW AND COLUMN AVERAGES FOR 3D ARRAY ARR (THIRD INDEX GIVEN BY
C PARAMETER IL). ARR IS AN ARRAY OF BIN AVERAGES, THE NUMBER OF ITEMS IN
C EACH BIN IS GIVEN BY NARR.
      SUBROUTINE TABAVE(ARR,NARR,N,M,L,NN,NM,COLAVE,ROWAVE,IL)
C
C PARAMETERS
C
C       ARR (I)   ARRAY TO BE AVERAGED
C      NARR (I)   ARRAY CONTAINING NUMBER OF ITEMS CONTRIBUTING TO EACH
C                 ELEMENT OF ARR
C         N (I)   FIRST,
C         M (I)   SECOND,
C         L (I)   AND THIRD DIMENSIONS OF ARR AND NARR
C        NN (I)   NUMBER OF ROWS
C        NM (I)   AND COLUMNS TO BE AVERAGED
C    COLAVE (O)   THE AVERAGES OF THE COLUMNS
C    ROWAVE (O)   THE AVERAGES OF THE ROWS
C        IL (I)   INDEX OF THE THIRD DIMENSION OF ARR
      REAL ARR(N,M,L),COLAVE(M),ROWAVE(N)
      INTEGER NARR(N,M,L)
C ROWS
      DO 30 I = 1 , NN
         ITOT = 0
         TOT = 0.0
         DO 20 J = 1 , NM
            ITOT = ITOT + NARR(I,J,IL)
            TOT = TOT + ARR(I,J,IL)*NARR(I,J,IL)
 20      CONTINUE
         IF (ITOT.EQ.0) THEN
            ROWAVE(I) = 0.0
         ELSE
            ROWAVE(I) = TOT/ITOT
         END IF
 30   CONTINUE
C COLS
      DO 50 I = 1 , NM
         ITOT = 0
         TOT = 0.0
         DO 40 J = 1 , NN
            ITOT = ITOT + NARR(J,I,IL)
            TOT = TOT + ARR(J,I,IL)*NARR(J,I,IL)
 40      CONTINUE
         IF (ITOT.EQ.0) THEN
            COLAVE(I) = 0.0
         ELSE
            COLAVE(I) = TOT/ITOT
         END IF
 50   CONTINUE
      RETURN
      END
