From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Donjon/src/CREDRV.f | 210 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 210 insertions(+) create mode 100644 Donjon/src/CREDRV.f (limited to 'Donjon/src/CREDRV.f') 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 -- cgit v1.2.3