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/DLEAK.f | 303 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 303 insertions(+) create mode 100644 Donjon/src/DLEAK.f (limited to 'Donjon/src/DLEAK.f') diff --git a/Donjon/src/DLEAK.f b/Donjon/src/DLEAK.f new file mode 100644 index 0000000..f3e629b --- /dev/null +++ b/Donjon/src/DLEAK.f @@ -0,0 +1,303 @@ +*DECK DLEAK + SUBROUTINE DLEAK(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Create a delta Macrolib with respect to leakage information. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal. +* +*Author(s): +* A. Hebert +* +*Parameters: input +* NENTRY number of data structures transfered to this module. +* HENTRY name of the data structures. +* IENTRY data structure type where: +* IENTRY=1 for LCM memory object; +* IENTRY=2 for XSM file; +* IENTRY=3 for sequential binary file; +* IENTRY=4 for sequential ASCII file. +* JENTRY access permission for the data structure where: +* JENTRY=0 for a data structure in creation mode; +* JENTRY=1 for a data structure in modifications mode; +* JENTRY=2 for a data structure in read-only mode. +* KENTRY data structure pointer. +* +*Comments: +* None +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER HSIGN*12,TEXT12*12 + DOUBLE PRECISION DFLOTT + INTEGER ISTATE(NSTATE) + DOUBLE PRECISION OPTPRR(NSTATE) + TYPE(C_PTR) IPOPT,IPNEW,IPOLD,JPNEW,JPOLD,KPNEW,KPOLD,LPNEW,MPNEW + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ + REAL, ALLOCATABLE, DIMENSION(:) :: GAR,PER + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VARV,WEI +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.3)CALL XABORT('DLEAK: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2))CALL XABORT('@DLEAK' + 1 //': LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).EQ.0)THEN + HSIGN='L_MACROLIB' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + ELSE + CALL XABORT('DLEAK: EMPTY DELTA MACROLIB EXPECTED AT LHS.') + ENDIF + IPNEW=KENTRY(1) + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))CALL XABORT('DLEAK: LC' + 1 //'M OBJECT EXPECTED AT LHS.') + IF(JENTRY(2).EQ.0)THEN + HSIGN='L_OPTIMIZE' + CALL LCMPTC(KENTRY(2),'SIGNATURE',12,HSIGN) + ELSE + CALL XABORT('DLEAK: EMPTY OPTIMIZE OBJECT EXPECTED AT LHS.') + ENDIF + IPOPT=KENTRY(2) + IF((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))CALL XABORT('DLEAK: LC' + 1 //'M OBJECT EXPECTED AT RHS.') + IF(JENTRY(3).NE.2)CALL XABORT('DLEAK: MACROLIB IN READ-ONLY MOD' + 1 //'E EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB')THEN + CALL XABORT('DLEAK: SIGNATURE OF '//HENTRY(3)//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + IPOLD=KENTRY(3) + CALL LCMGET(IPOLD,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + NMIX=ISTATE(2) + ILEAK=ISTATE(9) +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + ITYPE=0 + IDELTA=0 + NGR1=1 + NGR2=NGRP + IBM1=1 + IBM2=NMIX + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('DLEAK: CHARACTER DATA EXPECTED(1).') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DLEAK: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT12.EQ.'TYPE') THEN +* READ THE TYPE OF LEAKAGE. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DLEAK: CHARACTER DATA EXPECTED(2).') + IF(TEXT12.EQ.'DIFF') THEN + ITYPE=1 + ELSE IF(TEXT12.EQ.'NTOT1') THEN + ITYPE=2 + ELSE + CALL XABORT('DLEAK: INVALID TYPE OF CROSS SECTION.') + ENDIF + ELSE IF(TEXT12.EQ.'DELTA') THEN +* READ THE TYPE OF DELTA. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DLEAK: CHARACTER DATA EXPECTED(3).') + IF(TEXT12.EQ.'VALUE') THEN + IDELTA=1 + ELSE IF(TEXT12.EQ.'FACTOR') THEN + IDELTA=2 + ELSE + CALL XABORT('DLEAK: INVALID DELTA TYPE.') + ENDIF + ELSE IF(TEXT12.EQ.'MIXMIN') THEN +* READ THE MINIMUM MIXTURE INDEX. + CALL REDGET(INDIC,IBM1,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DLEAK: INTEGER DATA EXPECTED(2).') + IF((IBM1.LE.0).OR.(IBM1.GT.NMIX)) CALL XABORT('DLEAK: INVALID ' + 1 //'VALUE OF MIXMIN.') + ELSE IF(TEXT12.EQ.'MIXMAX') THEN +* READ THE MAXIMUM MIXTURE INDEX. + CALL REDGET(INDIC,IBM2,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DLEAK: INTEGER DATA EXPECTED(3).') + IF((IBM2.LT.IBM1).OR.(IBM2.GT.NMIX)) CALL XABORT('DLEAK: INVAL' + 1 //'ID VALUE OF MIXMAX.') + ELSE IF(TEXT12.EQ.'GRPMIN') THEN +* READ THE MINIMUM GROUP INDEX. + CALL REDGET(INDIC,NGR1,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DLEAK: INTEGER DATA EXPECTED(4).') + IF((NGR1.LE.0).OR.(NGR1.GT.NGRP)) CALL XABORT('DLEAK: INVALID ' + 1 //'VALUE OF GRPMIN.') + ELSE IF(TEXT12.EQ.'GRPMAX') THEN +* READ THE MAXIMUM GROUP INDEX. + CALL REDGET(INDIC,NGR2,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DLEAK: INTEGER DATA EXPECTED(5).') + IF((NGR2.LT.NGR1).OR.(NGR2.GT.NGRP)) CALL XABORT('DLEAK: INVAL' + 1 //'ID VALUE OF GRPMAX.') + ELSE IF(TEXT12.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('DLEAK: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 + 30 IF(ITYPE.EQ.0) CALL XABORT('DLEAK: LEAKAGE TYPE NOT SET.') + IF(IDELTA.EQ.0) CALL XABORT('DLEAK: DELTA TYPE NOT SET.') + IF(IBM2.LT.IBM1) CALL XABORT('DLEAK: INVALID MIXTURE INDICES.') + IF(NGR2.LT.NGR1) CALL XABORT('DLEAK: INVALID GROUP INDICES.') + IF((ITYPE.EQ.1).AND.(ILEAK.EQ.0)) CALL XABORT('DLEAK: NO LEAKAGE' + 1 //' ON INPUT MACROLIB.') + NPERT=(IBM2-IBM1+1)*(NGR2-NGR1+1) + IF(IMPX.GT.0) WRITE(6,'(/36H DLEAK: NUMBER OF CROSS-SECTION PERT, + 1 10HURBATIONS=,I5)') NPERT +*---- +* SET THE PERTURBED MACROLIB +*---- + ALLOCATE(VARV(NPERT),WEI(NPERT)) + JPNEW=LCMLID(IPNEW,'STEP',NPERT) + JPOLD=LCMGID(IPOLD,'GROUP') + IPERT=0 + ALLOCATE(IJJ(NMIX),NJJ(NMIX),GAR(NMIX),PER(NMIX)) + DO 52 IGRP=NGR1,NGR2 + DO 51 IBMP=IBM1,IBM2 + IPERT=IPERT+1 + KPNEW=LCMDIL(JPNEW,IPERT) + LPNEW=LCMLID(KPNEW,'GROUP',NGRP) + DO 50 IGR=1,NGRP + MPNEW=LCMDIL(LPNEW,IGR) + KPOLD=LCMGIL(JPOLD,IGR) + GAR(:NMIX)=0.0 + NJJ(:NMIX)=1 + DO 40 IMIX=1,NMIX + IJJ(IMIX)=IGR + 40 CONTINUE + CALL LCMPUT(MPNEW,'NTOT0',NMIX,2,GAR) + CALL LCMPUT(MPNEW,'SIGS00',NMIX,2,GAR) + CALL LCMPUT(MPNEW,'SIGW00',NMIX,2,GAR) + CALL LCMPUT(MPNEW,'SCAT00',NMIX,2,GAR) + CALL LCMPUT(MPNEW,'NJJS00',NMIX,1,NJJ) + CALL LCMPUT(MPNEW,'IJJS00',NMIX,1,IJJ) + CALL LCMPUT(MPNEW,'IPOS00',NMIX,1,NJJ) + PER(:NMIX)=0.0 + IF((IDELTA.EQ.1).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.1)) THEN + IF(IGR.EQ.IGRP) PER(IBMP)=1.0 + CALL LCMPUT(MPNEW,'DIFF',NMIX,2,PER) + CALL LCMGET(KPOLD,'DIFF',GAR) + IF(IGR.EQ.IGRP) VARV(IPERT)=GAR(IBMP) + ELSE IF((IDELTA.EQ.1).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.2)) THEN + IF(IGR.EQ.IGRP) PER(IBMP)=1.0 + CALL LCMPUT(MPNEW,'DIFFX',NMIX,2,PER) + CALL LCMPUT(MPNEW,'DIFFY',NMIX,2,PER) + CALL LCMPUT(MPNEW,'DIFFZ',NMIX,2,PER) + CALL LCMGET(KPOLD,'DIFFX',GAR) + IF(IGR.EQ.IGRP) VARV(IPERT)=GAR(IBMP) + ELSE IF((IDELTA.EQ.1).AND.(ITYPE.EQ.2)) THEN + IF(IGR.EQ.IGRP) PER(IBMP)=1.0 + CALL LCMPUT(MPNEW,'NTOT1',NMIX,2,PER) + CALL LCMLEN(KPOLD,'NTOT1',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPOLD,'NTOT1',GAR) + ELSE + CALL LCMGET(KPOLD,'NTOT0',GAR) + ENDIF + IF(IGR.EQ.IGRP) VARV(IPERT)=GAR(IBMP) + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.1)) THEN + CALL LCMGET(KPOLD,'DIFF',GAR) + IF(IGR.EQ.IGRP) PER(IBMP)=GAR(IBMP) + CALL LCMPUT(MPNEW,'DIFF',NMIX,2,PER) + IF(IGR.EQ.IGRP) VARV(IPERT)=1.0D0 + IF(IGR.EQ.IGRP) WEI(IPERT)=GAR(IBMP)**2 + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.1).AND.(ILEAK.EQ.2)) THEN + CALL LCMGET(KPOLD,'DIFFX',GAR) + IF(IGR.EQ.IGRP) PER(IBMP)=GAR(IBMP) + CALL LCMPUT(MPNEW,'DIFFX',NMIX,2,PER) + CALL LCMPUT(MPNEW,'DIFFY',NMIX,2,PER) + CALL LCMPUT(MPNEW,'DIFFZ',NMIX,2,PER) + IF(IGR.EQ.IGRP) VARV(IPERT)=1.0D0 + IF(IGR.EQ.IGRP) WEI(IPERT)=GAR(IBMP)**2 + ELSE IF((IDELTA.EQ.2).AND.(ITYPE.EQ.2)) THEN + CALL LCMLEN(KPOLD,'NTOT1',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPOLD,'NTOT1',GAR) + ELSE + CALL LCMGET(KPOLD,'NTOT0',GAR) + ENDIF + IF(IGR.EQ.IGRP) PER(IBMP)=GAR(IBMP) + CALL LCMPUT(MPNEW,'NTOT1',NMIX,2,PER) + IF(IGR.EQ.IGRP) VARV(IPERT)=1.0D0 + IF(IGR.EQ.IGRP) WEI(IPERT)=GAR(IBMP)**2 + ENDIF + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + DEALLOCATE(PER,GAR,NJJ,IJJ) +*---- +* SET THE PERTURBED MACROLIB STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NMIX + ISTATE(3)=1 + ISTATE(9)=ILEAK + ISTATE(11)=NPERT + CALL LCMPUT(IPNEW,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IMPX.GT.1) CALL LCMLIB(IPNEW) +*---- +* PUT OPTIMIZE OBJECT INFORMATION +*---- + CALL LCMPUT(IPOPT,'VAR-VALUE',NPERT,4,VARV) + IF(IDELTA.EQ.2) CALL LCMPUT(IPOPT,'VAR-WEIGHT',NPERT,4,WEI) + DEALLOCATE(WEI,VARV) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NMIX + ISTATE(3)=ITYPE + ISTATE(4)=IDELTA + ISTATE(5)=NGR1 + ISTATE(6)=NGR2 + ISTATE(7)=IBM1 + ISTATE(8)=IBM2 + IF(IMPX.GT.0) WRITE(6,100) (ISTATE(I),I=1,8) + CALL LCMPUT(IPOPT,'DEL-STATE',NSTATE,1,ISTATE) + ISTATE(:NSTATE)=0 + ISTATE(1)=NPERT + ISTATE(2)=0 + ISTATE(3)=1 + ISTATE(4)=0 + ISTATE(5)=0 + ISTATE(6)=2 + ISTATE(9)=2 + ISTATE(10)=0 + CALL LCMPUT(IPOPT,'STATE-VECTOR',NSTATE,1,ISTATE) + OPTPRR(:NSTATE)=0.0D0 + OPTPRR(1)=1.0 + OPTPRR(2)=0.1 + OPTPRR(3)=1.0E-4 + OPTPRR(4)=1.0E-4 + OPTPRR(5)=1.0E-4 + CALL LCMPUT(IPOPT,'OPT-PARAM-R',NSTATE,4,OPTPRR) + RETURN +* + 100 FORMAT(/18H DEL-STATE OPTIONS/18H -----------------/ + 1 7H NGRP ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 2 7H NMIX ,I8,32H (NUMBER OF MATERIAL MIXTURES)/ + 3 7H ITYPE ,I8,29H (=1/2: USE DIFF/USE NTOT1)/ + 4 7H IDELTA,I8,31H (=1/2: USE VALUE/USE FACTOR)/ + 5 7H NGR1 ,I8,24H (MINIMUM GROUP INDEX)/ + 6 7H NGR2 ,I8,24H (MAXIMUM GROUP INDEX)/ + 7 7H IBM1 ,I8,26H (MINIMUM MIXTURE INDEX)/ + 8 7H IBM2 ,I8,26H (MAXIMUM MIXTURE INDEX)) + END -- cgit v1.2.3