Initial commit from Polytechnique Montreal

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