Initial commit from Polytechnique Montreal

1 files changed, 956 insertions, 0 deletions

diff --git a/Dragon/src/SAPCA2.f b/Dragon/src/SAPCA2.f
new file mode 100644
index 0000000..b7e071a
--- /dev/null
+++ b/Dragon/src/SAPCA2.f
@@ -0,0 +1,956 @@
+*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