*DECK LIBA24
      SUBROUTINE LIBA24(NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS,L104,
     1 SEQHOM,TEMPS,TN,SN,ABSOHE,DIFFHE,FISSHE,FLUXHE,IMPX,TAUX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* temperature and dilution interpolation of self-shielded effective
* rates in the APOLIB-2 format
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* NGRO    number of energy groups
* FGHOMO  first self-shielded energy group
* NGHOMO  number of self-shielded energy groups
* NSEQHO  number of tabulated dilutions
* NTEMPS  number of tabulated temperatures
* LFIS    fission reaction flag (=.true. if the fission reaction is
*         self-shielded)
* L104    resonance flux flag (=.true. if the apolib contains dilution
*         /temperature-dependent flux information). If this information
*         is not provided, it will be reconstructed from a balance
*         relation
* SEQHOM  tabulated dilutions
* TEMPS   tabulated temperatures
* TN      temperature of isotope
* SN      dilution of isotope
* ABSOHE  tabulated absorption effective reaction rates
* DIFFHE  tabulated diffusion effective reaction rates
* FISSHE  tabulated nu*fission effective reaction rates (if LFIS=.true.)
* FLUXHE  tabulated self-shielded fluxes (if L104=.true.)
* IMPX    print flag
*
*Parameters: output
* TAUX    interpolated effective rates:
*         TAUX(I,1): absorption effective rates;
*         TAUX(I,2): diffusion effective rates;
*         TAUX(I,3): nu*fission effective rates;
*         TAUX(I,4): pseudo-absorption effective rates used to
*                    reconstruct the self-shielded flux;
*         TAUX(I,5): infinite-dilution absorption x-s;
*         TAUX(I,6): infinite-dilution diffusion x-s
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,IMPX
      LOGICAL LFIS,L104
      REAL SEQHOM(NSEQHO),TEMPS(NTEMPS),TN,SN(NGRO),
     1 ABSOHE(NGHOMO,NSEQHO,NTEMPS),DIFFHE(NGHOMO,NSEQHO,NTEMPS),
     2 FISSHE(NGHOMO,NSEQHO,NTEMPS),FLUXHE(NGHOMO,NSEQHO,NTEMPS),
     3 TAUX(NGHOMO,6)
*----
*  LOCAL VARIABLES
*----
      CHARACTER HSMG*131,TEXTE*80
      PARAMETER (NINT=2,NINTSS=3,DTMIN=1.0)
      LOGICAL LGONE
      REAL, ALLOCATABLE, DIMENSION(:) :: WEIJHT,SQRTEM,SEQ2,WEIGH
      REAL, ALLOCATABLE, DIMENSION(:,:) :: ABSOH,DIFFH,FISSH,FLUXH
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS),ABSOH(NGHOMO,NSEQHO),
     1 DIFFH(NGHOMO,NSEQHO),FISSH(NGHOMO,NSEQHO),
     2 FLUXH(NGHOMO,NSEQHO))
*----
*  SQUARE ROOT OF TEMPERATURE INTERPOLATION.
*
*  IGTFIX=1 IF ONLY ONE TABULATED TEMPERATURE OR IF STT IS ONE OF THE
*  TABULATED TEMPERATURES. IGTFIX=2 IF STT IS OUTSIDE THE TABULATED
*  RANGE. IGTFIX=0 OTHERWISE.
*
*----
      DO 10 I=1,NTEMPS
   10 SQRTEM(I)=SQRT(TEMPS(I))
      IF(NTEMPS.EQ.1) THEN
        IGTFIX=1
        IPROX=1
      ELSE
        STT=SQRT(TN)
        CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0)
        IF(ABS(TN-TEMPS(IPROX)).LE.DTMIN) THEN
          IGTFIX=1
        ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN
          WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)')
     1    'LIBA24: A TEMPERATURE', TN,'K IS NOT INCLUDED BETWEEN ',
     2    TEMPS(1),' AND ',TEMPS(NTEMPS)
          WRITE(6,'(/1X,A)') HSMG
          IGTFIX=2
        ELSE
          IGTFIX=0
        ENDIF
      ENDIF
*
      IF(IGTFIX .EQ. 1) THEN
         DO 20 J=1,NSEQHO
         DO 20 I=1,NGHOMO
         ABSOH(I,J)=ABSOHE(I,J,IPROX)
         DIFFH(I,J)=DIFFHE(I,J,IPROX)
         IF(LFIS) FISSH(I,J)=FISSHE(I,J,IPROX)
         IF(L104) FLUXH(I,J)=FLUXHE(I,J,IPROX)
   20    CONTINUE
      ELSE
       DO 40 J=1,NSEQHO
       DO 40 I=1,NGHOMO
        S1=0.
        S2=0.
        S3=0.
        S4=0.
        IT=I0+1
        DO 30 K=1,IORD
         S1=S1+WEIJHT(K)*ABSOHE(I,J,IT)
         S2=S2+WEIJHT(K)*DIFFHE(I,J,IT)
         IF(LFIS)S3=S3+WEIJHT(K)*FISSHE(I,J,IT)
         IF(L104)S4=S4+WEIJHT(K)*FLUXHE(I,J,IT)
         IT=IT+1
   30   CONTINUE
        IF(IGTFIX.EQ.2) THEN
          IF(ABSOHE(I,J,IPROX).GE.0.) THEN
            ABSOH(I,J)=MAX(0.,S1)
          ELSE
            ABSOH(I,J)=MIN(S1,0.)
          ENDIF
          IF(DIFFHE(I,J,IPROX).GE.0.) THEN
            DIFFH(I,J)=MAX(0.,S2)
          ELSE
            DIFFH(I,J)=MIN(S2,0.)
          ENDIF
        ELSE
          ABSOH(I,J)=S1
          DIFFH(I,J)=S2
        ENDIF
        IF(LFIS) THEN
          IF(IGTFIX .EQ. 2) THEN
            IF(FISSHE(I,J,IPROX).GE.0.) THEN
              FISSH(I,J)=MAX(0.,S3)
            ELSE
              FISSH(I,J)=MIN(S3,0.)
            ENDIF
          ELSE
            FISSH(I,J)=S3
          ENDIF
        ENDIF
        IF(L104) THEN
          IF(IGTFIX .EQ. 2) THEN
            IF(FLUXHE(I,J,IPROX).GE.0.) THEN
              FLUXH(I,J)=MAX(0.,S4)
            ELSE
              FLUXH(I,J)=MIN(S4,0.)
            ENDIF
          ELSE
            FLUXH(I,J)=S4
          ENDIF
        ENDIF
   40  CONTINUE
      ENDIF
*----
*  SET INFINITE DILUTION VALUES.
*----
      DO 50 I=1,NGHOMO
      TAUX(I,5)=ABSOH(I,NSEQHO)
   50 TAUX(I,6)=DIFFH(I,NSEQHO)
*----
*  DILUTION INTERPOLATION.
*----
      LGONE=NSEQHO.EQ.1
      NSEQH1=0
      SEQHO1=0.0
      SEQHO0=0.0
      IF(.NOT.LGONE)THEN
        NSEQH1=NSEQHO-1
        SEQHO1=SEQHOM(NSEQH1)
        SEQHO0=SEQHOM(NSEQHO)
      ENDIF
      DO 110 IGG=FGHOMO,FGHOMO+NGHOMO-1
         IGSSC=IGG+1-FGHOMO
         BACK=SN(IGG)
         IF(LGONE) THEN
*----
*  UNIQUE TABULATED TEMPERATURE.
*----
             TAUX(IGSSC,1)=ABSOH(IGSSC,NSEQHO)
             TAUX(IGSSC,2)=DIFFH(IGSSC,NSEQHO)
             IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,NSEQHO)
             IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,NSEQHO)
           GOTO 110
         ENDIF
*----
*  MANY TABULATED TEMPERATURES.
*----
         IF(BACK.GE.SEQHO1)THEN
*
*           ASYMPTOTIC BEHAVIOR: REACTION RATES VARY LINEARLY WITH
*           1/SEQHOM FOR THE LAST 2 POINTS OF THE TABULATION
*
            IF(BACK.GT.SEQHO0) BACK=SEQHO0
            AUX=1.0/(BACK*(SEQHO0-SEQHO1))
            AUX1=SEQHO1*(SEQHO0-BACK)*AUX
            AUX2=SEQHO0*(SEQHO1-BACK)*AUX
            TAUX(IGSSC,1)=ABSOH(IGSSC,NSEQH1)*AUX1
     1                     -ABSOH(IGSSC,NSEQHO)*AUX2
            TAUX(IGSSC,2)=DIFFH(IGSSC,NSEQH1)*AUX1
     1                     -DIFFH(IGSSC,NSEQHO)*AUX2
            IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,NSEQH1)*AUX1
     1               -FISSH(IGSSC,NSEQHO)*AUX2
            IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,NSEQH1)*AUX1
     1               -FLUXH(IGSSC,NSEQHO)*AUX2
         ELSE
*
*           REACTION RATES VARY WITH THE SQRT OF THE BACKGROUND XSECT
*
            BACKH2=SQRT(BACK)
            ALLOCATE(SEQ2(NSEQHO),WEIGH(NINTSS))
            DO 60 I=1,NSEQHO
   60       SEQ2(I)=SQRT(SEQHOM(I))
            CALL LIBA28(BACKH2,SEQ2,NSEQHO,NINTSS,WEIGH,IORD,IPR,I0)
            DO 70 ISEQHO=1,NSEQHO
              IF(ABS(BACK-SEQHOM(ISEQHO)).LE.1.E-2) THEN
                TAUX(IGSSC,1)=ABSOH(IGSSC,ISEQHO)
                TAUX(IGSSC,2)=DIFFH(IGSSC,ISEQHO)
                IF(LFIS) TAUX(IGSSC,3)=FISSH(IGSSC,ISEQHO)
                IF(L104) TAUX(IGSSC,4)=FLUXH(IGSSC,ISEQHO)
                DEALLOCATE(WEIGH,SEQ2)
                GOTO 110
              ENDIF
   70       CONTINUE
            SUMA=0.
            SUMS=0.
            SUMF=0.
            SUM104=0.
            DO 80 I=1,IORD
            I1=I+I0
            SUMA=SUMA+WEIGH(I)*ABSOH(IGSSC,I1)
            SUMS=SUMS+WEIGH(I)*DIFFH(IGSSC,I1)
            IF(LFIS) SUMF=SUMF+WEIGH(I)*FISSH(IGSSC,I1)
            IF(L104) SUM104=SUM104+WEIGH(I)*FLUXH(IGSSC,I1)
   80       CONTINUE
            DO 90 I=1,IORD
              I1=I+I0
              IF(SEQHOM(I1).GT.BACK) THEN
                IF(I1-1.GT.0) THEN
*
*               ABSORPTION RATE CRITERION.
*
                YMIN=MIN(ABSOH(IGSSC,I1-1),ABSOH(IGSSC,I1))
                YMAX=MAX(ABSOH(IGSSC,I1-1),ABSOH(IGSSC,I1))
                IF((SUMA.GT.YMAX) .OR. (SUMA.LT.YMIN)) THEN
                  RNTERP=SUMA
                  SUMA=ABSOH(IGSSC,I1-1)+
     1            (ABSOH(IGSSC,I1)-ABSOH(IGSSC,I1-1))*
     1            (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1))
                  REL = (RNTERP-SUMA)/SUMA
                  IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN
                    WRITE(TEXTE,10000)
     1              'ABS. G=',IGG,' DIL=',BACK,
     1              ' INT. LIN. --> ERR. RELA.=',REL
                      WRITE(6,'(/1X,A)') TEXTE
                    ENDIF
                  ENDIF
*
*               SCATTERING RATE CRITERION.
*
                YMIN = MIN(DIFFH(IGSSC,I1-1),DIFFH(IGSSC,I1))
                YMAX = MAX(DIFFH(IGSSC,I1-1),DIFFH(IGSSC,I1))
                IF((SUMS.GT.YMAX) .OR. (SUMS.LT.YMIN)) THEN
                  RNTERP=SUMS
                  SUMS=DIFFH(IGSSC,I1-1)+
     1                 (DIFFH(IGSSC,I1)-DIFFH(IGSSC,I1-1))*
     1                 (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1))
                  REL = (RNTERP-SUMS)/SUMS
                  IF(REL.GE. 0.1 .OR. IMPX .GT. 3) THEN
                    WRITE(TEXTE,10000)
     1              'DIF. G=',IGG,' DIL=',BACK,
     1              ' INT. LIN. --> ERR. RELA.=',REL
                      WRITE(6,'(/1X,A)') TEXTE
                   ENDIF
                  ENDIF
*
*               PRODUCTION RATE CRITERION.
*
                IF(LFIS) THEN
                  YMIN = MIN(FISSH(IGSSC,I1-1),FISSH(IGSSC,I1))
                  YMAX = MAX(FISSH(IGSSC,I1-1),FISSH(IGSSC,I1))
                  IF((SUMF.GT.YMAX) .OR. (SUMF.LT.YMIN)) THEN
                    RNTERP=SUMF
                    SUMF=FISSH(IGSSC,I1-1)+
     1                   (FISSH(IGSSC,I1)-FISSH(IGSSC,I1-1))*
     1                   (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1))
                    REL = (RNTERP-SUMF)/SUMF
                    IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN
                      WRITE(TEXTE,10000)
     1                'FIS. G=',IGG,' DIL=',BACK,
     1                ' INT. LIN. --> ERR. RELA.=',REL
                      WRITE(6,'(/1X,A)') TEXTE
                      ENDIF
                    ENDIF
                  ENDIF
*
*               TEST FLUX 104
*
                IF(L104) THEN
                  YMIN = MIN(FLUXH(IGSSC,I1-1),FLUXH(IGSSC,I1))
                  YMAX = MAX(FLUXH(IGSSC,I1-1),FLUXH(IGSSC,I1))
                  IF((SUM104.GT.YMAX) .OR. (SUM104.LT.YMIN)) THEN
                    RNTERP=SUM104
                    SUM104=FLUXH(IGSSC,I1-1)+
     1                   (FLUXH(IGSSC,I1)-FLUXH(IGSSC,I1-1))*
     1                   (BACKH2-SEQ2(I1-1))/(SEQ2(I1)-SEQ2(I1-1))
                    REL = (RNTERP-SUM104)/SUM104
                    IF(REL.GE.0.1 .OR. IMPX .GT. 3) THEN
                      WRITE(TEXTE,10000)
     1                'FIS. G=',IGG,' DIL=',BACK,
     1                ' INT. LIN. --> ERR. RELA.=',REL
                      WRITE(6,'(/1X,A)') TEXTE
                      ENDIF
                    ENDIF
                  ENDIF
*
                ELSE
                  SUMA=ABSOH(IGSSC,1)+
     1                 (ABSOH(IGSSC,2)-ABSOH(IGSSC,1))*
     1                 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1))
                  IF(SUMA.LE.0.) THEN
                    SUMA=ABSOH(IGSSC,1)
                    WRITE(TEXTE,3000)
     1              ' DIL. : ',BACK, ' TROP PETITE ',
     2              'TAUX ABS. NON EXTRAPOLES GR. ',IGG
                    WRITE(6,'(/1X,A)') TEXTE
                    ENDIF
*
                  SUMS=DIFFH(IGSSC,1)+
     1                 (DIFFH(IGSSC,2)-DIFFH(IGSSC,1))*
     1                 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1))
                  IF(SUMS.LE.0.) THEN
                    SUMS=DIFFH(IGSSC,1)
                    WRITE(TEXTE,3000)
     1              ' DIL. : ',BACK, ' TROP PETITE ',
     2              'TAUX DIFF. NON EXTRAPOLES GR. ',IGG
                    WRITE(6,'(/1X,A)') TEXTE
                    ENDIF
*
                  IF(LFIS) SUMF=FISSH(IGSSC,1)+
     1                 (FISSH(IGSSC,2)-FISSH(IGSSC,1))*
     1                 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1))
                  IF(LFIS.AND.SUMF.LE.0.) THEN
                    SUMF=FISSH(IGSSC,1)
                    WRITE(TEXTE,3000)
     1              ' DIL. : ',BACK, ' TROP PETITE ',
     2              'TAUX PROD. NON EXTRAPOLES GR. ',IGG
                    WRITE(6,'(/1X,A)') TEXTE
                    ENDIF
*
                  IF(L104) SUM104=FLUXH(IGSSC,1)+
     1                 (FLUXH(IGSSC,2)-FLUXH(IGSSC,1))*
     1                 (BACKH2-SEQ2(1))/(SEQ2(2)-SEQ2(1))
                  IF(L104.AND.SUM104.LE.0.) THEN
                    SUM104=FLUXH(IGSSC,1)
                    WRITE(TEXTE,3000)
     1              ' DIL. : ',BACK, ' TROP PETITE ',
     2              'TAUX PROD. NON EXTRAPOLES GR. ',IGG
                    WRITE(6,'(/1X,A)') TEXTE
                    ENDIF
                  ENDIF
                GOTO 100
              ENDIF
   90       CONTINUE
*
  100       TAUX(IGSSC,1)=SUMA
            TAUX(IGSSC,2)=SUMS
            IF(LFIS) TAUX(IGSSC,3)=SUMF
            IF(L104) TAUX(IGSSC,4)=SUM104
            IF(SUMA.LE.0.) THEN
              WRITE(TEXTE,1000)
     1        'GROUPE ',IGG,' DIL. ',BACK,' ABS. <= 0.'
              CALL XABORT('LIBA24:'//TEXTE)
            ENDIF
            IF(SUMS.LE.0.) THEN
              WRITE(TEXTE,1000)
     1        'GROUPE ',IGG,' DIL. ',BACK,' DIF. <= 0.'
              CALL XABORT('LIBA24:'//TEXTE)
            ENDIF
            IF(LFIS .AND. SUMF.LE.0.) THEN
              WRITE(TEXTE,1000)
     1        'GROUPE ',IGG,' DIL. ',BACK,' FIS. <= 0.'
              CALL XABORT('LIBA24:'//TEXTE)
            ENDIF
            IF(L104 .AND. (1.-SUM104/BACK).LE.0.) THEN
              WRITE(TEXTE,1000)
     1        'GROUPE ',IGG,' DIL. ',BACK,' FLU. <= 0.'
              CALL XABORT('LIBA24:'//TEXTE)
            ENDIF
            DEALLOCATE(WEIGH,SEQ2)
         ENDIF
  110 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(FLUXH,FISSH,DIFFH,ABSOH,SQRTEM,WEIJHT)
      RETURN
*
1000  FORMAT(A,I3,A,E13.5,A)
3000  FORMAT(A,E13.5,A,A,I3)
10000 FORMAT(A,I3,A,1P,E13.5,A,E13.5)
      END
