Initial commit from Polytechnique Montreal

1 files changed, 295 insertions, 0 deletions

diff --git a/Donjon/src/D2PXS.f b/Donjon/src/D2PXS.f
new file mode 100644
index 0000000..48db05b
--- /dev/null
+++ b/Donjon/src/D2PXS.f
@@ -0,0 +1,295 @@
+*DECK D2PXS
+      SUBROUTINE D2PXS (IPDAT,IPMIC,IPSAP,STAVEC,SIGNAT,MIXDIR,
+     >                 JOBOPT,IPRINT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover cross sections from a microlib object and write cross
+* sections for one branch at a fixed burnup point in the INFO data
+* block.
+*
+*Author(s): 
+* J. Taforeau
+*
+*Parameters: input
+* IPDAT   address of info data block
+* IPSAP   address of the saphyb object
+* IPMIC   address of the microlib object
+* STAVEC  various parameters associated with the IPDAT structure
+* SIGNAT  signature of the object containing cross sections
+* MIXDIR  directory that contains homogeneous mixture information
+* IPRINT  control the printing on screen
+*
+*Parameters: 
+* JOBOPT  
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPDAT,IPMIC,IPSAP
+      INTEGER STAVEC(40),IPRINT
+      CHARACTER*12 SIGNAT,MIXDIR
+*----
+*  LOCAL VARIABLES
+*----
+      ! INDEX OF CURRENT VALUE FOR EACH STATE VARIABLES
+      PARAMETER(NSTATE=40)
+      INTEGER STAIDX (STAVEC(2)),ISTATE(NSTATE)
+      INTEGER DIMSAP(50)
+      INTEGER ITBRA,NSF,ITR
+      INTEGER ::NREA = 0
+      INTEGER :: NISO = 0
+      INTEGER ::NMIL = 0
+      INTEGER ::NBISO = 0
+      INTEGER ::NANI = 0
+      INTEGER ::NFISS = 0
+      INTEGER :: NADD = 0
+      INTEGER :: NBMIX = 0
+      INTEGER :: NMAC = 0
+      INTEGER :: NADRX = 0
+      INTEGER :: NPAR = 0
+      INTEGER :: NDEL = 0
+      INTEGER :: ISPH = 0
+      ! INDICATES THE END OF A BRANCH CALCULATION (REW=1), AND A
+      ! DEFAULT MESHING (GRID)
+      INTEGER REW,GRID
+      ! NUMBER OF STATES VARIABLES
+      INTEGER NVAR
+      ! NUMBER OF BURNUP POINTS
+      INTEGER NBU,NGP
+      INTEGER :: NADF = 1
+      INTEGER :: NCDF = 1
+      INTEGER :: NGFF = 1
+      INTEGER :: NPIN = 1
+      INTEGER :: NTYPE = 1
+      INTEGER FLAG
+      INTEGER ICOR
+      REAL    STATE(STAVEC(2)),BURN(STAVEC(4)),REFSTA(STAVEC(2)-1)
+      ! DATSRC BLOCK OF INFO/GENPMAXS DIRECTORY
+      REAL DATSRC(5),FLUX(STAVEC(1))
+      ! STATE VARIABLE NAMES
+      CHARACTER(len=12) STAVAR(STAVEC(2))
+      CHARACTER JOBOPT(16)
+
+      CHARACTER*4 BRANCH
+      CHARACTER*3 ADF_T,CDF_T,GFF_T
+      LOGICAL LABS(3),SCAT
+      LOGICAL :: LADF = .FALSE.
+      LOGICAL :: LCDF = .FALSE.
+      LOGICAL :: LGFF = .FALSE.
+      LOGICAL :: LXES = .FALSE.
+      LOGICAL :: LDET = .FALSE.
+      LOGICAL :: LTH  = .FALSE.
+      LOGICAL :: LCOR = .FALSE.
+
+
+      ! INITIALIZATION OF PARAMETERS
+      NVAR=STAVEC(2)
+      NBU=STAVEC(4)
+      GRID=STAVEC(5)
+      NGP=STAVEC(1)
+      NSF=STAVEC(11)
+      ICOR=STAVEC(22)
+
+      ! RECOVER INFORMATION FROM INFO date block
+      CALL LCMSIX(IPDAT,' ',0)
+      CALL LCMSIX(IPDAT,'GENPMAXS_INP',1)
+      CALL LCMGET(IPDAT,'FLAG',FLAG)
+      CALL LCMGET(IPDAT,'DAT_SRC',DATSRC)
+
+
+      CALL LCMSIX(IPDAT,' ',0)
+      CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
+
+      IF (ICOR>0) LCOR=.TRUE.
+      IF(JOBOPT(1)=='T') THEN
+         CALL LCMGTC(IPDAT,'ADF_TYPE',3,ADF_T)
+         LADF = .TRUE.
+         IF((ADF_T.EQ.'SEL').OR.(ADF_T.EQ.'GET')) THEN
+          STAVEC(13)=NSF
+          STAVEC(14)=1
+         ENDIF
+         IF((ADF_T.EQ. 'DRA').OR.(ADF_T.EQ. 'GEN'))THEN
+          STAVEC(13)=1
+          CALL LCMSIX(IPMIC,' ',0)
+          CALL LCMSIX(IPMIC,'MACROLIB',1)
+          CALL LCMSIX(IPMIC,'ADF',1)
+          CALL LCMGET(IPMIC,'NTYPE',STAVEC(14))
+         ENDIF
+         NADF=STAVEC(13)
+         NTYPE=STAVEC(14)
+      ENDIF
+
+      IF(JOBOPT(2)=='T') LXES = .TRUE.
+      IF(JOBOPT(8)=='T') LDET = .TRUE.
+      IF((JOBOPT(5)=='T').OR.(JOBOPT(7)=='T').OR.
+     >   (JOBOPT(9)=='T').OR.(JOBOPT(13)=='T')) THEN
+        LTH =.TRUE.
+      ENDIF
+
+      IF(JOBOPT(10)=='T') THEN
+         CALL LCMGTC(IPDAT,'CDF_TYPE',3,CDF_T)
+         LCDF = .TRUE.
+         IF(CDF_T.EQ. 'DRA')THEN
+          CALL LCMSIX(IPMIC,' ',0)
+          CALL LCMSIX(IPMIC,'MACROLIB',1)
+          CALL LCMSIX(IPMIC,'ADF',1)
+          CALL LCMGET(IPMIC,'NTYPE',STAVEC(14))
+         ENDIF
+         NCDF=STAVEC(15)
+         NTYPE=STAVEC(14)
+      ENDIF
+      IF(JOBOPT(11)=='T') THEN
+         CALL LCMGTC(IPDAT,'GFF_TYPE',3,GFF_T)
+         LGFF = .TRUE.
+         NGFF=STAVEC(16)
+         NPIN=STAVEC(17)
+      ENDIF
+
+      IF(DATSRC(3).NE.0.0) THEN
+        CALL LCMGET(IPDAT,'LABS',LABS)
+        CALL LCMGET(IPDAT,'SCAT',SCAT)
+      ENDIF
+
+      CALL LCMGTC(IPDAT,'STATE_VAR',12,NVAR,STAVAR)
+      CALL LCMGET(IPDAT,'BURN',BURN)
+      CALL LCMSIX(IPDAT,' ',0)
+      CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
+      CALL LCMGET(IPDAT,'REWIND',REW)
+      CALL LCMGTC(IPDAT,'BRANCH',4,BRANCH)
+      CALL LCMGET(IPDAT,'BRANCH_IT',ITBRA)
+
+      CALL LCMGET(IPDAT,'STATE_INDEX',STAIDX)
+      CALL LCMGET(IPDAT,'STATE',STATE)
+      CALL LCMSIX(IPMIC,' ',0)
+      CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATE)
+
+      NBISO=ISTATE(2)         ! NUMBER OF ISOTOPES
+      NDEL=ISTATE(19)         ! NUMBER OF DELAYED NEUTRON GROUPS
+
+      IF(NDEL.NE.STAVEC(7)) THEN
+         WRITE(6,*) "@D2PXS: ERROR IN NUMBER OF DELAYED NEUTRON GROUPS"
+         WRITE(6,*) "THE NUMBER OF DELAYED NEUTRON GROUPS IN SAP (",
+     1   STAVEC(7),") IS DIFFERENT FROM MICROLIB (",NDEL,")"
+         CALL XABORT('@D2PXS: DELAYED NEUTRON DATA ERROR')
+      ENDIF
+
+      ISTATE(:NSTATE)=0
+      CALL LCMSIX(IPMIC,' ',0)
+      CALL LCMSIX(IPMIC,'MACROLIB',1)
+      CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATE)
+
+      NBMIX=ISTATE(2)          ! NUMBER OF MIXTURESS
+      NANI=ISTATE(3)           ! SCATTERING ANISOTROPY
+      NADD=ISTATE(5)           ! NUMBER OF ADDITIONAL CROSS SECTIONS
+      NFISS=ISTATE(4)          ! NUMBER OF FISSILE ISOTOPES
+      ITR=ISTATE(6)            ! TRANSPORT CORRECTION OTPION
+      NED=ISTATE(13)           ! NUMBER OF P0 ADDITIONAL XS
+      ISPH=ISTATE(14)
+
+      IF(IPRINT > 0)  THEN
+         WRITE(6,*)
+         WRITE(6,*) "******     BRANCH CHARACTERISTICS     ******"
+         WRITE(6,*) "BRANCH TYPE         :",BRANCH
+         WRITE(6,*) "BRANCH INDEX        :",ITBRA
+         WRITE(6,*) "STATE VARIABLE NAME :",STAVAR
+         WRITE(6,*) "BRANCH STATE VALUES :",STATE
+      ENDIF
+
+      IF(DATSRC(3)==0.0) THEN
+        CALL D2PRFL(  IPDAT, IPMIC , IPRINT,    NBU,   NGP,   NBMIX,
+     >                NANI,   NVAR,  STAIDX,   LADF,  NADF,   NTYPE)
+      ELSE IF(DATSRC(3) == 1.0) THEN
+        ! CASE FOR FUEL CROSS SECTIONS
+        CALL LCMSIX(IPSAP,' ',0)
+        DIMSAP(:50)=0
+        IF (SIGNAT .EQ. 'L_SAPHYB') THEN
+         CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)  ! recover DIMSAP info
+         NREA=DIMSAP(4)       ! NUMBER OF REACTIONS
+         NISO=DIMSAP(5)       ! NUMBER OF PARTICULARIZED ISOTOPES
+         NMAC=DIMSAP(6)       ! NUMBER OF MACROSCOPIC SETS
+         NMIL=DIMSAP(7)       ! NUMBER OF MIXTURES
+         NPAR=DIMSAP(8)       ! NUMBER OF STATE VARIABLE IN SAPHYB
+         NADRX=DIMSAP(18)     ! CONCERN CROSS SECTIONS
+                        ! (INCLUDING FLUE AND TIME)
+        ELSE
+         CALL LCMSIX(IPSAP,' ',0)
+         CALL LCMSIX(IPSAP,MIXDIR,1)
+         CALL LCMGET(IPSAP,'STATE-VECTOR',DIMSAP)
+         NMIL = DIMSAP(1)
+        ENDIF
+        IF(STAVEC(1).NE.ISTATE(1)) THEN
+          CALL XABORT("@D2PBRA: INCOHERENT NUMBER OF ENERGY GROUPS ")
+        ENDIF
+
+
+        IF(NMIL.NE.NBMIX) THEN
+         CALL XABORT("@D2PBRA: DIFFERENT NUMBER OF MIX ")
+         ENDIF
+
+        ! RECOVER MACROLIB CROSS SECTIONS FROM SAPHYB
+        CALL D2PMAC(     IPDAT, IPMIC , IPRINT,    NBU,   NGP,   NBMIX,
+     >                    NADD,   NANI,  NVAR,  STAIDX,  LADF,    NADF,
+     >                    NTYPE,  LCDF,  NCDF,    LGFF,    NGFF,  NPIN,
+     >                     FLUX                                       )
+
+        IF(LTH) THEN
+          ICOR=STAVEC(22)
+          ! RECOVER THE T/H INVARIANT BLOCK (OPTIONAL IN PMAXS FILES)
+          CALL D2PTH(    IPDAT, IPMIC , IPRINT,    NBU,   NGP,   NBMIX,
+     >                   NFISS,   NDEL,   NVAR, STAIDX,JOBOPT,    FLAG)
+        ENDIF
+
+        IF((LXES).OR.(LDET).OR.(LCOR)) THEN
+          ! RECOVER MICROSCOPIC CROSS SECTIONS FROM SAPHYB
+          CALL D2PMIC  (  IPDAT, IPMIC , IPRINT,    NGP,  NBMIX, NBISO,
+     >                      NED,   NVAR, STAIDX,   LXES,   LDET,  LCOR,
+     >                     FLUX                                       )
+        ENDIF
+
+        IF((GRID<2).and. (SIGNAT .EQ. 'L_SAPHYB')) THEN
+
+          ! RECOVER THE DIVERS DIRECTORY OF SAPHYB
+          CALL D2PDIV(    IPDAT, IPSAP , IPRINT,    NGP,   NBU,   NVAR,
+     >                     GRID,   NPAR,   NREA,   NISO,  NMAC,   NMIL,
+     >                     NANI,  NADRX, STAIDX,  STATE, STAVAR,   NSF,
+     >                     LABS,   SCAT,   LADF                       )
+        ENDIF
+
+
+      ENDIF
+
+      IF(REW.EQ.NBU) THEN
+        ! REINITIALIZATION OF INDEX
+        IF (FLAG.EQ.-1) THEN
+         CALL LCMSIX(IPDAT,' ',0)
+         CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
+         CALL LCMGET(IPDAT,'REF_STATE',REFSTA)
+         STATE(1:NVAR-1)=REFSTA(:)
+         FLAG=0
+         CALL LCMPUT(IPDAT,'FLAG',1,1,FLAG)
+        ENDIF
+         STAIDX(NVAR)= 1
+         REW = 1
+         STATE(NVAR)=BURN(1)
+
+
+      ELSE
+        !  UPDATE THE INDEX FOR THE CALCULATION OF THE NEXT BRANCH
+        REW=0
+        STAIDX(NVAR)= STAIDX(NVAR)+1
+        REW = STAIDX(NVAR)
+        STATE(NVAR)=BURN(STAIDX(NVAR))
+      ENDIF
+
+      ! STORE NEW VALUES OF BRANCH CALCULATION
+      CALL LCMSIX(IPDAT,' ',0)
+      CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
+      CALL LCMPUT(IPDAT,'REWIND',1,1,REW)
+      CALL LCMPUT(IPDAT,'STATE',NVAR,2,STATE)
+      CALL LCMPUT(IPDAT,'STATE_INDEX',NVAR,1,STAIDX)
+      END