summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBDEN.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LIBDEN.f')
-rw-r--r--Dragon/src/LIBDEN.f1150
1 files changed, 1150 insertions, 0 deletions
diff --git a/Dragon/src/LIBDEN.f b/Dragon/src/LIBDEN.f
new file mode 100644
index 0000000..da4eeb2
--- /dev/null
+++ b/Dragon/src/LIBDEN.f
@@ -0,0 +1,1150 @@
+*DECK LIBDEN
+ SUBROUTINE LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM,
+ 1 IPISO,MIX,DEN,MASK,MASKL,NED,NAMEAD,ITRANC,MAXNFI,NPART,LSAME,
+ 2 ITSTMP,TMPDAY,STERN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transformation of the isotope ordered microscopic cross sections to
+* group ordered macroscopic cross sections (part 2).
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): A. Hebert and A. Naceur
+*
+*Parameters: input
+* IPLIB pointer to the lattice microscopic cross section library
+* (L_LIBRARY signature).
+* NGROUP number of energy groups.
+* NBISO number of isotopes present in the calculation domain.
+* NBMIX number of mixtures present in the calculation domain.
+* NL number of Legendre orders required in the calculation
+* (NL=1 or higher).
+* NDEL number of delayed precursor groups.
+* NESP number of energy-dependent fission spectra.
+* ISONAM names of microlib isotopes.
+* IPISO pointer array towards microlib isotopes.
+* MIX mixture number of each isotope (can be zero).
+* DEN density of each isotope.
+* MASK mixture mask (=.true. if a mixture is to be made).
+* MASKL group mask (=.true. if an energy group is to be treated).
+* NED number of extra edit vectors.
+* NAMEAD names of these extra edits.
+* ITRANC type of transport corrections in the microlib
+* (=0: no transport correction).
+* MAXNFI maximum number of fissionable isotopes in a mixture.
+* NPART number of companion particles.
+* LSAME fission spectrum flag (=.true. if all the isotopes have the
+* same fission spectrum and the same precursor group decay
+* constants).
+* ITSTMP type of cross section perturbation (=0: perturbation
+* forbidden; =1: perturbation not used even if present;
+* =2: perturbation used if present).
+* TMPDAY time stamp in day/burnup/irradiation.
+* STERN Sternheimer flag (=0/1: off/on).
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPLIB,IPISO(NBISO)
+ INTEGER NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM(3,NBISO),
+ 1 MIX(NBISO),NED,ITRANC,MAXNFI,NPART,NAMEAD(2,NED),ITSTMP,STERN
+ REAL DEN(NBISO),TMPDAY(3)
+ LOGICAL MASK(NBMIX),MASKL(NGROUP),LSAME
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER NBLK,NSTATE,IOUT,MAXESP
+ PARAMETER (NBLK=50,NSTATE=40,IOUT=6,MAXESP=4)
+ CHARACTER CM*4,CV*12,HSMG*131,TEXT12*12,HCM(0:10)*2,NORD(3)*4,
+ 1 TEXT2*2,HPRT1*1
+ LOGICAL EXIST,MASKK,LOGL,LALL,LWP1,LSTRD,LH,LC,LOVERV,LDIFF,
+ 1 LFISS,LWT0,LWT1
+ INTEGER IDATA(NSTATE),IESP(MAXESP+1),I,J,I0,IOF,IOF0,IP,IPOSDE,
+ 1 IPASS,ISP,IGR,IG1,LLL,LLL0,IGMIN,IGMAX,IBM,JBM,IDEL,IED,IFIS,
+ 2 NXSPER,ISOT,IBLK,ILONG,LENGTZ,ITYLCM,IWFIS,IXSPER,KFIS,M,NBM0,
+ 3 NFISS0,NFISSI,NGROUPS
+ REAL TMPPER(2,3),TIMFCT,DENISO,ENEAVG,FACT,TOTDEN,XTF
+ DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ,ZNU
+ TYPE(C_PTR) JPLIB,KPLIB
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IJJ,NJJ,IWRK,NGPART
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJM,IJJM,INDFIS
+ REAL, ALLOCATABLE, DIMENSION(:) :: GA1,GA2,SCAT,VOLMIX,NWTMIX,
+ 1 VOLI,C2PART,KGAS,ENER
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: GA3,GAR,WRK1,WRK2,DENMAT
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAF,CHECK,ZNUS,ZCHI,FLUX
+ TYPE(C_PTR), ALLOCATABLE, DIMENSION(:,:) :: IPGRP
+ LOGICAL, ALLOCATABLE, DIMENSION(:) :: LMADE
+ CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPART
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: ISONRF
+*----
+* DATA STATEMENTS
+*----
+ DATA HCM/'00','01','02','03','04','05','06','07','08','09','10'/
+ DATA NORD/' ',' LIN',' QUA'/
+*----
+* SCRATCH STORAGE ALLOCATION
+* IPGRP LCM pointers of the macrolib groupwise directories.
+*----
+ ALLOCATE(NJJM(NBMIX,NBLK),IJJM(NBMIX,NBLK),IPOS(NBMIX),
+ 1 INDFIS(NBMIX,MAXNFI),IJJ(NGROUP),NJJ(NGROUP))
+ ALLOCATE(GA2(NGROUP*NGROUP),GA3(NDEL,MAXNFI),GAR(NBMIX,NBLK+1),
+ 1 GAF(NBMIX,NGROUP,NBLK),SCAT(NGROUP*NBMIX),CHECK(NBMIX,NGROUP,NL),
+ 2 ZNUS(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL),
+ 3 ZCHI(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL))
+ ALLOCATE(IPGRP(NGROUP,NPART+1))
+ ALLOCATE(LMADE(NBISO))
+ ALLOCATE(NGPART(NPART+1),C2PART(NPART+1),HNPART(NPART+1))
+ ALLOCATE(DENMAT(NBMIX,NGROUP+1))
+*----
+* FOR AVERAGED NEUTRON VELOCITY
+* V=SQRT(2*ENER/M)=SQRT(2/M)*SQRT(ENER)
+* SQFMAS=SQRT(2/M) IN CM/S/SQRT(EV) FOR V IN CM/S AND E IN EV
+* =SQRT(2*1.602189E-19(J/EV)* 1.0E4(CM2/M2) /1.67495E-27 (KG))
+* =1383155.30602 CM/S/SQRT(EV)
+*----
+ EVJ=XDRCST('eV','J')
+ NMASS=XDRCST('Neutron mass','kg')
+ SQFMAS=SQRT(2.0D4*EVJ/NMASS)
+*----
+* SET MULTIPLE FISSION SPECTRA INFORMATION.
+*----
+ IF(NESP.GT.1) THEN
+ IF(NESP.GT.MAXESP) CALL XABORT('LIBDEN: MAXESP OVERFLOW.')
+ CALL LCMGET(IPLIB,'CHI-LIMITS',IESP)
+ ENDIF
+*----
+* SET CROSS SECTION PERTURBATION INFORMATION.
+*----
+ NXSPER=1
+ TIMFCT=0.0
+ CALL LCMLEN(IPLIB,'TIMESPER',ILONG,ITYLCM)
+ IF((ILONG.GE.2).AND.(ILONG.LE.6)) THEN
+ IF(ITSTMP.EQ.0) THEN
+ CALL XABORT('LIBDEN: XS PERTURBATION FORBIDDEN.')
+ ELSE IF(ITSTMP.EQ.2) THEN
+ CALL LCMGET(IPLIB,'TIMESPER',TMPPER)
+ TIMFCT=TMPDAY(1)-TMPPER(1,1)
+ XTF=TIMFCT/TMPPER(2,1)
+ IF(XTF.NE.0.0) NXSPER=2
+ IF(XTF.LT.0.0) THEN
+ WRITE(IOUT,6000) TMPPER(1,1),TMPDAY(1)
+ ELSE IF(XTF.GT.1.0) THEN
+ WRITE(IOUT,6001) TMPPER(1,1)+TMPPER(2,1),TMPDAY(1)
+ ENDIF
+ ENDIF
+ ENDIF
+*----
+* RECOVER MIXTURE VOLUMES IN MICROLIB.
+*----
+ CALL LCMLEN(IPLIB,'ISOTOPESVOL',ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ ALLOCATE(VOLMIX(NBMIX),VOLI(NBISO))
+ CALL LCMGET(IPLIB,'ISOTOPESVOL',VOLI)
+ VOLMIX(:NBMIX)=0.0
+ DO ISOT=1,NBISO
+ IBM=MIX(ISOT)
+ IF(IBM.GT.0) VOLMIX(IBM)=VOLI(ISOT)
+ ENDDO
+ CALL LCMPUT(IPLIB,'MIXTURESVOL',NBMIX,2,VOLMIX)
+ DEALLOCATE(VOLI,VOLMIX)
+ ENDIF
+*----
+* MASKK=.TRUE. IF MIXTURE MASKING IS TO BE USED (IT IS NOT USED IF
+* ALL MIXTURES ARE TO BE UPDATED).
+*----
+ LDIFF=.TRUE.
+ CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM)
+ MASKK=(ILONG.EQ.-1)
+ IF(MASKK) THEN
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12)
+ IF(TEXT12.NE.'L_MACROLIB') THEN
+ CALL XABORT('LIBDEN: INVALID SIGNATURE ON THE MACROLIB.')
+ ENDIF
+ CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA)
+ NBM0=IDATA(2)
+ NFISSI=IDATA(4)/NESP
+ LDIFF=(IDATA(9).EQ.1)
+ IF(IDATA(1).NE.NGROUP) THEN
+ WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NGROUP=,I4,
+ 1 25H NEW MACROLIB HAS NGROUP=,I4,1H.)') IDATA(1),NGROUP
+ CALL XABORT(HSMG)
+ ELSE IF((IDATA(6).NE.2).AND.(ITRANC.GT.0)) THEN
+ WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS ITRANC=,I4,
+ 1 25H NEW MACROLIB HAS ITRANC=,I4,1H.)') IDATA(6),ITRANC
+ CALL XABORT(HSMG)
+ ELSE IF(NBM0.GT.NBMIX) THEN
+ WRITE(HSMG,'(36HLIBDEN: EXISTING MACROLIB HAS NBMIX=,I4,
+ 1 24H NEW MACROLIB HAS NBMIX=,I4,1H.)') NBM0,NBMIX
+ CALL XABORT(HSMG)
+ ELSE IF(NFISSI.GT.NBISO) THEN
+ WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NFISSI=,I4,
+ 1 13H GREATER THAN,I5,1H.)') IDATA(4),NBISO
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(NFISSI.GT.0) THEN
+ CALL LCMLEN(IPLIB,'FISSIONINDEX',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) THEN
+* THE NAMES ARE NOT DEFINED.
+ DO 11 IFIS=1,NFISSI
+ DO 10 IBM=1,NBMIX
+ INDFIS(IBM,IFIS)=0
+ 10 CONTINUE
+ 11 CONTINUE
+ ELSE IF(ILONG.EQ.NFISSI*NBMIX) THEN
+ CALL LCMGET(IPLIB,'FISSIONINDEX',INDFIS)
+ DO 16 IFIS=1,NFISSI
+ DO 15 IBM=1,NBMIX
+ IF(INDFIS(IBM,IFIS).GT.NBISO) THEN
+ CALL XABORT('LIBDEN: INVALID RECORD FISSIONINDEX.')
+ ENDIF
+ 15 CONTINUE
+ 16 CONTINUE
+ ELSE IF(ILONG.LT.NFISSI*NBMIX) THEN
+* REORDER THE 'FISSIONINDEX' MATRIX.
+ ALLOCATE(IWRK(ILONG))
+ CALL LCMGET(IPLIB,'FISSIONINDEX',IWRK)
+ DO 31 IFIS=1,NFISSI
+ DO 20 IBM=1,NBM0
+ INDFIS(IBM,IFIS)=IWRK((IFIS-1)*NBM0+IBM)
+ 20 CONTINUE
+ DO 30 IBM=NBM0+1,NBMIX
+ INDFIS(IBM,IFIS)=0
+ 30 CONTINUE
+ 31 CONTINUE
+ DEALLOCATE(IWRK)
+ ELSE
+ CALL XABORT('LIBDEN: INVALID NUMBER OF MIXTURES.')
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPLIB,' ',2)
+ LALL=NBMIX.GT.NBM0
+ ELSE
+ NFISSI=0
+ LALL=.FALSE.
+ ENDIF
+*----
+* RECOVER PARTICLE DATA
+*----
+ CALL LCMLEN(IPLIB,'PARTICLE',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) THEN
+ HPRT1=' '
+ HNPART(1)=' '
+ ELSE
+ CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1)
+ CALL LCMGTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART)
+ CALL LCMGET(IPLIB,'PARTICLE-NGR',NGPART)
+ CALL LCMGET(IPLIB,'PARTICLE-MC2',C2PART)
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ CALL LCMPTC(IPLIB,'PARTICLE',1,HPRT1)
+ CALL LCMPTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART)
+ CALL LCMPUT(IPLIB,'PARTICLE-NGR',NPART+1,1,NGPART)
+ CALL LCMPUT(IPLIB,'PARTICLE-MC2',NPART+1,2,C2PART)
+ CALL LCMSIX(IPLIB,' ',2)
+ IF(HPRT1.NE.HNPART(1)) THEN
+ WRITE(HSMG,'(27HLIBDEN: MICROLIB PARTICLE (,A1,10H) IS DIFFE,
+ 1 26HRENT FROM PARTICLE-NAM(1)=,A1,1H.)') HPRT1,HNPART(1)
+ CALL XABORT(HSMG)
+ ENDIF
+ DO IP=2,NPART+1
+ ALLOCATE(GA1(NGPART(IP)+1))
+ CALL LCMGET(IPLIB,HNPART(IP)//'ENERGY',GA1)
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ CALL LCMPUT(IPLIB,HNPART(IP)//'ENERGY',NGPART(IP)+1,2,GA1)
+ CALL LCMSIX(IPLIB,' ',2)
+ DEALLOCATE(GA1)
+ ENDDO
+ ENDIF
+*----
+* SELECT NUMBER OF GROUPS TO PROCESS
+*----
+ NGROUPS=0
+ DO 35 LLL=1,NGROUP
+ IF(MASKL(LLL).OR.LALL) NGROUPS=NGROUPS+1
+ 35 CONTINUE
+ IF(NGROUPS.EQ.0) GO TO 880
+*----
+* CHECK IF ALL REQUIRED ISOTOPES ARE PRESENT IN THE MICROLIB
+*----
+ ALLOCATE(GA1(NGROUP+1))
+ DO 40 ISOT=1,NBISO
+ IF(MIX(ISOT).EQ.0) GO TO 40
+ IF(.NOT.MASK(MIX(ISOT))) GO TO 40
+ JPLIB=IPISO(ISOT)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) THEN
+ WRITE(HSMG,'(17HLIBDEN: ISOTOPE '',3A4,8H'' (SPEC=,I6,5H) IS ,
+ > 30HNOT AVAILABLE IN THE MICROLIB.)') (ISONAM(I0,ISOT),I0=1,3),
+ > ISOT
+ CALL XABORT(HSMG)
+ ENDIF
+ 40 CONTINUE
+*----
+* SET THE LCM MACROLIB GROUPWISE AND MICROLIB ISOTOPEWISE DIRECTORIES
+*----
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ JPLIB=LCMLID(IPLIB,'GROUP',NGROUP)
+ DO 45 LLL=1,NGROUP
+ IPGRP(LLL,1)=LCMDIL(JPLIB,LLL)
+ 45 CONTINUE
+ DO 47 IP=2,NPART+1
+ JPLIB=LCMLID(IPLIB,'GROUP-'//HNPART(IP),NGROUP)
+ DO 46 LLL=1,NGROUP
+ IPGRP(LLL,IP)=LCMDIL(JPLIB,LLL)
+ 46 CONTINUE
+ 47 CONTINUE
+ CALL LCMSIX(IPLIB,' ',2)
+*----
+* PROCESS THE SCATTERING TABLES.
+*----
+ DO 52 I=1,NGROUP
+ DO 51 IBM=1,NBMIX
+ DO 50 J=1,NL
+ CHECK(IBM,I,J)=0.0
+ 50 CONTINUE
+ 51 CONTINUE
+ 52 CONTINUE
+ DO 245 IP=1,NPART+1
+ DO 240 M=1,NL
+ IF(M.LE.11) THEN
+ CM=HCM(M-1)//' '
+ ELSE
+ WRITE(CM,'(I2.2,2X)') M-1
+ ENDIF
+ DO 235 IPASS=0,(NGROUP-1)/NBLK
+ LLL0=IPASS*NBLK
+ DO 70 IBLK=1,NBLK
+ DO 60 IBM=1,NBMIX
+ GAR(IBM,IBLK)=0.0
+ 60 CONTINUE
+ DO 71 LLL=1,NGROUP
+ DO 72 IBM=1,NBMIX
+ GAF(IBM,LLL,IBLK)=0.0
+ 72 CONTINUE
+ 71 CONTINUE
+ 70 CONTINUE
+ DO 80 ISOT=1,NBISO
+ LMADE(ISOT)=DEN(ISOT).EQ.0.0
+ 80 CONTINUE
+ DO 140 ISOT=1,NBISO
+ IF(LMADE(ISOT)) GO TO 140
+ JPLIB=IPISO(ISOT)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 140
+*
+* RECOVER THE MICROSCOPIC TRANSFER XS WITHOUT USING XDRLGS (IN
+* ORDER TO REDUCE CPU TIME)
+ IF(IP.GE.2) CALL LCMSIX(JPLIB,HNPART(IP),1)
+ FACT=1.0
+ DO 135 IXSPER=1,NXSPER
+ CALL LCMLEN(JPLIB,'SIGS'//CM//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.EQ.0) GO TO 130
+ CALL LCMGET(JPLIB,'SIGS'//CM//NORD(IXSPER),GA1)
+ CALL LCMGET(JPLIB,'NJJS'//CM//NORD(IXSPER),NJJ)
+ CALL LCMGET(JPLIB,'IJJS'//CM//NORD(IXSPER),IJJ)
+ CALL LCMGET(JPLIB,'SCAT'//CM//NORD(IXSPER),GA2)
+ IOF0=0
+ DO 90 LLL=1,LLL0
+ IOF0=IOF0+NJJ(LLL)
+ 90 CONTINUE
+ DO 110 IBM=1,NBMIX
+ IF((MASK(IBM).OR.(.NOT.MASKK)).AND.(MIX(ISOT).EQ.IBM)) THEN
+ IOF=IOF0
+ DO 105 IBLK=1,NBLK
+ LLL=LLL0+IBLK
+ IF(LLL.GT.NGROUP) GO TO 110
+ GAR(IBM,IBLK)=GAR(IBM,IBLK)+GA1(LLL)*DEN(ISOT)
+ DO 100 IG1=IJJ(LLL),IJJ(LLL)-NJJ(LLL)+1,-1
+ IOF=IOF+1
+ GAF(IBM,IG1,IBLK)=GAF(IBM,IG1,IBLK)+GA2(IOF)*DEN(ISOT)*FACT
+ 100 CONTINUE
+ 105 CONTINUE
+ ENDIF
+ 110 CONTINUE
+ LMADE(ISOT)=.TRUE.
+ 130 FACT=FACT*TIMFCT
+ 135 CONTINUE
+ IF(IP.GE.2) CALL LCMSIX(JPLIB,' ',2)
+*-
+ 140 CONTINUE
+ DO 230 IBLK=1,NBLK
+ LLL=LLL0+IBLK
+ IF(LLL.GT.NGROUP) GO TO 230
+ KPLIB=IPGRP(LLL,IP)
+ IF(MASKL(LLL).OR.LALL) THEN
+ IF(MASKK) THEN
+ ILONG=1
+ IF(M.GT.1) CALL LCMLEN(KPLIB,'SIGS'//CM,ILONG,ITYLCM)
+ GAR(:NBMIX,NBLK+1)=0.0
+ IF(ILONG.GT.0) THEN
+ CALL LCMGET(KPLIB,'SIGS'//CM,GAR(1,NBLK+1))
+ ENDIF
+ DO 150 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAR(IBM,IBLK)=GAR(IBM,NBLK+1)
+ 150 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'SIGS'//CM,NBMIX,2,GAR(1,IBLK))
+ ENDIF
+*
+ LOGL=MASKL(LLL).OR.LALL
+ DO 165 IBM=1,NBMIX
+ DO 160 IG1=1,NGROUP
+ LOGL=LOGL.OR.(MASKL(IG1).AND.(GAF(IBM,IG1,IBLK).NE.0.0))
+ 160 CONTINUE
+ 165 CONTINUE
+ IF(LOGL) THEN
+ IF(MASKK) THEN
+ ILONG=1
+ IF(M.GT.1) CALL LCMLEN(KPLIB,'SCAT'//CM,ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ DO 170 I=1,NBMIX
+ IPOS(I)=-99
+ 170 CONTINUE
+ CALL LCMGET(KPLIB,'SCAT'//CM,SCAT)
+ CALL LCMGET(KPLIB,'NJJS'//CM,NJJM(1,IBLK))
+ CALL LCMGET(KPLIB,'IJJS'//CM,IJJM(1,IBLK))
+ CALL LCMGET(KPLIB,'IPOS'//CM,IPOS)
+ DO 190 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) THEN
+ IPOSDE=IPOS(IBM)
+ IF(IPOSDE.EQ.-99) GO TO 190
+ DO 180 IG1=IJJM(IBM,IBLK),IJJM(IBM,IBLK)-NJJM(IBM,IBLK)
+ 1 +1,-1
+ GAF(IBM,IG1,IBLK)=SCAT(IPOSDE)
+ IPOSDE=IPOSDE+1
+ 180 CONTINUE
+ ENDIF
+ 190 CONTINUE
+ ENDIF
+ ENDIF
+*
+ IPOSDE=0
+ DO 220 IBM=1,NBMIX
+ IPOS(IBM)=IPOSDE+1
+ IGMIN=LLL
+ IGMAX=LLL
+ DO 200 IG1=NGROUP,1,-1
+ IF(GAF(IBM,IG1,IBLK).NE.0.0) THEN
+ IGMIN=MIN(IGMIN,IG1)
+ IGMAX=MAX(IGMAX,IG1)
+ ENDIF
+ 200 CONTINUE
+ IJJM(IBM,IBLK)=IGMAX
+ NJJM(IBM,IBLK)=IGMAX-IGMIN+1
+ DO 210 IG1=IGMAX,IGMIN,-1
+ IPOSDE=IPOSDE+1
+ SCAT(IPOSDE)=GAF(IBM,IG1,IBLK)
+ CHECK(IBM,IG1,M)=CHECK(IBM,IG1,M)+SCAT(IPOSDE)
+ 210 CONTINUE
+ GAR(IBM,1)=SCAT(IPOS(IBM)+IJJM(IBM,IBLK)-LLL)
+ 220 CONTINUE
+ CALL LCMPUT(KPLIB,'SCAT'//CM,IPOSDE,2,SCAT)
+ CALL LCMPUT(KPLIB,'NJJS'//CM,NBMIX,1,NJJM(1,IBLK))
+ CALL LCMPUT(KPLIB,'IJJS'//CM,NBMIX,1,IJJM(1,IBLK))
+ CALL LCMPUT(KPLIB,'IPOS'//CM,NBMIX,1,IPOS)
+ CALL LCMPUT(KPLIB,'SIGW'//CM,NBMIX,2,GAR(1,1))
+ ENDIF
+ 230 CONTINUE
+ 235 CONTINUE
+ 240 CONTINUE
+ 245 CONTINUE
+*----
+* STERNHEIMER DENSITY CORRECTION FOR CHARGED PARTICLE CASES
+*----
+ IF(HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN
+ ALLOCATE(ISONRF(NBISO),ENER(NGROUP+1),KGAS(NBMIX))
+ CALL LCMGTC(IPLIB,'ISOTOPERNAME',12,NBISO,ISONRF)
+ CALL LCMGET(IPLIB,'ENERGY',ENER)
+ CALL LCMGET(IPLIB,'MIXTUREGAS',KGAS)
+ CALL LIBSDC(NBMIX,NGROUP,NBISO,ISONRF,MIX,DEN,MASK,ENER,KGAS,
+ 1 DENMAT)
+ DEALLOCATE(KGAS,ENER,ISONRF)
+ ENDIF
+*----
+* PROCESS THE REACTION VECTORS TOTAL, TOTAL-P1, STRD, H-FACTOR,
+* C-FACTOR, OVERV AND TRANC.
+*----
+ LWP1=.FALSE.
+ LSTRD=.FALSE.
+ LH=.FALSE.
+ LC=.FALSE.
+ LOVERV=.FALSE.
+ DO 340 IBM=1,NBMIX
+ IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
+ DO 255 IP=1,14
+ DO 250 LLL=1,NGROUP
+ GAF(IBM,LLL,IP)=0.0
+ 250 CONTINUE
+ 255 CONTINUE
+ TOTDEN=0.0
+ DO 320 ISOT=1,NBISO
+ IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 320
+ JPLIB=IPISO(ISOT)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 320
+*-
+ DENISO=DEN(ISOT)
+ TOTDEN=TOTDEN+DENISO
+ DO 315 IXSPER=1,NXSPER
+ CALL LCMGET(JPLIB,'NTOT0 '//NORD(IXSPER),GA1)
+ DO 260 LLL=1,NGROUP
+ GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
+ 260 CONTINUE
+ CALL LCMLEN(JPLIB,'NTOT1 '//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ LWP1=.TRUE.
+ CALL LCMGET(JPLIB,'NTOT1 '//NORD(IXSPER),GA1)
+ DO 270 LLL=1,NGROUP
+ GAF(IBM,LLL,3)=GAF(IBM,LLL,3)+GA1(LLL)*DENISO
+ 270 CONTINUE
+ ENDIF
+ IF(LDIFF) THEN
+ CALL LCMLEN(JPLIB,'STRD '//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ LSTRD=.TRUE.
+ CALL LCMGET(JPLIB,'STRD '//NORD(IXSPER),GA1)
+ DO 280 LLL=1,NGROUP
+ GAF(IBM,LLL,5)=GAF(IBM,LLL,5)+GA1(LLL)*DENISO
+ 280 CONTINUE
+ ENDIF
+ ENDIF
+ CALL LCMLEN(JPLIB,'H-FACTOR'//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ LH=.TRUE.
+ CALL LCMGET(JPLIB,'H-FACTOR'//NORD(IXSPER),GA1) !eV-barns
+ DO 290 LLL=1,NGROUP
+ GAF(IBM,LLL,7)=GAF(IBM,LLL,7)+GA1(LLL)*DENISO !MeV/cm
+ 290 CONTINUE
+ ENDIF
+ CALL LCMLEN(JPLIB,'C-FACTOR'//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ LC=.TRUE.
+ CALL LCMGET(JPLIB,'C-FACTOR'//NORD(IXSPER),GA1)
+ DO 295 LLL=1,NGROUP
+ GAF(IBM,LLL,13)=GAF(IBM,LLL,13)+GA1(LLL)*DENISO
+ 295 CONTINUE
+ ENDIF
+ CALL LCMLEN(JPLIB,'OVERV '//NORD(IXSPER),ILONG,ITYLCM)
+ IF((ILONG.GT.0).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR.
+ 1 (HPRT1.EQ.' '))) THEN
+ LOVERV=.TRUE.
+ CALL LCMGET(JPLIB,'OVERV '//NORD(IXSPER),GA1)
+ DO 300 LLL=1,NGROUP
+ GAF(IBM,LLL,9)=GAF(IBM,LLL,9)+GA1(LLL)*DENISO
+ 300 CONTINUE
+ ENDIF
+ IF(ITRANC.NE.0) THEN
+ CALL LCMGET(JPLIB,'TRANC '//NORD(IXSPER),GA1)
+ DO 310 LLL=1,NGROUP
+ GAF(IBM,LLL,11)=GAF(IBM,LLL,11)+GA1(LLL)*DENISO
+ 310 CONTINUE
+ ENDIF
+ DENISO=DENISO*TIMFCT
+ 315 CONTINUE
+*-
+ 320 CONTINUE
+ IF(LOVERV) THEN
+ DO 330 LLL=1,NGROUP
+ IF(GAF(IBM,LLL,9).NE.0.0) THEN
+ GAF(IBM,LLL,9)=GAF(IBM,LLL,9)/TOTDEN
+ ENDIF
+ 330 CONTINUE
+ ENDIF
+ ENDIF
+ !-----------------------------------------------------------
+ !APPLY STERNHEIMER DENSITY CORRECTION ON HEAT DEPOSITION FOR
+ !ELECTRON AND POSITRON.
+ !REASON: SOFT INLEASTIC HEAT DEPOSITION IN ELECTR
+ !CONTAINS A COLLISONNAL STOPPING POWER WHICH HAS NOT
+ !BEEN CORRECTED IN NJOY.
+ !-----------------------------------------------------------
+ IF (STERN.EQ.1) THEN
+ IF (HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN
+ DO LLL=1,NGROUP
+ GAF(IBM,LLL,7)=GAF(IBM,LLL,7)-DENMAT(IBM,LLL) !eV/cm
+ ENDDO
+ ENDIF
+ ENDIF
+ 340 CONTINUE
+ DO 420 LLL=1,NGROUP
+ KPLIB=IPGRP(LLL,1)
+ IF(MASKL(LLL).OR.LALL) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,2)=0.0
+ CALL LCMGET(KPLIB,'NTOT0',GAF(1,LLL,2))
+ DO 350 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2)
+ 350 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'NTOT0',NBMIX,2,GAF(1,LLL,1))
+ IF(LWP1) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,4)=0.0
+ CALL LCMGET(KPLIB,'NTOT1',GAF(1,LLL,4))
+ DO 360 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,3)=GAF(IBM,LLL,4)
+ 360 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'NTOT1',NBMIX,2,GAF(1,LLL,3))
+ ENDIF
+ IF(LSTRD) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,6)=0.0
+ CALL LCMGET(KPLIB,'DIFF',GAF(1,LLL,6))
+ DO 370 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) THEN
+ GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,6))
+ ENDIF
+ 370 CONTINUE
+ ENDIF
+ DO 380 IBM=1,NBMIX
+ IF(GAF(IBM,LLL,5).NE.0.0) THEN
+ GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,5))
+ ENDIF
+ 380 CONTINUE
+ CALL LCMPUT(KPLIB,'DIFF',NBMIX,2,GAF(1,LLL,5))
+ ENDIF
+ IF(LH) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,8)=0.0
+ CALL LCMLEN(KPLIB,'H-FACTOR',ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ CALL LCMGET(KPLIB,'H-FACTOR',GAF(1,LLL,8))
+ DO 390 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,7)=GAF(IBM,LLL,8)
+ 390 CONTINUE
+ ENDIF
+ ENDIF
+ CALL LCMPUT(KPLIB,'H-FACTOR',NBMIX,2,GAF(1,LLL,7)) !eV/cm
+ ENDIF
+ IF(LC) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,14)=0.0
+ CALL LCMGET(KPLIB,'C-FACTOR',GAF(1,LLL,14))
+ DO 395 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,13)=GAF(IBM,LLL,14)
+ 395 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'C-FACTOR',NBMIX,2,GAF(1,LLL,13)) !e/cm
+ ENDIF
+ IF(LOVERV) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,10)=0.0
+ CALL LCMGET(KPLIB,'OVERV',GAF(1,LLL,10))
+ DO 400 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,9)=GAF(IBM,LLL,10)
+ 400 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAF(1,LLL,9))
+ ENDIF
+ IF(ITRANC.NE.0) THEN
+ IF(MASKK) THEN
+ GAF(:NBMIX,LLL,12)=0.0
+ CALL LCMGET(KPLIB,'TRANC',GAF(1,LLL,12))
+ DO 410 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,11)=GAF(IBM,LLL,12)
+ 410 CONTINUE
+ ENDIF
+ CALL LCMPUT(KPLIB,'TRANC',NBMIX,2,GAF(1,LLL,11))
+ ENDIF
+ ENDIF
+ 420 CONTINUE
+*----
+* PROCESS THE FISSION VECTORS FOR EACH NEW FISSILE ISOTOPE.
+*----
+ NFISS0=NFISSI
+ DO 460 ISOT=1,NBISO
+ IBM=MIX(ISOT)
+ IF(IBM.EQ.0) GO TO 460
+ IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
+ JPLIB=IPISO(ISOT)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 460
+ CALL LCMLEN(JPLIB,'NUSIGF',ILONG,ITYLCM)
+ IF(NESP.EQ.1) THEN
+ CALL LCMLEN(JPLIB,'CHI',LENGTZ,ITYLCM)
+ ELSE
+ CALL LCMLEN(JPLIB,'CHI--01',LENGTZ,ITYLCM)
+ ENDIF
+ IF((ILONG.GT.0).AND.(LENGTZ.GT.0)) THEN
+ IF(NESP.EQ.1) THEN
+ CALL LCMGET(JPLIB,'CHI',GA1)
+ ELSE
+ CALL LCMGET(JPLIB,'CHI--01',GA1)
+ ENDIF
+ LFISS=.FALSE.
+ DO 425 IGR=1,NGROUP
+ LFISS=LFISS.OR.(GA1(IGR).GT.0.0)
+ 425 CONTINUE
+ IF(.NOT.LFISS) GO TO 455
+ DO 430 IFIS=1,NFISSI
+ IWFIS=INDFIS(IBM,IFIS)
+ IF((IWFIS.EQ.ISOT).OR.(IWFIS.EQ.0)) THEN
+ KFIS=IFIS
+ GO TO 450
+ ENDIF
+ 430 CONTINUE
+ NFISSI=NFISSI+1
+ IF(NFISSI.GT.MAXNFI) CALL XABORT('LIBDEN: INDFIS IS FULL.')
+ KFIS=NFISSI
+ DO 440 JBM=1,NBMIX
+ INDFIS(JBM,KFIS)=0
+ 440 CONTINUE
+ 450 INDFIS(IBM,KFIS)=ISOT
+ ENDIF
+ 455 CONTINUE
+ ENDIF
+ 460 CONTINUE
+ IF(NFISS0.GT.0) THEN
+ ALLOCATE(WRK1(NBM0,NFISS0*NESP),WRK2(NBM0,NFISS0*NESP))
+ DO 480 LLL=1,NGROUP
+ IF(MASKL(LLL).OR.LALL) THEN
+ DO 465 IDEL=0,NDEL
+ ZNUS(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0
+ ZCHI(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0
+ 465 CONTINUE
+ KPLIB=IPGRP(LLL,1)
+ CALL LCMLEN(KPLIB,'NUSIGF',ILONG,ITYLCM)
+ IF(ILONG.NE.NBM0*NFISS0*NESP) THEN
+ CALL XABORT('LIBDEN: NBM ERROR.')
+ ENDIF
+ CALL LCMGET(KPLIB,'NUSIGF',WRK1)
+ CALL LCMGET(KPLIB,'CHI',WRK2)
+ DO 467 IFIS=1,NFISS0*NESP
+ DO 466 IBM=1,NBM0
+ ZNUS((IFIS-1)*NBMIX+IBM,LLL,0)=WRK1(IBM,IFIS)
+ ZCHI((IFIS-1)*NBMIX+IBM,LLL,0)=WRK2(IBM,IFIS)
+ 466 CONTINUE
+ 467 CONTINUE
+ DO 475 IDEL=1,NDEL
+ WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
+ CALL LCMLEN(KPLIB,TEXT12,ILONG,ITYLCM)
+ IF(ILONG.NE.0) THEN
+ CALL LCMGET(KPLIB,TEXT12,WRK1)
+ WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
+ CALL LCMGET(KPLIB,TEXT12,WRK2)
+ DO 471 IFIS=1,NFISS0*NESP
+ DO 470 IBM=1,NBM0
+ ZNUS((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK1(IBM,IFIS)
+ ZCHI((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK2(IBM,IFIS)
+ 470 CONTINUE
+ 471 CONTINUE
+ ENDIF
+ 475 CONTINUE
+ ENDIF
+ 480 CONTINUE
+ DEALLOCATE(WRK2,WRK1)
+ ENDIF
+ IF(NFISSI.GT.0) THEN
+ DO 525 ISP=1,NESP
+ DO 520 KFIS=1,NFISSI
+ IF(KFIS.GT.NFISS0*NESP) THEN
+ DO 492 IDEL=0,NDEL
+ DO 491 LLL=1,NGROUP
+ DO 490 IBM=1,NBMIX
+ IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
+ ZNUS(IOF,LLL,IDEL)=0.0
+ ZCHI(IOF,LLL,IDEL)=0.0
+ 490 CONTINUE
+ 491 CONTINUE
+ 492 CONTINUE
+ ELSE
+ DO 510 IBM=1,NBMIX
+ IWFIS=INDFIS(IBM,KFIS)
+ IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
+ DO 505 IDEL=0,NDEL
+ DO 500 LLL=1,NGROUP
+ IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
+ ZNUS(IOF,LLL,IDEL)=0.0
+ ZCHI(IOF,LLL,IDEL)=0.0
+ 500 CONTINUE
+ 505 CONTINUE
+ ENDIF
+ 510 CONTINUE
+ ENDIF
+ 520 CONTINUE
+ 525 CONTINUE
+*-
+ IF(NESP.EQ.1) THEN
+* ONE FISSION SPECTRUM (CLASSICAL CASE)
+ DO 585 KFIS=1,NFISSI
+ DO 580 IBM=1,NBMIX
+ IWFIS=INDFIS(IBM,KFIS)
+ IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
+ IF(LSAME) THEN
+ IOF=IBM
+ ELSE
+ IOF=(KFIS-1)*NBMIX+IBM
+ ENDIF
+ JPLIB=IPISO(IWFIS)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 580
+*-
+ DENISO=DEN(IWFIS)
+ DO 570 IXSPER=1,NXSPER
+ CALL LCMGET(JPLIB,'NUSIGF '//NORD(IXSPER),GA1)
+ DO 530 LLL=1,NGROUP
+ ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
+ 530 CONTINUE
+ IF(NDEL.GT.0) THEN
+ WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
+ CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ DO 545 IDEL=1,NDEL
+ WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
+ CALL LCMGET(JPLIB,TEXT12,GA1)
+ DO 540 LLL=1,NGROUP
+ ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
+ 1 DENISO
+ 540 CONTINUE
+ 545 CONTINUE
+ ENDIF
+ WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
+ CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
+ IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN
+ DO 555 IDEL=1,NDEL
+ WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
+ CALL LCMGET(JPLIB,TEXT12,GA1)
+ DO 550 LLL=1,NGROUP
+ ZCHI(IOF,LLL,IDEL)=GA1(LLL)
+ 550 CONTINUE
+ 555 CONTINUE
+ ENDIF
+ ENDIF
+ IF(IXSPER.EQ.1) THEN
+ CALL LCMGET(JPLIB,'CHI '//NORD(IXSPER),GA1)
+ DO 560 LLL=1,NGROUP
+ ZCHI(IOF,LLL,0)=GA1(LLL)
+ 560 CONTINUE
+ ENDIF
+ DENISO=DENISO*TIMFCT
+ 570 CONTINUE
+ ENDIF
+ 580 CONTINUE
+ 585 CONTINUE
+ ELSE
+* NESP>1 MULTIPLE FISSION SPECTRA CASE
+ DO 662 ISP=1,NESP
+ DO 661 KFIS=1,NFISSI
+ DO 660 IBM=1,NBMIX
+ IWFIS=INDFIS(IBM,KFIS)
+ IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
+ IF(LSAME) THEN
+ IOF=IBM
+ ELSE
+ IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
+ ENDIF
+ JPLIB=IPISO(IWFIS)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 660
+*-
+ DENISO=DEN(IWFIS)
+ DO 650 IXSPER=1,NXSPER
+ CALL LCMGET(JPLIB,'NUSIGF '//NORD(IXSPER),GA1)
+ DO 610 LLL=IESP(ISP)+1,IESP(ISP+1)
+ ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
+ 610 CONTINUE
+ IF((NDEL.GT.0).AND.(ISP.EQ.1)) THEN
+ WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
+ CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ DO 625 IDEL=1,NDEL
+ WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
+ CALL LCMGET(JPLIB,TEXT12,GA1)
+ DO 620 LLL=1,NGROUP
+ ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
+ 1 DENISO
+ 620 CONTINUE
+ 625 CONTINUE
+ ENDIF
+ WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
+ CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
+ IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN
+ DO 635 IDEL=1,NDEL
+ WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
+ CALL LCMGET(JPLIB,TEXT12,GA1)
+ DO 630 LLL=1,NGROUP
+ ZCHI(IOF,LLL,IDEL)=GA1(LLL)
+ 630 CONTINUE
+ 635 CONTINUE
+ ENDIF
+ ENDIF
+ IF(IXSPER.EQ.1) THEN
+ WRITE(TEXT2,'(I2.2)') ISP
+ TEXT12='CHI--'//TEXT2//' '//NORD(IXSPER)
+ CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
+ IF(ILONG.EQ.NGROUP) THEN
+ CALL LCMGET(JPLIB,TEXT12,GA1)
+ DO 640 LLL=1,NGROUP
+ ZCHI(IOF,LLL,0)=GA1(LLL)
+ 640 CONTINUE
+ ENDIF
+ ENDIF
+ DENISO=DENISO*TIMFCT
+ 650 CONTINUE
+ ENDIF
+ 660 CONTINUE
+ 661 CONTINUE
+ 662 CONTINUE
+ ENDIF
+*-
+ DO 680 LLL=1,NGROUP
+ IF(MASKL(LLL).OR.LALL) THEN
+ KPLIB=IPGRP(LLL,1)
+ ILONG=NBMIX*NFISSI*NESP
+ IF(LSAME) ILONG=NBMIX
+ CALL LCMPUT(KPLIB,'NUSIGF',ILONG,2,ZNUS(1,LLL,0))
+ CALL LCMPUT(KPLIB,'CHI',ILONG,2,ZCHI(1,LLL,0))
+ DO 670 IDEL=1,NDEL
+ WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
+ CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZNUS(1,LLL,IDEL))
+ WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
+ CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZCHI(1,LLL,IDEL))
+ 670 CONTINUE
+ ENDIF
+ 680 CONTINUE
+ ENDIF
+*----
+* PROCESS THE EXTRA VECTOR EDITS.
+*----
+ DO 770 IED=1,NED
+ WRITE(CV,'(2A4)') (NAMEAD(I0,IED),I0=1,2)
+ IF(CV(:2).EQ.'NW') GO TO 770
+ IF(CV.EQ.'TRANC') GO TO 770
+ IF((CV(:3).EQ.'BST').OR.(CV(:3).EQ.'CST')) GO TO 770
+ IF(CV(:8).EQ.'H-FACTOR') GO TO 770
+ EXIST=.FALSE.
+ DO 740 IBM=1,NBMIX
+ IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
+ DO 690 LLL=1,NGROUP
+ GAF(IBM,LLL,1)=0.0
+ 690 CONTINUE
+ DO 730 ISOT=1,NBISO
+ IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 730
+ JPLIB=IPISO(ISOT)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 730
+*-
+ DENISO=DEN(ISOT)
+ DO 710 IXSPER=1,NXSPER
+ CALL LCMLEN(JPLIB,CV(:8)//NORD(IXSPER),ILONG,ITYLCM)
+ IF(ILONG.EQ.0) GO TO 720
+ EXIST=.TRUE.
+ CALL LCMGET(JPLIB,CV(:8)//NORD(IXSPER),GA1)
+ DO 700 LLL=1,NGROUP
+ GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
+ 700 CONTINUE
+ DENISO=DENISO*TIMFCT
+ 710 CONTINUE
+*-
+ 720 CONTINUE
+ 730 CONTINUE
+ ENDIF
+ 740 CONTINUE
+ DO 760 LLL=1,NGROUP
+ IF(MASKL(LLL).OR.LALL) THEN
+ KPLIB=IPGRP(LLL,1)
+ IF(MASKK) THEN
+ CALL LCMLEN(KPLIB,CV,ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ EXIST=.TRUE.
+ GAF(:NBMIX,LLL,2)=0.0
+ CALL LCMGET(KPLIB,CV,GAF(1,LLL,2))
+ DO 750 IBM=1,NBMIX
+ IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2)
+ 750 CONTINUE
+ ENDIF
+ ENDIF
+ IF(EXIST) CALL LCMPUT(KPLIB,CV,NBMIX,2,GAF(1,LLL,1))
+ ENDIF
+ 760 CONTINUE
+ 770 CONTINUE
+*
+ CALL LCMGET(IPLIB,'ENERGY',GA1)
+ IF(GA1(NGROUP+1).EQ.0.0) GA1(NGROUP+1)=1.0E-5
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ IF(NED.GT.0) CALL LCMPUT(IPLIB,'ADDXSNAME-P0',2*NED,3,NAMEAD)
+ IF(MASKK) THEN
+ CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA)
+ IDATA(2)=MAX(NBM0,NBMIX)
+ IDATA(3)=MAX(IDATA(3),NL)
+ IDATA(4)=NFISSI*NESP
+ IDATA(5)=MAX(IDATA(5),NED)
+ ELSE
+ IDATA(1)=NGROUP
+ IDATA(2)=NBMIX
+ IDATA(3)=NL
+ IDATA(4)=NFISSI*NESP
+ IDATA(5)=NED
+ TEXT12='L_MACROLIB'
+ CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12)
+ CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,GA1)
+ ENDIF
+*----
+* COMPUTE 1/V (ENER IS IN EV, NEUTRON MASS IS IN KG)
+*----
+ IF((.NOT.LOVERV).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR.
+ 1 (HPRT1.EQ.' '))) THEN
+ DO 800 LLL=1,NGROUP
+ ENEAVG=SQRT(GA1(LLL)*GA1(LLL+1))
+ ZNU=1.0/(SQRT(ENEAVG)*SQFMAS)
+ DO 790 IBM=1,NBMIX
+ GAR(IBM,1)=REAL(ZNU)
+ 790 CONTINUE
+ KPLIB=IPGRP(LLL,1)
+ CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAR(1,1))
+ 800 CONTINUE
+ ENDIF
+ DEALLOCATE(GA1)
+*----
+* SET THE STATE VECTOR
+*----
+ IF(LSAME) IDATA(4)=MIN(NFISSI*NESP,1)
+ IDATA(6)=ITRANC
+ IF(ITRANC.NE.0) IDATA(6)=2
+ IDATA(7)=NDEL
+ IDATA(8)=0
+ IDATA(9)=0
+ IF(LSTRD) IDATA(9)=1
+ IDATA(10)=0
+ IF(LWP1) IDATA(10)=1
+ DO 810 I=11,NSTATE
+ IDATA(I)=0
+ 810 CONTINUE
+ CALL LCMLEN(IPLIB,'SPH',ILONG,ITYLCM)
+ IF(ILONG.NE.0) IDATA(14)=1
+ CALL LCMPUT(IPLIB,'TIMESTAMP',3,2,TMPDAY)
+ CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IDATA)
+*----
+* RECOVER THE PRECURSOR DECAY CONSTANTS.
+*----
+ IF(NDEL*NFISSI.GT.0) THEN
+ IF(NFISS0.GT.0) THEN
+ CALL LCMLEN(IPLIB,'LAMBDA-D',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) THEN
+ GA3(:NDEL,1)=0.0
+ ELSE
+ CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,1))
+ ENDIF
+ ENDIF
+ DO 825 KFIS=NFISS0+1,NFISSI
+ DO 820 IDEL=1,NDEL
+ GA3(IDEL,KFIS)=0.0
+ 820 CONTINUE
+ 825 CONTINUE
+ CALL LCMSIX(IPLIB,' ',2)
+ DO 835 KFIS=1,NFISSI
+ DO 830 IBM=1,NBMIX
+ IWFIS=INDFIS(IBM,KFIS)
+ IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
+ JPLIB=IPISO(IWFIS)
+ IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 830
+ CALL LCMLEN(JPLIB,'LAMBDA-D',ILONG,ITYLCM)
+ IF(LSAME.AND.(ILONG.GT.0)) THEN
+ CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,1))
+ ELSE IF(ILONG.GT.0) THEN
+ CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,KFIS))
+ ENDIF
+ ENDIF
+ 830 CONTINUE
+ 835 CONTINUE
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ IF(LSAME) THEN
+ CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL,2,GA3(1,1))
+ ELSE
+ CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL*NFISSI,2,GA3)
+ ENDIF
+ ENDIF
+*
+ IF((NFISSI.GT.0).AND.(.NOT.LSAME)) THEN
+ CALL LCMPUT(IPLIB,'FISSIONINDEX',NBMIX*NFISSI,1,INDFIS)
+ ENDIF
+*
+ DO 850 LLL=1,NGROUP
+ IF(MASKL(LLL).OR.LALL) THEN
+ KPLIB=IPGRP(LLL,1)
+ DO 840 M=0,NL-1
+ IF(M.LE.10) THEN
+ CM=HCM(M)//' '
+ ELSE
+ WRITE(CM,'(I2.2,2X)') M
+ ENDIF
+ CALL LCMPUT(KPLIB,'CHECK'//CM,NBMIX,2,CHECK(1,LLL,M+1))
+ 840 CONTINUE
+ ENDIF
+ 850 CONTINUE
+ CALL LCMSIX(IPLIB,' ',2)
+*----
+* RECOVER THE INTEGRATED FLUX
+*----
+ CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ ALLOCATE(VOLMIX(NBMIX),NWTMIX(NGROUP),FLUX(NBMIX,NGROUP,2))
+ CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMIX)
+ LWT0=.FALSE.
+ LWT1=.FALSE.
+ FLUX(:NBMIX,:NGROUP,:2)=0.0
+ DO 860 ISOT=1,NBISO
+ IBM=MIX(ISOT)
+ IF(IBM.GT.0) THEN
+ JPLIB=IPISO(ISOT)
+ IF(C_ASSOCIATED(JPLIB)) THEN
+ CALL LCMLEN(JPLIB,'NWT0',ILONG,ITYLCM)
+ IF(ILONG.EQ.NGROUP) THEN
+ LWT0=.TRUE.
+ CALL LCMGET(JPLIB,'NWT0',NWTMIX)
+ DO IGR=1,NGROUP
+ FLUX(IBM,IGR,1)=NWTMIX(IGR)*VOLMIX(IBM)
+ ENDDO
+ ENDIF
+ CALL LCMLEN(JPLIB,'NWT1',ILONG,ITYLCM)
+ IF(ILONG.EQ.NGROUP) THEN
+ LWT1=.TRUE.
+ CALL LCMGET(JPLIB,'NWT1',NWTMIX)
+ DO IGR=1,NGROUP
+ FLUX(IBM,IGR,2)=NWTMIX(IGR)*VOLMIX(IBM)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ 860 CONTINUE
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ CALL LCMPUT(IPLIB,'VOLUME',NBMIX,2,VOLMIX)
+ JPLIB=LCMGID(IPLIB,'GROUP')
+ DO 870 IGR=1,NGROUP
+ KPLIB=LCMGIL(JPLIB,IGR)
+ IF(LWT0) CALL LCMPUT(KPLIB,'FLUX-INTG',NBMIX,2,FLUX(1,IGR,1))
+ IF(LWT1) CALL LCMPUT(KPLIB,'FLUX-INTG-P1',NBMIX,2,FLUX(1,IGR,2))
+ 870 CONTINUE
+ CALL LCMSIX(IPLIB,' ',2)
+ DEALLOCATE(FLUX,NWTMIX,VOLMIX)
+ ENDIF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ 880 DEALLOCATE(DENMAT)
+ DEALLOCATE(HNPART,C2PART,NGPART)
+ DEALLOCATE(LMADE)
+ DEALLOCATE(IPGRP)
+ DEALLOCATE(ZCHI,ZNUS,CHECK,SCAT,GAF,GAR,GA3,GA2)
+ DEALLOCATE(NJJ,IJJ,INDFIS,IPOS,IJJM,NJJM)
+ RETURN
+*----
+* FORMAT
+*----
+ 6000 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/
+ > ' EXTRAPOLATION BELOW PRETURBATION TABLES'/
+ > ' INITIAL TIME = ',F15.6,' DAYS'/
+ > ' EXTRAPOLATION TIME = ',F15.6,' DAYS')
+ 6001 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/
+ > ' EXTRAPOLATION ABOVE PRETURBATION TABLES'/
+ > ' FINAL TIME = ',F15.6,' DAYS'/
+ > ' EXTRAPOLATION TIME = ',F15.6,' DAYS')
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 19:22:09 +0000