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/PCRONE.f | 346 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) create mode 100644 Donjon/src/PCRONE.f (limited to 'Donjon/src/PCRONE.f') diff --git a/Donjon/src/PCRONE.f b/Donjon/src/PCRONE.f new file mode 100644 index 0000000..bb8aee2 --- /dev/null +++ b/Donjon/src/PCRONE.f @@ -0,0 +1,346 @@ +*DECK PCRONE + SUBROUTINE PCRONE(IMPX,ICAL,IPMIC,NCAL,NGRP,XS_CALC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Copy an elementary calculation of the PMAXS file into a microlib. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* +*Author(s): +* A. Hebert and D. Calic +* +*Parameters: input +* IMPX print parameter. +* ICAL index of the elementary calculation. +* IPMIC address of the microlib. +* NCAL number of elementary calculations in the PMAXS file. +* NGRP number of energy groups. +* XS_CALC pointers towards PMAXS elementary calculations. +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE PCRDATA +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,ICAL,NCAL,NGRP + TYPE(C_PTR) IPMIC + TYPE(XSBLOCK_ITEM),TARGET :: XS_CALC(NCAL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMIC,KPMIC + INTEGER NSTATE + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE),ITYPR(1) + REAL DENS(3) + DOUBLE PRECISION DELTA + LOGICAL LEX + CHARACTER(LEN=8) :: HVECT(3) + CHARACTER(LEN=12) :: HNAME,HISONA(3) + CHARACTER(LEN=131) :: HSMG + TYPE(XSBLOCK_TYPE),POINTER :: XSONE,XSREF + TYPE(TH_INDEP_VAR),POINTER :: TIVONE +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: SIG1,GAR,ENERGY + REAL, ALLOCATABLE, DIMENSION(:,:) :: SIG2 +*---- +* SET SIGNATURE AND STATE VECTOR +*---- + INQUIRE(FILE='PCRONE.txt',EXIST=LEX) + IF(LEX) THEN + NUNIT=KDROPN('PCRONE.txt',1,3,0) + ELSE + NUNIT=KDROPN('PCRONE.txt',0,3,0) + ENDIF + IF(NUNIT.LE.0) THEN + WRITE(HSMG,'(28HPCRONE: KDROPN FAILURE (IER=,I5,2H).)') NUNIT + CALL XABORT(HSMG) + ENDIF + + NED=1 + HVECT(1)='H-FACTOR' + IF(NXST.GE.7) THEN + NED=2 + HVECT(2)='NFTOT' + ENDIF + IF(NXST.EQ.8) THEN + NED=3 + HVECT(3)='DETEC' + ENDIF + NBISO=1 ! number of isotopes + IF(NXST.GT.4) NBISO=3 ! include Xe and Sm + HNAME='L_LIBRARY' + CALL LCMPTC(IPMIC,'SIGNATURE',12,HNAME) + ISTATE(:)=0 + ISTATE(1)=1 + ISTATE(2)=NBISO + ISTATE(3)=NGRP + ISTATE(4)=1 ! isotropic scattering + ISTATE(13)=NED ! number of additional edits + ISTATE(19)=NDLAY ! number of delayed neutron groups + CALL LCMPUT(IPMIC,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPTC(IPMIC,'ADDXSNAME-P0',8,NED,HVECT) + JPMIC=LCMLID(IPMIC,'ISOTOPESLIST',NBISO) +* + ALLOCATE(SIG1(NGRP),SIG2(NGRP,NGRP)) + XSONE=>XS_CALC(ICAL)%XS + XSREF=>XS_CALC(XS_CALC(ICAL)%IBURN)%XS + WRITE(NUNIT,*)XS_CALC(ICAL)%IBURN + TIVONE=>XS_CALC(ICAL)%TIV + KPMIC=LCMDIL(JPMIC,1) ! step up isot 1 + HISONA(1)='*MAC*RES' + DENS(1)=1.0 + CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(1)) +*---- +* PROCESS VECTORIAL CROSS SECTIONS +*---- +* 1 2 3 4 5 6 7 +* xtr,xab,xnf,xkf,xfi,xxe,xsm +*---- +* RUN ELEMENTARY CALC IN CASE THE PMAXS FILE IS GIVEN AS DERIVATIVES +*---- + IF(derivatives) THEN + DELTA=XS_CALC(ICAL)%DELTA + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,1)+DELTA*XSONE%sig(IG,1)) + ENDDO + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,2)+SUM(XSREF%sct(IG,:))+DELTA* + 1 XSONE%sig(IG,2)+SUM(XSONE%sct(IG,:))) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,3)+DELTA*XSONE%sig(IG,3)) + WRITE(NUNIT,*)SIG1(IG) + ENDDO + CALL LCMPUT(KPMIC,'NUSIGF',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,4)+DELTA*XSONE%sig(IG,4)) + ENDDO + CALL LCMPUT(KPMIC,'H-FACTOR',NGRP,2,SIG1) + IF(NXST.GT.4) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,7)+DELTA*XSONE%sig(IG,7)) + ENDDO + CALL LCMPUT(KPMIC,'NFTOT',NGRP,2,SIG1) + SIG1(:NGRP)=0.0 + SIG1(1)=1.0 + CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1) + ENDIF + IF(NXST.EQ.8) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,8)+DELTA*XSONE%sig(IG,8)) + ENDDO + CALL LCMPUT(KPMIC,'DETEC',NGRP,2,SIG1) + ENDIF + IF(lamb) THEN + ALLOCATE(GAR(ELAM-BLAM+1)) + GAR(:ELAM-BLAM+1)=REAL(TIVONE%kinp(BLAM:ELAM)) + CALL LCMPUT(KPMIC,'LAMBDA',ELAM-BLAM+1,2,GAR) + DEALLOCATE(GAR) + ENDIF + DO j=1,iXSTI + k=iTIV(j) + IF(k.GT.0) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(TIVONE%sig(IG,k)) + ENDDO + IF(j.EQ.1) THEN + CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1) + ELSE IF(j.EQ.2) THEN + CALL LCMPUT(KPMIC,'CHID',NGRP,2,SIG1) + ELSE IF(j.EQ.3) THEN + CALL LCMPUT(KPMIC,'INVEL',NGRP,2,SIG1) + ENDIF + ENDIF + ENDDO +*---- +* PROCESS SCATTERING INFORMATION (JG --> IG) +*---- + DO IG=1,NGRP + SIG1(IG)=REAL(SUM(XSREF%sct(IG,:))+DELTA*SUM(XSONE%sct(IG,:))) + DO JG=1,NGRP + SIG2(IG,JG)=REAL(XSREF%sct(JG,IG)+DELTA*XSONE%sct(JG,IG)) + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + IF(IMPX.GT.5) CALL LCMLIB(KPMIC) +*---- +* PROCESS Xe and Sm +*---- + IF(NXST.GT.4) THEN + KPMIC=LCMDIL(JPMIC,2) ! step up isot 2 + HISONA(2)='Xe135' + DENS(2)=0.0 + CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(2)) + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,5)+DELTA*XSONE%sig(IG,5)) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=0.0 + DO JG=1,NGRP + SIG2(IG,JG)=0.0 + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + KPMIC=LCMDIL(JPMIC,3) ! step up isot 3 + HISONA(3)='Sm149' + DENS(3)=0.0 + CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(3)) + DO IG=1,NGRP + SIG1(IG)=REAL(XSREF%sig(IG,6)+DELTA*XSONE%sig(IG,6)) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=0.0 + DO JG=1,NGRP + SIG2(IG,JG)=0.0 + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + ENDIF + CALL LCMPTC(IPMIC,'ISOTOPESUSED',12,NBISO,HISONA) + CALL LCMPUT(IPMIC,'ISOTOPESDENS',NBISO,2,DENS) + DEALLOCATE(SIG2,SIG1) + ELSE +*---- +* RUN ELEMENTARY CALC IN CASE THE PMAXS FILE IS GIVEN AS RAW CROSS +* SECTIONS +*---- + DELTA=XS_CALC(ICAL)%DELTA + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,1)) + ENDDO + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,2)+SUM(XSONE%sct(IG,:))) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,3)) + WRITE(NUNIT,*)XSONE%sig(IG,3) + ENDDO + CALL LCMPUT(KPMIC,'NUSIGF',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,4)) + ENDDO + CALL LCMPUT(KPMIC,'H-FACTOR',NGRP,2,SIG1) + IF(NXST.GT.4) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,7)) + ENDDO + CALL LCMPUT(KPMIC,'NFTOT',NGRP,2,SIG1) + SIG1(:NGRP)=0.0 + SIG1(1)=1.0 + CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1) + ENDIF + IF(NXST.EQ.8) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,8)) + ENDDO + CALL LCMPUT(KPMIC,'DETEC',NGRP,2,SIG1) + ENDIF + IF(lamb) THEN + ALLOCATE(GAR(ELAM-BLAM+1)) + GAR(:ELAM-BLAM+1)=REAL(TIVONE%kinp(BLAM:ELAM)) + CALL LCMPUT(KPMIC,'LAMBDA',ELAM-BLAM+1,2,GAR) + DEALLOCATE(GAR) + ENDIF + DO j=1,iXSTI + k=iTIV(j) + IF(k.GT.0) THEN + DO IG=1,NGRP + SIG1(IG)=REAL(TIVONE%sig(IG,k)) + ENDDO + IF(j.EQ.1) THEN + CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1) + ELSE IF(j.EQ.2) THEN + CALL LCMPUT(KPMIC,'CHID',NGRP,2,SIG1) + ELSE IF(j.EQ.3) THEN + CALL LCMPUT(KPMIC,'INVEL',NGRP,2,SIG1) + ENDIF + ENDIF + ENDDO +*---- +* PROCESS SCATTERING INFORMATION +*---- + DO IG=1,NGRP + SIG1(IG)=REAL(SUM(XSONE%sct(IG,:))) + DO JG=1,NGRP + SIG2(IG,JG)=REAL(XSONE%sct(JG,IG)) ! JG --> IG + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + IF(IMPX.GT.5) CALL LCMLIB(KPMIC) +*---- +* PROCESS Xe and Sm +*---- + IF(NXST.GT.4) THEN + KPMIC=LCMDIL(JPMIC,2) ! step up isot 2 + HISONA(2)='Xe135' + DENS(2)=0.0 + CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(2)) + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,5)) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=0.0 + DO JG=1,NGRP + SIG2(IG,JG)=0.0 + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + KPMIC=LCMDIL(JPMIC,3) ! step up isot 3 + HISONA(3)='Sm149' + DENS(3)=0.0 + CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(3)) + DO IG=1,NGRP + SIG1(IG)=REAL(XSONE%sig(IG,6)) + ENDDO + CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1) + CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1) + DO IG=1,NGRP + SIG1(IG)=0.0 + DO JG=1,NGRP + SIG2(IG,JG)=0.0 + ENDDO + ENDDO + ITYPR(1)=1 + CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR) + ENDIF + CALL LCMPTC(IPMIC,'ISOTOPESUSED',12,NBISO,HISONA) + CALL LCMPUT(IPMIC,'ISOTOPESDENS',NBISO,2,DENS) + DEALLOCATE(SIG2,SIG1) + ENDIF + CLOSE(NUNIT) +*---- +* SET ENERGY MESH +*---- + ALLOCATE(ENERGY(NGRP+1)) + IF(NGRP.EQ.2) THEN + ENERGY(:)=(/ 1.964E7, 6.25E-1, 1.1E-4 /) + ELSE + CALL XABORT('PCRONE: UNKNOWN ENERGY MESH') + ENDIF + CALL LCMPUT(IPMIC,'ENERGY',NGRP+1,2,ENERGY) + DEALLOCATE(ENERGY) + RETURN + END -- cgit v1.2.3