Initial commit from Polytechnique Montreal

1 files changed, 210 insertions, 0 deletions

diff --git a/Donjon/src/CREDRV.f b/Donjon/src/CREDRV.f
new file mode 100644
index 0000000..71091e4
--- /dev/null
+++ b/Donjon/src/CREDRV.f
@@ -0,0 +1,210 @@
+*DECK CREDRV

+      SUBROUTINE CREDRV(IPMAC,IPMAP,NENTRY,HENTRY,KENTRY,LMAC,NMIX,

+     1 NGRP,NL,ILEAK,IMPX)

+*

+*-----------------------------------------------------------------------

+*

+*Purpose:

+* Recover and/or interpolate l_compo information, store properties

+* in a new or existing macrolib.

+*

+*Copyright:

+* Copyright (C) 2007 Ecole Polytechnique de Montreal.

+*

+*Author(s): 

+* A. Hebert, M. Guyot

+*

+*Parameters: input/output

+* IPMAC   pointer to the macrolib information.

+* IPMAP   pointer to fuel-map information (=0 if no l_fmap).

+* NENTRY  number of lcm or xsm objects used by the module.

+* HENTRY  character*12 name of each lcm or xsm objects.

+* KENTRY  pointers to the lcm or xsm objects.

+* LMAC    flag for macrolib object type: =.false. in create mode;

+*          =.true. in modification mode.

+* NMIX    maximum number of material mixtures.

+* NGRP    number of energy groups.

+* NL      number of legendre orders (=1 for isotropic scattering).

+* ILEAK   diffusion coefficient flag (=1: isotropic; =2: anisotropic).

+* IMPX    printing index (=0 for no print).

+*

+*NOTE: a cross section not read is set to zero.

+*

+*-----------------------------------------------------------------------

+*

+      USE GANLIB

+*----

+*  SUBROUTINE ARGUMENTS

+*----

+      INTEGER NENTRY,NMIX,NGRP,NL,ILEAK,IMPX

+      TYPE(C_PTR) IPMAC,IPMAP,KENTRY(NENTRY)

+      CHARACTER HENTRY(NENTRY)*12

+      LOGICAL LMAC

+*----

+*  LOCAL VARIABLES

+*----

+      CHARACTER CM*2

+      TYPE(C_PTR) JPMAC,KPMAC

+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS

+      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IJJ,NJJ

+      REAL, ALLOCATABLE, DIMENSION(:) :: WORK

+      REAL, ALLOCATABLE, DIMENSION(:,:) :: TOTAL,ZNUG,SNUGF,CHI,OVERV,

+     1 DIFFX,DIFFY,DIFFZ

+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: H

+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT

+*----

+*  SCRATCH STORAGE ALLOCATION

+*----

+      ALLOCATE(IPOS(NMIX),IJJ(NMIX,NL,NGRP),NJJ(NMIX,NL,NGRP))

+      ALLOCATE(TOTAL(NMIX,NGRP),ZNUG(NMIX,NGRP),SNUGF(NMIX,NGRP),

+     1        CHI(NMIX,NGRP),OVERV(NMIX,NGRP),DIFFX(NMIX,NGRP),

+     2        DIFFY(NMIX,NGRP),DIFFZ(NMIX,NGRP),WORK(NMIX*NGRP),

+     3        SCAT(NMIX,NL,NGRP,NGRP),H(NMIX,NGRP,NL))

+*

+      TOTAL(:NMIX,:NGRP)=0.0

+      ZNUG(:NMIX,:NGRP)=0.0

+      SNUGF(:NMIX,:NGRP)=0.0

+      CHI(:NMIX,:NGRP)=0.0

+      OVERV(:NMIX,:NGRP)=0.0

+      DIFFX(:NMIX,:NGRP)=0.0

+      DIFFY(:NMIX,:NGRP)=0.0

+      DIFFZ(:NMIX,:NGRP)=0.0

+      WORK(:NMIX*NGRP)=0.0

+      SCAT(:NMIX,:NL,:NGRP,:NGRP)=0.0

+      H(:NMIX,:NGRP,:NL)=0.0

+      IPOS(:NMIX)=0

+      DO 12 IGR=1,NGRP

+      DO 11 IBM=1,NMIX

+      DO 10 IL=1,NL

+      IJJ(IBM,IL,IGR)=IGR

+      NJJ(IBM,IL,IGR)=1

+   10 CONTINUE

+   11 CONTINUE

+   12 CONTINUE

+      IF((IMPX.GT.1).AND.LMAC) CALL LCMLIB(IPMAC)

+*----

+*  RECOVER THE EXISTING MACROLIB DATA

+*----

+      ILEAK=0

+      IF(LMAC)THEN

+        JPMAC=LCMGID(IPMAC,'GROUP')

+        DO 40 JGR=1,NGRP

+        KPMAC=LCMGIL(JPMAC,JGR)

+        CALL LCMLEN(KPMAC,'NTOT0',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)THEN

+          CALL LCMGET(KPMAC,'NTOT0',TOTAL(1,JGR))

+        ELSEIF(ILENGT.NE.0)THEN

+          CALL XABORT('@CREDRV: INVALID INPUT MACROLIB(1).')

+        ENDIF

+        CALL LCMLEN(KPMAC,'NUSIGF',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)CALL LCMGET(KPMAC,'NUSIGF',ZNUG(1,JGR))

+        CALL LCMLEN(KPMAC,'NFTOT',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)CALL LCMGET(KPMAC,'NFTOT',SNUGF(1,JGR))

+        CALL LCMLEN(KPMAC,'CHI',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)CALL LCMGET(KPMAC,'CHI',CHI(1,JGR))

+        CALL LCMLEN(KPMAC,'OVERV',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)CALL LCMGET(KPMAC,'OVERV',OVERV(1,JGR))

+        CALL LCMLEN(KPMAC,'DIFF',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)THEN

+          ILEAK=1

+          CALL LCMGET(KPMAC,'DIFF',DIFFX(1,JGR))

+        ENDIF

+        CALL LCMLEN(KPMAC,'DIFFX',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)THEN

+          ILEAK=2

+          CALL LCMGET(KPMAC,'DIFFX',DIFFX(1,JGR))

+          CALL LCMGET(KPMAC,'DIFFY',DIFFY(1,JGR))

+          CALL LCMGET(KPMAC,'DIFFZ',DIFFZ(1,JGR))

+        ENDIF

+        CALL LCMLEN(KPMAC,'H-FACTOR',ILENGT,ITYLCM)

+        IF(ILENGT.EQ.NMIX)CALL LCMGET(KPMAC,'H-FACTOR',H(1,JGR,1))

+        DO IL=1,NL

+          WRITE (CM,'(I2.2)') IL-1

+          CALL LCMLEN(KPMAC,'SCAT'//CM,ILENGT,ITYLCM)

+          IF(ILENGT.GT.NMIX*NL*NGRP*NGRP)THEN

+            CALL XABORT('@CREDRV: INVALID INPUT MACROLIB(2).')

+          ELSEIF(ILENGT.GT.0)THEN

+            CALL LCMGET(KPMAC,'SCAT'//CM,WORK)

+            CALL LCMGET(KPMAC,'NJJS'//CM,NJJ(1,IL,JGR))

+            CALL LCMGET(KPMAC,'IJJS'//CM,IJJ(1,IL,JGR))

+            IPOSDE=0

+            DO 25 IBM=1,NMIX

+            IJJ0=IJJ(IBM,IL,JGR)

+            DO 20 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1

+            IPOSDE=IPOSDE+1

+            SCAT(IBM,IL,IGR,JGR)=WORK(IPOSDE)

+   20       CONTINUE

+   25       CONTINUE

+          ELSE

+            CALL XABORT('@CREDRV: OLD FORMAT OF THE MACROLIB.')

+          ENDIF

+        ENDDO

+   40   CONTINUE

+      ENDIF

+*----

+*  READ INPUT DATA

+*----

+      CALL CREXSI(IPMAP,NENTRY,HENTRY,KENTRY,NMIX,NGRP,NL,ILEAK,IMPX,

+     1 TOTAL,ZNUG,SNUGF,CHI,OVERV,DIFFX,DIFFY,DIFFZ,H,IJJ,NJJ,SCAT)

+*----

+*  MACROLIB DATA STORAGE

+*----

+      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)

+      DO 190 JGR=1,NGRP

+      KPMAC=LCMDIL(JPMAC,JGR)

+      CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,TOTAL(1,JGR))

+      CALL LCMPUT(KPMAC,'NUSIGF',NMIX,2,ZNUG(1,JGR))

+      CALL LCMPUT(KPMAC,'NFTOT',NMIX,2,SNUGF(1,JGR))

+      CALL LCMPUT(KPMAC,'CHI',NMIX,2,CHI(1,JGR))

+      CALL LCMPUT(KPMAC,'OVERV',NMIX,2,OVERV(1,JGR))

+      IF(ILEAK.EQ.1)THEN

+        CALL LCMPUT(KPMAC,'DIFF',NMIX,2,DIFFX(1,JGR))

+      ELSEIF(ILEAK.EQ.2)THEN

+        CALL LCMPUT(KPMAC,'DIFFX',NMIX,2,DIFFX(1,JGR))

+        CALL LCMPUT(KPMAC,'DIFFY',NMIX,2,DIFFY(1,JGR))

+        CALL LCMPUT(KPMAC,'DIFFZ',NMIX,2,DIFFZ(1,JGR))

+      ENDIF

+      CALL LCMPUT(KPMAC,'H-FACTOR',NMIX,2,H(1,JGR,1))

+  190 CONTINUE

+*----

+*  SCATTERING DATA

+*----

+      H(:NMIX,:NGRP,:NL)=0.0

+      DO 215 JGR=1,NGRP

+      KPMAC=LCMDIL(JPMAC,JGR)

+      DO 210 IL=1,NL

+        WRITE (CM,'(I2.2)') IL-1

+        IPOSDE=0

+        DO 205 IBM=1,NMIX

+        IPOS(IBM)=IPOSDE+1

+        DO 200 IGR=IJJ(IBM,IL,JGR),IJJ(IBM,IL,JGR)-NJJ(IBM,IL,JGR)+1,-1

+        IPOSDE=IPOSDE+1

+        WORK(IPOSDE)=SCAT(IBM,IL,IGR,JGR)

+        H(IBM,IGR,IL)=H(IBM,IGR,IL)+SCAT(IBM,IL,IGR,JGR)

+  200   CONTINUE

+  205   CONTINUE

+        CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,WORK)

+        CALL LCMPUT(KPMAC,'IPOS'//CM,NMIX,1,IPOS)

+        CALL LCMPUT(KPMAC,'NJJS'//CM,NMIX,1,NJJ(1,IL,JGR))

+        CALL LCMPUT(KPMAC,'IJJS'//CM,NMIX,1,IJJ(1,IL,JGR))

+        CALL LCMPUT(KPMAC,'SIGW'//CM,NMIX,2,SCAT(1,IL,JGR,JGR))

+  210 CONTINUE

+  215 CONTINUE

+      DO 225 IGR=1,NGRP

+      KPMAC=LCMDIL(JPMAC,IGR)

+      DO 220 IL=1,NL

+      WRITE (CM,'(I2.2)') IL-1

+      CALL LCMPUT(KPMAC,'SIGS'//CM,NMIX,2,H(1,IGR,IL))

+      IF(IMPX.GT.2)CALL LCMLIB(KPMAC)

+  220 CONTINUE

+  225 CONTINUE

+*

+      IF(IMPX.GT.1)CALL LCMLIB(IPMAC)

+*----

+*  SCRATCH STORAGE DEALLOCATION

+*----

+      DEALLOCATE(H,SCAT,WORK,DIFFZ,DIFFY,DIFFX,OVERV,CHI,SNUGF,ZNUG,

+     1 TOTAL)

+      DEALLOCATE(NJJ,IJJ,IPOS)

+      RETURN

+      END