summaryrefslogtreecommitdiff
path: root/Dragon/src/SAPCA2.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/SAPCA2.f')
-rw-r--r--Dragon/src/SAPCA2.f956
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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:32:57 +0000