Merge branch '20-correct-a-ntot1-issue-in-spn-bivac-trivac-solutions' into 'main'

#20: Correct a NTOT1 issue in SPN Bivac/Trivac solutions

See merge request dragon/5.1!34

5 files changed, 27 insertions, 16 deletions

diff --git a/Trivac/src/BIVACA.f b/Trivac/src/BIVACA.f
index eeb30a2..f18cd64 100755
--- a/Trivac/src/BIVACA.f
+++ b/Trivac/src/BIVACA.f
@@ -127,6 +127,7 @@
       NANI=IPAR(3)
       NBFIS=IPAR(4)
       NALBP=IPAR(8)
+      NW=IPAR(10)
       IF(IGP(4).GT.NBMIX) THEN
          WRITE(HSMG,'(46HBIVACA: THE NUMBER OF MIXTURES IN THE TRACKING,
      1   2H (,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MAC,
@@ -199,7 +200,7 @@
      1   VOL,NBMIX)
       ELSE
 *        SIMPLIFIED PN THEORY.
-         CALL BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NAN,NBFIS,
+         CALL BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NAN,NW,NBFIS,
      1   NALBP,LDIFF,MAT,VOL,NBMIX)
       ENDIF
 *
diff --git a/Trivac/src/BIVSPS.f b/Trivac/src/BIVSPS.f
index d9e1ff4..e03ce67 100755
--- a/Trivac/src/BIVSPS.f
+++ b/Trivac/src/BIVSPS.f
@@ -1,6 +1,6 @@
 *DECK BIVSPS
-      SUBROUTINE BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NANI,NBFIS,
-     1 NALBP,LDIFF,MAT,VOL,NBMIX)
+      SUBROUTINE BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NANI,NW,
+     1 NBFIS,NALBP,LDIFF,MAT,VOL,NBMIX)
 *
 *-----------------------------------------------------------------------
 *
@@ -27,6 +27,7 @@
 * NEL     total number of finite elements.
 * NLF     number of Legendre orders for the flux (even number).
 * NANI    number of Legendre orders for the scattering cross sections.
+* NW      maximum Legendre order (0 or 1) for the total cross sections.
 * NBFIS   number of fissionable isotopes.
 * NALBP   number of physical albedos per energy group.
 * LDIFF   flag set to .true. to use 1/3D as 'NTOT1' cross sections.
@@ -41,7 +42,7 @@
 *  SUBROUTINE ARGUMENTS
 *----
       TYPE(C_PTR) IPTRK,IPMACR,IPSYS
-      INTEGER IMPX,NGRP,NEL,NLF,NANI,NBFIS,NALBP,MAT(NEL),NBMIX
+      INTEGER IMPX,NGRP,NEL,NLF,NANI,NW,NBFIS,NALBP,MAT(NEL),NBMIX
       REAL VOL(NEL)
       LOGICAL LDIFF
 *----
@@ -126,6 +127,8 @@
             DO 5 IBM=1,NBMIX
             SGD(IBM,2)=1.0/(3.0*SGD(IBM,2))
     5       CONTINUE
+         ELSE IF(NW.EQ.0) THEN
+            CALL LCMGET(KPMACR,'NTOT0',SGD(1,2))
          ELSE IF(LENGT.EQ.NBMIX) THEN
             CALL LCMGET(KPMACR,TEXT12,SGD(1,2))
          ELSE IF(LENGT1.EQ.NBMIX) THEN
diff --git a/Trivac/src/TRIRCA.f b/Trivac/src/TRIRCA.f
index 34cf544..8202f29 100755
--- a/Trivac/src/TRIRCA.f
+++ b/Trivac/src/TRIRCA.f
@@ -1,5 +1,6 @@
 *DECK TRIRCA
-      SUBROUTINE TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,LDIFF,IL,IPR,RCAT)
+      SUBROUTINE TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,NW,LDIFF,IL,IPR,
+     1 RCAT)
 *
 *-----------------------------------------------------------------------
 *
@@ -22,6 +23,7 @@
 * NGRP    number of energy groups.
 * NBMIX   total number of material mixtures in the macrolib.
 * NANI    maximum scattering order recovered from tracking and macrolib.
+* NW      maximum Legendre order (0 or 1) for the total cross sections.
 * LDIFF   flag set to .true. to use 1/3D as 'NTOT1' cross sections.
 * IL      scattering Legendre order.
 * IPR     type of assembly:
@@ -41,7 +43,7 @@
 *  SUBROUTINE ARGUMENTS
 *----
       TYPE(C_PTR) IPMACR,IPMACP
-      INTEGER NGRP,NBMIX,NANI,IL,IPR
+      INTEGER NGRP,NBMIX,NANI,NW,IL,IPR
       LOGICAL LDIFF
       DOUBLE PRECISION RCAT(NGRP,NGRP,NBMIX)
 *----
@@ -59,7 +61,7 @@
 *----
       ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX))
       ALLOCATE(SGD(NBMIX,3),WORK(NBMIX*NGRP))
-*      
+*
       JPMACR=LCMGID(IPMACR,'GROUP')
       JPMACP=LCMGID(IPMACP,'GROUP')
       WRITE(CM,'(I2.2)') IL-1
@@ -128,9 +130,11 @@
             ENDIF
             GO TO 100
          ELSE
-            IF(LENGT.EQ.NBMIX) THEN
+            IF(NW.EQ.0) THEN
+               CALL LCMGET(KPMACP,'NTOT0',SGD(1,2))
+            ELSE IF(LENGT.EQ.NBMIX) THEN
                CALL LCMGET(KPMACP,TEXT12,SGD(1,2))
-            ELSE IF(LENGT1.EQ.NBMIX) THEN
+            ELSE IF((NW.GE.1).AND.(LENGT1.EQ.NBMIX)) THEN
                CALL LCMGET(KPMACP,'NTOT1',SGD(1,2))
             ELSE
                CALL LCMGET(KPMACP,'NTOT0',SGD(1,2))
diff --git a/Trivac/src/TRISPS.f b/Trivac/src/TRISPS.f
index 10cd2cf..1fddcae 100755
--- a/Trivac/src/TRISPS.f
+++ b/Trivac/src/TRISPS.f
@@ -1,6 +1,6 @@
 *DECK TRISPS
       SUBROUTINE TRISPS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NLF,
-     1 NANI,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
+     1 NANI,NW,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
 *
 *-----------------------------------------------------------------------
 *
@@ -30,6 +30,7 @@
 * NEL     total number of finite elements.
 * NLF     number of Legendre orders for the flux (even number).
 * NANI    number of Legendre orders for the scattering cross sections.
+* NW      maximum Legendre order (0 or 1) for the total cross sections.
 * NBFIS   number of fissionable isotopes.
 * NALBP   number of physical albedos per energy group.
 * LDIFF   flag set to .true. to use 1/3D as 'NTOT1' cross sections.
@@ -50,7 +51,7 @@
 *  SUBROUTINE ARGUMENTS
 *----
       TYPE(C_PTR) IPTRK,IPMACR,IPMACP,IPSYS
-      INTEGER IMPX,NGRP,NEL,NLF,NANI,NBFIS,NALBP,IPR,MAT(NEL),NBMIX
+      INTEGER IMPX,NGRP,NEL,NLF,NANI,NW,NBFIS,NALBP,IPR,MAT(NEL),NBMIX
       REAL VOL(NEL)
       LOGICAL LDIFF
 *----
@@ -84,7 +85,7 @@
       IF(NLF.EQ.0) CALL XABORT('TRISPS: SPN APPROXIMATION REQUESTED.')
       DO 142 IL=1,NLF
       WRITE(CM,'(I2.2)') IL-1
-      CALL TRIRCA(IPMACR,IPMACR,NGRP,NBMIX,NANI,LDIFF,IL,0,RCAT)
+      CALL TRIRCA(IPMACR,IPMACR,NGRP,NBMIX,NANI,NW,LDIFF,IL,0,RCAT)
       IF(IPR.EQ.0) THEN
          DO 20 IBM=1,NBMIX
          DO 15 JGR=1,NGRP
@@ -97,7 +98,8 @@
    20    CONTINUE
       ELSE
          ALLOCATE(RCAT2(NGRP,NGRP,NBMIX),GAR(NGRP))
-         CALL TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,LDIFF,IL,IPR,RCAT2)
+         CALL TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,NW,LDIFF,IL,IPR,
+     1   RCAT2)
          IF(IPR.EQ.1) THEN
             DO 62 IBM=1,NBMIX
             DO 31 JGR=1,NGRP
diff --git a/Trivac/src/TRIVAA.f b/Trivac/src/TRIVAA.f
index acee907..b1628c4 100755
--- a/Trivac/src/TRIVAA.f
+++ b/Trivac/src/TRIVAA.f
@@ -140,6 +140,7 @@
       NANI=IPAR(3)
       NBFIS=IPAR(4)
       NALBP=IPAR(8)
+      NW=IPAR(10)
       IF(IGP(4).GT.NBMIX) THEN
          WRITE(HSMG,'(46HTRIVAA: THE NUMBER OF MIXTURES IN THE TRACKING,
      1   2H (,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MAC,
@@ -253,7 +254,7 @@
          ELSE
 *           SIMPLIFIED PN THEORY.
             CALL TRISPS(IPTRK,IPMACR,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,
-     1      NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
+     1      NAN,NW,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
          ENDIF
       ELSE IF((IASM.EQ.1).AND.(IPR.EQ.0)) THEN
 *        PERFORM FACTORIZATION WITHOUT ASSEMBLY.
@@ -270,7 +271,7 @@
          ELSE
 *           SIMPLIFIED PN THEORY.
             CALL TRISPS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NLF,
-     1      NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
+     1      NAN,NW,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
          ENDIF
       ELSE IF(NSTEP.GT.0) THEN
 *        ASSEMBLY OF PERTURBED SYSTEM MATRICES (WITH STEP DIRECTORIES).
@@ -287,7 +288,7 @@
          ELSE
 *           SIMPLIFIED PN THEORY.
             CALL TRISPS(IPTRK,IPMACR,KPMACR,KPSYS,IMPX,NGRP,NEL,NLF,
-     1      NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
+     1      NAN,NW,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX)
          ENDIF
    50    CONTINUE
       ELSE