*DECK SAPCA2
      SUBROUTINE SAPCA2(IPSAP,IPEDIT,NREA,NISO,NMAC,NADRX,NED,NPRC,NG,
     1 NL,ITRANC,IMC,NMIL,NBISO,ICAL,MAXRDA,MAXIDA,FNORM,LCRON,NISOTS,
     2 NMILNR,NISFS,NISPS,NISYS,REGFLX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover the cross sections of an elementary calculation.
*
*Copyright:
* Copyright (C) 2007 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
* IPSAP   pointer to the Saphyb.
* IPEDIT  pointer to the edition object (L_EDIT signature).
* NREA    number of requested reactions.
* NISO    number of particularized isotopes.
* NMAC    number of macros.
* NADRX   total number of ADRX sets.
* NED     number of additional edition cross sections.
* NPRC    number of delayed neutron precursors.
* NG      number of condensed energy groups.
* NL      number of Legendre orders.
* ITRANC  type of transport correction.
* IMC     type of macro-calculation (1 for diffusion or SPN;
*         2 other method).
* NMIL    number of mixtures in the Saphyb.
* NBISO   number of isotopes in the condensed microlib of the edition
*         object. A given isotope may appear in many mixtures.
* ICAL    index of the current elementary calculation.
* MAXRDA  dimension of RDATAX array.
* MAXIDA  dimension of IDATAP array.
* FNORM   flux normalization factor.
* LCRON   flag set to .TRUE. to put kinetics data into divers directory.
*
*Parameters: output
* NISOTS  number of distinct isotopes.
* NMILNR  number of mixtures with delayed neutron data.
* NISFS   number of particularized fissile isotopes.
* NISPS   number of particularized fission products.
* NISYS   number of particularized fissile isotopes, fission products
*         and macros.
* REGFLX  averaged flux in the complete geometry.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPSAP,IPEDIT
      INTEGER NREA,NISO,NMAC,NADRX,NED,NPRC,NG,NL,ITRANC,IMC,NMIL,NBISO,
     1 ICAL,MAXRDA,MAXIDA,NISOTS,NMILNR,NISFS,NISPS,NISYS
      REAL FNORM,REGFLX(NG)
      LOGICAL LCRON
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NREAK=20,MAXISO=800)
      TYPE(C_PTR) JPEDIT,KPEDIT,IPTEMP,KPTEMP
      INTEGER FGYS(2)
      REAL VALDIV(3)
      CHARACTER NOMREA(NREAK)*12,NOMISO(MAXISO)*8,ISOTS(MAXISO)*8,
     1 DIRNAM*12,CM*2,TEXT8*8,TEXT12*12,IDVAL(3)*4,HSMG*131
      LOGICAL EXIST,LSPH
      DOUBLE PRECISION CONV
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: RESMAC,NISOMN,ISADRX,LENGDX,
     1 LENGDP,IDATAP,IFDG,IADR,IFDG2,IADR2,IJJ1,NJJ1,IPOS,IJJ2,NJJ2,MIX,
     2 ITYPE
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOMIL,ISONAM
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ADRX
      REAL, ALLOCATABLE, DIMENSION(:) :: RDATAX,FLUX,OVERV,WORKD,WORK1,
     1 WORK2,VOL,DEN,DENISO,CONCES,DECAYC
      REAL, ALLOCATABLE, DIMENSION(:,:) :: DNUSIG,DCHI,DATA1,DATA2,
     1 DATA4,SPH
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DATA3
      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(RESMAC(NMIL),ADRX(NREA+2,NISO+NMAC,NADRX+NMIL),
     1 ISOMIL(NISO+NMAC,NMIL),NISOMN(NMIL),ISADRX(NMIL),LENGDX(NMIL),
     2 LENGDP(NMIL),IDATAP(MAXIDA),IFDG(NG),IADR(NG+1),IFDG2(NG),
     3 IADR2(NG+1),IJJ1(NMIL),NJJ1(NMIL),IPOS(NMIL),IJJ2(NG),NJJ2(NG),
     4 ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO))
      ALLOCATE(RDATAX(MAXRDA),FLUX(NG),OVERV(NG),DNUSIG(NG,NPRC+1),
     1 DCHI(NG,NPRC),WORKD(NPRC),WORK1(NG*NMIL+1),WORK2(NG),VOL(NMIL),
     2 DATA1(NG,NREA),DATA2(NG,NL),DATA3(NG,NG,NL),DATA4(NG,NG),
     3 DEN(NBISO),DENISO(NISO),CONCES(NBISO),DECAYC(NBISO))
*
      CONV=1.0D6 ! convert MeV to eV in H-FACTOR
      IF(NREA.GT.NREAK) CALL XABORT('SAPCA2: NOMREA OVERFLOW.')
*----
*  RECOVER INFORMATION FROM THE 'contenu' DIRECTORY.
*----
      CALL LCMSIX(IPSAP,'contenu',1)
      IF(NREA.GT.0) CALL LCMGTC(IPSAP,'NOMREA',12,NREA,NOMREA)
      IF(NISO.GT.0) CALL LCMGTC(IPSAP,'NOMISO',8,NISO,NOMISO)
      CALL LCMGET(IPSAP,'RESMAC',RESMAC)
      CALL LCMSIX(IPSAP,' ',2)
*----
*  RECOVER INFORMATION FROM THE 'geom' DIRECTORY.
*----
      CALL LCMSIX(IPSAP,'geom',1)
      CALL LCMGET(IPSAP,'XVOLMT',VOL)
      CALL LCMSIX(IPSAP,' ',2)
*----
*  RECOVER INFORMATION FROM THE 'adresses' DIRECTORY.
*----
      CALL LCMSIX(IPSAP,'adresses',1)
      CALL LCMLEN(IPSAP,'ADRX',ILONG,ITYLCM)
      IF(ILONG.GT.0) CALL LCMGET(IPSAP,'ADRX',ADRX)
      CALL LCMLEN(IPSAP,'NISOMN',ILONG,ITYLCM)
      IF(ILONG.GT.0) THEN
         CALL LCMGET(IPSAP,'NISOMN',NISOMN)
      ELSE
         NISOMN(:NMIL)=0
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
*----
*  SAVE INFORMATION TO THE 'constphysiq' DIRECTORY.
*----
      IF(ICAL.EQ.1) THEN
         CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM)
         IF(ILONG.EQ.0) THEN
            CALL LCMSIX(IPEDIT,'MACROLIB',1)
            CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM)
            IF(ILONG.NE.NG+1) CALL XABORT('SAPCA2: BAD VALUE OF NG(1).')
            CALL LCMGET(IPEDIT,'ENERGY',WORK1)
            CALL LCMSIX(IPEDIT,' ',2)
         ELSE
            IF(ILONG.NE.NG+1) CALL XABORT('SAPCA2: BAD VALUE OF NG(2).')
            CALL LCMGET(IPEDIT,'ENERGY',WORK1)
         ENDIF
         CALL LCMSIX(IPSAP,'constphysiq',1)
         DO 10 I=1,NG+1
         WORK1(I)=WORK1(I)*1.0E-6
   10    CONTINUE
         CALL LCMPUT(IPSAP,'ENRGS',NG+1,2,WORK1)
         FGYS(1)=1
         FGYS(2)=NG+1
         CALL LCMPUT(IPSAP,'FGYS',2,1,FGYS)
         CALL LCMSIX(IPSAP,' ',2)
      ENDIF
*----
*  MOVE TO THE 'calc' DIRECTORY.
*----
      WRITE(DIRNAM,'(''calc'',I8)') ICAL
      CALL LCMSIX(IPSAP,DIRNAM,1)
*----
*  FIND THE NUMBER AND NAMES OF THE ISOTOPES IN THE OUTPUT TABLES.
*----
      IF(NBISO.GT.0) THEN
         CALL LCMGET(IPEDIT,'ISOTOPESUSED',ISONAM)
         CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX)
         CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN)
         CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE)
      ENDIF
      NISOTS=0
      DO 30 IBISO=1,NBISO
      IF(MIX(IBISO).EQ.0) GO TO 30
      WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
      DO 20 ISO=1,NISOTS
      IF(TEXT12(:8).EQ.ISOTS(ISO)) GO TO 30
   20 CONTINUE
      NISOTS=NISOTS+1
      IF(NISOTS.GT.MAXISO) CALL XABORT('SAPCA2: ISOTS OVERFLOW.')
      IF(NISOTS.GT.NBISO) CALL XABORT('SAPCA2: CONCES OVERFLOW.')
      ISOTS(NISOTS)=TEXT12(:8)
   30 CONTINUE
*----
*  RECOVER INVERSE OF SPH EQUIVALENCE FACTORS.
*----
      CALL LCMSIX(IPEDIT,'MACROLIB',1)
      JPEDIT=LCMGID(IPEDIT,'GROUP')
      LSPH=.FALSE.
      ALLOCATE(SPH(NMIL,NG))
      DO 35 IGR=1,NG
      KPEDIT=LCMGIL(JPEDIT,IGR)
      CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM)
      IF(ILONG.GT.0) THEN
         LSPH=.TRUE.
         CALL LCMGET(KPEDIT,'NSPH',WORK1)
         DO 33 IMIL=1,NMIL
         SPH(IMIL,IGR)=1.0/WORK1(IMIL)
   33    CONTINUE
      ELSE
         DO 34 IMIL=1,NMIL
         SPH(IMIL,IGR)=1.0
   34    CONTINUE
      ENDIF
   35 CONTINUE
      CALL LCMSIX(IPEDIT,' ',2)
*----
*  CREATE A SPH-UNCORRECTED MICROLIB.
*----
      CALL LCMOP(IPTEMP,'*TEMPORARY*',0,1,0)
      ALLOCATE(IPISO(NBISO))
      CALL LCMEQU(IPEDIT,IPTEMP)
      IF(LSPH) THEN
        IF(IMC.EQ.0) CALL XABORT('SAPCA2: UNDEFINED TYPE OF SPH.')
        NW=1 ! NTOT1 cross section present
        NALBP=0 ! no albedo correction
        CALL SPHCMI(IPTEMP,0,IMC,NMIL,NBISO,NG,NL,NW,NED,NPRC,NALBP,SPH)
      ENDIF
      DEALLOCATE(SPH)
*----
*  LOOP OVER SAPHYB MIXTURES.
*----
      NMILNR=0
      REGFLX(1:NG)=0.0
      VOLTOT=0.0
      DO 500 IMIL=1,NMIL
      VOLTOT=VOLTOT+VOL(IMIL)
      IOR=0
      IOI=0
      IIS=0
      NISMAX=NMAC
      ISOMIL(:NISO+NMAC,IMIL)=0
      IADR(1)=1
*----
*  PROCESS MACROS.
*----
      CALL LCMSIX(IPTEMP,'MACROLIB',1)
      JPEDIT=LCMGID(IPTEMP,'GROUP')
      NVDIV=0
      CALL LCMLEN(IPTEMP,'K-EFFECTIVE',ILONG,ITYLCM)
      IF(ILONG.EQ.1) THEN
         CALL LCMGET(IPTEMP,'K-EFFECTIVE',FLOTT)
         NVDIV=NVDIV+1
         IDVAL(NVDIV)='KEFF'
         VALDIV(NVDIV)=FLOTT
      ENDIF
      CALL LCMLEN(IPTEMP,'K-INFINITY',ILONG,ITYLCM)
      IF(ILONG.EQ.1) THEN
         CALL LCMGET(IPTEMP,'K-INFINITY',FLOTT)
         NVDIV=NVDIV+1
         IDVAL(NVDIV)='KINF'
         VALDIV(NVDIV)=FLOTT
      ENDIF
      CALL LCMLEN(IPTEMP,'B2  B1HOM',ILONG,ITYLCM)
      IF(ILONG.EQ.1) THEN
         CALL LCMGET(IPTEMP,'B2  B1HOM',B2)
         IF(B2.EQ.0.0) B2=1.0E-10
         NVDIV=NVDIV+1
         IDVAL(NVDIV)='B2  '
         VALDIV(NVDIV)=B2
      ELSE
         B2=0.0
      ENDIF
      DATA2(:NG,:NL)=0.0
      DATA3(:NG,:NG,:NL)=0.0
*
      DO 90 IGR=1,NG
      KPEDIT=LCMGIL(JPEDIT,IGR)
*----
*  RECOVER THE NEUTRON FLUX.
*----
      CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1)
      FLUX(IGR)=WORK1(IMIL)*FNORM*1.0E13
      REGFLX(IGR)=REGFLX(IGR)+FLUX(IGR)
*----
*  RECOVER DELAYED NEUTRON INFORMATION.
*----
      CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM)
      IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN
         CALL LCMGET(KPEDIT,'NUSIGF',WORK1)
         DNUSIG(IGR,NPRC+1)=WORK1(IMIL)
         CALL LCMGET(KPEDIT,'OVERV',WORK1)
         OVERV(IGR)=WORK1(IMIL)
         DO 40 IPRC=1,NPRC
         WRITE(TEXT12,'(6HNUSIGF,I2.2)') IPRC
         CALL LCMGET(KPEDIT,TEXT12,WORK1)
         DNUSIG(IGR,IPRC)=WORK1(IMIL)
         WRITE(TEXT12,'(3HCHI,I2.2)') IPRC
         CALL LCMGET(KPEDIT,TEXT12,WORK1)
         DCHI(IGR,IPRC)=WORK1(IMIL)
   40    CONTINUE
      ELSE
         DNUSIG(IGR,:NPRC+1)=0.0
      ENDIF
*
      DO 80 IREA=1,NREA
      DATA1(IGR,IREA)=0.0
      IF(NOMREA(IREA).EQ.'TOTALE') THEN
         CALL LCMGET(KPEDIT,'NTOT0',WORK1)
         DATA1(IGR,IREA)=WORK1(IMIL)
      ELSE IF(NOMREA(IREA).EQ.'TOTALE P1') THEN
         CALL LCMGET(KPEDIT,'NTOT1',WORK1)
         DATA1(IGR,IREA)=WORK1(IMIL)
      ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN
         CALL LCMGET(KPEDIT,'NTOT0',WORK1)
         DATA1(IGR,IREA)=WORK1(IMIL)
         CALL LCMLEN(KPEDIT,'SIGS00',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'SIGS00',WORK1)
            DATA1(IGR,IREA)=DATA1(IGR,IREA)-WORK1(IMIL)
         ENDIF
         CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N2N',WORK1)
            DATA1(IGR,IREA)=DATA1(IGR,IREA)+WORK1(IMIL)
         ENDIF
         CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N3N',WORK1)
            DATA1(IGR,IREA)=DATA1(IGR,IREA)+2.0*WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'EXCESS') THEN
         CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N2N',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
         CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N3N',WORK1)
            DATA1(IGR,IREA)=DATA1(IGR,IREA)+2.0*WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'FISSION') THEN
         CALL LCMLEN(KPEDIT,'NFTOT',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'NFTOT',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'SPECTRE') THEN
         CALL LCMLEN(KPEDIT,'CHI',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'CHI',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'NU*FISSION') THEN
         CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'NUSIGF',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'ENERGIE') THEN
         CALL LCMLEN(KPEDIT,'H-FACTOR',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'H-FACTOR',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)/REAL(CONV)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN
         CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            IF(B2.EQ.0.0) B2=1.0E-10
            CALL LCMGET(KPEDIT,'DIFF',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)*B2
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'STRD') THEN
         CALL LCMLEN(KPEDIT,'DIFF',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'DIFF',WORK1)
            DATA1(IGR,IREA)=1.0/(3.0*WORK1(IMIL))
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'SELF') THEN
         CALL LCMGET(KPEDIT,'SIGW00',WORK1)
         DATA1(IGR,IREA)=WORK1(IMIL)
      ELSE IF(NOMREA(IREA).EQ.'DIFFUSION') THEN
         DO 50 IL=1,NL
         WRITE (CM,'(I2.2)') IL-1
         CALL LCMGET(KPEDIT,'SIGS'//CM,WORK1)
         DATA2(IGR,IL)=WORK1(IMIL)
   50    CONTINUE
         CALL LCMLEN(KPEDIT,'N2N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N2N',WORK1)
            DATA2(IGR,1)=DATA2(IGR,1)-WORK1(IMIL)
         ENDIF
         CALL LCMLEN(KPEDIT,'N3N',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,'N3N',WORK1)
            DATA2(IGR,1)=DATA2(IGR,1)-2.0*WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'TRANSP-CORR') THEN
         IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN
            CALL LCMGET(KPEDIT,'SIGS01',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ELSE IF(ITRANC.EQ.2) THEN
            CALL LCMGET(KPEDIT,'TRANC',WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
      ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN
         IFDG(IGR)=NG+1
         ILDG=0
         DO 60 IL=1,NL
         WRITE (CM,'(I2.2)') IL-1
         CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1)
         CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1)
         IFDG(IGR)=MIN(IFDG(IGR),IJJ1(IMIL)-NJJ1(IMIL)+1)
         ILDG=MAX(ILDG,IJJ1(IMIL))
   60    CONTINUE
         IADR(IGR+1)=IADR(IGR)+(ILDG-IFDG(IGR)+1)
      ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN
         DO 75 IL=1,NL
         WRITE (CM,'(I2.2)') IL-1
         CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ1)
         CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ1)
         CALL LCMGET(KPEDIT,'IPOS'//CM,IPOS)
         CALL LCMGET(KPEDIT,'SCAT'//CM,WORK1)
         IPO=IPOS(IMIL)
         J2=IJJ1(IMIL)
         J1=IJJ1(IMIL)-NJJ1(IMIL)+1
         DO 70 JGR=J2,J1,-1
         DATA3(JGR,IGR,IL)=WORK1(IPO)*REAL(2*IL-1)
         IPO=IPO+1
   70    CONTINUE
   75    CONTINUE
      ELSE
         CALL LCMLEN(KPEDIT,NOMREA(IREA),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            CALL LCMGET(KPEDIT,NOMREA(IREA),WORK1)
            DATA1(IGR,IREA)=WORK1(IMIL)
         ENDIF
      ENDIF
   80 CONTINUE
   90 CONTINUE
      CALL LCMSIX(IPTEMP,' ',2)
*----
*  FIND ISOTOPE POINTERS IN INPUT MICROLIB
*----
      CALL LIBIPS(IPTEMP,NBISO,IPISO)
*----
*  PROCESS PARTICULARIZED ISOTOPES
*----
      DO 105 IISO=1,NISO
      DO 100 IREA=1,NREA+2
      ADRX(IREA,IISO,NADRX+1)=0
  100 CONTINUE
  105 CONTINUE
      CONCES(:NISOTS)=0.0
      DECAYC(:NISOTS)=0.0
      DO 250 IBISO=1,NBISO
      IF(MIX(IBISO).EQ.IMIL) THEN
         WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
         DO 110 ISO=1,NISO
         IISO=ISO
         IF(NOMISO(ISO).EQ.TEXT12(:8)) GO TO 120
  110    CONTINUE
         GO TO 250
  120    KPTEMP=IPISO(IBISO) ! set IBISO-th isotope
         IF(.NOT.C_ASSOCIATED(KPTEMP)) THEN
           WRITE(HSMG,'(17HSAPCA2: ISOTOPE '',A12,7H'' (ISO=,I8,3H) I,
     1     32HS NOT AVAILABLE IN THE MICROLIB.)') TEXT12,IBISO
           CALL XABORT(HSMG)
         ENDIF
         IISOTS=0
         DO 130 ISO=1,NISOTS
         IISOTS=ISO
         IF(ISOTS(ISO).EQ.TEXT12(:8)) GO TO 135
  130    CONTINUE
         CALL XABORT('SAPCA2: UNABLE TO FIND ISOTOPE '//TEXT12//'.')
  135    CALL LCMLEN(KPTEMP,'DECAY',ILONG,ITYLCM)
         IF(ILONG.EQ.1) THEN
            CALL LCMGET(KPTEMP,'DECAY',DECAYC(IISOTS))
         ELSE
            DECAYC(IISOTS)=0.0
         ENDIF
         CONCES(IISOTS)=DEN(IBISO)
         DENISO(IISO)=DEN(IBISO)
         NISMAX=NISMAX+1
         IIS=IIS+1
         ISOMIL(IIS,IMIL)=IISO
         DO 240 IREA=1,NREA
         WORK2(:NG)=0.0
         IF(NOMREA(IREA).EQ.'TOTALE') THEN
            CALL LCMGET(KPTEMP,'NTOT0',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'TOTALE P1') THEN
            CALL LCMGET(KPTEMP,'NTOT1',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN
            CALL LCMGET(KPTEMP,'NTOT0',WORK2)
            CALL LCMLEN(KPTEMP,'SIGS00',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'SIGS00',WORK1)
               DO 140 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)-WORK1(IGR)
  140          CONTINUE
            ENDIF
            CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'N2N',WORK1)
               DO 150 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)+WORK1(IGR)
  150          CONTINUE
            ENDIF
            CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'N3N',WORK1)
               DO 151 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR)
  151          CONTINUE
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'EXCESS') THEN
            CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'N2N',WORK2)
            CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'N3N',WORK1)
               DO 152 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)+2.0*WORK1(IGR)
  152          CONTINUE
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'FISSION') THEN
            CALL LCMLEN(KPTEMP,'NFTOT',ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NFTOT',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'SPECTRE') THEN
            CALL LCMLEN(KPTEMP,'CHI',ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'CHI',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'NU*FISSION') THEN
            CALL LCMLEN(KPTEMP,'NUSIGF',ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'NUSIGF',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'ENERGIE') THEN
            CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'NFTOT',WORK2)
               CALL LCMGET(KPTEMP,'MEVF',FLOTT)
               DO 155 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)*FLOTT
  155          CONTINUE
            ENDIF
            CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'NG',WORK1)
               CALL LCMGET(KPTEMP,'MEVG',FLOTT)
               DO 160 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)+WORK1(IGR)*FLOTT
  160          CONTINUE
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'ENERGIE F.') THEN
            CALL LCMLEN(KPTEMP,'MEVF',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'NFTOT',WORK2)
               CALL LCMGET(KPTEMP,'MEVF',FLOTT)
               DO 165 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)*FLOTT
  165          CONTINUE
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'ENERGIE G.') THEN
            CALL LCMLEN(KPTEMP,'MEVG',ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'NG',WORK2)
               CALL LCMGET(KPTEMP,'MEVG',FLOTT)
               DO 170 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)*FLOTT
  170          CONTINUE
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'STRD') THEN
            CALL LCMLEN(KPTEMP,'STRD',ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,'STRD',WORK2)
         ELSE IF(NOMREA(IREA).EQ.'SELF') THEN
            IMPX=0
            CALL XDRLGS(KPTEMP,-1,IMPX,0,0,1,NG,WORK2,DATA4,ITYPRO)
            DO 175 IGR=1,NG
            WORK2(IGR)=DATA4(IGR,IGR)
  175       CONTINUE
         ELSE IF(NOMREA(IREA).EQ.'DIFFUSION') THEN
            ADRX(IREA,IISO,NADRX+1)=IOR+1
            ADRX(NREA+1,IISO,NADRX+1)=NL
            IOR=IOR+NG*NL
            IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(1).')
            DO 181 IL=1,NL
            WRITE (CM,'(I2.2)') IL-1
            CALL LCMLEN(KPTEMP,'SIGS'//CM,ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               CALL LCMGET(KPTEMP,'SIGS'//CM,WORK2)
            ELSE
               WORK2(:NG)=0.0
            ENDIF
            CALL LCMLEN(KPTEMP,'N2N',ILONG,ITYLCM)
            IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN
               CALL LCMGET(KPTEMP,'N2N',WORK1)
               DO 176 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)-WORK1(IGR)
  176          CONTINUE
            ENDIF
            CALL LCMLEN(KPTEMP,'N3N',ILONG,ITYLCM)
            IF((IL.EQ.1).AND.(ILONG.GT.0)) THEN
               CALL LCMGET(KPTEMP,'N3N',WORK1)
               DO 177 IGR=1,NG
               WORK2(IGR)=WORK2(IGR)-2.0*WORK1(IGR)
  177          CONTINUE
            ENDIF
            DO 180 IGR=1,NG
            RDATAX(ADRX(IREA,IISO,NADRX+1)+(IL-1)*NG+IGR-1)=WORK2(IGR)
  180       CONTINUE
  181       CONTINUE
            GO TO 240
         ELSE IF(NOMREA(IREA).EQ.'TRANSP-CORR') THEN
            IF((ITRANC.EQ.1).AND.(NL.GE.2)) THEN
               CALL LCMGET(KPTEMP,'SIGS01',WORK2)
            ELSE IF(ITRANC.EQ.2) THEN
               CALL LCMGET(KPTEMP,'TRANC',WORK2)
            ENDIF
         ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN
            DO 185 IGR=1,NG
            IFDG2(IGR)=NG+1
            IADR2(IGR+1)=0
  185       CONTINUE
            DO 190 IL=1,NL
            WRITE (CM,'(I2.2)') IL-1
            CALL LCMLEN(KPTEMP,'IJJS'//CM,ILONG,ITYLCM)
            IF(ILONG.EQ.0) GO TO 190
            CALL LCMGET(KPTEMP,'IJJS'//CM,IJJ2)
            CALL LCMGET(KPTEMP,'NJJS'//CM,NJJ2)
            DO 186 IGR=1,NG
            IFDG2(IGR)=MIN(IFDG2(IGR),IJJ2(IGR)-NJJ2(IGR)+1)
            IADR2(IGR+1)=MAX(IADR2(IGR+1),IJJ2(IGR))
  186       CONTINUE
  190       CONTINUE
            IADR2(1)=1
            DO 195 IGR=1,NG
            IADR2(IGR+1)=IADR2(IGR)+(IADR2(IGR+1)-IFDG2(IGR)+1)
  195       CONTINUE
            ADRX(IREA,IISO,NADRX+1)=IOI+1
            ADRX(NREA+2,IISO,NADRX+1)=NL
            IOI=IOI+2*NG+7
            IF(IOI.GT.MAXIDA) CALL XABORT('SAPCA2: IDATAP OVERFLOW(1).')
            IDATAP(ADRX(IREA,IISO,NADRX+1))=0
            IDATAP(ADRX(IREA,IISO,NADRX+1)+1)=0
            IDATAP(ADRX(IREA,IISO,NADRX+1)+2)=0
            IDATAP(ADRX(IREA,IISO,NADRX+1)+3)=0
            IDATAP(ADRX(IREA,IISO,NADRX+1)+4)=1
            IDATAP(ADRX(IREA,IISO,NADRX+1)+5)=NG
            DO 200 IGR=1,NG
            IDATAP(ADRX(IREA,IISO,NADRX+1)+5+IGR)=IFDG2(IGR)
            IDATAP(ADRX(IREA,IISO,NADRX+1)+5+NG+IGR)=IADR2(IGR)
  200       CONTINUE
            IDATAP(ADRX(IREA,IISO,NADRX+1)+6+2*NG)=IADR2(NG+1)
            GO TO 240
         ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN
            IF(IOI.EQ.0) CALL XABORT('SAPCA2: MUST FIRST DEFINE PROF.')
            ADRX(IREA,IISO,NADRX+1)=IOR+1
            IOR=IOR+(IADR2(NG+1)-1)*NL
            IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(2).')
            JOFS=0
            DO 212 IL=1,NL
            IMPX=0
            CALL XDRLGS(KPTEMP,-1,IMPX,IL-1,IL-1,1,NG,WORK2,DATA4,
     1      ITYPRO)
            ZIL=REAL(2*IL-1)
            DO 211 IGR=1,NG
            DO 210 JGR=IFDG2(IGR),IFDG2(IGR)+(IADR2(IGR+1)-IADR2(IGR))-1
            JOFS=JOFS+1
            RDATAX(ADRX(IREA,IISO,NADRX+1)+JOFS-1)=DATA4(IGR,JGR)*ZIL
  210       CONTINUE
  211       CONTINUE
  212       CONTINUE
            GO TO 240
         ELSE
            CALL LCMLEN(KPTEMP,NOMREA(IREA),ILONG,ITYLCM)
            IF(ILONG.GT.0) CALL LCMGET(KPTEMP,NOMREA(IREA),WORK2)
         ENDIF
*
         EXIST=.FALSE.
         DO 220 IGR=1,NG
         EXIST=EXIST.OR.(WORK2(IGR).NE.0.0)
  220    CONTINUE
         IF(EXIST) THEN
            ADRX(IREA,IISO,NADRX+1)=IOR+1
            IOR=IOR+NG
            IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(3).')
            DO 230 IGR=1,NG
            RDATAX(ADRX(IREA,IISO,NADRX+1)+IGR-1)=WORK2(IGR)
  230       CONTINUE
         ELSE
            ADRX(IREA,IISO,NADRX+1)=0
         ENDIF
  240    CONTINUE
      ENDIF
  250 CONTINUE
*----
*  STORE MACROSCOPIC CROSS SECTIONS IN RDATAX.
*----
      DO 260 IMAC=1,NMAC
      ADRX(NREA+1,NISO+IMAC,NADRX+1)=0
      ADRX(NREA+2,NISO+IMAC,NADRX+1)=0
  260 CONTINUE
      DO 340 IREA=1,NREA
      IF(NOMREA(IREA).EQ.'DIFFUSION') THEN
         DO 272 IMAC=1,NMAC
         ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1
         ADRX(NREA+1,NISO+IMAC,NADRX+1)=NL
         IOR=IOR+NG*NL
         IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(4).')
         JOFS=0
         DO 271 IL=1,NL
         DO 270 IGR=1,NG
         JOFS=JOFS+1
         RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+JOFS-1)=DATA2(IGR,IL)
  270    CONTINUE
  271    CONTINUE
  272    CONTINUE
      ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN
         DO 290 IMAC=1,NMAC
         ADRX(IREA,NISO+IMAC,NADRX+1)=IOI+1
         ADRX(NREA+2,NISO+IMAC,NADRX+1)=NL
         IOI=IOI+2*NG+7
         IF(IOI.GT.MAXIDA) CALL XABORT('SAPCA2: IDATAP OVERFLOW(2).')
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1))=0
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+1)=0
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+2)=0
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+3)=0
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+4)=1
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5)=NG
         DO 280 IGR=1,NG
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5+IGR)=IFDG(IGR)
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+5+NG+IGR)=IADR(IGR)
  280    CONTINUE
         IDATAP(ADRX(IREA,NISO+IMAC,NADRX+1)+6+2*NG)=IADR(NG+1)
  290    CONTINUE
      ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN
         IF(IOI.EQ.0) CALL XABORT('SAPCA2: MUST FIRST DEFINE PROF.')
         DO 303 IMAC=1,NMAC
         ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1
         IOR=IOR+(IADR(NG+1)-1)*NL
         IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(5).')
         JOFS=0
         DO 302 IL=1,NL
         DO 301 IGR=1,NG
         DO 300 JGR=IFDG(IGR),IFDG(IGR)+(IADR(IGR+1)-IADR(IGR))-1
         JOFS=JOFS+1
         RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+JOFS-1)=DATA3(JGR,IGR,IL)
  300    CONTINUE
  301    CONTINUE
  302    CONTINUE
  303    CONTINUE
      ELSE
         EXIST=.FALSE.
         DO 310 IGR=1,NG
         EXIST=EXIST.OR.(DATA1(IGR,IREA).NE.0.0)
  310    CONTINUE
         DO 330 IMAC=1,NMAC
         IF(EXIST) THEN
            ADRX(IREA,NISO+IMAC,NADRX+1)=IOR+1
            IOR=IOR+NG
            IF(IOR.GT.MAXRDA) CALL XABORT('SAPCA2: RDATAX OVERFLOW(6).')
            DO 320 IGR=1,NG
            RDATAX(ADRX(IREA,NISO+IMAC,NADRX+1)+IGR-1)=DATA1(IGR,IREA)
  320       CONTINUE
          ELSE
            ADRX(IREA,NISO+IMAC,NADRX+1)=0
         ENDIF
  330    CONTINUE
      ENDIF
  340 CONTINUE
      DO 350 IMAC=1,NMAC
      IIS=IIS+1
      ISOMIL(IIS,IMIL)=NISO+IMAC
  350 CONTINUE
*----
*  REMOVE PARTICULARIZED ISOTOPIC CONTRIBUTIONS FROM MACROS.
*----
      IF(RESMAC(IMIL).GT.0) THEN
         DO 410 IREA=1,NREA
         IMACR=ADRX(IREA,NISO+RESMAC(IMIL),NADRX+1)
         IF(IMACR.EQ.0) GO TO 410
         IGRTOT=NG
         IF(NOMREA(IREA).EQ.'DIFFUSION') IGRTOT=NG*NL
         IF(NOMREA(IREA).EQ.'SPECTRE') GO TO 410
         IF(NOMREA(IREA).EQ.'PROFIL') GO TO 410
         DO 400 IISO=1,NISO
         IF(DENISO(IISO).EQ.0.0) GO TO 400
         JMACR=ADRX(IREA,IISO,NADRX+1)
         IF(JMACR.EQ.0) GO TO 400
         IF(NOMREA(IREA).EQ.'TRANSFERT') THEN
            DO 370 IGR=1,NG
            IFDG2(IGR)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+5+IGR)
            IADR2(IGR)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+5+NG+IGR)
  370       CONTINUE
            IADR2(NG+1)=IDATAP(ADRX(IREA-1,IISO,NADRX+1)+6+2*NG)
            JOFS=0
            DO 382 IL=1,NL
            DO 381 IGR=1,NG
            DO 380 JGR=IFDG2(IGR),IFDG2(IGR)+(IADR2(IGR+1)-IADR2(IGR))-1
            I=(IL-1)*(IADR(NG+1)-1)+IADR(IGR)+JGR-IFDG(IGR)
            JOFS=JOFS+1
            RDATAX(IMACR+I-1)=RDATAX(IMACR+I-1)-DENISO(IISO)*
     1                        RDATAX(JMACR+JOFS-1)
  380       CONTINUE
  381       CONTINUE
  382       CONTINUE
         ELSE
            DO 390 IGR=1,IGRTOT
            RDATAX(IMACR+IGR-1)=RDATAX(IMACR+IGR-1)-DENISO(IISO)*
     1                          RDATAX(JMACR+IGR-1)
  390       CONTINUE
         ENDIF
  400    CONTINUE
  410    CONTINUE
      ENDIF
*
      LENGDX(IMIL)=IOR
      LENGDP(IMIL)=IOI
      DO 430 IADRX=1,NADRX
      DO 425 I=1,NREA+2
      DO 420 J=1,NISO+NMAC
      IF(ADRX(I,J,NADRX+1).NE.ADRX(I,J,IADRX)) GO TO 430
  420 CONTINUE
  425 CONTINUE
      ISADRX(IMIL)=IADRX
      GO TO 440
  430 CONTINUE
      NADRX=NADRX+1
      ISADRX(IMIL)=NADRX
*----
*  STORE INFORMATION IN THE MIXTURE DIRECTORY.
*----
  440 WRITE(DIRNAM,'(''mili'',I8)') IMIL
      CALL LCMSIX(IPSAP,DIRNAM,1)
      CALL LCMPUT(IPSAP,'FLUXS',NG,2,FLUX)
      IF(LENGDX(IMIL).GT.0) THEN
         CALL LCMPUT(IPSAP,'RDATAX',LENGDX(IMIL),2,RDATAX)
      ENDIF
      IF(LENGDP(IMIL).GT.0) THEN
         CALL LCMPUT(IPSAP,'IDATAP',LENGDP(IMIL),1,IDATAP)
      ENDIF
      IF(NISOTS.GT.0) THEN
         CALL LCMPUT(IPSAP,'CONCES',NISOTS,2,CONCES)
         DO 445 ISO=1,NISOTS
         DECAYC(ISO)=DECAYC(ISO)*1.0E-8
  445    CONTINUE
         CALL LCMPUT(IPSAP,'DECAYC',NISOTS,2,DECAYC)
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
*
      NISOMN(IMIL)=MAX(NISOMN(IMIL),NISMAX)
      IF(NPRC.GT.0) THEN
         EXIST=.FALSE.
         DO 455 IPRC=1,NPRC
         DO 450 IGR=1,NG
         EXIST=EXIST.OR.(DNUSIG(IGR,IPRC).NE.0.0)
  450    CONTINUE
  455    CONTINUE
         IF(EXIST) THEN
            NMILNR=NMILNR+1
            IF(LCRON) THEN
              IF(NMIL.NE.1) CALL XABORT('SAPCA2: NMIL=1 MANDATORY WITH'
     1        //' CRONOS OPTION.')
              CALL LCMSIX(IPSAP,'divers',1)
            ELSE
              CALL LCMSIX(IPSAP,DIRNAM,1)
              CALL LCMSIX(IPSAP,'cinetique',1)
            ENDIF
            CALL LCMPUT(IPSAP,'NPR',1,1,NPRC)
            CALL LCMPUT(IPSAP,'CHIRS',NG*NPRC,2,DCHI)
            CALL LCMPUT(IPSAP,'INVELS',NG,2,OVERV)
            CALL LCMSIX(IPTEMP,'MACROLIB',1)
            CALL LCMGET(IPTEMP,'LAMBDA-D',WORKD)
            CALL LCMSIX(IPTEMP,' ',2)
            CALL LCMPUT(IPSAP,'LAMBRS',NPRC,2,WORKD)
            TGENRS=0.0
            DENOM=0.0
            DO 460 IGR=1,NG
            TGENRS=TGENRS+OVERV(IGR)*FLUX(IGR)
            DENOM=DENOM+DNUSIG(IGR,NPRC+1)*FLUX(IGR)
  460       CONTINUE
            TGENRS=TGENRS/DENOM
            DO 480 IPRC=1,NPRC
            WORKD(IPRC)=0.0
            DO 470 IGR=1,NG
            WORKD(IPRC)=WORKD(IPRC)+DNUSIG(IGR,IPRC)*FLUX(IGR)
  470       CONTINUE
            WORKD(IPRC)=WORKD(IPRC)/DENOM
  480       CONTINUE
            CALL LCMPUT(IPSAP,'BETARS',NPRC,2,WORKD)
            CALL LCMPUT(IPSAP,'TGENRS',1,2,TGENRS)
            IF(LCRON) THEN
              CALL LCMSIX(IPSAP,' ',2)
            ELSE
              CALL LCMSIX(IPSAP,' ',2)
              CALL LCMSIX(IPSAP,' ',2)
            ENDIF
         ENDIF
      ENDIF
  500 CONTINUE
      DO IGR=1,NG
         REGFLX(IGR)=REGFLX(IGR)/VOLTOT
      ENDDO
      DEALLOCATE(IPISO)
      CALL LCMCL(IPTEMP,2)
*----
*  STORE INFORMATION IN THE ELEMENTARY CALCULATION DIRECTORIES.
*----
      NISFS=0
      NISPS=0
      DO 530 ISO=1,NISO
      DO 510 IBISO=1,NBISO
      WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2)
      IF(NOMISO(ISO).EQ.TEXT8) THEN
         ITY=ITYPE(IBISO)
         GO TO 520
      ENDIF
  510 CONTINUE
      GO TO 530
  520 IF(ITY.EQ.2) THEN
         NISFS=NISFS+1
      ELSE IF(ITY.EQ.3) THEN
         NISPS=NISPS+1
      ENDIF
  530 CONTINUE
      IF(NISPS.EQ.0) THEN
         NISYS=0
      ELSE
         NISYS=NISO+NMAC
      ENDIF
      CALL LCMSIX(IPSAP,'info',1)
      CALL LCMPUT(IPSAP,'NISOTS',1,1,NISOTS)
      CALL LCMPUT(IPSAP,'NISF',1,1,NISFS)
      CALL LCMPUT(IPSAP,'NISP',1,1,NISPS)
      CALL LCMPUT(IPSAP,'NISY',1,1,NISYS)
      IF(NISOTS.GT.0) CALL LCMPTC(IPSAP,'ISOTS',8,NISOTS,ISOTS)
      CALL LCMPUT(IPSAP,'ISADRX',NMIL,1,ISADRX)
      CALL LCMPUT(IPSAP,'LENGDX',NMIL,1,LENGDX)
      CALL LCMPUT(IPSAP,'LENGDP',NMIL,1,LENGDP)
      CALL LCMSIX(IPSAP,' ',2)
*
      IF(NVDIV.GT.0) THEN
         CALL LCMSIX(IPSAP,'divers',1)
         CALL LCMPUT(IPSAP,'NVDIV',1,1,NVDIV)
         CALL LCMPTC(IPSAP,'IDVAL',4,NVDIV,IDVAL)
         CALL LCMPUT(IPSAP,'VALDIV',NVDIV,2,VALDIV)
         CALL LCMSIX(IPSAP,' ',2)
      ENDIF
*----
*  MOVE TO THE SAPHYB ROOT DIRECTORY.
*----
      CALL LCMSIX(IPSAP,' ',2)
*----
*  STORE INFORMATION IN THE 'adresses' DIRECTORY.
*----
      CALL LCMSIX(IPSAP,'adresses',1)
      CALL LCMPUT(IPSAP,'ADRX',(NREA+2)*(NISO+NMAC)*NADRX,1,ADRX)
      CALL LCMPUT(IPSAP,'ISOMIL',(NISO+NMAC)*NMIL,1,ISOMIL)
      CALL LCMPUT(IPSAP,'NISOMN',NMIL,1,NISOMN)
      CALL LCMPUT(IPSAP,'ISADRC',NMIL,1,ISADRX)
      CALL LCMSIX(IPSAP,' ',2)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(DECAYC,CONCES,DENISO,DEN,DATA4,DATA3,DATA2,DATA1,VOL,
     1 WORK2,WORK1,WORKD,DCHI,DNUSIG,OVERV,FLUX,RDATAX)
      DEALLOCATE(ITYPE,MIX,ISONAM,NJJ2,IJJ2,IPOS,NJJ1,IJJ1,IADR2,IFDG2,
     1 IADR,IFDG,IDATAP,LENGDP,LENGDX,ISADRX,NISOMN,ISOMIL,ADRX,RESMAC)
      RETURN
      END