summaryrefslogtreecommitdiff
path: root/Donjon/src/D2PRFL.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/D2PRFL.f')
-rw-r--r--Donjon/src/D2PRFL.f262
1 files changed, 262 insertions, 0 deletions
diff --git a/Donjon/src/D2PRFL.f b/Donjon/src/D2PRFL.f
new file mode 100644
index 0000000..d9d6429
--- /dev/null
+++ b/Donjon/src/D2PRFL.f
@@ -0,0 +1,262 @@
+*DECK D2PRFL
+ SUBROUTINE D2PRFL( IPDAT, IPMIC , IPRINT, NBU, NGP, NBMIX,
+ > NANI, NVAR, STAIDX, LADF, NADF, NTYPE)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover macroscopic and microscopic cross sections from a microlib
+* object and write cross sections for one branch at a fixed burnup point
+* in the INFO data block.
+* WARNING: 04/2014 The information recovered by this routine is exactly
+* the same than GET_MACROLIB_XS but is used for reflector case, in this
+* case the following reactions are set to zero :
+* DET(IGR) = 0
+* SFI(IGR) = 0
+* KAPPA_FI(IGR)= 0
+* FLUX(IGR) = 0
+* VELINV(IGR) = 0
+* CHI_SPEC(IGR) = 0
+* X_NU_FI(IGR) = 0
+* KAPPA_FI(IGR) = 0
+* XENG(IGR)=0
+* SMNG(IGR)=0
+* NB : for reflector case, the upscattering is fixed to zero
+*
+*Author(s):
+* J. Taforeau
+*
+*Parameters: input
+* IPDAT address of info data block
+* IPMIC address of the microlib object
+* NBU number of burnup points
+* NBMIX number of mixturess
+* NGP number of energy groups
+* NANI number of anisotropy
+* NVAR number of state variables
+* STAIDX table of states index order
+* NADF number of ADF to be recovered
+* NTYPE number of adf type
+* LADF flag for adf
+*
+*Parameters:
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPDAT,IPMIC
+ INTEGER STAIDX(NVAR)
+ INTEGER NBU,NVAR,NBMIX,NGP,NANI,NADF,NTYPE
+ LOGICAL LADF
+*----
+* LOCAL VARIABLES
+*----
+ TYPE(C_PTR) JPMIC,KPMIC,IPTH,KPTH
+ INTEGER NSCAT,MIX
+ INTEGER IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)
+ REAL GAR2(NGP,NGP,NBMIX,NANI),GAR3(NBMIX*NGP)
+ REAL XSECT(NGP,NBMIX) ! TOTAL CROSS SECTIONS
+ REAL KAPPA_FI(NGP) ! KAPPA FISSION CROSS SECTIONS
+ REAL X_NU_FI(NGP) ! NU SIGMA FISSION CROSS SECTIONS
+ REAL XTR(NGP) ! TRANSPORT CROSS SECTIONS
+ REAL DIFF(NGP,NBMIX) ! DIFFUSION COEFF
+ REAL SCAT(NGP,NBMIX) ! SCATTERING CROSS SECTIONS
+ REAL DET(NGP) ! DETECTOR CROSS SECTIONS
+ REAL SFI(NGP) ! FISSION CROSS SECTIONS
+ REAL ABSORPTION(NGP) ! ABSORPTION CROSS SECTIONS
+ REAL SCAT_MAT(NGP*NGP) ! SCATTERING MATRIX
+ REAL SCAT_TMP(NGP,NGP,NBMIX,NANI) ! TEMPORARY SCATTERING MATRIX
+ REAL FLUX(NGP)
+ REAL VELINV(NGP)
+ REAL XENG(NGP)
+ REAL CHI_SPEC(NGP),VOLUME(NBMIX)
+ REAL SMNG(NGP),FLXHET(NGP*NBMIX),FLXHOM(NGP,NBMIX)
+ REAL FLXL(NGP),FLXR(NGP),CURL(NGP),CURR(NGP)
+ REAL ADF(NADF,NGP)
+ CHARACTER CM*2,ADF_T*3
+ CHARACTER*8 ADFD(NADF),HADF(NTYPE),HFLX(2),HCUR(2)
+ IF(IPRINT > 0) THEN
+ WRITE(6,*)
+ WRITE(6,*) "****** RECOVER REFLECTOR CROSS SECTIONS ******"
+ ENDIF
+ CALL LCMSIX(IPDAT,' ',0)
+ CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
+ IF(LADF) THEN
+ ADF_T=" "
+ CALL LCMGTC(IPDAT,'ADF_TYPE',3,ADF_T)
+ IF ((ADF_T.NE.'DRA').AND.(ADF_T.NE.'GEN')) THEN
+ WRITE(6,*)'@D2PRFL:',ADF_T,'ADF NOT SUPPORTED ',
+ > 'WITH REFL CALCULATION'
+ CALL XABORT('')
+ ENDIF
+ IF ((ADF_T.EQ.'DRA')) THEN
+ CALL LCMGTC(IPDAT,'HADF',8,NADF,ADFD)
+ ELSE IF ((ADF_T.EQ.'GEN')) THEN
+ CALL LCMGTC(IPDAT,'HFLX',8,2,HFLX)
+ CALL LCMGTC(IPDAT,'HCUR',8,2,HCUR)
+ ENDIF
+
+ ENDIF
+
+ CALL LCMGET(IPDAT,'MIX',MIX)
+ CALL LCMSIX(IPDAT,' ',0)
+ CALL LCMSIX(IPMIC,' ',0)
+ CALL LCMSIX(IPMIC,'MACROLIB',1)
+ CALL LCMGET(IPMIC,'VOLUME',VOLUME)
+
+ IF (LADF) THEN
+ CALL LCMSIX(IPMIC,'ADF',1)
+ CALL LCMGTC(IPMIC,'HADF',8,NTYPE,HADF)
+ ITYPE=1
+ IF ((ADF_T.EQ.'DRA')) THEN
+ DO ITYPE=1,NTYPE
+ CALL LCMGET(IPMIC,HADF(ITYPE),FLXHET)
+ DO I=1,NADF
+ IF(HADF(ITYPE).EQ.ADFD(I))THEN
+ DO IGR=1, NGP
+ ADF(I,IGR)= FLXHET((IGR-1)*NBMIX+MIX)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE IF ((ADF_T.EQ.'GEN')) THEN
+ DO ITYPE=1,NTYPE
+ CALL LCMGET(IPMIC,HADF(ITYPE),FLXHET)
+ IF(HADF(ITYPE).EQ.HFLX(1))THEN
+ FLXL(:)=FLXHET
+ ENDIF
+ IF (HADF(ITYPE).EQ.HFLX(2))THEN
+ FLXR(:)=FLXHET
+ ENDIF
+ IF (HADF(ITYPE).EQ.HCUR(1))THEN
+ CURL(:)=FLXHET
+ ENDIF
+ IF (HADF(ITYPE).EQ.HCUR(2))THEN
+ CURR(:)=FLXHET
+ ENDIF
+ ENDDO
+ ENDIF
+ CALL LCMSIX(IPMIC,'',2)
+
+ ENDIF
+
+ JPMIC=LCMGID(IPMIC,'GROUP')
+
+ ! RECOVER CROSS SECTIONS INFORMATION
+ DO IGR=1,NGP
+ WRITE(6,'(/28H PROCESS ENERGY GROUP NUMBER,I4)') IGR
+ KPMIC=LCMGIL(JPMIC,IGR)
+ CALL LCMLEN(KPMIC,'NTOT0',ILONG,ITYLCM)
+
+ IF(ILONG.NE.NBMIX) THEN
+ CALL XABORT('D2P: MORE THAN ONE MIXTURE IN SAPHYB')
+ ENDIF
+ CALL LCMGET(KPMIC,'FLUX-INTG',FLXHOM(IGR,1:NBMIX))
+ CALL LCMGET(KPMIC,'NTOT0',XSECT(IGR,1:NBMIX))
+ CALL LCMGET(KPMIC,'SIGS00',SCAT(IGR,1:NBMIX))
+ CALL LCMGET(KPMIC,'DIFF',DIFF(IGR,1:NBMIX))
+ ABSORPTION(IGR)=XSECT(IGR,MIX)-SCAT(IGR,MIX)
+ IF (LADF) ADF(:,IGR)= VOLUME * ADF(:,IGR) / FLXHOM(IGR,MIX)
+ DET(IGR) = 0
+ SFI(IGR) = 0
+ KAPPA_FI(IGR)= 0
+ FLUX(IGR) = 0
+ VELINV(IGR) = 0
+ CHI_SPEC(IGR) = 0
+ X_NU_FI(IGR) = 0
+ KAPPA_FI(IGR) = 0
+ XENG(IGR)=0
+ SMNG(IGR)=0
+ XTR(IGR)=1/(3*DIFF(IGR,MIX))
+
+ GAR2(:NGP,:NGP,:NBMIX,:NANI)=0.0
+ DO IL=1,NANI
+ WRITE(CM,'(I2.2)') IL-1
+ LENGTH=1
+ IF(IL.GT.1) CALL LCMLEN(KPMIC,'SCAT'//CM,LENGTH,ITYLCM)
+ IF(LENGTH.GT.0) THEN
+ CALL LCMGET(KPMIC,'SCAT'//CM,GAR3)
+ CALL LCMGET(KPMIC,'NJJS'//CM,NJJ)
+ CALL LCMGET(KPMIC,'IJJS'//CM,IJJ)
+ CALL LCMGET(KPMIC,'IPOS'//CM,IPOS)
+ DO IMIL=1,NBMIX
+ IPOSDE=IPOS(IMIL)
+ DO JGR=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1
+ GAR2(IGR,JGR,IMIL,IL)=GAR3(IPOSDE) ! IGR <-- JGR
+ SCAT_TMP(IGR,JGR,IMIL,IL)=GAR2(IGR,JGR,IMIL,IL)
+ IPOSDE=IPOSDE+1
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+ NSCAT=1
+ DO J=1, NGP
+ DO I=1, NGP
+ SCAT_MAT(NSCAT)=SCAT_TMP(I,J,MIX,1) ! I <-- J
+ IF(NSCAT==3) SCAT_MAT(NSCAT)=0
+ NSCAT=NSCAT+1
+ ENDDO
+ ENDDO
+
+ CALL LCMSIX(IPDAT,' ',0)
+ CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
+ IF(STAIDX(NVAR)==1) THEN
+ IPTH=LCMLID(IPDAT,'CROSS_SECT',NBU)
+ ELSE
+ IPTH=LCMGID(IPDAT,'CROSS_SECT')
+ ENDIF
+
+ KPTH=LCMDIL(IPTH,STAIDX(NVAR))
+ CALL LCMSIX(KPTH,'MICROLIB_XS',1)
+
+ CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
+ CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)
+
+ CALL LCMSIX(KPTH,' ',2)
+ CALL LCMSIX(KPTH,'MACROLIB_XS',1)
+
+ CALL LCMPUT(KPTH,'XTR',NGP,2,XTR)
+ CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
+ CALL LCMPUT(KPTH,'X_NU_FI',NGP,2,X_NU_FI)
+ CALL LCMPUT(KPTH,'KAPPA_FI',NGP,2,KAPPA_FI)
+ CALL LCMPUT(KPTH,'SFI',NGP,2,SFI)
+ CALL LCMPUT(KPTH,'DET',NGP,2,DET)
+ CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)
+ IF (LADF) THEN
+ IF (ADF_T.EQ.'DRA') THEN
+ CALL LCMPUT(KPTH,'ADF',NADF*NGP,2,ADF)
+ ELSE IF (ADF_T.EQ.'GEN') THEN
+ CALL LCMPUT(KPTH,'FLXL',NGP,2,FLXL)
+ CALL LCMPUT(KPTH,'FLXR',NGP,2,FLXR)
+ CALL LCMPUT(KPTH,'CURL',NGP,2,CURL)
+ CALL LCMPUT(KPTH,'CURR',NGP,2,CURR)
+ ENDIF
+ ENDIF
+ IF(IPRINT>1) THEN
+ WRITE(6,*)
+ WRITE(6,*) "**** MACROSCOPIC cross sections (1:NGP) ****"
+ WRITE(6,*) "TOTALE :",XSECT(:,MIX)
+ WRITE(6,*) "DIFFUSION :",DIFF(:,MIX)
+ WRITE(6,*) "TRANSPORT :",XTR
+ WRITE(6,*) "ABSORPTION :",ABSORPTION
+ WRITE(6,*) "NU FISSION :",X_NU_FI
+ WRITE(6,*) "KAPPA FISSION :",KAPPA_FI
+ WRITE(6,*) "DETECTOR :",DET
+ WRITE(6,*) "SCATTERING (g to g') :",SCAT_MAT
+ IF (LADF) THEN
+ IF (ADF_T.EQ.'DRA') THEN
+ WRITE(6,*) "ADF([N/E/W/S]||[W/E]) :",ADF
+ ELSE IF (ADF_T.EQ.'GEN') THEN
+ WRITE(6,*) "WEST FLUX BOUNDARY :",FLXL
+ WRITE(6,*) "EST FLUX BOUNDARY :",FLXR
+ WRITE(6,*) "WEST CURRENT BOUNDARY :",CURL
+ WRITE(6,*) "EST CURRENT BOUNDARY :",CURR
+ ENDIF
+ ENDIF
+ ENDIF
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 20:50:18 +0000