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/CREMAC.f | 327 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 327 insertions(+) create mode 100644 Donjon/src/CREMAC.f (limited to 'Donjon/src/CREMAC.f') diff --git a/Donjon/src/CREMAC.f b/Donjon/src/CREMAC.f new file mode 100644 index 0000000..6f063db --- /dev/null +++ b/Donjon/src/CREMAC.f @@ -0,0 +1,327 @@ +*DECK CREMAC + SUBROUTINE CREMAC(IPCPO,NISO,NGRP,NL,IMPX,HISO,DENSIT,ILEAK,TOTAL, + 1 ZNUG,SNUGF,CHI,OVERV,DIFFX,DIFFY,DIFFZ,H,SCAT,FLUX,UPS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add the microscopic x-sections of the extracted isotopes to the +* macroscopic residual. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal. +* +*Author(s): +* A. Hebert +* +*Update(s): +* E. Varin (2010/01/26) +* +*Parameters: input +* IPCPO pointer to l_compo information. +* NISO 1+number of extracted isotopes. +* NGRP number of energy groups. +* NL number of legendre orders (=1 for isotropic scattering). +* IMPX print parameter (=0 for no print). +* HISO hollerith name information for extracted isotopes. +* DENSIT number densities. +* UPS =.true.: no upscatering cross sections will be stored. +* +*Parameters: output +* ILEAK diffusion coefficient flag (=1: isotropic; =2: anisotropic). +* TOTAL total macroscopic x-sections. +* ZNUG nu*fission macroscopic x-sections. +* SNUGF fission macroscopic x-sections. +* CHI fission spectrum. +* OVERV reciprocal neutron velocities. +* DIFFX x-directed diffusion coefficients. +* DIFFY y-directed diffusion coefficients. +* DIFFZ z-directed diffusion coefficients. +* H h-factors (kappa*fission macroscopic x-sections). +* SCAT scattering macroscopic x-sections. +* FLUX integrated fluxes. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO + INTEGER NISO,NGRP,NL,IMPX,ILEAK,HISO(3*NISO) + REAL DENSIT(NISO),TOTAL(NGRP),ZNUG(NGRP),SNUGF(NGRP),CHI(NGRP), + 1 OVERV(NGRP),DIFFX(NGRP),DIFFY(NGRP),DIFFZ(NGRP),H(NGRP), + 2 SCAT(NL,NGRP,NGRP),FLUX(NGRP) + LOGICAL UPS +*---- +* LOCAL VARIABLES +*---- + CHARACTER HMICRO*12,CM*2 + LOGICAL LFISS + DOUBLE PRECISION XDRCST,EVJ +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,INDXS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK2,ENGFIS + REAL, ALLOCATABLE, DIMENSION(:,:) :: WORK1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NGRP),NJJ(NGRP),WORK1(NGRP,3),WORK2(NGRP*NGRP), + 1 INDXS(21+NL),ENGFIS(NISO)) +*---- +* RECOVER MACROSCOPIC RESIDUAL OF VECTORIAL X-SECTIONS +*---- + EVJ=XDRCST('eV','J') + DO 10 IGR=1,NGRP + TOTAL(IGR)=0.0 + DIFFX(IGR)=0.0 + DIFFY(IGR)=0.0 + DIFFZ(IGR)=0.0 + ZNUG(IGR)=0.0 + SNUGF(IGR)=0.0 + CHI(IGR)=0.0 + 10 CONTINUE + CALL LCMGET(IPCPO,'FLUX-INTG',FLUX) + CALL LCMGET(IPCPO,'OVERV',OVERV) + CALL LCMGET(IPCPO,'ISOTOPES-EFJ',ENGFIS) + CALL LCMSIX(IPCPO,'MACR',1) + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + IF(INDXS(1).EQ.1)CALL LCMGET(IPCPO,'TOTAL',TOTAL) + ILEAK=0 + IF(INDXS(17).EQ.1)THEN + ILEAK=1 + CALL LCMGET(IPCPO,'STRD',DIFFX) + ELSE IF(INDXS(18).EQ.1)THEN + ILEAK=2 + CALL LCMGET(IPCPO,'STRD X',DIFFX) + CALL LCMGET(IPCPO,'STRD Y',DIFFY) + CALL LCMGET(IPCPO,'STRD Z',DIFFZ) + ENDIF + IF(INDXS(3).EQ.1)THEN + CALL LCMGET(IPCPO,'NUSIGF',ZNUG) + CALL LCMGET(IPCPO,'NFTOT',SNUGF) + CALL LCMGET(IPCPO,'CHI',CHI) + ENDIF + DO 11 IGR=1,NGRP + H(IGR)=ENGFIS(1)*SNUGF(IGR)/REAL(EVJ) + 11 CONTINUE + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER MICROSCOPIC CONTRIBUTIONS OF VECTORIAL X-SECTIONS +*---- + LFISS=.FALSE. + DO 40 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.)GOTO 40 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+I),I=1,3) + CALL LCMLEN(IPCPO,HMICRO,ILENG,ITYLCM) + IF(ILENG.EQ.0)GOTO 40 + IF(IMPX.GT.1)WRITE(6,'(/29H CREMAC: PROCESSING ISOTOPE '',A12, + 1 16H'' WITH DENSITY =,1P,E13.5,2H .)') HMICRO,DENSIT(ISO) + CALL LCMSIX(IPCPO,HMICRO,1) + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + IF(INDXS(1).EQ.1)THEN + CALL LCMGET(IPCPO,'TOTAL',WORK1(1,1)) + DO 20 IGR=1,NGRP + TOTAL(IGR)=TOTAL(IGR)+DENSIT(ISO)*WORK1(IGR,1) + 20 CONTINUE + ENDIF + IF(INDXS(17).EQ.1)THEN + CALL LCMGET(IPCPO,'STRD',WORK1(1,1)) + DO 21 IGR=1,NGRP + DIFFX(IGR)=DIFFX(IGR)+DENSIT(ISO)*WORK1(IGR,1) + 21 CONTINUE + ELSE IF(INDXS(18).EQ.1)THEN + CALL LCMGET(IPCPO,'STRD X',WORK1(1,1)) + CALL LCMGET(IPCPO,'STRD Y',WORK1(1,2)) + CALL LCMGET(IPCPO,'STRD Z',WORK1(1,3)) + DO 22 IGR=1,NGRP + DIFFX(IGR)=DIFFX(IGR)+DENSIT(ISO)*WORK1(IGR,1) + DIFFY(IGR)=DIFFY(IGR)+DENSIT(ISO)*WORK1(IGR,2) + DIFFZ(IGR)=DIFFZ(IGR)+DENSIT(ISO)*WORK1(IGR,3) + 22 CONTINUE + ENDIF + IF(INDXS(3).EQ.1)THEN + CALL LCMGET(IPCPO,'NUSIGF',WORK1(1,1)) + CALL LCMGET(IPCPO,'NFTOT',WORK1(1,2)) + CALL LCMGET(IPCPO,'CHI',WORK1(1,3)) + DO 30 IGR=1,NGRP + LFISS=LFISS.OR.(CHI(IGR).NE.WORK1(IGR,3)) + ZNUG(IGR)=ZNUG(IGR)+DENSIT(ISO)*WORK1(IGR,1) + SNUGF(IGR)=SNUGF(IGR)+DENSIT(ISO)*WORK1(IGR,2) + H(IGR)=H(IGR)+DENSIT(ISO)*WORK1(IGR,2)*ENGFIS(ISO)/REAL(EVJ) + 30 CONTINUE + ENDIF + CALL LCMSIX(IPCPO,' ',2) + 40 CONTINUE +*---- +* COMPUTE AN AVERAGE FISSION SPECTRUM +*---- + IF(LFISS)THEN + CALL LCMGET(IPCPO,'FLUX-INTG',WORK1(1,1)) + CALL LCMSIX(IPCPO,'MACR',1) + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + IF(INDXS(3).EQ.1)THEN + CALL LCMGET(IPCPO,'NUSIGF',WORK1(1,2)) + CALL LCMGET(IPCPO,'CHI',WORK1(1,3)) + DO 55 JGR=1,NGRP + DO 50 IGR=1,NGRP + SCAT(1,IGR,JGR)=WORK1(IGR,1)*WORK1(IGR,2)*WORK1(JGR,3) + 50 CONTINUE + 55 CONTINUE + ELSE + DO 65 JGR=1,NGRP + DO 60 IGR=1,NGRP + SCAT(1,IGR,JGR)=0. + 60 CONTINUE + 65 CONTINUE + ENDIF + CALL LCMSIX(IPCPO,' ',2) + DO 80 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.)GOTO 80 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+I),I=1,3) + CALL LCMLEN(IPCPO,HMICRO,ILENG,ITYLCM) + IF(ILENG.EQ.0)GOTO 80 + CALL LCMSIX(IPCPO,HMICRO,1) + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + IF(INDXS(3).EQ.1)THEN + CALL LCMGET(IPCPO,'NUSIGF',WORK1(1,2)) + CALL LCMGET(IPCPO,'CHI',WORK1(1,3)) + DO 75 JGR=1,NGRP + DO 70 IGR=1,NGRP + SCAT(1,IGR,JGR)=SCAT(1,IGR,JGR)+DENSIT(ISO)* + 1 WORK1(IGR,1)*WORK1(IGR,2)*WORK1(JGR,3) + 70 CONTINUE + 75 CONTINUE + ENDIF + CALL LCMSIX(IPCPO,' ',2) + 80 CONTINUE + SSUM=0. + DO 95 JGR=1,NGRP + CHI(JGR)=0. + DO 90 IGR=1,NGRP + SSUM=SSUM+SCAT(1,IGR,JGR) + CHI(JGR)=CHI(JGR)+SCAT(1,IGR,JGR) + 90 CONTINUE + 95 CONTINUE + DO 100 JGR=1,NGRP + CHI(JGR)=CHI(JGR)/SSUM + 100 CONTINUE + ENDIF +*---- +* RECOVER MACROSCOPIC RESIDUAL OF SCATTERING X-SECTIONS +*---- + CALL LCMSIX(IPCPO,'MACR',1) + CALL LCMLEN(IPCPO,'SCAT-SAVED',ILONG,ITYP) + IF(ILONG.EQ.0)THEN + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + ELSE + CALL LCMGET(IPCPO,'SCAT-SAVED',INDXS(21)) + ENDIF + DO 130 IL=1,NL + DO 115 JGR=1,NGRP + DO 110 IGR=1,NGRP + SCAT(IL,IGR,JGR)=0. + 110 CONTINUE + 115 CONTINUE + WRITE (CM,'(I2.2)') IL-1 + IF(INDXS(20+IL).EQ.1)THEN +* OLD COMPO DEFINITION + CALL LCMLEN(IPCPO,'SCAT'//CM,ILONG,ITYP) + IF(ILONG.EQ.0)THEN + WRITE (CM,'(I2)') IL-1 + CALL LCMGET(IPCPO,'SCAT'//CM,WORK2) + CALL LCMGET(IPCPO,'NJJ '//CM,NJJ) + CALL LCMGET(IPCPO,'IJJ '//CM,IJJ) + ELSE + CALL LCMGET(IPCPO,'SCAT'//CM,WORK2) + CALL LCMGET(IPCPO,'NJJS'//CM,NJJ) + CALL LCMGET(IPCPO,'IJJS'//CM,IJJ) + ENDIF + IGAR=0 + DO 125 JGR=1,NGRP + DO 120 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SCAT(IL,IGR,JGR)=WORK2(IGAR) + 120 CONTINUE + 125 CONTINUE + ENDIF + 130 CONTINUE + CALL LCMSIX(IPCPO,' ',2) +*---- +* RECOVER MICROSCOPIC CONTRIBUTIONS OF SCATTERING X-SECTIONS +*---- + DO 160 ISO=2,NISO + IF(DENSIT(ISO).EQ.0.)GOTO 160 + WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+I),I=1,3) + CALL LCMLEN(IPCPO,HMICRO,ILENG,ITYLCM) + IF(ILENG.EQ.0)GOTO 160 + CALL LCMSIX(IPCPO,HMICRO,1) + CALL LCMLEN(IPCPO,'SCAT-SAVED',ILONG,ITYP) +*EV + IF(ILONG.EQ.0)THEN + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + ELSE + CALL LCMGET(IPCPO,'SCAT-SAVED',INDXS(21)) + ENDIF +*EV + DO 150 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IF(INDXS(20+IL).EQ.1)THEN +* OLD COMPO DEFINITION + CALL LCMLEN(IPCPO,'SCAT'//CM,ILONG,ITYP) + IF(ILONG.EQ.0)THEN + WRITE (CM,'(I2)') IL-1 + CALL LCMGET(IPCPO,'SCAT'//CM,WORK2) + CALL LCMGET(IPCPO,'NJJ '//CM,NJJ) + CALL LCMGET(IPCPO,'IJJ '//CM,IJJ) + ELSE + CALL LCMGET(IPCPO,'SCAT'//CM,WORK2) + CALL LCMGET(IPCPO,'NJJS'//CM,NJJ) + CALL LCMGET(IPCPO,'IJJS'//CM,IJJ) + ENDIF + IGAR=0 + DO 145 JGR=1,NGRP + DO 140 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1 + IGAR=IGAR+1 + SCAT(IL,IGR,JGR)=SCAT(IL,IGR,JGR) + 1 +DENSIT(ISO)*WORK2(IGAR) + 140 CONTINUE + 145 CONTINUE + ENDIF + 150 CONTINUE + CALL LCMSIX(IPCPO,' ',2) + 160 CONTINUE +*---- +* COMPUTE DIFFUSION COEFFICIENTS FROM STRD X-SECTIONS +*---- + CALL LCMSIX(IPCPO,'MACR',1) + CALL LCMGET(IPCPO,'XS-SAVED',INDXS) + CALL LCMSIX(IPCPO,' ',2) + IF(INDXS(17).EQ.1)THEN + DO 170 IGR=1,NGRP + DIFFX(IGR)=1.0/(3.0*DIFFX(IGR)) + 170 CONTINUE + ELSE IF(INDXS(18).EQ.1)THEN + DO 180 IGR=1,NGRP + DIFFX(IGR)=1.0/(3.0*DIFFX(IGR)) + DIFFY(IGR)=1.0/(3.0*DIFFY(IGR)) + DIFFZ(IGR)=1.0/(3.0*DIFFZ(IGR)) + 180 CONTINUE + ENDIF +*---- +* COMPUTE TOTAL CROSS SECTION FOR UPSCATERING CORRECTION +*---- + IF((UPS).AND.(NGRP.EQ.2))THEN + DO 200 IL=1,NL + TOTAL(2)=TOTAL(2)-SCAT(IL,2,1) + SCAT(IL,2,1)=0. + 200 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ENGFIS,INDXS,WORK2,WORK1,NJJ,IJJ) + RETURN + END -- cgit v1.2.3