summaryrefslogtreecommitdiff
path: root/Donjon/src/D2PXSA.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/D2PXSA.f')
-rw-r--r--Donjon/src/D2PXSA.f315
1 files changed, 315 insertions, 0 deletions
diff --git a/Donjon/src/D2PXSA.f b/Donjon/src/D2PXSA.f
new file mode 100644
index 0000000..316188c
--- /dev/null
+++ b/Donjon/src/D2PXSA.f
@@ -0,0 +1,315 @@
+*DECK D2PXSA
+ SUBROUTINE D2PXSA(IPDAT,IPSAP,ICAL,IPRINT,NGP,NREA,NISO,NMAC,
+ 1 NMIL,NANI,NVAR,NADRX,STAIDX,B2,ADF_T,NSF,LABS,SCAT,LADF)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover FISSION cross sections of an elementary calculation and store
+* in INFO/BRANCH_INFO/MACROLIB_XS/SFI.
+* WARNING: the GET_SFI_XS subroutine cannot recover FISSION XS in the
+* case where cross sections are ineterpolated by the SCR: module
+*
+*Author(s):
+* J. Taforeau
+*
+*Parameters: input
+* IPDAT address of the INFO data block
+* ICAL number of the elementary calculation in which fission cross
+* sections is to be recovered
+* IPSAP address of the Saphyb object
+* NGP number of group energies in Saphyb
+* NREA number of reactions in Saphyb
+* NISO number of isotopes in Saphyb
+* NMAC number of macros in Saphyb
+* NMIL number of mixtures in Saphyb
+* NANI number of Legendre orders in Saphyb
+* NADRX concerne cross section vector (ADRX)
+* STAIDX index of current branch state values
+* NSF number of elements of the tranfert matrix
+* LABS content of absorption xs LABS(1) : ABS XS = TOTAL - SIGS00 ;
+* LABS(2) abs xs recovered from sap ; LABS (3) abs xs recovered
+* from SAP minus excess xs
+
+*Parameters: output
+* SFI fission cross sections of the current BRANCH:
+* INFO/BRANCH_INFO/MACROLIB_XS/SFI
+*
+*Parameters:
+* IPRINT
+* NVAR
+* B2
+* ADF_T
+* SCAT
+* LADF
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPDAT,IPSAP
+ INTEGER ICAL,IPRINT,NGP,NREA,NISO,NMAC, NMIL,NANI,NVAR,
+ 1 STAIDX(NVAR),NSF,NADRX
+ REAL B2
+ CHARACTER*3 ADF_T
+ LOGICAL LABS(3),SCAT,LADF
+*----
+* LOCAL VARIABLES
+*----
+ TYPE(C_PTR) IPTH,KPTH
+ ! order numbers of current : reaction , isotope, macro
+ INTEGER iprf,isot,imil,imac,iabs,iexc,idif,itra
+ INTEGER idifc
+ INTEGER ani, il, nj, ii, it, i1,i2, j1, j2, iadc,g
+ INTEGER ND
+ ! location of excess cross sections in RDATAX
+ INTEGER ADR_EXC
+ ! location of absorption cross sections in RDATAX
+ INTEGER ADR_ABS
+ ! location of profil cross sections in RDATAX
+ INTEGER ADR_PRF
+ ! location of TRANSFERT cross sections in RDATAX
+ INTEGER ADR_TRA
+ INTEGER ADR_DIF
+ ! number of group energies in Saphyb
+ INTEGER NG
+ ! type of data recovered from GANLIB subroutines
+ INTEGER ITYLCM
+ ! name of : isotopes, macros
+ CHARACTER(LEN=8) NOM_MAC(NMAC)
+ ! name of reactions
+ CHARACTER(LEN=10) NOM_REA(NREA)
+ ! residual macro
+ INTEGER RESMAC(NMIL)
+ ! 3rd index of ADRX
+ INTEGER ISADRX(NMIL)
+ ! number of elements in RADATAX
+ INTEGER LENGDX(NMIL)
+ ! name of total macro
+ INTEGER TOTMAC(NMIL)
+ ! number of elements in IDATAP
+ INTEGER LENGDP(NMIL)
+ ! contains the adress of the 1st element in RDATAX
+ INTEGER ADRX (NREA+2,NISO+NMAC,NADRX)
+ REAL ABSORPTION(NGP)
+ REAL TRANSFERT (NANI,NGP*NGP)
+ REAL DIFC(NGP)
+ CHARACTER(LEN=12) CALDIR
+ INTEGER fagg, lagg,fdgg,wgal,fag,lag ! CF SAPHTOOL MANUAL
+ INTEGER fdg(NGP),adr(NGP+1) ! CF SAPHTOOL MANUAL
+ INTEGER NSCAT
+ REAL CURRN(NSF,NGP,2)
+ REAL SRFLX(NSF,NGP)
+ REAL ZAFLX(NMIL,NGP)
+ DOUBLE PRECISION RPAR (6,NSF)
+ INTEGER IPAR (3,NSF)
+ REAL ADF(NGP,NSF,10)
+ REAL SCAT_MAT(NGP*NGP)
+ ! transfert matrix
+ INTEGER ,ALLOCATABLE, DIMENSION(:) :: IDATAP
+ ! contains values of cross sections of an elementary calculation
+ REAL,ALLOCATABLE, DIMENSION(:) :: RDATAX
+
+ TRANSFERT(:,:) = 0
+
+ WRITE(CALDIR,'("calc", I8)') ICAL
+ CALL LCMSIX(IPSAP,' ',0)
+ CALL LCMSIX(IPSAP,'contenu',1)
+ IF(NMIL.NE.1) THEN
+ ! the number of mixtures must be equal to one for converting
+ ! Saphyb into PMAXS format
+ CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
+ ENDIF
+ CALL LCMGTC(IPSAP,'NOMREA',10,NREA,NOM_REA)
+ CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOM_MAC)
+ CALL LCMGET(IPSAP,'RESMAC',RESMAC)
+ CALL LCMGET(IPSAP,'TOTMAC',TOTMAC)
+ CALL LCMSIX(IPSAP,' ',0)
+
+ CALL LCMSIX(IPSAP,'adresses',1)
+ CALL LCMGET(IPSAP,'ADRX',ADRX)
+ CALL LCMSIX(IPSAP,' ',0)
+ CALL LCMSIX(IPSAP,CALDIR,1)
+ CALL LCMSIX(IPSAP,'info',1)
+ CALL LCMGET(IPSAP,'ISADRX',ISADRX)
+ CALL LCMGET(IPSAP,'LENGDX',LENGDX)
+ CALL LCMGET(IPSAP,'LENGDP',LENGDP)
+ ALLOCATE (RDATAX(LENGDX(1)),IDATAP(LENGDP(1)))
+ imac=0
+ IF(RESMAC(1).NE.0) THEN
+ imac=RESMAC(1) ! recover name of residual macro
+ ELSE IF(TOTMAC(1).NE.0) THEN
+ imac=TOTMAC(1) ! recover name of total macro
+ ELSE
+ CALL XABORT('@D2P: NO MACRO DEFINED')
+ ENDIF
+ isot=NISO+imac ! we interest in macro fission cross sections
+ imil=1 ! set the mixtures number to 1
+ iprf=0
+ iexc=0
+ iabs=0
+ idif=0
+ iadc=0
+ itra=0
+ idifc=0
+ !TEST HFATC
+ NSCAT=1
+
+ DO ir=1,NREA
+ ! store the order numbers of PROFIL matrix
+ IF((SCAT) .and. NOM_REA(ir)=="PROFIL") iprf=ir
+ IF((SCAT) .and. NOM_REA(ir)=="DIFFUSION") idif=ir
+ IF((SCAT) .and. NOM_REA(ir)=="TRANSFERT") itra=ir
+ IF(NOM_REA(ir)=="NU*FISSION") iabs=ir
+ ! store the order numbers of EXCESS matrix
+ IF(LABS(3).and. NOM_REA(ir)=="EXCESS") iexc=ir
+ IF((LADF) .and. NOM_REA(ir)=="FUITES") idifc=ir
+ ENDDO
+ IF(iabs==0) CALL XABORT ('@D2P: NO ABSORPTION XS AVAILABLE')
+ IF(LABS(3).and.iexc==0) THEN
+ CALL XABORT('@D2P: NO EXCESS XS AVAILABLE')
+ ENDIF
+ IF(SCAT .and. iprf==0) THEN
+ CALL XABORT('@D2P: NO PROFIL XS AVAILABLE')
+ ENDIF
+ IF(SCAT .and. idif==0) THEN
+ CALL XABORT('@D2P: NO DIFFUSION XS AVAILABLE')
+ ENDIF
+ IF(SCAT .and. itra==0) THEN
+ CALL XABORT('@D2P: NO TRANSFERT XS AVAILABLE')
+ ENDIF
+ IF((LADF) .and. idifc==0) THEN
+ CALL XABORT('@D2P: NO FUITES XS AVAILABLE')
+ ENDIF
+ NANI=ADRX(NREA+2,isot,ISADRX(imil))-1
+ ND=ADRX(NREA+1,isot,ISADRX(imil))
+ IF(MOD(idif,NREA+1).GT.0 .AND. ND.GE.1) THEN
+ iadc=ADRX(idif,isot,ISADRX(imil))+NGP
+ ENDIF
+ ! address in RDATAX of ABSORPTION XS
+ ADR_ABS=ADRX(iabs,isot,ISADRX(imil))
+
+
+ ! address in RDATAX of EXCESS XS
+ ADR_EXC=0
+ IF(LABS(3)) ADR_EXC=ADRX(iexc,isot,ISADRX(imil))
+ ! address in RDATAX of PROFIL XS
+ ADR_PRF=0
+ IF(SCAT) ADR_PRF=ADRX(iprf,isot,ISADRX(imil))
+ ! address in RDATAX of TRANSFERT XS
+ ADR_TRA=0
+ IF(SCAT) ADR_TRA=ADRX(itra,isot,ISADRX(imil))
+ ! address in RDATAX of FUITES XS
+ ADR_DIF=0
+ IF(LADF) ADR_DIF=ADRX(idifc,isot,ISADRX(imil))
+
+ ! moving in the saphyyb object to recover RDATAX information
+ CALL LCMSIX(IPSAP,' ',0)
+ CALL LCMSIX(IPSAP,CALDIR,1)
+ CALL LCMSIX(IPSAP,'mili 1',1)
+ CALL LCMGET(IPSAP,'RDATAX',RDATAX)
+ CALL LCMGET(IPSAP,'IDATAP',IDATAP)
+
+ ! LOOP over energy groups
+ DO ig=1, NGP
+ ABSORPTION(ig)=RDATAX(ADR_ABS+ig-1)
+ IF(LADF) DIFC(ig)=RDATAX(ADR_DIF+ig-1)
+ IF(LABS(3)) THEN
+ ABSORPTION(ig)=ABSORPTION(ig)-RDATAX(ADR_EXC+ig-1)
+ ENDIF
+ ENDDO
+
+
+ IF(SCAT)THEN ! recover the scattering XS from Saphyb
+ ii = ADR_PRF
+ nj = IDATAP(ii+6+2*NGP)-1
+
+ DO ani=0, NANI
+ il = ADR_TRA + (ani) * nj
+ fagg =IDATAP(ii)
+ lagg =IDATAP(ii+1)
+ fdgg =IDATAP(ii+2)
+ wgal =IDATAP(ii+3)
+ fag =IDATAP(ii+4)
+ lag =IDATAP(ii+5)
+ fdg =IDATAP(ii+6:ii+5+NGP)
+ adr =IDATAP(ii+6+NGP:ii+6+2*NGP)
+ IF(wgal.GT.0)THEN
+ it=il
+ DO g=fagg,lagg
+ i1=(g-1)*NGP+fdgg
+ i2=(g-1)*NGP+fdgg+wgal-1
+ TRANSFERT(ani+1,i1:i2)=RDATAX(it:it+wgal-1)
+ it=it+wgal
+ ENDDO
+ ENDIF
+ DO g=fag,lag
+ i1=(g-1)*NGP+fdg(g)
+ i2=(g-1)*NGP+fdg(g)+adr(g+1)-adr(g)-1
+ j1=il-1+adr(g)
+ j2=il-1+adr(g+1)-1
+ TRANSFERT(ani+1,i1:i2)=RDATAX(j1:j2)
+ ENDDO
+ ENDDO
+ IF(iadc.NE.0)THEN
+ NG=NGP
+! TRANSFERT(1,1:NG*NG:NG+1) =
+! > TRANSFERT(1,1:NG*NG:NG+1) - RDATAX(iadc:iadc+NGP-1)
+ ENDIF
+ ENDIF
+ DO g=1, NGP
+ DO ig=1, NGP
+ SCAT_MAT(NSCAT) = TRANSFERT(1,g+(ig-1)*NGP)
+ NSCAT=NSCAT+1
+ ENDDO
+ ENDDO
+
+ ! RECOVER ADF IN SAPHYB (IF AVAILABLE) (adapted from !
+ ! saphyb_browser of UPM)
+
+ IF(LADF) THEN
+ IF((ADF_T.EQ.'SEL').OR.(ADF_T.EQ.'GET')) THEN
+ CALL LCMSIX (IPSAP,' ',0)
+ CALL LCMSIX (IPSAP,'geom ',1)
+ CALL LCMSIX (IPSAP,'outgeom ',1)
+ CALL LCMLEN(IPSAP,'SURF',NSURF,ITYLCM)
+ IF(NSF.NE.NSURF) THEN
+ WRITE(6,*) "@D2P: ERROR IN NUMBER OF ASSEMBLY SURFACES"
+ WRITE(6,*) "THE NUMBER OF SURFACES IN SAP (",
+ 1 NSURF,") IF DIFFERENT FROM DRAG2PARCS INPUT (",NSF,")"
+ CALL XABORT('')
+ ENDIF
+
+ CALL LCMGET(IPSAP,'IPAR',IPAR)
+ CALL LCMGET(IPSAP,'RPAR',RPAR)
+
+ CALL LCMSIX(IPSAP,' ',0)
+ CALL LCMSIX(IPSAP,CALDIR,1)
+ CALL LCMSIX(IPSAP,'outflx ',1)
+
+ CALL LCMGET(IPSAP,'CURRM',CURRN(:,:,2))
+ CALL LCMGET(IPSAP,'CURRP',CURRN(:,:,1))
+ CALL LCMGET(IPSAP,'SURFLX',SRFLX(:,:))
+ CALL LCMGET(IPSAP,'REGFLX',ZAFLX(:,:))
+ ADF = 0.
+ DIFC(:)=DIFC(:)/B2
+
+ ! CALL to GET_SFI_XS to recover ADF
+ CALL D2PADF(IPDAT,IPRINT,NGP,NMIL, ADF, NSF, DIFC,CURRN,SRFLX,
+ 1 ZAFLX,RPAR,IPAR,ADF_T,STAIDX,NVAR)
+ ENDIF
+ ENDIF
+ ! STORE RESULTS IN INFO DATA BLOCK
+ 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(LABS(2)) CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
+ IF(SCAT) CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)
+ IF(LABS(2)) WRITE(6,*) "ABSORPTION EXCESS :", ABSORPTION
+ IF(SCAT) WRITE(6,*) "SCATTERING MATRIX :", SCAT_MAT
+ DEALLOCATE (RDATAX,IDATAP)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 14:54:49 +0000