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 --- Dragon/src/LIBEPR.f | 349 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 349 insertions(+) create mode 100644 Dragon/src/LIBEPR.f (limited to 'Dragon/src/LIBEPR.f') diff --git a/Dragon/src/LIBEPR.f b/Dragon/src/LIBEPR.f new file mode 100644 index 0000000..ad893cc --- /dev/null +++ b/Dragon/src/LIBEPR.f @@ -0,0 +1,349 @@ +*DECK LIBEPR + SUBROUTINE LIBEPR(IMPX,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR, + > HNADPL,NMDEPL,IDR,RER,RRD,KPAR,BPAR,YIELD,IZAE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Print isotopic depletion chain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): G. Marleau +* +*Parameters: input +* IMPX print parameter: +* .ge.5 nice formatted printout; +* .ge.10 dragon input formatted; +* .ge.20 dragon/APOLIB-2 input formatted. +* NBESP number of energy-dependent fission yield matrices. +* NDEPL number of depleting isotopes. +* NSTABL number of non-depleting isotopes producing energy. +* NDFI number of direct fissile isotopes. +* NDFP number of direct fission product. +* NREAC maximum number of depletion reaction in the depletion chain. +* NPAR maximum number of parent isopopes from decay and +* neutron-induced reactions. +* HNADPL reactive isotope names in chain. +* NMDEPL names of used depletion reactions +* (NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT'; +* NMDEPL(3)='NG' ; NMDEPL(4)='N2N'; +* etc.). +* IDR DEPLETE-REAC matrix (reaction identifiers). +* RER DEPLETE-ENER matrix (MeV/reaction values). +* RRD DEPLETE-DECA vector (decay constant values). +* KPAR PRODUCE-REAC matrix (production identifiers). +* BPAR PRODUCE-RATE matrix (branching ratios). +* YIELD fission product yield matrix. +* IZAE 6-digit nuclide identifier: +* atomic number z*10000 (digits) + mass number a*10 + +* energy state (0 = ground state, 1 = first state, etc.). +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR, + > HNADPL(3,NDEPL),NMDEPL(2,NREAC),IDR(NREAC,NDEPL), + > KPAR(NPAR,NDEPL),IZAE(NDEPL) + REAL RER(NREAC,NDEPL),RRD(NDEPL),BPAR(NPAR,NDEPL), + > YIELD(NBESP,NDFI,NDFP) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,J,ISO,KRD,KRF,ISOF,IPF,KRC,IOF,KROTH,NBPROD,IPAR, + > JSO,KREAC,ISOFP,IOFS,IREAC,NBFIS,IOUT,IBESP + REAL RATD1,RATD2,RATF,RATC,RREAC + REAL, ALLOCATABLE, DIMENSION(:) :: RATFS +*---- +* INTERNAL PARAMETERS +*---- + REAL CNVDAY + PARAMETER (IOUT=6,CNVDAY=1.0E+8/86400.0) + CHARACTER NONOFF(2)*3 + CHARACTER LINE*130 + SAVE NONOFF + DATA NONOFF/'NO ','YES'/ +*---- +* PRINT THE DEPLETION CHAIN. +*---- + IF(IMPX.GE.5) THEN + WRITE(IOUT,6000) ((NMDEPL(J,I),J=1,2),I=4,NREAC) + WRITE(IOUT,6010) + ALLOCATE(RATFS(NBESP)) + DO 40 ISO=1,NDEPL + KRD=1 + RATD1=0.0 + RATD2=0.0 + IF(IDR(1,ISO).NE.0) THEN + RATD1=CNVDAY/RRD(ISO) + RATD2=RER(1,ISO) + KRD=2 + ENDIF + KRF=1 + RATF=0.0 + RATFS(:)=0.0 + IF(MOD(IDR(2,ISO),100).EQ.3) THEN + KRF=2 + RATF=RER(2,ISO) + ELSE IF(MOD(IDR(2,ISO),100).EQ.4) THEN + KRF=2 + RATF=RER(2,ISO) + ISOF=IDR(2,ISO)/100 + IF(ISOF.NE.0) THEN + DO 20 IBESP=1,NBESP + DO 10 IPF=1,NDFP + RATFS(IBESP)=RATFS(IBESP)+YIELD(IBESP,ISOF,IPF) + 10 CONTINUE + 20 CONTINUE + ENDIF + ENDIF + KRC=1 + RATC=0.0 + IF(IDR(3,ISO).NE.0) THEN + RATC=RER(3,ISO) + KRC=2 + ENDIF + LINE=' ' +*---- +* WRITE ISOTOPE PROPERTIES +*---- + WRITE(LINE(:18),'(I5,1X,2A4,1X,A3)') ISO,HNADPL(1,ISO), + > HNADPL(2,ISO),NONOFF(KRD) + IF(KRD.EQ.2) WRITE(LINE(19:42),'(1P,2E12.4)') RATD1,RATD2 + WRITE(LINE(45:47),'(A3)') NONOFF(KRF) + IF(KRF.EQ.2) WRITE(LINE(48:71),'(1P,2E12.4)') RATF,RATFS(1) + WRITE(LINE(74:76),'(A3)') NONOFF(KRC) + IF(KRC.EQ.2) WRITE(LINE(77:88),'(1P,E12.4)') RATC + IOF=91 + DO 30 I=4,NREAC + KROTH=1 + IF(IDR(I,ISO).GT.0) KROTH=2 + IF(IOF+7.GT.130) THEN + WRITE(IOUT,'(1X,A)') LINE + IOF=91 + LINE=' ' + ENDIF + WRITE(LINE(IOF:IOF+7),'(A3,5X)') NONOFF(KROTH) + IOF=IOF+8 + 30 CONTINUE + WRITE(IOUT,'(1X,A)') LINE + 40 CONTINUE + DEALLOCATE(RATFS) +*---- +* WRITE PARENTS FROM ALL REACTION EXCEPT FISSION +*---- + WRITE(IOUT,7000) + DO 70 ISO=1,NDEPL-NSTABL + NBPROD=0 + DO 50 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + IF((KREAC.LE.0).OR.(KREAC.GT.NREAC)) CALL XABORT('LIBEPR' + > //': INDALID REACTION INDEX') + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) THEN + WRITE(IOUT,6012) ISO,HNADPL(1,ISO),HNADPL(2,ISO), + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),JSO,HNADPL(1,JSO), + > HNADPL(2,JSO),RREAC + ELSE + WRITE(IOUT,6013) NMDEPL(1,KREAC),NMDEPL(2,KREAC), + > JSO,HNADPL(1,JSO),HNADPL(2,JSO),RREAC + ENDIF + ENDIF + 50 CONTINUE +*---- +* WRITE PARENTS FROM FISSION IF REQUIRED +*---- + IF(MOD(IDR(2,ISO),100).EQ.2) THEN + GO TO 70 + ELSE IF(MOD(IDR(2,ISO),100).EQ.5) THEN + ISOFP=IDR(2,ISO)/100 + IF(ISOFP.GT.NDFP) + > CALL XABORT('LIBEPR: INVALID FISSION PRODUCT NUMBER') + DO 60 JSO=1,NDEPL + IF(MOD(IDR(2,JSO),100).EQ.4) THEN + ISOF=IDR(2,JSO)/100 + IF(ISOF.GT.NDFI) THEN + CALL XABORT('LIBEPR: INVALID FISSILE NUMBER') + ELSE IF(ISOF.GT.0) THEN + RREAC=YIELD(1,ISOF,ISOFP) + IF(RREAC.GT.0.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) THEN + WRITE(IOUT,6012) ISO,HNADPL(1,ISO),HNADPL(2,ISO), + > NMDEPL(1,2),NMDEPL(2,2),JSO,HNADPL(1,JSO), + > HNADPL(2,JSO),RREAC + ELSE + WRITE(IOUT,6013) NMDEPL(1,2),NMDEPL(2,2),JSO, + > HNADPL(1,JSO),HNADPL(2,JSO),RREAC + ENDIF + ENDIF + ENDIF + ENDIF + 60 CONTINUE + ENDIF + 70 CONTINUE + ENDIF +* + IF(IMPX.GE.10) THEN + WRITE(IOUT,'(/1X,4HDEPL,I6,6H CHAIN)') NDEPL + DO 330 ISO=1,NDEPL + LINE=' ' + WRITE(LINE(:17),'(1H'',2A4,1H'',I7)') HNADPL(1,ISO), + > HNADPL(2,ISO),IZAE(ISO) + IOFS=18 + IF(IDR(1,ISO).NE.0) THEN + WRITE(LINE(IOFS:IOFS+20),'(1X,5HDECAY,1P,E14.6)') RRD(ISO) + IOFS=IOFS+20 +* IF(RER(1,ISO).NE.0.0) THEN +* WRITE(LINE(IOFS:IOFS+13),'(1X,1P,E12.5)') RER(1,ISO) +* IOFS=IOFS+13 +* ENDIF + ENDIF + IF((MOD(IDR(2,ISO),100).EQ.3).OR.(MOD(IDR(2,ISO),100).EQ.4)) + > THEN + WRITE(LINE(IOFS:IOFS+15),'(1X,5HNFTOT,F9.4)') RER(2,ISO) + IOFS=IOFS+15 + ENDIF + IF(IDR(3,ISO).NE.0) THEN + WRITE(LINE(IOFS:IOFS+17),'(1X,2HNG,1P,E14.6)') RER(3,ISO) + IOFS=IOFS+17 + ENDIF + DO 80 IREAC=4,NREAC + IF(IDR(IREAC,ISO).NE.0) THEN + IF(IOFS+9.GT.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=18 + ENDIF + WRITE(LINE(IOFS:IOFS+9),'(1X,2A4)') NMDEPL(1,IREAC), + > NMDEPL(2,IREAC) + IOFS=IOFS+9 + ENDIF + 80 CONTINUE + IF(ISO.GT.NDEPL-NSTABL) THEN + WRITE(LINE(IOFS:IOFS+7),'(7H STABLE)') + IOFS=IOFS+7 + IF(IOFS.GT.71) CALL XABORT('LIBEPR: LINE OVERFLOW.') + ENDIF + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=7 + NBPROD=0 + DO 310 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(2:6),'(5HFROM )') + IF(IOFS+34.GE.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=7 + ENDIF + WRITE(LINE(IOFS:IOFS+34),6100) + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),RREAC,HNADPL(1,JSO), + > HNADPL(2,JSO) + IOFS=IOFS+34 + ENDIF + 310 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=16 + NBFIS=0 + IF(MOD(IDR(2,ISO),100).EQ.2) THEN + GO TO 330 + ELSE IF(MOD(IDR(2,ISO),100).EQ.5) THEN + ISOFP=IDR(2,ISO)/100 + DO 320 JSO=1,NDEPL + IF(MOD(IDR(2,JSO),100).EQ.4) THEN + ISOF=IDR(2,JSO)/100 + IF(ISOF.GT.0) THEN + RREAC=YIELD(1,ISOF,ISOFP) + IF(RREAC.GT.0.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(2:6),'(5HFROM )') + NBFIS=NBFIS+1 + IF(NBFIS.EQ.1) WRITE(LINE(7:14),'(A8)') 'NFTOT ' + WRITE(LINE(IOFS:IOFS+24),6101) + > RREAC,HNADPL(1,JSO),HNADPL(2,JSO) + IOFS=IOFS+24 + IF(IOFS.GE.60) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=16 + ENDIF + ENDIF + ENDIF + ENDIF + 320 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + ENDIF + 330 CONTINUE + WRITE(IOUT,'(9H ENDCHAIN)') + ENDIF +* + IF(IMPX.GE.500) THEN + WRITE(IOUT,'(/1X,33HDEPL LIB: APLIB2 FIL: XXXXX CHAIN)') + DO 350 ISO=1,NDEPL-NSTABL + LINE=' ' + WRITE(LINE(:8),'(2A4)') HNADPL(1,ISO),HNADPL(2,ISO) + IOFS=14 + NBPROD=0 + DO 340 IPAR=1,NPAR + JSO=KPAR(IPAR,ISO)/100 + KREAC=MOD(KPAR(IPAR,ISO),100) + RREAC=BPAR(IPAR,ISO) + IF(JSO.GT.0) THEN + NBPROD=NBPROD+1 + IF(NBPROD.EQ.1) WRITE(LINE(10:13),'(4HFROM)') + WRITE(LINE(IOFS:IOFS+29),'(1X,2A4,1P,E11.4,1X,2A4)') + > NMDEPL(1,KREAC),NMDEPL(2,KREAC),RREAC,HNADPL(1,JSO), + > HNADPL(2,JSO) + IOFS=IOFS+29 + IF(IOFS.GE.71) THEN + WRITE(IOUT,'(1X,A)') LINE + LINE=' ' + IOFS=14 + ENDIF + ENDIF + 340 CONTINUE + IF(LINE.NE.' ') WRITE(IOUT,'(1X,A)') LINE + 350 CONTINUE + WRITE(IOUT,'(9H ENDCHAIN)') + ENDIF +*---- +* RETURN FROM LIBEPR +*---- + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/' DEPLETION CHAIN DATA'/' --------------------'// + > 43X,'DEPLETION REACTIONS'/ + > ' -----------------------------', + > '--------------------------------------------'/ + > ' ISOTOPE ......DECAY................ ..........', + > '.FISSION......... ......NG....... ',10A4:/(91X,10A4)) + 6010 FORMAT(' NB. NAME MLIFE(DAYS) ENERGY(MEV) ENERGY', + > '(MEV) TOTAL YIELD ENERGY(MEV)') + 6012 FORMAT(I5,1X,2A4,4X,2A4,3X,I5,1X,2A4,1X,1P,E14.6) + 6013 FORMAT(18X,2A4,3X,I5,1X,2A4,1X,1P,E14.6) + 6100 FORMAT(2A4,1X,1P,E13.6,2H ',2A4,2H' ) + 6101 FORMAT(1P,E13.6,2H ',2A4,1H') + 7000 FORMAT(//27X,'PRODUCTION REACTIONS'/ + > 18X,'---------------------------------------'/ + > ' ISOTOPE REACTION ISOTOPE',14X,'YIELD'/ + > ' NB. NAME NB. NAME ') + END -- cgit v1.2.3