Initial commit from Polytechnique Montreal

1 files changed, 149 insertions, 0 deletions

diff --git a/Dragon/src/BIVAA.f b/Dragon/src/BIVAA.f
new file mode 100644
index 0000000..bc80653
--- /dev/null
+++ b/Dragon/src/BIVAA.f
@@ -0,0 +1,149 @@
+*DECK BIVAA
+      SUBROUTINE BIVAA(IPSYS,IPTRK,IMPX,NREG,NBMIX,NANI,NW,MAT,VOL,
+     1 SIGT0,SIGW0,DIFF)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Assembly of one-speed finite-difference or finite-element matrices
+* for a discretization of the 2D diffusion equation.
+*
+*Copyright:
+* Copyright (C) 2004 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
+* IPSYS   pointer to the system matrices.
+* IPTRK   pointer to the tracking (L_TRACK signature).
+* IMPX    print flag (equal to zero for no print).
+* NREG    total number of merged regions for which specific values
+*         of the neutron flux and reaction rates are required.
+* NBMIX   number of mixtures.
+* NANI    number of Legendre orders for the scattering cross sections.
+* NW      type of weighting for P1 cross section info (=0: P0 ; =1: P1).
+* MAT     index-number of the mixture type assigned to each volume.
+* VOL     volumes.
+* SIGT0   P0 and P1 total macroscopic cross sections ordered by mixture.
+* SIGW0   within-group scattering macroscopic cross section ordered
+*         by mixture.
+* DIFF    diffusion coefficients ordered by mixture.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSYS,IPTRK
+      INTEGER IMPX,NREG,NBMIX,NANI,NW,MAT(NREG)
+      REAL VOL(NREG),SIGT0(0:NBMIX,NW+1),SIGW0(0:NBMIX,NANI),
+     1 DIFF(0:NBMIX)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40)
+      INTEGER JPAR(NSTATE),IGB(8)
+      LOGICAL LBIHET
+      CHARACTER NAMP*12,TEXT10*10
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SGD
+      PARAMETER(TEXT10='A001001')
+*----
+*  RECOVER BIVAC SPECIFIC TRACKING PARAMETERS.
+*----
+      CALL LCMGET(IPTRK,'STATE-VECTOR',JPAR)
+      LBIHET=JPAR(40).NE.0
+      IF(LBIHET) THEN
+         CALL LCMSIX(IPTRK,'BIHET',1)
+         CALL LCMGET(IPTRK,'PARAM',IGB)
+         IF(NREG.NE.IGB(3)) CALL XABORT('BIVAA: INVALID VALUE OF NREG('
+     1   //'1).')
+         CALL LCMSIX(IPTRK,' ',2)
+      ELSE
+         IF(NREG.NE.JPAR(1)) CALL XABORT('BIVAA: INVALID VALUE OF NREG'
+     1   //'(2).')
+      ENDIF
+      NLF=JPAR(14)
+      ISCAT=ABS(JPAR(16))
+*----
+*  RECOVER PHYSICAL ALBEDO FUNCTIONS.
+*----
+      CALL LCMLEN(IPSYS,'ALBEDO-FU',NALBP,ITYLCM)
+      IF(NALBP.GT.0) THEN
+         ALLOCATE(GAMMA(NALBP))
+         CALL LCMGET(IPSYS,'ALBEDO-FU',GAMMA)
+      ENDIF
+*----
+*  COMPUTE THE WITHIN-GROUP SYSTEM MATRICES (LEAKAGE AND REMOVAL).
+*----
+      IF(NLF.EQ.0) THEN
+*----
+*  ++++ DIFFUSION THEORY ++++
+*----
+         IF(NANI.GT.1) THEN
+            CALL XABORT('BIVAA: SPN MACRO-CALCULATION EXPECTED(1).')
+         ENDIF
+         ALLOCATE(SGD(NBMIX,3))
+         DO 10 IBM=1,NBMIX
+         SGD(IBM,1)=DIFF(IBM)
+         SGD(IBM,2)=DIFF(IBM)
+         SGD(IBM,3)=SIGT0(IBM,1)-SIGW0(IBM,1)
+   10    CONTINUE
+*----
+*  ASSEMBLING OF A SINGLE-GROUP SYSTEM MATRIX FOR BIVAC.
+*----
+         CALL BIVASM(TEXT10,0,IPTRK,IPSYS,IMPX,NBMIX,NREG,NLF,3,NALBP,
+     1   MAT,VOL,GAMMA,SGD)
+         DEALLOCATE(SGD)
+      ELSE
+*----
+*  ++++ PN OR SPN THEORY ++++
+*----
+         IF(NLF.LT.2) THEN
+            CALL XABORT('BIVAA: PN OR SPN KEYWORD EXPECTED.')
+         ENDIF
+         NAN=MIN(ISCAT,NANI)+1
+         ALLOCATE(SGD(NBMIX,2*NAN))
+         DO 30 IL=0,NAN-1
+         DO 20 IBM=1,NBMIX
+         IF(IL.LE.NW) THEN
+            GARS=SIGT0(IBM,IL+1)
+         ELSE IF((NW.GE.1).AND.(MOD(IL,2).EQ.1)) THEN
+            GARS=SIGT0(IBM,2)
+         ELSE
+            GARS=SIGT0(IBM,1)
+         ENDIF
+         IF(IL.LE.NAN-2) GARS=GARS-SIGW0(IBM,IL+1)
+         SGD(IBM,IL+1)=GARS
+         IF(GARS.NE.0.0) THEN
+            SGD(IBM,NAN+IL+1)=1.0/GARS
+         ELSE
+            SGD(IBM,NAN+IL+1)=1.0E10
+         ENDIF
+   20    CONTINUE
+         WRITE(NAMP,'(4HSCAR,I2.2,6H001001)') IL
+         CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGD(1,NAN+IL+1))
+         WRITE(NAMP,'(4HSCAI,I2.2,6H001001)') IL
+         CALL LCMPUT(IPSYS,NAMP,NBMIX,2,SGD(1,NAN+IL+1))
+   30    CONTINUE
+         JPAR(:NSTATE)=0
+         JPAR(7)=NBMIX
+         JPAR(8)=NAN
+         CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,JPAR)
+*----
+*  ASSEMBLING OF A SINGLE-GROUP SYSTEM MATRIX FOR BIVAC.
+*----
+         CALL BIVASM(TEXT10,0,IPTRK,IPSYS,IMPX,NBMIX,NREG,NLF,2*NAN,
+     1   NALBP,MAT,VOL,GAMMA,SGD)
+         DEALLOCATE(SGD)
+      ENDIF
+      IF(NALBP.GT.0) DEALLOCATE(GAMMA)
+      IF(IMPX.GT.2) CALL LCMLIB(IPSYS)
+      IF(IMPX.GT.10) CALL LCMVAL(IPSYS,' ')
+      RETURN
+      END