Initial commit from Polytechnique Montreal

1 files changed, 405 insertions, 0 deletions

diff --git a/Dragon/src/APXCA2.f b/Dragon/src/APXCA2.f
new file mode 100644
index 0000000..e541cc8
--- /dev/null
+++ b/Dragon/src/APXCA2.f
@@ -0,0 +1,405 @@
+*DECK APXCA2
+      SUBROUTINE APXCA2(IPAPX,IPEDIT,NREA,NISO,NMAC,NED,NPRC,NG,NL,
+     1 ITRANC,NALBP,IMC,NMIL,NBISO,ICAL,IMPX,FNORM,NMILNR,NISFS,NISPS,
+     2 VOLMIL,FLXMIL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover the cross sections of an elementary calculation in the Apex
+* file.
+*
+*Copyright:
+* Copyright (C) 2025 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
+* IPAPX   pointer to the Apex file.
+* IPEDIT  pointer to the edition object (L_EDIT signature).
+* NREA    number of requested reactions.
+* NISO    number of particularized isotopes.
+* NMAC    number of macros.
+* NED     number of additional edition cross sections.
+* NPRC    number of delayed neutron precursors.
+* NG      number of condensed energy groups.
+* NL      number of Legendre orders.
+* ITRANC  type of transport correction.
+* NALBP   number of physical albedos per energy group.
+* IMC     type of macro-calculation (1 for diffusion or SPN;
+*         2 other method).
+* NMIL    number of mixtures in the Apex file.
+* NBISO   number of isotopes in the condensed microlib of the edition
+*         object. A given isotope may appear in many mixtures.
+* ICAL    index of the current elementary calculation.
+* FNORM   flux normalization factor.
+* IMPX    print parameter.
+*
+*Parameters: output
+* NMILNR  number of mixtures with delayed neutron data.
+* NISFS   number of particularized fissile isotopes.
+* NISPS   number of particularized fission products.
+* VOLMIL  mixture volumes.
+* FLXMIL  averaged flux of mixtures.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE hdf5_wrap
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPAPX,IPEDIT
+      INTEGER NREA,NISO,NMAC,NED,NPRC,NG,NL,ITRANC,NALBP,IMC,NMIL,NBISO,
+     1 ICAL,IMPX,NMILNR,NISFS,NISPS
+      REAL FNORM,VOLMIL(NMIL),FLXMIL(NMIL,NG)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPEDIT,KPEDIT,IPTEMP
+      CHARACTER RECNAM*80,RECNAM2*80,TEXT8*8,TEXT12*12,HSMG*131
+      LOGICAL EXIST,LSPH
+      DOUBLE PRECISION CONV
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM
+      REAL, ALLOCATABLE, DIMENSION(:) :: OVERV,WORKD,WORK1,WORK2,DEN,
+     1 DENISO,ENRGS,VOLMIX,WORK1D
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: DNUSIG,DCHI,SPH,CONCES,DECAYC
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:,:) :: IPERM
+      CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TYPISO
+      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: NOMISO,NOMMAC
+      CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NOMREA
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO))
+      ALLOCATE(OVERV(NG),DNUSIG(NG,NPRC+1),DCHI(NG,NPRC),WORKD(NPRC),
+     1 WORK1(NG*NMIL+1),WORK2(NG),DEN(NBISO),DENISO(NISO),
+     2 CONCES(NISO,NMIL),IPERM(NISO,NMIL),VOLMIX(NMIL))
+*
+      CONV=1.0D6 ! convert MeV to eV in H-FACTOR
+*----
+*  RECOVER INFORMATION FROM THE 'explicit' GROUP.
+*----
+      IF(NREA.GT.0) CALL hdf5_read_data(IPAPX,"/explicit/REANAME",
+     1 NOMREA)
+      IF(NMAC.GT.0) CALL hdf5_read_data(IPAPX,"/explicit/MACNAME",
+     1 NOMMAC)
+      IF(NISO.GT.0) THEN
+        CALL hdf5_read_data(IPAPX,"/physconst/ISOTA",NOMISO)
+        CALL hdf5_read_data(IPAPX,"/physconst/ISOTYP",TYPISO)
+      ENDIF
+*----
+*  SAVE INFORMATION TO THE 'physconst' GROUP.
+*----
+      IF(ICAL.EQ.1) THEN
+         ALLOCATE(ENRGS(NG+1))
+         CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM)
+         IF(ILONG.EQ.0) THEN
+            CALL LCMSIX(IPEDIT,'MACROLIB',1)
+            CALL LCMLEN(IPEDIT,'ENERGY',ILONG,ITYLCM)
+            IF(ILONG.NE.NG+1) CALL XABORT('APXCA2: BAD VALUE OF NG(1).')
+            CALL LCMGET(IPEDIT,'ENERGY',ENRGS)
+            CALL LCMSIX(IPEDIT,' ',2)
+         ELSE
+            IF(ILONG.NE.NG+1) CALL XABORT('APXCA2: BAD VALUE OF NG(2).')
+            CALL LCMGET(IPEDIT,'ENERGY',ENRGS)
+         ENDIF
+         ENRGS(:NG+1)=ENRGS(:NG+1)*1.0E-6
+         CALL hdf5_write_data(IPAPX,"/physconst/ENRGS",ENRGS)
+         DEALLOCATE(ENRGS)
+         CALL LCMSIX(IPEDIT,'MACROLIB',1)
+         CALL LCMLEN(IPEDIT,'VOLUME',ILONG,ITYLCM)
+         IF(ILONG.NE.NMIL) CALL XABORT('APXCA2: INCORRECT VOLUME.')
+         CALL LCMGET(IPEDIT,'VOLUME',VOLMIL)
+         CALL LCMSIX(IPEDIT,' ',2)
+      ENDIF
+*----
+*  RECOVER INVERSE OF SPH EQUIVALENCE FACTORS.
+*----
+      CALL LCMSIX(IPEDIT,'MACROLIB',1)
+      CALL LCMGET(IPEDIT,'VOLUME',VOLMIX)
+      JPEDIT=LCMGID(IPEDIT,'GROUP')
+      LSPH=.FALSE.
+      ALLOCATE(SPH(NMIL,NG))
+      DO 80 IGR=1,NG
+      KPEDIT=LCMGIL(JPEDIT,IGR)
+      CALL LCMLEN(KPEDIT,'NSPH',ILONG,ITYLCM)
+      IF(ILONG.GT.0) THEN
+         LSPH=.TRUE.
+         CALL LCMGET(KPEDIT,'NSPH',WORK1)
+         DO 70 IMIL=1,NMIL
+         SPH(IMIL,IGR)=1.0/WORK1(IMIL)
+   70    CONTINUE
+      ELSE
+         SPH(:NMIL,IGR)=1.0
+      ENDIF
+   80 CONTINUE
+      CALL LCMSIX(IPEDIT,' ',2)
+*----
+*  CREATE A SPH-UNCORRECTED MICROLIB.
+*----
+      CALL LCMOP(IPTEMP,'*TEMPORARY*',0,1,0)
+      CALL LCMEQU(IPEDIT,IPTEMP)
+      IF(LSPH) THEN
+        IF(IMC.EQ.0) CALL XABORT('APXCA2: UNDEFINED TYPE OF SPH.')
+        NW=1 ! NTOT1 cross section present
+        CALL SPHCMI(IPTEMP,0,IMC,NMIL,NBISO,NG,NL,NW,NED,NPRC,NALBP,SPH)
+      ENDIF
+      DEALLOCATE(SPH)
+*----
+*  FIND THE NUMBER AND NAMES OF THE ISOTOPES IN THE OUTPUT TABLES.
+*----
+      IF(NISO.GT.0) THEN
+        IPERM(:NISO,:NMIL)=C_NULL_PTR
+        CONCES(:NISO,:NMIL)=0.0
+        IF(NBISO.GT.0) THEN
+          ALLOCATE(IPISO(NBISO))
+          CALL LCMGET(IPTEMP,'ISOTOPESUSED',ISONAM)
+          CALL LCMGET(IPTEMP,'ISOTOPESMIX',MIX)
+          CALL LCMGET(IPTEMP,'ISOTOPESDENS',DEN)
+          CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE)
+          CALL LIBIPS(IPTEMP,NBISO,IPISO)
+          DO IBISO=1,NBISO
+            IMIL=MIX(IBISO)
+            IF(IMIL.EQ.0) CYCLE
+            WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
+            DO ISO=1,NISO
+              IF(NOMISO(ISO).EQ.TEXT12(:8)) THEN
+                IPERM(ISO,IMIL)=IPISO(IBISO)
+                CONCES(ISO,IMIL)=DEN(IBISO)
+                CYCLE
+              ENDIF
+            ENDDO
+          ENDDO
+          DEALLOCATE(IPISO)
+        ENDIF
+        DO ISO=1,NISO
+          DO IMIL=1,NMIL
+            IF(C_ASSOCIATED(IPERM(ISO,IMIL))) GO TO 10
+          ENDDO
+          WRITE(HSMG,'(17HAPXCA2: ISOTOPE '',A8,7H'' (ISO=,I8,3H) I,
+     1    32HS NOT AVAILABLE IN THE MICROLIB.)') NOMISO(ISO),ISO
+          CALL XABORT(HSMG)
+   10     CONTINUE
+        ENDDO
+*----
+*  RECOVER RADIOACTIVE DECAY CONSTANTS.
+*----
+        IF(ICAL.EQ.1) THEN
+          ALLOCATE(DECAYC(1,NISO),IPISO(NBISO))
+          CALL LIBIPS(IPTEMP,NBISO,IPISO)
+          DECAYC(1,:NISO)=0.0
+          DO 40 ISO=1,NISO
+          IISOTS=0
+          DO 20 IBISO=1,NBISO
+          IISOTS=ISO
+          IF(MIX(IBISO).EQ.0) GO TO 20
+          WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
+          IF(TEXT12(:8).EQ.NOMISO(ISO)) GO TO 30
+   20     CONTINUE
+          CALL XABORT('APXCA2: CANNOT FIND ISOTOPE '//NOMISO(ISO)//'.')
+   30     JPEDIT=IPISO(IISOTS)
+          IF(.NOT.C_ASSOCIATED(JPEDIT)) GO TO 40
+          CALL LCMLEN(JPEDIT,'DECAY',ILONG,ITYLCM)
+          IF(ILONG.EQ.1) CALL LCMGET(JPEDIT,'DECAY',DECAYC(1,ISO))
+   40     CONTINUE
+          DECAYC(1,:NISO)=DECAYC(1,:NISO)*1.0E-8
+          CALL hdf5_write_data(IPAPX,"/physconst/DECAYC",DECAYC)
+          DEALLOCATE(IPISO,DECAYC)
+        ENDIF
+      ENDIF
+*----
+*  FILL miscellaneous GROUP
+*----
+      WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL
+      CALL LCMSIX(IPTEMP,'MACROLIB',1)
+      NVDIV=0
+      CALL LCMLEN(IPTEMP,'K-EFFECTIVE',ILONG,ITYLCM)
+      IF(ILONG.EQ.1) THEN
+         CALL LCMGET(IPTEMP,'K-EFFECTIVE',FLOTT)
+         CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"KEFF",FLOTT)
+      ENDIF
+      CALL LCMLEN(IPTEMP,'K-INFINITY',ILONG,ITYLCM)
+      IF(ILONG.EQ.1) THEN
+         CALL LCMGET(IPTEMP,'K-INFINITY',FLOTT)
+         CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"KINF",FLOTT)
+      ENDIF
+      CALL LCMLEN(IPTEMP,'B2  B1HOM',ILONG,ITYLCM)
+      IF(ILONG.EQ.1) THEN
+         CALL LCMGET(IPTEMP,'B2  B1HOM',B2)
+      ELSE
+         B2=0.0
+      ENDIF
+      IF(B2.EQ.0.0) B2=1.0E-10
+      CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"B2",B2)
+      CALL LCMSIX(IPTEMP,' ',2)
+*----
+*  LOOP OVER APEX MIXTURES.
+*----
+      NMILNR=0
+      DO 500 IMIL=1,NMIL
+      IF(NMIL.EQ.1) THEN
+        WRITE(RECNAM,'(4Hcalc,I8,4H/xs/)') ICAL
+      ELSE
+        WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IMIL
+      ENDIF
+      CALL hdf5_create_group(IPAPX,RECNAM)
+*----
+*  RECOVER APEX VOLUMES AND INTEGRATED FLUXES.
+*----
+      CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME",
+     1 VOLMIX(IMIL))
+      WORK2(:NG)=0.0
+      CALL LCMSIX(IPTEMP,'MACROLIB',1)
+      JPEDIT=LCMGID(IPTEMP,'GROUP')
+      DO IGR=1,NG
+        KPEDIT=LCMGIL(JPEDIT,IGR)
+        CALL LCMLEN(KPEDIT,'FLUX-INTG',ILONG,ITYLCM)
+        IF(ILONG.EQ.0) CYCLE
+        ALLOCATE(WORK1D(NMIL))
+        CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1D)
+        WORK2(IGR)=WORK1D(IMIL)
+        DEALLOCATE(WORK1D)
+      ENDDO
+      CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"FLUX",WORK2)
+      CALL LCMSIX(IPTEMP,' ',2)
+*----
+*  RECOVER APEX CROSS SECTIONS
+*----
+      IF(NISO.GT.0) THEN
+        CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mic")
+        RECNAM2=TRIM(RECNAM)//"mic/CONC"
+        CALL hdf5_write_data(IPAPX,TRIM(RECNAM2),CONCES(:NISO,IMIL))
+      ENDIF
+      CALL hdf5_create_group(IPAPX,TRIM(RECNAM)//"mac")
+      DO IREA=1,NREA
+        CALL APXSX2(IPAPX,IPTEMP,NG,NL,NMAC,NISO,NMIL,IMIL,ITRANC,
+     1  RECNAM,NOMMAC,TYPISO,NOMREA(IREA),IPERM(1,IMIL),CONCES(1,IMIL),
+     2  B2)
+      ENDDO
+      IF(IMPX.GT.0) THEN
+        CALL hdf5_list(IPAPX,TRIM(RECNAM))
+        IF(NISO.GT.0) CALL hdf5_list(IPAPX,TRIM(RECNAM)//"mic")
+        CALL hdf5_list(IPAPX,TRIM(RECNAM)//"mac")
+      ENDIF
+      IOR=0
+      IOI=0
+      IIS=0
+      NISMAX=NMAC
+*
+      CALL LCMSIX(IPTEMP,'MACROLIB',1)
+      JPEDIT=LCMGID(IPTEMP,'GROUP')
+      DO 150 IGR=1,NG
+      KPEDIT=LCMGIL(JPEDIT,IGR)
+*----
+*  RECOVER THE NEUTRON FLUX.
+*----
+      CALL LCMGET(KPEDIT,'FLUX-INTG',WORK1)
+      IF(FNORM.NE.1.0) THEN
+        FLXMIL(IMIL,IGR)=WORK1(IMIL)*FNORM*1.0E13
+      ELSE
+        FLXMIL(IMIL,IGR)=WORK1(IMIL)
+      ENDIF
+*----
+*  RECOVER DELAYED NEUTRON INFORMATION.
+*----
+      CALL LCMLEN(KPEDIT,'NUSIGF',ILONG,ITYLCM)
+      IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN
+         CALL LCMGET(KPEDIT,'NUSIGF',WORK1)
+         DNUSIG(IGR,NPRC+1)=WORK1(IMIL)
+         CALL LCMGET(KPEDIT,'OVERV',WORK1)
+         OVERV(IGR)=WORK1(IMIL)
+         DO 90 IPRC=1,NPRC
+         WRITE(TEXT12,'(6HNUSIGF,I2.2)') IPRC
+         CALL LCMGET(KPEDIT,TEXT12,WORK1)
+         DNUSIG(IGR,IPRC)=WORK1(IMIL)
+         WRITE(TEXT12,'(3HCHI,I2.2)') IPRC
+         CALL LCMGET(KPEDIT,TEXT12,WORK1)
+         DCHI(IGR,IPRC)=WORK1(IMIL)
+   90    CONTINUE
+      ELSE
+         DNUSIG(IGR,:NPRC+1)=0.0
+      ENDIF
+  150 CONTINUE
+      CALL LCMSIX(IPTEMP,' ',2)
+*----
+*  STORE INFORMATION IN THE calc_id/kinetics GROUP.
+*----
+      IF(NPRC.GT.0) THEN
+         EXIST=.FALSE.
+         DO 455 IPRC=1,NPRC
+         DO 450 IGR=1,NG
+         EXIST=EXIST.OR.(DNUSIG(IGR,IPRC).NE.0.0)
+  450    CONTINUE
+  455    CONTINUE
+         IF(EXIST) THEN
+            NMILNR=NMILNR+1
+            RECNAM2=TRIM(RECNAM)//"kinetics/"
+            CALL hdf5_create_group(IPAPX,TRIM(RECNAM2))
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"NBGRD",NPRC)
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"CHIDA",DCHI)
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"INVELA",OVERV)
+            CALL LCMSIX(IPTEMP,'MACROLIB',1)
+            CALL LCMGET(IPTEMP,'LAMBDA-D',WORKD)
+            CALL LCMSIX(IPTEMP,' ',2)
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"LAMBDA",WORKD)
+            TGENRS=0.0
+            DENOM=0.0
+            DO 460 IGR=1,NG
+            TGENRS=TGENRS+OVERV(IGR)*FLXMIL(IMIL,IGR)
+            DENOM=DENOM+DNUSIG(IGR,NPRC+1)*FLXMIL(IMIL,IGR)
+  460       CONTINUE
+            TGENRS=TGENRS/DENOM
+            DO 480 IPRC=1,NPRC
+            WORKD(IPRC)=0.0
+            DO 470 IGR=1,NG
+            WORKD(IPRC)=WORKD(IPRC)+DNUSIG(IGR,IPRC)*FLXMIL(IMIL,IGR)
+  470       CONTINUE
+            WORKD(IPRC)=WORKD(IPRC)/DENOM
+  480       CONTINUE
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"BETADA",WORKD)
+            CALL hdf5_write_data(IPAPX,TRIM(RECNAM2)//"NGENT",TGENRS)
+            IF(IMPX.GT.0) CALL hdf5_list(IPAPX,TRIM(RECNAM2))
+         ENDIF
+      ENDIF
+  500 CONTINUE
+*----
+*  COMPUTE NISFS AND NISPS
+*----
+      NISFS=0
+      NISPS=0
+      DO 530 ISO=1,NISO
+      DO 510 IBISO=1,NBISO
+      WRITE(TEXT8,'(2A4)') (ISONAM(I0,IBISO),I0=1,2)
+      IF(NOMISO(ISO).EQ.TEXT8) THEN
+         ITY=ITYPE(IBISO)
+         GO TO 520
+      ENDIF
+  510 CONTINUE
+      GO TO 530
+  520 IF(ITY.EQ.2) THEN
+         NISFS=NISFS+1
+      ELSE IF(ITY.EQ.3) THEN
+         NISPS=NISPS+1
+      ENDIF
+  530 CONTINUE
+      CALL LCMCL(IPTEMP,2)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      IF(NISO.GT.0) DEALLOCATE(TYPISO,NOMISO)
+      IF(NMAC.GT.0) DEALLOCATE(NOMMAC)
+      IF(NREA.GT.0) DEALLOCATE(NOMREA)
+      DEALLOCATE(VOLMIX,IPERM,CONCES,DENISO,DEN,WORK2,WORK1,WORKD,DCHI,
+     1 DNUSIG,OVERV,ITYPE,MIX,ISONAM)
+      RETURN
+      END