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

---
 Dragon/src/MACUPG.f | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 Dragon/src/MACUPG.f

(limited to 'Dragon/src/MACUPG.f')

diff --git a/Dragon/src/MACUPG.f b/Dragon/src/MACUPG.f
new file mode 100644
index 0000000..b8c2d66
--- /dev/null
+++ b/Dragon/src/MACUPG.f
@@ -0,0 +1,125 @@
+*DECK MACUPG
+      SUBROUTINE MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP,
+     > NBMIXF,NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX,
+     > IMLOC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Cross section processing in GROUP list directory with update.
+*
+*Copyright:
+* Copyright (C) 2007 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): G. Marleau
+*
+*Parameters: input
+* KENTRY  array of macrolib structures.
+* HGROUP  character*12 name of GROUP list directory.
+* NENTRY  number of structures.
+* NIFISF  maximum number fissile isotopes per mixture.
+* NDELF   final number of precursor groups.
+* NEDF    final number of aditional x-s.
+* NGROUP  number of groups.
+* NBMIXF  final number of mixtures.
+* NIFISS  number fissile isotopes per mixture.
+* NANISO  maximun scattering anisotropy.
+* NEDMAC  number of aditional edition x-s.
+* NTOTMX  maximum number of mixtures in input macrolibs.
+* ITRANC  type of transport correction.
+* IPRINT  print level.
+* NAMEN   total number of x-s.
+* NUMPX   correspondence between old and new 'NUSIGF' arrays.
+* IMLOC   mixture location.
+*
+*-----------------------------------------------------------------------
+*
+      USE          GANLIB
+      IMPLICIT     NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      CHARACTER HGROUP*12
+      INTEGER NENTRY,NIFISF,NDELF,NEDF,NGROUP,NBMIXF,NIFISS,NANISO,
+     > NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN(2*NEDMAC),NUMPX(NBMIXF*NIFISS),
+     > IMLOC(2,NTOTMX)
+      TYPE(C_PTR) KENTRY(NENTRY)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) IPMACR,JPMACR,KPMACR
+      INTEGER IOUT,NREACD,NTREA,IGR,IEN,IMIX,IPRG
+      PARAMETER (IOUT=6,NREACD=14)
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IXSPRO
+      REAL, ALLOCATABLE, DIMENSION(:) :: XSGEN,XSIGS,SCAT
+*----
+*  DATA
+*----
+      CHARACTER    NAMREA(NREACD)*12
+      SAVE         NAMREA
+      DATA         NAMREA
+     >  /'NTOT0       ','NTOT1       ','TRANC       ','FIXE        ',
+     >   'DIFF        ','DIFFX       ','DIFFY       ','DIFFZ       ',
+     >   'NSPH        ','H-FACTOR    ','C-FACTOR    ','OVERV       ',
+     >   'FLUX-INTG   ','FLUX-INTG-P1'/
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      NTREA=NREACD+2*NIFISF*(1+NDELF)+NEDF
+      ALLOCATE(XSGEN(NBMIXF*(NTREA+2)),XSIGS(NBMIXF*NANISO),
+     > IXSPRO(NTREA+2*NANISO+1),SCAT(NGROUP*NBMIXF*NANISO))
+      IXSPRO(:NTREA+2*NANISO+1)=0
+      IPRG=IPRINT
+      DO 140 IGR=1,NGROUP
+        XSGEN(:NBMIXF*(NTREA+2))=0.0
+        XSIGS(:NBMIXF*NANISO)=0.0
+        SCAT(:NGROUP*NBMIXF*NANISO)=0.0
+        DO 150 IEN=1,NENTRY
+          IPMACR=KENTRY(IEN)
+          IF(IEN.EQ.1) THEN
+*           IPMACR IS OPEN IN CREATION/MODIFICATION MODE
+            JPMACR=LCMLID(IPMACR,HGROUP,NGROUP)
+            KPMACR=LCMDIL(JPMACR,IGR)
+          ELSE
+*           IPMACR IS OPEN IN READ-ONLY MODE
+            JPMACR=LCMGID(IPMACR,HGROUP)
+            KPMACR=LCMGIL(JPMACR,IGR)
+          ENDIF
+          IF(IPRG.GE.10) WRITE(IOUT,6020) IEN
+          DO 151 IMIX=1,NTOTMX
+            IF(IMLOC(1,IMIX).EQ.IEN) THEN
+              CALL MACRDM(KPMACR,IPRG  ,IEN   ,NTOTMX,NGROUP,NANISO,
+     >                    NBMIXF,NIFISF,NEDF  ,NDELF ,NREACD,NTREA ,
+     >                    IMLOC ,NAMREA,NAMEN ,NUMPX ,IXSPRO,XSGEN ,
+     >                    XSIGS ,SCAT  )
+              GO TO 155
+            ENDIF
+ 151      CONTINUE
+ 155      CONTINUE
+ 150    CONTINUE
+        IPMACR=KENTRY(1)
+        JPMACR=LCMLID(IPMACR,HGROUP,NGROUP)
+        KPMACR=LCMDIL(JPMACR,IGR)
+*----
+*  FOR TRANC OFF DO NOT SAVE TRANSPORT CORRECTION
+*----
+        IF(ITRANC.EQ.0) IXSPRO(2)=0
+        CALL MACPRM(KPMACR,IPRG  ,NGROUP,NANISO,NBMIXF,NIFISF,
+     >              NEDF  ,NDELF ,NREACD,NTREA ,IGR   ,NAMREA,
+     >              NAMEN ,IXSPRO,XSGEN ,XSIGS ,SCAT  )
+        IPRG=0
+ 140  CONTINUE
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(SCAT,IXSPRO,XSIGS,XSGEN)
+      RETURN
+ 6020 FORMAT(' MACUPG: PROCESSING MACROLIB',I12)
+      END
-- 
cgit v1.2.3