*DECK EVOSIG
      SUBROUTINE EVOSIG(IPLIB,IMPX,INR,IGLOB,NGROUP,NREGIO,NBMIX,NBISO,
     1 NCOMB,ISONAM,DEN,MAT,VOL,FLUXES,VX,MILVO,JM,NVAR,NSUPS,NREAC,
     2 NFISS,HREAC,IDR,RER,RRD,FIT,FUELDN,NXSPER,DELTAT,PFACT,SIG,VPHV,
     3 KFISS,FLX,XSREC,VTOTD,MIXPWR,MILPW)
*
*-----------------------------------------------------------------------
*
*Purpose:
* compute and normalize the microscopic depletion reaction rates.
*
*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
* IPLIB   pointer to the lattice microscopic cross section library
*         (L_LIBRARY signature).
* IMPX    print flag (equal to zero for no print).
* INR     type of flux normalization:
*         =0: out-of-core depletion;
*         =1: constant flux depletion;
*         =2: constant fuel power depletion;
*         =3: constant assembly power depletion.
* IGLOB   out-of-fuel power in flux normalization:
*         =0: compute the burnup using the power released in the fuel;
*         =1: compute the burnup using the power released in the global
*         geometry.
* NGROUP  number of energy groups.
* NREGIO  number of volumes.
* NBMIX   number of mixtures.
* NBISO   number of isotopes/materials including non-depleting ones.
* NCOMB   number of depleting mixtures.
* ISONAM  alias name of isotopes.
* DEN     density of each isotope.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* FLUXES  neutron fluxes.
* VX      volumes of the depleting mixtures.
* MILVO   mixture index corresponding to each depleting mixture.
* JM      position in isotope list of each nuclide of the depletion
*         chain. A negative value indicates a non-depleting isotope
*         producing energy.
* NVAR    number of depleting nuclides.
* NSUPS   number of non-depleting isotopes producing energy.
* NREAC   maximum number of depletion reactions.
* NFISS   number of fissile isotopes producing fission products.
* HREAC   names of used depletion reactions:
*         HREAC(1)='DECAY'; HREAC(2)='NFTOT';
*         HREAC(3)='NG'   ; HREAC(4)='N2N';  etc.
* IDR     identifier for each depleting reaction.
* RER     energy (Mev) per reaction. If RER(3,J)=0., the fission energy
*         is including radiative capture energy. Neutrino energy is
*         never included.
* RRD     sum of radioactive decay constants in 10**-8/s.
* FIT     flux normalization factor:
*         n/cm**2/s if INR=1;
*         MW/tonne of initial heavy elements if INR=2;
*         W/cc of assembly volume if INR=3.
* FUELDN  fuel initial density and mass.
* NXSPER  perturbation order for cross sections.
* DELTAT  perturbation coefficients for cross sections.
*
*Parameters: output
* PFACT   form factor for out-of-fuel power production.
* SIG     microscopic reaction rates for nuclide I in mixture IBM:
*         SIG(I,1,IBM) fission reaction rate;
*         SIG(I,2,IBM) gamma reaction rate;
*         SIG(I,3,IBM) N2N reaction rate;
*         cont...;
*         SIG(I,NREAC,IBM) neutron-induced energy released;
*         SIG(I,NREAC+1,IBM) decay energy released (10**-8 MeV/s).
* VPHV    integrated fluxes in mixtures.
* VTOTD   Total volume.
* MIXPWR  flags for mixtures to include in power normalization.
* MILPW   mixture index corresponding to each depleting mixture
*         contributing to flux and power normalization.
*
*Parameters: scratch
* KFISS
* FLX
* XSREC
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPLIB,IMPX,INR,IGLOB,NGROUP,NREGIO,NBMIX,NBISO,NCOMB,
     1 ISONAM(3,NBISO),MAT(NREGIO),MILVO(NCOMB),JM(NBMIX,NVAR+NSUPS),
     2 NVAR,NSUPS,NREAC,NFISS,HREAC(2,NREAC),IDR(NREAC,NVAR+NSUPS),
     3 NXSPER,KFISS(NFISS)
      REAL DEN(NBISO),VOL(NREGIO),FLUXES(NREGIO,NGROUP),VX(NBMIX),
     1 RER(NREAC,NVAR+NSUPS),RRD(NVAR+NSUPS),FIT,FUELDN(3),DELTAT(2),
     2 PFACT,SIG(NVAR+1,NREAC+1,NBMIX),VPHV(NBMIX),FLX(NGROUP,NBMIX),
     3 XSREC(NGROUP,NREAC-1)
      DOUBLE PRECISION VTOTD
      INTEGER MIXPWR(NBMIX),MILPW(NCOMB)
*----
*  LOCAL VARIABLES
*----
      PARAMETER(IOUT=6,MAXREA=20)
      CHARACTER HNAMIS*12,HSMG*131,NAMDXS(MAXREA)*6
      LOGICAL LFISS
      DOUBLE PRECISION GAR,GAR1,GAR2,GARD,XDRCST,EVJ
      COMMON BASE(1)
      INTEGER IPRLOC
*
      IPRLOC=0
      DO 20 IBM=1,NBMIX
      VPHV(IBM)=0.0
      DO 20 IU=1,NGROUP
      FLX(IU,IBM)=0.0
      IF(VX(IBM).NE.0.0) THEN
         DO 10 I=1,NREGIO
         IF(MAT(I).EQ.IBM) FLX(IU,IBM)=FLX(IU,IBM)+FLUXES(I,IU)*VOL(I)
   10    CONTINUE
         FLX(IU,IBM)=FLX(IU,IBM)/VX(IBM)
      ENDIF
   20 CONTINUE
*
      EVJ=XDRCST('eV','J')*1.0E22
      CALL XDISET(KFISS,NFISS,0)
      DO 30 IS=1,NVAR
      KDRI=IDR(2,IS)/100
      IF((KDRI.GT.0).AND.(MOD(IDR(2,IS),100).EQ.4)) THEN
         IF(KDRI.GT.NFISS) CALL XABORT('EVOSIG: INVALID NFISS.')
         KFISS(KDRI)=IS
      ENDIF
   30 CONTINUE
      VPH=0.0
      DO IU=1,NGROUP
        DO IBM=1,NBMIX
          VPHV(IBM)=VPHV(IBM)+VX(IBM)*FLX(IU,IBM)
        ENDDO
        DO ICMB=1,NCOMB
          IBM=MILVO(ICMB)
          IF(MILPW(ICMB) .EQ. 1) VPH=VPH+VX(IBM)*FLX(IU,IBM)
        ENDDO
      ENDDO
      DO 60 IBM=1,NBMIX
      DO 60 IQ=1,NREAC+1
      DO 60 IS=1,NVAR+1
   60 SIG(IS,IQ,IBM)=0.0
      IF(NREAC-1.GT.MAXREA) CALL XABORT('EVOSIG: MAXREA OVERFLOW.')
      DO 70 IREAC=2,NREAC
      WRITE(NAMDXS(IREAC-1),'(A4,A2)') HREAC(1,IREAC),HREAC(2,IREAC)
   70 CONTINUE
      DO 220 IBM=1,NBMIX
      DO 220 IST=1,NVAR+NSUPS
      LFISS=.FALSE.
      DO 80 IFIS=1,NFISS
   80 LFISS=LFISS.OR.(KFISS(IFIS).EQ.IST)
      K=JM(IBM,IST)
      IF(K.EQ.0) THEN
         GO TO 220
      ELSE IF(K.GT.0) THEN
*        DEPLETING ISOTOPE.
         IS=IST
         FACT=1.0
      ELSE
*        STABLE ISOTOPE PRODUCING ENERGY.
         K=-K
         IS=NVAR+1
         FACT=DEN(K)*VX(IBM)
      ENDIF
      SIG(IS,NREAC+1,IBM)=SIG(IS,NREAC+1,IBM)+FACT*RER(1,IST)*RRD(IST)
      IF(INR.EQ.0) GO TO 220
*----
*  RECOVER MULTIGROUP XS
*----
      WRITE(HNAMIS,'(3A4)') (ISONAM(I0,K),I0=1,3)
      CALL LCMSIX(IPLIB,HNAMIS,1)
      DO 140 IXSPER=1,NXSPER
      CALL XDRLXS(IPLIB,-1,IPRLOC,NREAC-1,NAMDXS,IXSPER,NGROUP,XSREC)
      DO 140 IREAC=2,NREAC
      CALL LCMLEN(IPLIB,NAMDXS(IREAC-1),LENGT,ITYLCM)
      IF((LENGT.NE.NGROUP).AND.(IDR(IREAC,IST).GT.0)) THEN
         IF((IREAC.EQ.2).AND.(MOD(IDR(2,IST),100).EQ.5)) GO TO 120
         IF(IMPX.GT.90) CALL LCMLIB(IPLIB)
         IF(IMPX.GT.3) THEN
            WRITE(HSMG,'(17HEVOSIG: REACTION ,A6,18H IS MISSING FOR IS,
     1      7HOTOPE '',A12,2H''.)') NAMDXS(IREAC-1),HNAMIS
            WRITE(IOUT,'(1X,A)') HSMG
         ENDIF
      ENDIF
  120 GAR=0.0D0
      DO 130 IU=1,NGROUP
  130 GAR=GAR+DBLE(XSREC(IU,IREAC-1)*FLX(IU,IBM))
      SIG(IS,IREAC-1,IBM)=SIG(IS,IREAC-1,IBM)+1.0E-3*FACT*GAR*
     1 DELTAT(IXSPER)
      SIG(IS,NREAC,IBM)=SIG(IS,NREAC,IBM)+1.0E-3*FACT*RER(IREAC,IST)*
     1 GAR*DELTAT(IXSPER)
  140 CONTINUE
      CALL LCMSIX(IPLIB,' ',2)
  220 CONTINUE
*----
*  CONSTANT FLUX OR CONSTANT POWER NORMALIZATION
*----
      PFACT=1.0
      IF(INR.EQ.1) THEN
         PHI=FIT*1.E-13
      ELSE IF(INR.GE.2) THEN
         GAR=0.0D0
         GARD=0.0D0
         DO ICMB=1,NCOMB
           IBM=MILVO(ICMB)
           IF(MILPW(ICMB) .EQ. 1) THEN
             DO IS=1,NVAR
               IF(JM(IBM,IS).GT.0) THEN
                GAR=GAR+VX(IBM)*DEN(JM(IBM,IS))*SIG(IS,NREAC,IBM)
                GARD=GARD+VX(IBM)*DEN(JM(IBM,IS))*SIG(IS,NREAC+1,IBM)
               ENDIF
             ENDDO
           ENDIF
         ENDDO
         GAR1=GAR
         DO ICMB=1,NCOMB
           IF(MILPW(ICMB) .EQ. 1) THEN
             GAR1=GAR1+SIG(NVAR+1,NREAC,MILVO(ICMB))
           ENDIF
         ENDDO
         GAR2=GAR
         DO IBM=1,NBMIX
           IF(MIXPWR(IBM) .EQ. 1) THEN
             GAR2=GAR2+SIG(NVAR+1,NREAC,IBM)
           ENDIF
         ENDDO
         PFACT=GAR2/GAR1
         IF((IGLOB.EQ.1).OR.(INR.EQ.3)) THEN
            GAR=GAR2
         ELSE IF(IGLOB.EQ.0) THEN
            GAR=GAR1
         ENDIF
         IF(GAR.EQ.0.0D0) CALL XABORT('EVOSIG: UNABLE TO NORMALIZE.')
         IF(INR.EQ.2) THEN
*           FITD IS THE DECAY POWER IN WATT PER GRAM.
            FITD=(EVJ*GARD)/(FUELDN(1)*VTOTD)
            IF(FITD.GT.FIT) THEN
               WRITE(HSMG,'(35HEVOSIG: NEGATIVE FIT(1) FIT(DECAY)=,1P,
     1         E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT
               CALL XABORT(HSMG)
            ENDIF
            PHI=(FIT-FITD)*FUELDN(1)*VPH/(EVJ*GAR)
         ELSE IF(INR.EQ.3) THEN
*           FITD IS THE DECAY POWER IN WATT PER CUBIC CENTIMETER.
            FITD=(EVJ*GARD*FUELDN(3))/(FUELDN(1)*VTOTD)
            IF(FITD.GT.FIT) THEN
               WRITE(HSMG,'(35HEVOSIG: NEGATIVE FIT(2) FIT(DECAY)=,1P,
     1         E11.4,12H FIT(INPUT)=,E11.4,1H.)') FITD,FIT
               CALL XABORT(HSMG)
            ENDIF
            PHI=(FIT-FITD)*FUELDN(1)*VPH/(EVJ*GAR*FUELDN(3))
         ENDIF
      ENDIF
      IF(INR.GT.0) THEN
         FNORM=PHI*VTOTD/VPH
         DO 270 IBM=1,NBMIX
         VPHV(IBM)=VPHV(IBM)*FNORM
         DO 270 IQ=1,NREAC
         DO 270 IS=1,NVAR+1
  270    SIG(IS,IQ,IBM)=SIG(IS,IQ,IBM)*FNORM
      ENDIF
*----
*  Print microscopic and total fission rate
*----
      IF(IMPX .LE. -2) THEN
        WRITE(IOUT,6000) 
        DO ICMB=1,NCOMB
          IBM=MILVO(ICMB)
          WRITE(IOUT,6001) IBM
          DO IST=1,NVAR
            LFISS=.FALSE.
            DO IFIS=1,NFISS
              LFISS=LFISS.OR.(KFISS(IFIS).EQ.IST)
            ENDDO
            IF(LFISS) THEN
              K=JM(IBM,IST)
              IF(K.GT.0) THEN
                IS=IST
                FACT=DEN(K)*VX(IBM)
                IF(INR.NE.0) THEN
                  WRITE(HNAMIS,'(2A4)') (ISONAM(I0,K),I0=1,2)
                  WRITE(IOUT,6002) HNAMIS,SIG(IS,1,IBM)*1.E-8,
     >                             SIG(IS,1,IBM)*FACT*1.0E16
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDIF
      RETURN
*----
*  Formats
*----
 6000 FORMAT('Microscopic and total fission rate (decay/s)')
 6001 FORMAT('Mixture ',I4/
     >'Isotope     ',5X,'  Per atom',5X,'In mixture') 
 6002 FORMAT(A12,5X,1P,E10.3,5X,E10.3)
      END
