Initial commit from Polytechnique Montreal

1 files changed, 492 insertions, 0 deletions

diff --git a/Dragon/src/USSDRV.f b/Dragon/src/USSDRV.f
new file mode 100644
index 0000000..ae8ea6f
--- /dev/null
+++ b/Dragon/src/USSDRV.f
@@ -0,0 +1,492 @@
+*DECK USSDRV
+      SUBROUTINE USSDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX,
+     1 IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW,
+     2 ITRANC,IPHASE,TITR,KSPH,NRES,NPASS,ICALC,ICORR,ISUBG,MAXST,
+     3 LFLAT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Driver for a resonance self-shielding calculation.
+*
+*Copyright:
+* Copyright (C) 2003 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
+* IPLI0   pointer to the internal microscopic cross section library
+*         builded by the self-shielding module (L_LIBRARY signature).
+* IPTRK   pointer to the tracking (L_TRACK signature).
+* IPLIB   pointer to the internal microscopic cross section library
+*         with subgroups (L_LIBRARY signature).
+* IFTRAK  unit number of the sequential binary tracking file.
+* INDREC  access flag for the internal microscopic cross section library
+*         builded by the self-shielding module (=1 IPLI0 access in
+*         creation mode; =2 in modification mode).
+* CDOOR   name of the geometry/solution operator.
+* IMPX    print flag (equal to zero for no print).
+* IGRMIN  first group where the self-shielding is applied.
+* IGRMAX  most thermal group where the self-shielding is applied.
+* NGRP    number of energy groups.
+* NBMIX   number of mixtures in the internal library.
+* NREG    number of regions.
+* NUN     number of unknowns per energy group.
+* NBISO   number of isotopes specifications in the internal library.
+* NL      number of Legendre orders required in the calculation
+*         (NL=1 or higher).
+* NED     number of extra vector edits.
+* NDEL    number of delayed neutron precursor groups.
+* LEAKSW  leakage flag (LEAKSW=.TRUE. if neutron leakage through
+*         external boundary is present).
+* ITRANC  type of transport correction.
+* IPHASE  type of flux solution (=1 use a native flux solution door;
+*         =2 use collision probabilities).
+* TITR    title.
+* KSPH    SPH equivalence flag (=0 no SPH correction; =1 SPH correction
+*         in the fuel).
+* NRES    number of self-shielding zones, as given by LIB:.
+* NPASS   number of outer iterations.
+* ICALC   simplified self-shielding flag (=1 IPLI0 is containing ICALC
+*         data. =0 no ICALC data).
+* ICORR   mutual resonance shielding flag (=1 to suppress the model
+*         in cases it is required in LIB operator).
+* ISUBG   type of self-shielding model (=1 use physical probability
+*         tables; =3 use original Ribon method; =4 use Ribon extended
+*         method; =6 use resonance spectrum expansion method).
+* MAXST   maximum number of fixed point iterations for the ST scattering
+*         source.
+* LFLAT   force the initial subgroup flux to be flat if IPLI0 is open
+*         in modification mode.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLI0,IPTRK,IPLIB
+      INTEGER IFTRAK,INDREC,IMPX,IGRMIN,IGRMAX,NGRP,NBMIX,NREG,NUN,
+     1 NBISO,NL,NED,NDEL,ITRANC,IPHASE,KSPH,NRES,NPASS,ICALC,ICORR,
+     2 ISUBG,MAXST
+      CHARACTER CDOOR*12,TITR*72
+      LOGICAL LEAKSW,LFLAT
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NSTATE=40,MAXRSS=300,MAXESP=4)
+      TYPE(C_PTR) JPLI0,KPLI0,JPLIB,KPLIB
+      CHARACTER HSMG*131,HCAL*12,TEXT4*4,NAM1*4,FNAM1*4,NAM2*12,
+     1 FNAM2*12,CBDPNM*12,TEXT8*8
+      INTEGER IPAR(NSTATE),IRSS(MAXRSS),IESP(MAXESP+1)
+      REAL TMPDAY(3),EESP(MAXESP+1)
+      LOGICAL LTEST
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,KEYFLX,MIX,IEVOL,ITYPE,
+     1 LSHI,IAPT,IHSUF,IREX,ILLIB,JCEDM,LSHI2
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,ISONRF,IHLIB
+      REAL, ALLOCATABLE, DIMENSION(:) :: VOL,TN,DEN,ENER,GS,VOLMIX
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(MAT(NREG),KEYFLX(NREG),ISONAM(3,NBISO),ISONRF(3,NBISO),
+     3 MIX(NBISO),IEVOL(NBISO),ITYPE(NBISO),LSHI(NBISO),IAPT(NBISO),
+     4 IHSUF(NBISO),IREX(NBMIX),IHLIB(2,NBISO),ILLIB(NBISO))
+      ALLOCATE(VOL(NREG),TN(NBISO),DEN(NBISO))
+*----
+*  RECOVER USEFUL INFORMATION FROM TRACKING OBJECT.
+*----
+      CALL LCMGET(IPTRK,'MATCOD',MAT)
+      CALL LCMGET(IPTRK,'VOLUME',VOL)
+      CALL LCMGET(IPTRK,'KEYFLX',KEYFLX)
+*----
+*  RECOVER USEFUL INFORMATION FROM LIBRARY OBJECTS.
+*----
+      CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONAM)
+      CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF)
+      CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX)
+      CALL LCMGET(IPLIB,'ISOTOPESTODO',IEVOL)
+      CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYPE)
+      CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN)
+*
+      CALL LCMPUT(IPLI0,'ISOTOPESMIX',NBISO,1,MIX)
+      CALL LCMPUT(IPLI0,'ISOTOPESTODO',NBISO,1,IEVOL)
+      CALL LCMPUT(IPLI0,'ISOTOPESTYPE',NBISO,1,ITYPE)
+      CALL LCMPUT(IPLI0,'ISOTOPESTEMP',NBISO,2,TN)
+      IF(INDREC.EQ.1) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN)
+         CALL LCMPUT(IPLI0,'ISOTOPESDENS',NBISO,2,DEN)
+      ELSE IF(INDREC.EQ.2) THEN
+         CALL LCMGET(IPLI0,'ISOTOPESDENS',DEN)
+      ENDIF
+      CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI)
+      CALL LCMLEN(IPLIB,'ISOTOPESDSN',NELSN,ITYLCM)
+      IF(NELSN.GT.0) THEN
+        NGIS=NGRP*NBISO
+        ALLOCATE(GS(NGIS))
+        CALL LCMGET(IPLIB,'ISOTOPESDSN',GS)
+        CALL LCMPUT(IPLI0,'ISOTOPESDSN',NGIS,2,GS)
+        CALL LCMGET(IPLIB,'ISOTOPESDSB',GS)
+        CALL LCMPUT(IPLI0,'ISOTOPESDSB',NGIS,2,GS)
+        DEALLOCATE(GS)
+      ENDIF
+      ALLOCATE(ENER(NGRP+1))
+      CALL LCMGET(IPLIB,'ENERGY',ENER)
+      CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENER)
+      CALL LCMGET(IPLIB,'DELTAU',ENER)
+      CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENER)
+      DEALLOCATE(ENER)
+      CALL LCMLEN(IPLIB,'CHI-LIMITS',NBESP,ITYLCM)
+      IF(NBESP.GT.0) THEN
+         NBESP=NBESP-1
+         IF(NBESP.GT.MAXESP) CALL XABORT('USSDRV: MAXESP OVERFLOW.')
+         CALL LCMGET(IPLIB,'CHI-LIMITS',IESP)
+         CALL LCMPUT(IPLI0,'CHI-LIMITS',NBESP+1,1,IESP)
+         CALL LCMGET(IPLIB,'CHI-ENERGY',EESP)
+         CALL LCMPUT(IPLI0,'CHI-ENERGY',NBESP+1,2,EESP)
+      ENDIF
+      DO 10 ISO=1,NBISO
+      DO 5 I=1,NREG
+      IF(MAT(I).EQ.MIX(ISO)) GO TO 10
+    5 CONTINUE
+      LSHI(ISO)=0
+   10 CONTINUE
+*----
+*  COMPUTE MIXTURESVOL.
+*----
+      ALLOCATE(VOLMIX(NBMIX))
+      VOLMIX(:NBMIX)=0.0
+      DO I=1,NREG
+        IBM=MAT(I)
+        IF(IBM.GT.0) VOLMIX(IBM)=VOLMIX(IBM)+VOL(I)
+        CALL LCMPUT(IPLI0,'MIXTURESVOL',NBMIX,2,VOLMIX)
+      ENDDO
+      DEALLOCATE(VOLMIX)
+*
+      DO 15 ISO=1,NBISO
+      TEXT8='MICROLIB'
+      READ(TEXT8,'(2A4)') IHLIB(1,ISO),IHLIB(2,ISO)
+      ILLIB(ISO)=0
+   15 CONTINUE
+      CALL LCMPUT(IPLI0,'ILIBRARYTYPE',2*NBISO,3,IHLIB(1,1))
+      CALL LCMPUT(IPLI0,'ILIBRARYINDX',NBISO,1,ILLIB)
+*
+      JPLIB=LCMGID(IPLIB,'ISOTOPESLIST')
+      JPLI0=LCMLID(IPLI0,'ISOTOPESLIST',NBISO)
+      IF(INDREC.EQ.1) THEN
+*        COPY THE NON RESONANT ISOTOPES.
+         CALL KDRCPU(TK1)
+         DO 20 ISO=1,NBISO
+         IF((LSHI(ISO).EQ.0).OR.(DEN(ISO).EQ.0.0)) THEN
+            CALL LCMLEL(JPLIB,ISO,ILEN,ITYLCM)
+            IF(ILEN.EQ.0) THEN
+              DO JSO=1,ISO-1
+                CALL LCMLEL(JPLIB,JSO,ILEN,ITYLCM)
+                IF(ILEN.EQ.0) CYCLE
+                IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND.(ISONAM(2,ISO)
+     1          .EQ.ISONAM(2,JSO)).AND.(ISONAM(3,ISO).EQ.ISONAM(3,JSO)))
+     2          THEN
+                  IF(LSHI(JSO).GT.0) THEN
+                    KPLIB=LCMGIL(JPLIB,JSO) ! set JSO-th isotope
+                    GO TO 16
+                  ELSE
+                    GO TO 20
+                  ENDIF
+                ENDIF
+              ENDDO
+            ELSE
+              KPLIB=LCMGIL(JPLIB,ISO) ! set ISO-th isotope
+              GO TO 16
+            ENDIF
+            GO TO 20
+   16       CALL LCMLEL(JPLI0,ISO,ILEN,ITYLCM)
+            IF(ILEN.NE.0) GO TO 20
+            KPLI0=LCMDIL(JPLI0,ISO) ! set ISO-th isotope
+            CALL LCMEQU(KPLIB,KPLI0)
+         ENDIF
+   20    CONTINUE
+         CALL KDRCPU(TK2)
+         IF(IMPX.GT.1) WRITE(6,'(/33H USSDRV: CPU TIME SPENT TO COPY T,
+     1   26HHE NON-RESONANT ISOTOPES =,F8.1,8H SECOND.)') TK2-TK1
+*
+*        WRITE THE OUTPUT INTERNAL LIBRARY PARAMETERS.
+         CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
+         IPAR(8)=0
+         IPAR(17)=0
+         CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAR)
+         IF(NED.GT.0) THEN
+            ALLOCATE(JCEDM(2*NED))
+            CALL LCMGET(IPLIB,'ADDXSNAME-P0',JCEDM)
+            CALL LCMPUT(IPLI0,'ADDXSNAME-P0',2*NED,3,JCEDM)
+            DEALLOCATE(JCEDM)
+         ENDIF
+         CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG,ITYLCM)
+         IF(ILENG.NE.0) THEN
+            CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
+            CALL LCMSIX(IPLI0,'DEPL-CHAIN',1)
+            CALL LCMEQU(IPLIB,IPLI0)
+            CALL LCMSIX(IPLI0,' ',2)
+            CALL LCMSIX(IPLIB,' ',2)
+         ENDIF
+      ENDIF
+*----
+*  RECOMPUTE THE VECTOR LSHI.
+*----
+      ALLOCATE(LSHI2(NBISO))
+      NRES2=0
+      NRES3=0
+      DO 30 ISO=1,NBISO
+      IF(LSHI(ISO).NE.0) NRES3=NRES3+1
+      LSHI2(ISO)=0
+   30 CONTINUE
+      DO 80 INRS=1,NRES
+   40 DENMAX=0.0
+      KSOT=0
+      DO 60 ISO=1,NBISO
+      IF(LSHI2(ISO).EQ.0) THEN
+         VOLISO=0.0
+         DO 50 I=1,NREG
+         IF(MAT(I).EQ.MIX(ISO)) VOLISO=VOLISO+VOL(I)
+   50    CONTINUE
+         IF((ABS(LSHI(ISO)).EQ.INRS).AND.(DEN(ISO)*VOLISO.GT.DENMAX))
+     1   THEN
+            KSOT=ISO
+            DENMAX=DEN(ISO)*VOLISO
+         ENDIF
+      ENDIF
+   60 CONTINUE
+      IF(KSOT.GT.0) THEN
+         NRES2=NRES2+1
+         DO 70 ISO=1,NBISO
+         LTEST=((ISONRF(1,ISO).EQ.ISONRF(1,KSOT)).AND.
+     1      (ISONRF(2,ISO).EQ.ISONRF(2,KSOT)).AND.
+     2      (ISONRF(3,ISO).EQ.ISONRF(3,KSOT)).AND.
+     3      (ABS(LSHI(ISO)).EQ.INRS))
+         LTEST=LTEST.OR.((ISONAM(1,ISO).EQ.ISONAM(1,KSOT)).AND.
+     1      (ISONAM(2,ISO).EQ.ISONAM(2,KSOT)).AND.
+     2      (ABS(LSHI(ISO)).EQ.INRS))
+         IF(LTEST) LSHI2(ISO)=NRES2
+         IF(LTEST.AND.(LSHI(ISO).EQ.-INRS)) THEN
+            DO 65 JSO=1,NBISO
+            IF(LSHI(JSO).EQ.LSHI(ISO)) LSHI2(JSO)=NRES2
+   65       CONTINUE
+         ENDIF
+   70    CONTINUE
+         GO TO 40
+      ENDIF
+   80 CONTINUE
+      IF(NRES2.EQ.0) THEN
+        CALL LCMEQU(IPLIB,IPLI0)
+        GO TO 266
+      ENDIF
+*----
+* FIND THE ISOTOPE-NAME SUFFIX VALUES.
+*----
+      TEXT4=' '
+      READ(TEXT4,'(A4)') IHBLK
+      DO 90 ISO=1,NBISO
+      IF((LSHI2(ISO).NE.0).AND.(DEN(ISO).NE.0.0)) THEN
+         WRITE(TEXT4,'(I4.4)') MIX(ISO)
+         READ(TEXT4,'(A4)') IHSUF(ISO)
+      ELSE
+         IHSUF(ISO)=IHBLK
+      ENDIF
+   90 CONTINUE
+      IF(ICALC.EQ.1) THEN
+         CALL LCMSIX(IPLI0,'SHIBA_SG',1)
+         CALL LCMSIX(IPLI0,'-DATA-CALC-',1)
+         NAM1=' '
+         CALL LCMNXT(IPLI0,NAM1)
+         FNAM1=NAM1
+  100    CALL LCMSIX(IPLI0,NAM1,1)
+            NAM2=' '
+            CALL LCMNXT(IPLI0,NAM2)
+            FNAM2=NAM2
+  110       CALL LCMLEN(IPLI0,NAM2,NRSS,ITYLCM)
+            CALL LCMGET(IPLI0,NAM2,IRSS)
+            READ(NAM2,'(2A4)') IN1,IN2
+            DO 130 ISO=1,NBISO
+            IF((ISONAM(1,ISO).EQ.IN1).AND.(ISONAM(2,ISO).EQ.IN2).AND.
+     1      (LSHI2(ISO).NE.0)) THEN
+               IF((NRSS.EQ.1).AND.(IRSS(1).EQ.-999)) THEN
+                  READ(NAM1,'(A4)') IHSUF(ISO)
+               ELSE
+                  DO 120 I=1,NRSS
+                  IF(IRSS(I).EQ.MIX(ISO)) READ(NAM1,'(A4)') IHSUF(ISO)
+  120             CONTINUE
+               ENDIF
+            ENDIF
+  130       CONTINUE
+            CALL LCMNXT(IPLI0,NAM2)
+            IF(NAM2.EQ.FNAM2) GO TO 140
+            GO TO 110
+  140    CALL LCMSIX(IPLI0,' ',2)
+         CALL LCMNXT(IPLI0,NAM1)
+         IF(NAM1.EQ.FNAM1) THEN
+            CALL LCMSIX(IPLI0,' ',2)
+            CALL LCMSIX(IPLI0,' ',2)
+            GO TO 150
+         ENDIF
+         GO TO 100
+      ENDIF
+*
+  150 NPASS2=NPASS
+      IF(NRES3.EQ.1) NPASS2=1
+      DO 265 IPASS=1,NPASS2
+      IF((IMPX.GT.0).AND.(NPASS2.GT.1)) WRITE (6,'(/15H USSDRV: SELF S,
+     1 25HHIELDING ITERATION NUMBER,I4,8H  NRES2=,I4,1H.)') IPASS,NRES2
+      DO 260 INRS=1,NRES2
+*----
+*  COMPUTE THE NUMBER OF RESONANT ISOTOPES IN REGION INRS AND THE
+*  RESONANT ISOTOPE INDEX ASSOCIATED TO EACH ISOTOPE SPECIFICATION.
+*----
+      NIRES=0
+      DO 200 ISO=1,NBISO
+      IAPT(ISO)=0
+      IF((LSHI2(ISO).EQ.INRS).AND.(DEN(ISO).NE.0.0)) THEN
+         DO 170 I=1,NREG
+         IF(MAT(I).EQ.MIX(ISO)) GO TO 180
+  170    CONTINUE
+         GO TO 200
+  180    DO 190 JSO=1,ISO-1
+         IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND.
+     1      (ISONAM(2,ISO).EQ.ISONAM(2,JSO)).AND.
+     2      (ISONAM(3,ISO).EQ.ISONAM(3,JSO)).AND.
+     3      (LSHI2(JSO).EQ.INRS).AND.
+     4      (DEN(JSO).NE.0.0).AND.(IAPT(JSO).NE.0)) THEN
+              IAPT(ISO)=IAPT(JSO)
+              GO TO 200
+         ENDIF
+  190    CONTINUE
+         IIII=ISO
+         NIRES=NIRES+1
+         IAPT(ISO)=NIRES
+      ENDIF
+  200 CONTINUE
+      WRITE(HCAL,'(1HC,I5.5,1H/,I5.5)') IIII,NBISO
+      IF(NIRES.EQ.0) THEN
+         WRITE(HSMG,'(45HUSSDRV: NO RESONANT ISOTOPES IN RESONANT REGI,
+     1   9HON NUMBER,I4,7H (HCAL=,A12,2H).)') INRS,HCAL
+         CALL XABORT(HSMG)
+      ENDIF
+      IF(IMPX.GT.0) WRITE (6,'(/35H USSDRV: PERFORMING SELF-SHIELDING ,
+     1 18HCALCULATION NAMED ,A12,1H.)') HCAL
+*----
+*  FIND THE NUMBER OF FUEL REGIONS AND THE FUEL REGION INDICES ASSIGNED
+*  TO EACH RESONANT MIXTURE.
+*----
+      NBNRS=0
+      DO 210 IBM=1,NBMIX
+      IREX(IBM)=0
+  210 CONTINUE
+      DO 230 ISO=1,NBISO
+      IBM=MIX(ISO)
+      IF((IAPT(ISO).GT.0).AND.(IREX(IBM).EQ.0)) THEN
+         DO 220 JSO=1,ISO-1
+         IF((IHSUF(JSO).EQ.IHSUF(ISO)).AND.(IAPT(JSO).EQ.IAPT(ISO)))
+     1   THEN
+            IREX(IBM)=IREX(MIX(JSO))
+            GO TO 230
+         ENDIF
+  220    CONTINUE
+         IF(IMPX.GT.0) WRITE(6,'(9X,3H-->,3A4)') (ISONAM(J,ISO),J=1,2),
+     1   IHSUF(ISO)
+         NBNRS=NBNRS+1
+         IREX(IBM)=NBNRS
+      ELSE IF(IAPT(ISO).GT.0) THEN
+         IF(IMPX.GT.0) WRITE(6,'(9X,3H-->,3A4)') (ISONAM(J,ISO),J=1,3)
+      ENDIF
+  230 CONTINUE
+      IF(NBNRS.EQ.0) THEN
+         WRITE (HSMG,'(33HUSSDRV: INVALID RESONANT REGION =,I10)') INRS
+         CALL XABORT(HSMG)
+      ENDIF
+      IF(IMPX.GE.0) WRITE(6,410) NIRES,NBNRS,INRS
+*----
+*  DETERMINE WHICH MODERATOR ISOTOPES ARE MIXED WITH RESONANT ONES.
+*----
+      DO 250 ISO=1,NBISO
+      IF((IAPT(ISO).EQ.0).AND.(IREX(MIX(ISO)).GT.0)) IAPT(ISO)=NIRES+1
+  250 CONTINUE
+*----
+*  ERASE OLD GROUP-INFO AND ASSEMB- DIRECTORIES.
+*----
+      IF(LFLAT.AND.(IPASS.EQ.1).AND.(INDREC.EQ.2)) THEN
+         CALL LCMSIX(IPLI0,'SHIBA_SG',1)
+         CALL LCMSIX(IPLI0,HCAL,1)
+         DO IRES=1,NIRES
+            WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES
+            CALL LCMSIX(IPLI0,CBDPNM,1)
+            CALL LCMLEN(IPLI0,'GROUP-INFO',ILONG,ITYLCM)
+            IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'GROUP-INFO')
+            CALL LCMLEN(IPLI0,'ASSEMB-PHYS',ILONG,ITYLCM)
+            IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-PHYS')
+            CALL LCMLEN(IPLI0,'ASSEMB-RIBON',ILONG,ITYLCM)
+            IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-RIBON')
+            CALL LCMLEN(IPLI0,'ASSEMB-RSE',ILONG,ITYLCM)
+            IF(ILONG.GT.0) CALL LCMDEL(IPLI0,'ASSEMB-RSE')
+            CALL LCMSIX(IPLI0,' ',2)
+         ENDDO
+         CALL LCMSIX(IPLI0,' ',2)
+         CALL LCMSIX(IPLI0,' ',2)
+      ENDIF
+*----
+*  PERFORM A SELF-SHIELDING CALCULATION NAMED HCAL.
+*----
+      CALL USSONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,IGRMIN,IGRMAX,
+     1 NIRES,NBNRS,IREX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,ISONAM,
+     2 IHSUF,HCAL,DEN,MIX,IAPT,MAT,VOL,KEYFLX,LEAKSW,ITRANC,IPHASE,
+     3 TITR,KSPH,ICORR,ISUBG,MAXST)
+  260 CONTINUE
+  265 CONTINUE
+  266 DEALLOCATE(LSHI2)
+      IF(IMPX.GE.4) CALL LCMLIB(IPLI0)
+*----
+*  BUILD THE MACROLIB IN THE OUTPUT INTERNAL LIBRARY.
+*----
+      ALLOCATE(MASK(NBMIX))
+      DO 280 IBM=1,NBMIX
+      MASK(IBM)=.TRUE.
+      DO 270 I=1,NREG
+      IF(MAT(I).EQ.IBM) GO TO 280
+  270 CONTINUE
+      MASK(IBM)=.FALSE.
+  280 CONTINUE
+      ALLOCATE(MASKL(NGRP))
+      DO 290 I=1,NGRP
+      MASKL(I)=.TRUE.
+  290 CONTINUE
+*
+      ITSTMP=0
+      TMPDAY(1)=0.0
+      TMPDAY(2)=0.0
+      TMPDAY(3)=0.0
+      CALL KDRCPU(TK1)
+      CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILENG,ITYLCM)
+      IF(ILENG.EQ.0) CALL XABORT('USSDRV: MISSING ISOTOPESUSED RECORD.')
+      CALL LCMGET(IPLI0,'ISOTOPESUSED',ISONAM)
+      CALL LIBMIX(IPLI0,NBMIX,NGRP,NBISO,ISONAM,MIX,DEN,MASK,MASKL,
+     1 ITSTMP,TMPDAY)
+      CALL KDRCPU(TK2)
+      IF(IMPX.GT.1) WRITE(6,'(/37H USSDRV: CPU TIME SPENT TO BUILD THE ,
+     1 19HEMBEDDED MACROLIB =,F8.1,8H SECOND.)') TK2-TK1
+      DEALLOCATE(MASKL,MASK)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DEN,TN,VOL)
+      DEALLOCATE(ILLIB,IHLIB,IREX,IHSUF,IAPT,LSHI,ITYPE,IEVOL,MIX,
+     1 ISONRF,ISONAM,KEYFLX,MAT)
+      RETURN
+*
+  410 FORMAT(/48H USSDRV: NUMBER OF CORRELATED RESONANT ISOTOPES=,I4/9X,
+     1 35HNUMBER OF CORRELATED FUEL MIXTURES=,I4,19H IN RESONANT REGION,
+     2 I3)
+      END