summaryrefslogtreecommitdiff
path: root/Donjon/src/D2PMIC.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/D2PMIC.f')
-rw-r--r--Donjon/src/D2PMIC.f279
1 files changed, 279 insertions, 0 deletions
diff --git a/Donjon/src/D2PMIC.f b/Donjon/src/D2PMIC.f
new file mode 100644
index 0000000..c1f2a1d
--- /dev/null
+++ b/Donjon/src/D2PMIC.f
@@ -0,0 +1,279 @@
+*DECK D2PMIC
+ SUBROUTINE D2PMIC( IPDAT, IPMIC , IPRINT, NGP, NBMIX, NBISO,
+ > NED, NVAR, STAIDX, LXES, LDET, LCOR,
+ > FLUX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover microscopic cross sections from a microlib object and write
+* cross sections for one branch at a fixed burnup point in the INFO
+* data block
+*
+*Author(s):
+* J. Taforeau
+*
+*Parameters: input
+* IPDAT address of info data block
+* IPMIC address of the microlib object
+* NBMIX number of mixturess
+* NBISO number of isotopes
+* NED number of P0 additional XS
+* NGP number of energy groups
+* NVAR number of state variables
+* STAIDX table of states index order
+*
+*Parameters:
+* IPRINT
+* NGP
+* LXES
+* LDET
+* LCOR
+* FLUX
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPDAT,IPMIC
+ INTEGER NBMIX,NBISO,NED,NGP,NVAR
+ INTEGER STAIDX(NVAR)
+ REAL FLUX(NGP)
+ LOGICAL LDET,LXES,LCOR
+*----
+* LOCAL VARIABLES
+*----
+ TYPE(C_PTR) IPTH,KPTH,JPMIC
+ INTEGER :: iXE = 0
+ INTEGER :: iSM = 0
+ INTEGER :: IMR = 0
+ INTEGER :: iDT = 0
+ INTEGER ,DIMENSION(5) :: iCHAIN = 0
+ INTEGER :: DEB = -999
+ REAL XEND,SMND,MRND
+ REAL XSECT(NGP),XENG(NGP),SMNG(NGP),SCAT(NGP),DET(NGP)
+ REAL NFTOT(NGP),N2N(NGP)
+ REAL :: NUM = 0.
+ REAL :: DENO = 0.
+ REAL DEN(NBISO)
+ REAL NGXS(5,NGP),RPHI,YLDPM
+ CHARACTER(LEN=12) HUSE(NBISO),ISOTNAME(NBISO)
+ CHARACTER*8 XSNAM(12)
+ ! RECOVER ONLY EIGHT FIRST CHARACTER OF ISOTOPES
+ CHARACTER(LEN=8) ISOTOPES(2),HDET,SMCHAIN(5)
+
+ CALL LCMSIX (IPDAT,' ',0)
+ CALL LCMSIX (IPDAT,'SAPHYB_INFO',1)
+ CALL LCMSIX (IPDAT,'ISOTOPES',1)
+ CALL LCMGTC (IPDAT,'XE135',12,ISOTOPES(1))
+ CALL LCMGTC (IPDAT,'SM149',12,ISOTOPES(2))
+ CALL LCMGTC (IPDAT,'PM148',12,SMCHAIN(1))
+ CALL LCMGTC (IPDAT,'PM148M',12,SMCHAIN(2))
+ CALL LCMGTC (IPDAT,'PM149',12,SMCHAIN(3))
+ CALL LCMGTC (IPDAT,'PM147',12,SMCHAIN(4))
+ CALL LCMGTC (IPDAT,'ND147',12,SMCHAIN(5))
+ IF (LDET) CALL LCMGTC (IPDAT,'DET',12,HDET)
+
+ IF(NBMIX.NE.1) THEN
+ CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
+ ENDIF
+ IF(NED.GT.12) THEN
+ CALL XABORT('@D2P: MORE THAN 12 ADDITIONAL ISOTOPES')
+ ENDIF
+
+ CALL LCMSIX(IPMIC,' ',0)
+ CALL LCMGET(IPMIC,'ISOTOPESDENS',DEN)
+ CALL LCMGTC(IPMIC,'ISOTOPESUSED',12,NBISO,HUSE)
+ CALL LCMGTC(IPMIC,'ISOTOPERNAME',12,NBISO,ISOTNAME)
+ CALL LCMGTC(IPMIC,'ADDXSNAME-P0',8,NED,XSNAM)
+
+ DO I=1,NBISO
+ IF(INDEX(HUSE(I),ISOTOPES(1))>0) iXE=I
+ IF(INDEX(HUSE(I),ISOTOPES(2))>0) iSM=I
+ IF(INDEX(HUSE(I),'*MAC*RES')>0) iMR=I
+ IF (INDEX(HUSE(I),SMCHAIN(1))>0) iCHAIN(1)=I
+ IF (INDEX(HUSE(I),SMCHAIN(2))>0) iCHAIN(2)=I
+ IF (INDEX(HUSE(I),SMCHAIN(3))>0) iCHAIN(3)=I
+ IF (INDEX(HUSE(I),SMCHAIN(4))>0) iCHAIN(4)=I
+ IF (INDEX(HUSE(I),SMCHAIN(5))>0) iCHAIN(5)=I
+ IF (LDET) THEN
+ IF(INDEX(HUSE(I),HDET)>0) iDT=I
+ ENDIF
+ ENDDO
+
+ IF (LXES) THEN
+ ! CHECK THE EXISTENCE OF XE AND SM ISOTOPES
+
+ IF(iXE==0) THEN
+ CALL XABORT('@D2PMIC: XE MUST BE A PARTICULARIZED ISOTOPE')
+ ELSE IF(iSM==0) THEN
+ CALL XABORT('@D2PMIC: SM MUST BE A PARTICULARIZED ISOTOPE')
+ ENDIF
+ XEND=DEN(iXE)
+ SMND=DEN(iSM)
+ MRND=DEN(iMR)
+ CALL LCMSIX(IPMIC,' ',0)
+ ! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR XE
+ JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
+ IPMIC=LCMGIL(JPMIC,iXE)
+
+ CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
+
+ IF(ILONG.NE.NGP) THEN
+ CALL XABORT('@D2PMIC: INCONSISTENT NUMBERS OF ENERGY GROUP')
+ ENDIF
+ ! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF XE
+ CALL LCMGET(IPMIC,'NTOT0',XSECT)
+ CALL LCMGET(IPMIC,'SIGS00',SCAT)
+ DO I=1, NGP
+ XENG(I)=(XSECT(I)-SCAT(I))
+ IF (XENG(I)<0) THEN
+ XENG(I)= 0.
+ WRITE(6,*) '@D2PMIC: WARNING : XE NEGATIVE CROSS SECTION',
+ > '=> ZERO CROSS SECTION ASSUMED'
+ ENDIF
+ ENDDO
+
+ ! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR SM
+ CALL LCMSIX(IPMIC,' ',0)
+ JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
+ IPMIC=LCMGIL(JPMIC,iSM)
+ CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
+ IF(ILONG.NE.NGP) THEN
+ CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
+ ENDIF
+ XSECT(:NGP)=0.0
+ SCAT(:NGP)=0.0
+
+ ! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF SM
+ CALL LCMGET(IPMIC,'NTOT0',XSECT)
+ CALL LCMGET(IPMIC,'SIGS00',SCAT)
+ DO I=1, NGP
+ SMNG(I)=(XSECT(I)-SCAT(I))
+ IF (SMNG(I)<0) THEN
+ SMNG(I)= 0.
+ WRITE(6,*) '@D2PMIC: WARNING : SM NEGATIVE CROSS SECTION',
+ > '=> ZERO CROSS SECTION ASSUMED'
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (LCOR.OR.LXES) THEN
+ ! RECOVER FISSION CROSS SECTION OF MACROSCOPIC RESIDUAL
+ CALL LCMSIX(IPMIC,' ',0)
+ JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
+ IPMIC=LCMGIL(JPMIC,iMR)
+ CALL LCMLEN(IPMIC,'NFTOT',ILONG,ITYLCM)
+ CALL LCMGET(IPMIC,'N2N',N2N)
+ IF(ILONG.NE.NGP) THEN
+ CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
+ ENDIF
+
+ NFTOT(:NGP)=0
+ CALL LCMGET(IPMIC,'NFTOT',NFTOT)
+
+ NFTOT(:)=NFTOT(:)*MRND
+ CALL LCMSIX(IPMIC,' ',0)
+ ENDIF
+
+ IF (LCOR) THEN
+ RPHI=FLUX(1)/FLUX(2)
+ DO I=1,4
+ JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
+ IPMIC=LCMGIL(JPMIC,iCHAIN(I))
+ CALL LCMGET(IPMIC,'NG',NGXS(I,:))
+ CALL LCMSIX(IPMIC,' ',0)
+ ENDDO
+ NUM=0.
+ DO I=1,2
+ NUM=NUM+DEN(iCHAIN(I))*(NGXS(I,1)*RPHI+NGXS(I,2))
+ ENDDO
+ DENO=NFTOT(1)*RPHI+NFTOT(2)
+
+ CALL LCMSIX(IPDAT,' ',0)
+ CALL LCMSIX(IPDAT,'GENPMAXS_INP',1)
+ CALL LCMGET(IPDAT,'FLAG',DEB)
+ CALL LCMSIX(IPDAT,' ',0)
+ IPTH=LCMGID(IPDAT,'TH_DATA')
+ KPTH=LCMDIL(IPTH,STAIDX(NVAR))
+ CALL LCMGET(KPTH,'YLDPm',YLDPM)
+ DENO=DENO*YLDPM
+ YLDPM=YLDPM*(1+(NUM/DENO))
+ IF (DEB.EQ.-999) THEN
+ CALL XABORT ("@D2PMIC : PROBLEM IN YIELD CORRECTION")
+ ELSE IF (DEB<0) THEN
+ CALL LCMPUT(KPTH,'YLDPm',1,2,YLDPM)
+ ENDIF
+
+ ENDIF
+
+
+ IF (LDET) THEN
+ IF(iDT==0) THEN
+ WRITE(6,*) '@D2PMIC: UNKNOWN ISOTOPE (',HDET,') FOR DETECTOR',
+ > ' CROSS SECTIONS'
+ CALL XABORT ('=> PLEASE USE THE DET CARD IN D2P:')
+ ENDIF
+ CALL LCMSIX(IPMIC,' ',0)
+
+ JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
+ IPMIC=LCMGIL(JPMIC,iDT)
+ CALL LCMLEN(IPMIC,'NFTOT',ILONG,ITYLCM)
+ PRINT*,'ICI'
+ IF(ILONG.NE.NGP) THEN
+ CALL XABORT('@D2PMIC: INCONSISTENT NUMBERS OF ENERGY GROUP')
+ ENDIF
+ ! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF XE
+ CALL LCMGET(IPMIC,'NFTOT',DET)
+ CALL LCMSIX(IPMIC,' ',0)
+ ENDIF
+
+ CALL LCMSIX(IPDAT,' ',0)
+ CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
+ IPTH=LCMGID(IPDAT,'CROSS_SECT')
+ KPTH=LCMDIL(IPTH,STAIDX(NVAR))
+
+
+ CALL LCMSIX(KPTH,'MACROLIB_XS',1)
+ IF (LXES) CALL LCMPUT(KPTH,'SFI',NGP,2,NFTOT)
+ CALL LCMSIX(KPTH,' ',2)
+ CALL LCMSIX(KPTH,'MICROLIB_XS',1)
+ IF (LXES) THEN
+ CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
+ CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)
+ CALL LCMPUT(KPTH,'XEND',1,2,XEND)
+ CALL LCMPUT(KPTH,'SMND',1,2,SMND)
+ ENDIF
+ IF (LDET) CALL LCMPUT(KPTH,'DET',NGP,2,DET)
+ CALL LCMSIX(KPTH,' ',0)
+
+
+
+ IF(IPRINT > 1) THEN
+ WRITE(6,*)
+ WRITE(6,*) "**************************************************"
+ WRITE(6,*) "* SUMMARY *"
+ WRITE(6,*) "**************************************************"
+ WRITE(6,*)
+ WRITE(6,*) "**** MICROSCOPIC cross sections ****"
+ IF (LDET) THEN
+ WRITE(6,*) "DETECTOR :",DET
+ ENDIF
+ IF (LXES) THEN
+ WRITE(6,*) "XENON ABSORPTION :",XENG
+ WRITE(6,*) "SAMARIUM ABSORPTION :",SMNG
+ WRITE(6,*) "XENON NUMBER DENSITY :",XEND
+ WRITE(6,*) "SAMARIUM NUMBER DENSITY :",SMND
+ WRITE(6,*)
+ WRITE(6,*) "**** MACROSCOPIC cross sections(1:NGP) ****"
+ WRITE(6,*) "FISSION :",NFTOT
+ WRITE(6,*) "MAC*RES* NUMBER DENSITY :",MRND
+ ENDIF
+
+ IF (LCOR) THEN
+ WRITE(6,*) "PM149 FISSION YIELD CORRECTED:",YLDPM
+ ENDIF
+ ENDIF
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 16:55:22 +0000