From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001
From: stainer_t <thomas.stainer@oecd-nea.org>
Date: Mon, 8 Sep 2025 13:48:49 +0200
Subject: Initial commit from Polytechnique Montreal

---
 Donjon/src/CREBUR.f | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 110 insertions(+)
 create mode 100644 Donjon/src/CREBUR.f

(limited to 'Donjon/src/CREBUR.f')

diff --git a/Donjon/src/CREBUR.f b/Donjon/src/CREBUR.f
new file mode 100644
index 0000000..a46ba15
--- /dev/null
+++ b/Donjon/src/CREBUR.f
@@ -0,0 +1,110 @@
+*DECK CREBUR
+      SUBROUTINE CREBUR(IPCPO,NISO,NGRP,NL,IMPX,HISO,DERIV,NBURN,BURN0,
+     1 BURN1,BURNUP,ITY,CONC,ILEAK,TOTAL,ZNUG,SNUGF,CHI,OVERV,DIFFX,
+     2 DIFFY,DIFFZ,H,SCAT,FLUX,UPS)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Interpolate l_compo for a given burnup value.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* IPCPO   pointer to l_compo information.
+* NISO    1+number of extracted isotopes.
+* NGRP    number of energy groups.
+* NL      number of legendre orders (=1 for isotropic scattering).
+* IMPX    printing index (=0 for no print).
+* HISO    hollerith name information for extracted isotopes.
+* DERIV   =.true.: derivative of macrolib info is computed with
+*         respect to burn1.
+* NBURN   number of tabulated burnup steps.
+* BURN0   user defined initial burnup.
+* BURN1   user defined final burnup:
+*          if burn0=burn1, a simple interpolation is performed;
+*          if burn0<burn1, a time-average calculation is performed.
+* BURNUP  burnup tabulation points.
+* ITY     =0: do not process the isotope; =1: use number density
+*         stored in conc(i); =2: use number density stored in compo.
+* CONC    user defined number density.
+*
+*Parameters: output
+* ILEAK   diffusion coefficient flag (=1: isotropic; =2: anisotropic).
+* TOTAL   total macroscopic x-sections.
+* ZNUG    nu*fission macroscopic x-sections.
+* SNUGF   fission macroscopic x-sections.
+* CHI     fission spectrum.
+* OVERV   reciprocal neutron velocities.
+* DIFFX   x-directed diffusion coefficients.
+* DIFFY   y-directed diffusion coefficients.
+* DIFFZ   z-directed diffusion coefficients.
+* H       h-factors (kappa*fission macroscopic x-sections).
+* SCAT    scattering macroscopic x-sections.
+* FLUX    integrated flux.
+* UPS
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPCPO
+      INTEGER NISO,NGRP,NL,IMPX,NBURN,HISO(3*NISO),ITY(NISO),ILEAK
+      REAL BURNUP(NBURN),CONC(NISO),TOTAL(NGRP),ZNUG(NGRP),
+     1 CHI(NGRP),OVERV(NGRP),DIFFX(NGRP),DIFFY(NGRP),DIFFZ(NGRP),
+     2 H(NGRP),SCAT(NL,NGRP,NGRP),SNUGF(NGRP),FLUX(NGRP),BURN0,BURN1
+      LOGICAL DERIV,UPS
+*----
+*  LOCAL VARIABLES
+*----
+      LOGICAL LCUBIC
+      PARAMETER(LCUBIC=.TRUE.)
+      REAL, ALLOCATABLE, DIMENSION(:) :: TERP
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: ZTOTAL,ZZNUG,ZNUGF,ZCHI,
+     1 ZOVERV,ZDIFFX,ZDIFFY,ZDIFFZ,ZH,ZFLUX
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: ZSCAT
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ZTOTAL(NBURN,NGRP),ZZNUG(NBURN,NGRP),ZNUGF(NBURN,NGRP),
+     1 ZCHI(NBURN,NGRP),ZOVERV(NBURN,NGRP),ZDIFFX(NBURN,NGRP),
+     2 ZDIFFY(NBURN,NGRP),ZDIFFZ(NBURN,NGRP),ZH(NBURN,NGRP),
+     3 ZFLUX(NBURN,NGRP),ZSCAT(NBURN,NL,NGRP,NGRP),TERP(NBURN))
+*----
+*  RECOVER MACROSCOPIC X-SECTION INFO FROM BURNUP DIRECTORIES
+*----
+      IF(NBURN.LE.1)CALL XABORT('@CREBUR: NO BURNUP INFORMATION.')
+      CALL CRETAB(IPCPO,NISO,NGRP,NL,IMPX,HISO,NBURN,ITY,CONC,ILEAK,
+     1 ZTOTAL,ZZNUG,ZNUGF,ZCHI,ZOVERV,ZDIFFX,ZDIFFY,ZDIFFZ,ZH,ZSCAT,
+     2 ZFLUX,UPS)
+*----
+*  PERFORM INTERPOLATION OR TIME AVERAGING
+*----
+      IF(BURN0.LT.BURN1)THEN
+*       TIME-AVERAGED
+        CALL ALTERI(LCUBIC,NBURN,BURNUP,BURN0,BURN1,TERP)
+        DO 100 I=1,NBURN
+        TERP(I)=TERP(I)/(BURN1-BURN0)
+  100   CONTINUE
+      ELSE IF(BURN0.EQ.BURN1)THEN
+*       INSTANTANEOUS
+        CALL ALTERP(LCUBIC,NBURN,BURNUP,BURN0,DERIV,TERP)
+      ELSE
+        CALL XABORT('@CREBUR: ILLEGAL BURN1 VALUE.')
+      ENDIF
+      CALL CREITP(NGRP,NL,NBURN,TERP,TOTAL,ZNUG,SNUGF,CHI,OVERV,DIFFX,
+     1 DIFFY,DIFFZ,H,SCAT,FLUX,ZTOTAL,ZZNUG,ZNUGF,ZCHI,ZOVERV,ZDIFFX,
+     2 ZDIFFY,ZDIFFZ,ZH,ZSCAT,ZFLUX)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(TERP,ZFLUX,ZSCAT,ZH,ZDIFFZ,ZDIFFY,ZDIFFX,ZOVERV,ZCHI,
+     1 ZNUGF,ZZNUG,ZTOTAL)
+      RETURN
+      END
-- 
cgit v1.2.3