summaryrefslogtreecommitdiff
path: root/Donjon/src/NCRLIB.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/NCRLIB.f')
-rw-r--r--Donjon/src/NCRLIB.f575
1 files changed, 575 insertions, 0 deletions
diff --git a/Donjon/src/NCRLIB.f b/Donjon/src/NCRLIB.f
new file mode 100644
index 0000000..f207ed5
--- /dev/null
+++ b/Donjon/src/NCRLIB.f
@@ -0,0 +1,575 @@
+*DECK NCRLIB
+ SUBROUTINE NCRLIB(MAXNIS,MAXISO,MAXFEL,IPLIB,IPCPO,IACCS,NMIL,
+ 1 NMIX,NGRP,NGFF,NALBP,IDF,IMPX,NCAL,TERP,NISO,LISO,HISO,CONC,
+ 2 MIXC,LXS,LRES,LPURE,B2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the microlib by scanning the NCAL elementary calculations and
+* weighting them with TERP factors.
+*
+*Copyright:
+* Copyright (C) 2006 Ecole Polytechnique de Montreal
+*
+*Author(s):
+* A. Hebert
+*
+*Parameters: input
+* MAXNIS maximum value of NISO(I) in user data.
+* MAXISO maximum allocated space for output microlib TOC information.
+* MAXFEL number of fuel rings used for the micro-depletion.
+* IPLIB address of the output microlib LCM object.
+* IPCPO address of the multicompo object.
+* IACCS =0 microlib is created; =1 ... is updated.
+* NMIL number of material mixtures in the multicompo.
+* NMIX maximum number of material mixtures in the microlib.
+* NGRP number of energy groups.
+* NGFF number of group form factors per energy group.
+* NALBP number of physical albedos per energy group.
+* IDF ADF type, 0 = none, 1 = Albedo, 2 = FD_B/FD_C/..., 3 = ADF.
+* IMPX print parameter (equal to zero for no print).
+* NCAL number of elementary calculations in the multicompo.
+* TERP interpolation factors.
+* NISO number of user-selected isotopes.
+* LISO type of treatment (=.true.: ALL; =.false.: ONLY).
+* HISO name of the user-selected isotopes.
+* CONC user-defined number density of the user-selected isotopes.
+* A value of -99.99 is set to indicate that the multicompo value
+* is used.
+* MIXC mixture index in the multicompo corresponding to each microlib
+* mixture. Equal to zero if a microlib mixture is not updated.
+* LXS =.true. if keyword 'ALLX' is specified
+* LRES =.true. if the interpolation is done without updating isotopic
+* densities
+* LPURE =.true. if the interpolation is a pure linear interpolation
+* with TERP factors.
+* B2 buckling
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPLIB,IPCPO
+ INTEGER MAXNIS,MAXISO,MAXFEL,IACCS,NMIL,NMIX,NGRP,NGFF,NALBP,
+ 1 IDF,IMPX,NCAL,NISO(NMIX),HISO(2,NMIX,MAXNIS),MIXC(NMIX)
+ REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2
+ LOGICAL LISO(NMIX),LXS,LRES,LPURE
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER, PARAMETER::IOUT=6
+ INTEGER, PARAMETER::MAXED=50
+ INTEGER, PARAMETER::NSTATE=40
+ INTEGER I0, IACCOLD, IBMOLD, IBM, ICAL, IED1, IED2, IGR, ILONG,
+ & ISO, ITRANC, ITYLCM, I, JSO1, JSO, J, KSO1, KSO, NBISO1, NBISO2,
+ & NBISOT2, NBISOT, NBRG, NCOMB2, NCOMB, NDEL, NBESP, NDEPL, NDFI,
+ & NED1, NED2, NFINF, NL, NW, NTYPE
+ REAL WEIGHT
+ CHARACTER TEXT12*12,HNAME*12,HSMG*131,HVECT1(MAXED)*8,
+ 1 HVECT2(MAXED)*8,CHAR1*4,CHAR2*4,HHISO*8
+ INTEGER ISTATE(NSTATE)
+ LOGICAL LUSER
+ TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO,JPLIB,KPLIB
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYP1,ITOD1,IMIX2,ITYP2,
+ 1 ITOD2,MILVO,IMICR
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2
+ REAL, ALLOCATABLE, DIMENSION(:) :: TEMP1,VOL1,DENS2,TEMP2,VOL2,
+ 1 DENS3,TEMP3,VOL3,ENER,DELT,VOLMI2,GAR1,GAR2
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT,DENS1
+ TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPLIST
+ INTEGER NBISS
+ CHARACTER ISTMPN*12
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(HUSE1(3,MAXISO),HNAM1(3,MAXISO),ITYP1(MAXISO),
+ 1 ITOD1(MAXISO),IMIX2(MAXISO),ITYP2(MAXISO),ITOD2(MAXISO),
+ 2 HUSE2(3,MAXISO),HNAM2(3,MAXISO),MILVO(NMIX))
+ ALLOCATE(TEMP1(MAXISO),VOL1(MAXISO),DENS2(MAXISO),TEMP2(MAXISO),
+ 1 VOL2(MAXISO),ENER(NGRP+1),DELT(NGRP),VOLMI2(NMIX),IPLIST(MAXISO))
+ IACCOLD=IACCS ! for ADF and GFF
+*----
+* MICROLIB INITIALIZATION
+*----
+ ITRANC=0
+ VOLMI2(:NMIX)=0.0
+ DENS2(:MAXISO)=0.0
+ VOL2(:MAXISO)=0.0
+ TEMP2(:MAXISO)=0.0
+ IMIX2(:MAXISO)=0
+ ITYP2(:MAXISO)=0
+ ITOD2(:MAXISO)=0
+ IPLIST(:MAXISO)=C_NULL_PTR
+ IF(IACCS.EQ.0) THEN
+ IF(LRES) CALL XABORT('NCRLIB: RES OPTION IS INVALID.')
+ NBISO2=0
+ NCOMB2=0
+ NED2=0
+ TEXT12='L_LIBRARY'
+ CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12)
+ ELSE
+ CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
+ IF(ISTATE(1).NE.NMIX) CALL XABORT('NCRLIB: INVALID NUMBER OF '
+ 1 //'MATERIAL MIXTURES IN THE MICROLIB.')
+ IF(ISTATE(3).NE.NGRP) CALL XABORT('NCRLIB: INVALID NUMBER OF '
+ 1 //'ENERGY GROUPS IN THE MICROLIB.')
+ NBISO2=ISTATE(2)
+ NCOMB2=ISTATE(12)
+ IF(NBISO2.GT.MAXISO) CALL XABORT('NCRLIB: MAXISO OVERFLOW(1).')
+ NED2=ISTATE(13)
+ IF(NED2.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
+ CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM)
+ IF(ILONG.GT.0) THEN
+ CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2)
+ ELSE
+ VOLMI2(:NMIX)=0.0
+ ENDIF
+ CALL LCMGET(IPLIB,'ISOTOPESUSED',HUSE2)
+ CALL LCMGET(IPLIB,'ISOTOPERNAME',HNAM2)
+ CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYP2)
+ CALL LCMGET(IPLIB,'ISOTOPESTODO',ITOD2)
+ CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS2)
+ CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL2)
+ CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX2)
+ CALL LCMGET(IPLIB,'ISOTOPESTEMP',TEMP2)
+ IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
+ CALL LCMGET(IPLIB,'ENERGY',ENER)
+ CALL LCMGET(IPLIB,'DELTAU',DELT)
+ ENDIF
+*----
+* RECOVER NDEPL
+*----
+ NDEPL=0
+ CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILONG,ITYLCM)
+ IF(ILONG.NE.0) THEN
+ CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
+ CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
+ NDEPL=ISTATE(1)
+ CALL LCMSIX(IPCPO,' ',2)
+ ENDIF
+*----
+* LOOP OVER MICROLIB MIXTURES
+*----
+ ALLOCATE(DENS3(MAXISO),TEMP3(MAXISO),VOL3(MAXISO))
+ MILVO(:NMIX)=0
+ NCOMB=0
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ NBISS=0
+ DO 190 IBM=1,NMIX
+ IBMOLD=MIXC(IBM)
+ IF(IBMOLD.EQ.0) GO TO 190
+ IF(NISO(IBM).GT.MAXNIS) CALL XABORT('NCRLIB: MAXNIS OVERFLOW.')
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'CALCULATIONS')
+*----
+* FIND THE VALUE OF NBISO1 IN MIXTURE IBM
+*----
+ DO ICAL=1,NCAL
+ IF(TERP(ICAL,IBM).EQ.0.0) CYCLE
+ MPCPO=LCMGIL(LPCPO,ICAL)
+ CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
+ NBISO1=ISTATE(2)
+ CALL LCMGET(MPCPO,'ISOTOPESUSED',HUSE1)
+ CALL LCMGET(MPCPO,'ISOTOPERNAME',HNAM1)
+ EXIT
+ ENDDO
+ ALLOCATE(FACT(NCAL,NBISO1),DENS1(NBISO1,NCAL))
+*----
+* LOOP OVER ELEMENTARY CALCULATIONS
+*----
+ JSO1=0
+ DENS3(:NBISO1)=0.0
+ VOL3(:NBISO1)=0.0
+ TEMP3(:NBISO1)=0.0
+ DO 50 ICAL=1,NCAL
+ WEIGHT=TERP(ICAL,IBM)
+ IF(WEIGHT.EQ.0.0) GO TO 50
+ MPCPO=LCMGIL(LPCPO,ICAL)
+ IF(IMPX.GT.0) THEN
+ WRITE(IOUT,'(38H NCRLIB: MULTICOMPO ACCESS FOR MIXTURE,I8,
+ 1 5H (<==,I4,17H) AND CALCULATION,I8,9H. WEIGHT=,1P,E12.4)')
+ 2 IBM,IBMOLD,ICAL,WEIGHT
+ IF(IMPX.GT.50) CALL LCMLIB(MPCPO)
+ ENDIF
+ CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
+ IF(ISTATE(1).NE.1) CALL XABORT('NCRLIB: INVALID NUMBER OF MATERI'
+ 1 //'AL MIXTURES IN THE MULTICOMPO.')
+ IF(ISTATE(2).NE.NBISO1) CALL XABORT('NCRLIB: INVALID NBISO1.')
+ IF(ISTATE(3).NE.NGRP) CALL XABORT('NCRLIB: INVALID NUMBER OF ENE'
+ 1 //'RGY GROUPS IN THE MULTICOMPO.')
+ NL=ISTATE(4)
+ ITRANC=ISTATE(5)
+ NDEPL=MAX(ISTATE(11),NDEPL)
+ NED1=ISTATE(13)
+ NBESP=ISTATE(16)
+ NDEL=ISTATE(19)
+ NDFI=ISTATE(20)
+ NW=ISTATE(25)
+ IF(NED1.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
+ CALL LCMLEN(MPCPO,'MIXTURESVOL',ILONG,ITYLCM)
+ IF(ILONG.GT.0) CALL LCMGET(MPCPO,'MIXTURESVOL',VOLMI2(IBM))
+ CALL LCMGET(MPCPO,'ISOTOPESDENS',DENS1(1,ICAL))
+ CALL LCMGET(MPCPO,'ISOTOPESTYPE',ITYP1)
+ CALL LCMGET(MPCPO,'ISOTOPESTODO',ITOD1)
+ CALL LCMGET(MPCPO,'ISOTOPESVOL',VOL1)
+ CALL LCMGET(MPCPO,'ISOTOPESTEMP',TEMP1)
+ IF(NED1.GT.0) CALL LCMGTC(MPCPO,'ADDXSNAME-P0',8,NED1,HVECT1)
+ CALL LCMGET(MPCPO,'ENERGY',ENER)
+ CALL LCMGET(MPCPO,'DELTAU',DELT)
+ DO 30 IED1=1,NED1
+ DO 20 IED2=1,NED2
+ IF(HVECT1(IED1).EQ.HVECT2(IED2)) GO TO 30
+ 20 CONTINUE
+ NED2=NED2+1
+ IF(NED2.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
+ HVECT2(NED2)=HVECT1(IED1)
+ 30 CONTINUE
+ DO 49 ISO=1,NBISO1 ! multicompo isotope
+ WRITE(TEXT12,'(2A4)') (HUSE1(I,ISO),I=1,2)
+ IF(LXS) THEN
+ WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
+ READ(CHAR1,'(I4)') NBRG
+ NBISOT=NBRG+MAXFEL*(IBM-1)
+ IF(NBISOT.GT.9999) CALL XABORT('NCRLIB: NBISOT OVERFLOW.')
+ WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),NBISOT
+ ENDIF
+ KSO1=0
+ DO 40 KSO=1,NISO(IBM) ! user-selected isotope
+ WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
+ IF(TEXT12(:8).EQ.HHISO) THEN
+ KSO1=KSO
+ GO TO 45
+ ENDIF
+ 40 CONTINUE
+ 45 LUSER=.FALSE.
+ IF(KSO1.GT.0) LUSER=(CONC(IBM,KSO1).NE.-99.99)
+ IF(LUSER) DENS1(ISO,ICAL)=CONC(IBM,KSO1)
+ DENS3(ISO)=DENS3(ISO)+WEIGHT*DENS1(ISO,ICAL)
+ VOL3(ISO)=VOL3(ISO)+WEIGHT*VOL1(ISO)
+ TEMP3(ISO)=TEMP3(ISO)+WEIGHT*TEMP1(ISO)
+ 49 CONTINUE
+ 50 CONTINUE
+ FACT(:NCAL,:NBISO1)=1.0
+ IF(.NOT.LPURE) THEN
+ DO ICAL=1,NCAL
+ IF(TERP(ICAL,IBM).EQ.0.0) CYCLE
+ DO ISO=1,NBISO1 ! multicompo isotope
+ IF(DENS3(ISO).GT.DENS1(ISO,ICAL)*1.0E-9) THEN
+ FACT(ICAL,ISO)=DENS1(ISO,ICAL)/DENS3(ISO)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ DEALLOCATE(DENS1)
+*----
+* SET NUMBER DENSITIES AND VOLUMES IN OUTPUT MICROLIB
+*----
+ IF(LRES) THEN
+* -- Number densities are left unchanged except if they are
+* -- listed in HISO array.
+ DO 60 KSO=1,NISO(IBM) ! user-selected isotope
+ DO JSO=1,NBISO2 ! microlib isotope
+ IF(IMIX2(JSO).NE.IBM) CYCLE
+ IF((HISO(1,IBM,KSO).EQ.HUSE2(1,JSO)).AND.
+ 1 (HISO(2,IBM,KSO).EQ.HUSE2(2,JSO))) THEN
+ IF(CONC(IBM,KSO).EQ.-99.99) THEN
+* -- Only number densities of isotopes set with "MICR" and
+* -- "*" keywords are interpolated
+ DENS2(JSO)=0.0
+ DO ISO=1,NBISO1 ! multicompo isotope
+ JSO1=0
+ IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.
+ 1 (HUSE1(2,ISO).EQ.HUSE2(2,JSO))) THEN
+ IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN
+ WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO)
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(LXS) THEN
+ WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
+ WRITE(CHAR2,'(A4)') HUSE2(3,JSO)
+ READ(CHAR2,'(I4.4)') NBISOT2
+ NBISOT2=NBISOT2-MAXFEL*(IBM-1)
+ WRITE(CHAR2,'(I4.4)') NBISOT2
+ IF(CHAR1.EQ.CHAR2) THEN
+ JSO1=JSO
+ GO TO 55
+ ENDIF
+ ELSE
+ JSO1=JSO
+ GO TO 55
+ ENDIF
+ 55 IF(JSO1.EQ.0) CALL XABORT('NCRLIB: JSO1=0')
+ DENS2(JSO1)=DENS2(JSO1)+DENS3(ISO)
+ TEMP2(JSO1)=TEMP3(ISO)
+ ENDIF
+ ENDDO
+ ELSE IF(CONC(IBM,KSO).NE.-99.99) THEN
+* -- Number densities of isotopes set with "MICR" and
+* -- fixed value are forced to this value
+ DENS2(JSO)=CONC(IBM,KSO)
+ ENDIF
+ GO TO 60
+ ENDIF
+ ENDDO
+ WRITE(HSMG,'(31HNCRLIB: UNABLE TO FIND ISOTOPE ,2A4,6H IN MI,
+ 1 5HXTURE,I8,1H.)') HISO(1,IBM,KSO),HISO(2,IBM,KSO),IBM
+ CALL XABORT(HSMG)
+ 60 CONTINUE
+ ELSE
+* -- Number densities are interpolated or not according to
+* -- ALL/ONLY option
+ DO JSO=1,NBISO2 ! microlib isotope
+ IF(IBM.EQ.IMIX2(JSO)) THEN
+ DO ISO=1,NBISO1 ! multicompo isotope
+ IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.
+ 1 (HUSE1(2,ISO).EQ.HUSE2(2,JSO))) THEN
+ DENS2(JSO)=0.0
+ VOL2(JSO)=0.0
+ CYCLE
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ DO 110 ISO=1,NBISO1 ! multicompo isotope
+ WRITE(TEXT12,'(2A4)') (HUSE1(I,ISO),I=1,2)
+ IF(LXS) THEN
+ WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
+ READ(CHAR1,'(I4)') NBRG
+ NBISOT=NBRG+MAXFEL*(IBM-1)
+ IF(NBISOT.GT.9999) CALL XABORT('NCRLIB: NBISOT OVERFLOW.')
+ WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),NBISOT
+ ENDIF
+ IF(.NOT.LISO(IBM)) THEN
+* --ONLY option
+ DO KSO=1,NISO(IBM) ! user-selected isotope
+ WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
+ IF(TEXT12(:8).EQ.HHISO) GO TO 65
+ ENDDO
+ GO TO 110
+ ENDIF
+ 65 DO 70 JSO=1,NBISO2 ! microlib isotope
+ JSO1=0
+ IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.(HUSE1(2,ISO).EQ.
+ 1 HUSE2(2,JSO)).AND.(IMIX2(JSO).EQ.IBM)) THEN
+ IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN
+ WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO)
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(LXS) THEN
+ WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
+ WRITE(CHAR2,'(A4)') HUSE2(3,JSO)
+ READ(CHAR2,'(I4.4)') NBISOT2
+ NBISOT2=NBISOT2-MAXFEL*(IBM-1)
+ WRITE(CHAR2,'(I4.4)') NBISOT2
+ IF(CHAR1.EQ.CHAR2) THEN
+ JSO1=JSO
+ GO TO 100
+ ENDIF
+ ELSE
+ JSO1=JSO
+ GO TO 100
+ ENDIF
+ ENDIF
+ 70 CONTINUE
+ NBISO2=NBISO2+1
+ IF(NBISO2.GT.MAXISO) THEN
+ WRITE(IOUT,'(/16H NCRLIB: NBISO2=,I6,8H MAXISO=,I6)') NBISO2,
+ 1 MAXISO
+ CALL XABORT('NCRLIB: MAXISO OVERFLOW(2).')
+ ENDIF
+ READ(TEXT12,'(3A4)') (HUSE2(I0,NBISO2),I0=1,3)
+ DO 80 I0=1,3
+ HNAM2(I0,NBISO2)=HNAM1(I0,ISO)
+ 80 CONTINUE
+ IMIX2(NBISO2)=IBM
+ ITYP2(NBISO2)=ITYP1(ISO)
+ ITOD2(NBISO2)=ITOD1(ISO)
+ IF(ITYP2(NBISO2).EQ.1) ITOD2(NBISO2)=1
+ JSO1=NBISO2
+ IF(ITOD2(NBISO2).NE.1) THEN
+ DO 90 J=1,NCOMB
+ IF(IBM.EQ.MILVO(J)) GO TO 100
+ 90 CONTINUE
+ NCOMB=NCOMB+1
+ IF(NCOMB.GT.NMIX) CALL XABORT('NCRLIB: MILVO OVERFLOW.')
+ MILVO(NCOMB)=IBM
+ ENDIF
+ 100 DENS2(JSO1)=DENS2(JSO1)+DENS3(ISO)
+ VOL2(JSO1)=VOL2(JSO1)+VOL3(ISO)
+ TEMP2(JSO1)=TEMP3(ISO)
+ 110 CONTINUE
+ ENDIF
+*----
+* SELECT MICROLIB ISOTOPES CORRESPONDING TO MULTICOMPO ISOTOPES
+*----
+ ALLOCATE(IMICR(NBISO1))
+ IMICR(:NBISO1)=0
+ DO 130 ISO=1,NBISO2 ! microlib isotope
+ IF(IMIX2(ISO).NE.IBM) GO TO 130
+ DO 120 JSO=1,NBISO1 ! multicompo isotope
+ IF((HUSE1(1,JSO).EQ.HUSE2(1,ISO)).AND.(HUSE1(2,JSO).EQ.
+ 1 HUSE2(2,ISO))) THEN
+ IF(LXS) THEN
+ WRITE(CHAR1,'(A4)') HUSE1(3,JSO)
+ WRITE(CHAR2,'(A4)') HUSE2(3,ISO)
+ READ(CHAR1,'(I4.4)') NBRG
+ NBISOT=NBRG+MAXFEL*(IBM-1)
+ READ(CHAR2,'(I4.4)') NBISOT2
+ IF(NBISOT.EQ.NBISOT2) THEN
+ IMICR(JSO)=ISO
+ GO TO 130
+ ENDIF
+ ELSE
+ IMICR(JSO)=ISO
+ GO TO 130
+ ENDIF
+ ENDIF
+ 120 CONTINUE
+ WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO),I0=1,3)
+ CALL XABORT('NCRLIB: UNABLE TO FIND '//TEXT12//'.')
+ 130 CONTINUE
+*----
+* PROCESS ISOTOPE DIRECTORIES FOR MICROLIB MIXTURE IBM
+*----
+ DO 180 JSO=1,NBISO1 ! multicompo isotope
+ ISO=IMICR(JSO) ! microlib isotope
+ IF(ISO.EQ.0) GO TO 180
+ NBISS=NBISS+1
+ WRITE(HNAME,'(3A4)') (HUSE1(I0,JSO),I0=1,3)
+ WRITE(ISTMPN,'(A4,I6.6,A2)') '*ISO',NBISS,' *'
+ CALL LCMOP(KPLIB,ISTMPN,0,1,0)
+ IPLIST(ISO)=KPLIB ! set isot ISO
+ CALL NCRISO(KPLIB,LPCPO,NBISO1,IMICR,HNAME,JSO,IBMOLD,NCAL,NGRP,
+ 1 NL,NW,NED2,HVECT2,NDEL,NBESP,NDFI,IMPX,FACT(1,JSO),TERP(1,IBM),
+ 2 LPURE)
+ 180 CONTINUE
+ DEALLOCATE(IMICR,FACT)
+ 190 CONTINUE
+ DEALLOCATE(VOL3,TEMP3,DENS3)
+ DEALLOCATE(VOL1,TEMP1,MILVO,ITOD1,ITYP1,HNAM1,HUSE1)
+*----
+* CREATE ISOTOPE LIST DIRECTORY IN MICROLIB
+*----
+ JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO2)
+ DO 195 ISO=1,NBISO2 ! microlib isotope
+ IF(C_ASSOCIATED(IPLIST(ISO))) THEN
+ KPLIB=LCMDIL(JPLIB,ISO) ! step up isot ISO
+ CALL LCMEQU(IPLIST(ISO),KPLIB)
+ CALL LCMCL(IPLIST(ISO),2)
+ ENDIF
+ 195 CONTINUE
+ DEALLOCATE(IPLIST)
+*----
+* MICROLIB FINALIZATION
+*----
+ IF(.NOT.LRES) THEN
+ ISTATE(:NSTATE)=0
+ ISTATE(1)=NMIX
+ ISTATE(2)=NBISO2
+ ISTATE(3)=NGRP
+ ISTATE(4)=NL
+ ISTATE(5)=ITRANC
+ ISTATE(7)=1
+ ISTATE(11)=NDEPL
+ ISTATE(12)=NCOMB+NCOMB2
+ ISTATE(13)=NED2
+ ISTATE(14)=NMIX
+ ISTATE(18)=1
+ ISTATE(19)=NDEL
+ ISTATE(20)=NDFI
+ ISTATE(22)=MAXISO/NMIX
+ IF(NBISO2.EQ.0) CALL XABORT('NCRLIB: NBISO2=0.')
+ CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
+ CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIX,2,VOLMI2)
+ CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2)
+ CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2)
+ CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
+ CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2)
+ CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ITYP2)
+ CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2)
+ CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
+ CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2)
+ IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
+ CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER)
+ CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,DELT)
+ ELSE
+ CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
+ CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
+ CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2)
+ ENDIF
+ IF(IMPX.GT.5) CALL LCMLIB(IPLIB)
+ IACCS=1
+ DEALLOCATE(VOLMI2,DELT,ENER,VOL2,TEMP2,DENS2,HNAM2,HUSE2,ITOD2,
+ 1 ITYP2,IMIX2)
+*----
+* BUILD EMBEDDED MACROLIB
+*----
+ CALL SPHEMB(IPLIB,IPCPO,NGRP,NMIX,MIXC,IMPX)
+*----
+* INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
+*----
+ IF(B2.NE.0.0) THEN
+ IF(IMPX.GT.0) WRITE(6,'(/34H NCRLIB: INCLUDE LEAKAGE IN THE MA,
+ 1 11HCROLIB (B2=,1P,E12.5,2H).)') B2
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ JPLIB=LCMGID(IPLIB,'GROUP')
+ ALLOCATE(GAR1(NMIX),GAR2(NMIX))
+ DO 210 IGR=1,NGRP
+ KPLIB=LCMGIL(JPLIB,IGR)
+ CALL LCMGET(KPLIB,'NTOT0',GAR1)
+ CALL LCMGET(KPLIB,'DIFF',GAR2)
+ DO 200 IBM=1,NMIX
+ IF(MIXC(IBM).NE.0) GAR1(IBM)=GAR1(IBM)+B2*GAR2(IBM)
+ 200 CONTINUE
+ CALL LCMPUT(KPLIB,'NTOT0',NMIX,2,GAR1)
+ 210 CONTINUE
+ DEALLOCATE(GAR2,GAR1)
+ CALL LCMSIX(IPLIB,' ',2)
+ ENDIF
+*----
+* PROCESS ADF, GFF and physical albedos (if required)
+*----
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ KPCPO=LCMGIL(JPCPO,1)
+ LPCPO=LCMGID(KPCPO,'CALCULATIONS')
+ MPCPO=LCMGIL(LPCPO,1)
+ CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
+ IDF=ISTATE(24)
+ NTYPE=0
+ IF(IDF.EQ.1) THEN
+ NTYPE=2
+ ELSE IF(IDF.GE.2) THEN
+ CALL LCMSIX(MPCPO,'MACROLIB',1)
+ CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) CALL XABORT('NCRLIB: MISSING ADF DIRECTORY I'
+ 1 //'N MULTICOMPO OBJECT.')
+ CALL LCMSIX(MPCPO,'ADF',1)
+ CALL LCMGET(MPCPO,'NTYPE',NTYPE)
+ CALL LCMSIX(MPCPO,' ',2)
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+ IF(NGFF.GT.0) THEN
+ CALL LCMSIX(MPCPO,'MACROLIB',1)
+ CALL LCMLEN(MPCPO,'GFF',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) CALL XABORT('NCRLIB: MISSING GFF DIRECTORY I'
+ 1 //'N MULTICOMPO OBJECT.')
+ CALL LCMSIX(MPCPO,'GFF',1)
+ CALL LCMLEN(MPCPO,'FINF_NUMBER ',NFINF,ITYLCM)
+ CALL LCMSIX(MPCPO,' ',2)
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+ CALL LCMSIX(IPLIB,'MACROLIB',1)
+ CALL NCRAGF(IPLIB,IPCPO,IACCOLD,NMIL,NMIX,NGRP,NGFF,NALBP,IMPX,
+ 1 NCAL,TERP,MIXC,IDF,NTYPE,NFINF)
+ CALL LCMSIX(IPLIB,' ',2)
+ RETURN
+*
+ 500 FORMAT(8HNCRLIB: ,A,1H(,I4,2H)=,2I5)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 14:58:58 +0000