summaryrefslogtreecommitdiff
path: root/Dragon/src/MACPXS.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/MACPXS.f')
-rw-r--r--Dragon/src/MACPXS.f258
1 files changed, 258 insertions, 0 deletions
diff --git a/Dragon/src/MACPXS.f b/Dragon/src/MACPXS.f
new file mode 100644
index 0000000..827689d
--- /dev/null
+++ b/Dragon/src/MACPXS.f
@@ -0,0 +1,258 @@
+*DECK MACPXS
+ SUBROUTINE MACPXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,
+ > ITRANC,LNEWXS,XSTOTL,XSTOT1,XSFISS,XSSPEC,
+ > XSFIXE,XSTRAN,XSDIFF,XSNFTO,XSH,XSSCAT,NEDMAC,
+ > ISCATA,XSNUDL,XSCHDL,XSDIFX,XSDIFY,XSDIFZ,
+ > XSOVRV,XSINT0,XSINT1)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transfer cross section information on the macrolib.
+*
+*Copyright:
+* Copyright (C) 2006 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): G. Marleau
+*
+*Parameters: input
+* IPLIST LCM pointer to the macrolib.
+* MAXFIS set to max(1,NIFISS).
+* NGROUP number of energy groups.
+* NBMIX maximum number of mixtures.
+* NIFISS number of fissile isotopes.
+* NANISO maximum Legendre order (=1 isotropic collision;
+* =2 linearly anisotropic collision).
+* NDELG number of precursor groups for delayed neutrons.
+* ITRANC transport correction option (=0 no correction; =1 Apollo-
+* type; =2 recover TRANC record; =4 leakage correction alone).
+* LNEWXS check change in cross sections.
+* XSTOTL P0 total cross section of mixture.
+* XSTOT1 P1 total cross section of mixture.
+* XSFISS nu*fission cross section of mixture.
+* XSSPEC fission spectrum.
+* XSFIXE fixe sources.
+* XSTRAN transport correction.
+* XSDIFF isotropic diffusion coefficient.
+* XSNFTO fission cross section of mixture.
+* XSH power factor.
+* XSSCAT scattering cross section of mixture/group.
+* NEDMAC number of macro edit cross sections.
+* XSNUDL delayed nu*fission cross section of mixture.
+* XSCHDL delayed-neutron fission spectrum.
+* XSDIFX x-directed diffusion coefficients.
+* XSDIFY y-directed diffusion coefficients.
+* XSDIFZ z-directed diffusion coefficients.
+* XSOVRV reciprocal neutron velocities.
+* XSINT0 P0 volume-integrated flux of mixture.
+* XSINT1 P1 volume-integrated flux of mixture.
+* ISCATA check for scattering anisotropy.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPLIST
+ INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,ITRANC,NEDMAC,
+ > ISCATA(NANISO)
+ REAL XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP),
+ > XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP),
+ > XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP),
+ > XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP),
+ > XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP),
+ > XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP),
+ > XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP),
+ > XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP),
+ > XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP),
+ > XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP)
+ LOGICAL LNEWXS(18)
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER(MAXNED=50)
+ TYPE(C_PTR) JPLIST,KPLIST
+ CHARACTER CANISO*2,CHID*12,NUSIGD*12,HVECT(MAXNED)*8
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT
+ REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK
+*----
+* SCRATCH STORAGE ALLOCATION
+* INGSCT number of scattering group for cross sections.
+* IFGSCT first scattering group for cross sections.
+* IPOSCT material position in scattering.
+*----
+ ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX))
+ ALLOCATE(XSWORK(NBMIX*(2+NGROUP)))
+*----
+* GET NUMBER OF MACRO EDIT X-SECTIONS
+*----
+ CALL LCMLEN(IPLIST,'ADDXSNAME-P0',ILCMLN,ILCMTY)
+ NEDMAC=ILCMLN/2
+ IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(1).')
+ IF(NEDMAC.GT.0) CALL LCMGTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT)
+ IF(LNEWXS(8)) THEN
+ DO IED=1,NEDMAC
+ IF(HVECT(IED).EQ.'H-FACTOR') GO TO 5
+ ENDDO
+ NEDMAC=NEDMAC+1
+ IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(2).')
+ HVECT(NEDMAC)='H-FACTOR'
+ ENDIF
+ 5 IF(LNEWXS(15)) THEN
+ DO IED=1,NEDMAC
+ IF(HVECT(IED).EQ.'OVERV') GO TO 10
+ ENDDO
+ NEDMAC=NEDMAC+1
+ IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(3).')
+ HVECT(NEDMAC)='OVERV'
+ ENDIF
+ 10 IF(LNEWXS(16)) THEN
+ DO IED=1,NEDMAC
+ IF(HVECT(IED).EQ.'NFTOT') GO TO 15
+ ENDDO
+ NEDMAC=NEDMAC+1
+ IF(NEDMAC.GT.MAXNED) CALL XABORT('MACPXS: MAXNED OVERFLOW(4).')
+ HVECT(NEDMAC)='NFTOT'
+ ENDIF
+ 15 IF(NEDMAC.GT.0) CALL LCMPTC(IPLIST,'ADDXSNAME-P0',8,NEDMAC,HVECT)
+*
+ JPLIST=LCMLID(IPLIST,'GROUP',NGROUP)
+ DO 100 IGR=1,NGROUP
+ KPLIST=LCMDIL(JPLIST,IGR)
+*----
+* PUT TOTAL, FIXE AND TRANC ON THE MACROLIB IF MODIFIED
+*----
+ IF(LNEWXS(1)) CALL LCMPUT(KPLIST,'NTOT0',NBMIX,2,XSTOTL(1,IGR))
+ IF(LNEWXS(3)) CALL LCMPUT(KPLIST,'FIXE' ,NBMIX,2,XSFIXE(1,IGR))
+ IF(LNEWXS(6)) CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSTRAN(1,IGR))
+ IF(LNEWXS(7)) CALL LCMPUT(KPLIST,'DIFF',NBMIX,2,XSDIFF(1,IGR))
+ IF(LNEWXS(8)) CALL LCMPUT(KPLIST,'H-FACTOR',NBMIX,2,XSH(1,IGR))
+ IF(LNEWXS(9)) CALL LCMPUT(KPLIST,'NTOT1',NBMIX,2,XSTOT1(1,IGR))
+*----
+* PUT CHI AND NUSIGF ON THE MACROLIB IF MODIFIED
+*----
+ IF(LNEWXS(2))
+ > CALL LCMPUT(KPLIST,'NUSIGF',NBMIX*NIFISS,2,XSFISS(1,1,IGR))
+ IF(LNEWXS(4))
+ > CALL LCMPUT(KPLIST,'CHI',NBMIX*NIFISS,2,XSSPEC(1,1,IGR))
+*----
+* PUT DIFFX, DIFFY AND DIFFZ ON THE MACROLIB IF MODIFIED
+*----
+ IF(LNEWXS(10))CALL LCMPUT(KPLIST,'DIFFX',NBMIX,2,XSDIFX(1,IGR))
+ IF(LNEWXS(11))CALL LCMPUT(KPLIST,'DIFFY',NBMIX,2,XSDIFY(1,IGR))
+ IF(LNEWXS(12))CALL LCMPUT(KPLIST,'DIFFZ',NBMIX,2,XSDIFZ(1,IGR))
+*----
+* PUT CHID, NUSIGD AND OVERV ON THE MACROLIB IF MODIFIED
+*----
+ IF(LNEWXS(13)) THEN
+ DO I=1,NDELG
+ WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',I
+ CALL LCMPUT(KPLIST,NUSIGD,NBMIX*NIFISS,2,XSNUDL(1,1,I,IGR))
+ ENDDO
+ ENDIF
+ IF(LNEWXS(14)) THEN
+ DO I=1,NDELG
+ WRITE(CHID,'(A3,I2.2)') 'CHI',I
+ CALL LCMPUT(KPLIST,CHID,NBMIX*NIFISS,2,XSCHDL(1,1,I,IGR))
+ ENDDO
+ ENDIF
+ IF(LNEWXS(15))CALL LCMPUT(KPLIST,'OVERV',NBMIX,2,XSOVRV(1,IGR))
+ IF(LNEWXS(16))CALL LCMPUT(KPLIST,'NFTOT',NBMIX,2,XSNFTO(1,IGR))
+ IF(LNEWXS(17))CALL LCMPUT(KPLIST,'FLUX-INTG',NBMIX,2,
+ > XSINT0(1,IGR))
+ IF(LNEWXS(18))CALL LCMPUT(KPLIST,'FLUX-INTG-P1',NBMIX,2,
+ > XSINT1(1,IGR))
+*----
+* COMPRESS AND PUT ON SCATT ON THE MACROLIB IF MODIFIED
+*----
+ DO 60 IANIS=1,NANISO
+ WRITE(CANISO,'(I2.2)') IANIS-1
+ IF(LNEWXS(5).AND.ISCATA(IANIS).EQ.2) THEN
+ NELEM=0
+ DO 50 INM=1,NBMIX
+ J2=IGR
+ J1=IGR
+ DO 20 JGR=1,NGROUP
+ IF(XSSCAT(JGR,INM,IANIS,IGR).NE.0.0) THEN
+ J2=MAX(J2,JGR)
+ J1=MIN(J1,JGR)
+ ENDIF
+ 20 CONTINUE
+ INGSCT(INM)=J2-J1+1
+ IFGSCT(INM)=J2
+ IPOSCT(INM)=NELEM+1
+ DO 30 JGR=J2,J1,-1
+ NELEM=NELEM+1
+ XSWORK(2*NBMIX+NELEM)=XSSCAT(JGR,INM,IANIS,IGR)
+ 30 CONTINUE
+*----
+* STORE DIAGONAL ELEMENTS OF SCATTERING MATRIX
+* AND TOTAL SCATTERING OUT OF GROUP
+*----
+ XSWORK(INM)=XSSCAT(IGR,INM,IANIS,IGR)
+ XSTOT=0.0
+ DO 40 JGR=1,NGROUP
+ XSTOT=XSTOT+XSSCAT(IGR,INM,IANIS,JGR)
+ 40 CONTINUE
+ XSWORK(NBMIX+INM)=XSTOT
+ 50 CONTINUE
+ CALL LCMPUT(KPLIST,'NJJS'//CANISO,NBMIX,1,INGSCT)
+ CALL LCMPUT(KPLIST,'IJJS'//CANISO,NBMIX,1,IFGSCT)
+ CALL LCMPUT(KPLIST,'IPOS'//CANISO,NBMIX,1,IPOSCT)
+ CALL LCMPUT(KPLIST,'SIGW'//CANISO,NBMIX,2,XSWORK)
+ CALL LCMPUT(KPLIST,'SIGS'//CANISO,NBMIX,2,XSWORK(NBMIX+1))
+ CALL LCMPUT(KPLIST,'SCAT'//CANISO,NELEM,2,
+ > XSWORK(2*NBMIX+1))
+ ENDIF
+ 60 CONTINUE
+*----
+* COMPUTE/RECOVER TRANSPORT CORRECTION
+*----
+ IF(ITRANC.EQ.2) THEN
+* RECOVER TRANSPORT CORRECTION FROM RECORD 'TRANC'.
+ CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM)
+ IF(ILCMLN.NE.NBMIX) CALL XABORT('MACPXS: NO TRANC RECORD '
+ > //'AVAILABLE')
+ ELSE IF(ITRANC.NE.0) THEN
+ XSWORK(:NBMIX)=0.0
+ CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM)
+ IF(ILCMLN.EQ.NBMIX) THEN
+* LEAKAGE CORRECTION.
+ CALL LCMGET(KPLIST,'NTOT0',XSWORK(NBMIX+1))
+ CALL LCMGET(KPLIST,'NTOT1',XSWORK(2*NBMIX+1))
+ DO 70 INM=1,NBMIX
+ XSWORK(INM)=XSWORK(NBMIX+INM)-XSWORK(2*NBMIX+INM)
+ 70 CONTINUE
+ ENDIF
+ IF(ITRANC.EQ.1) THEN
+* APOLLO-TYPE TRANSPORT CORRECTION.
+ CALL LCMLEN(KPLIST,'SIGS01',ILCMLN,ITYLCM)
+ IF(ILCMLN.EQ.NBMIX) THEN
+ CALL LCMGET(KPLIST,'SIGS01',XSWORK(NBMIX+1))
+ DO 80 INM=1,NBMIX
+ XSWORK(INM)=XSWORK(INM)+XSWORK(NBMIX+INM)
+ 80 CONTINUE
+ ENDIF
+ ELSE IF(ITRANC.NE.4) THEN
+ CALL XABORT('MACPXS: UNKNOWN TYPE OF CORRECTION.')
+ ENDIF
+* ***CAUTION*** 'TRANC' CONTAINS BOTH TRANSPORT AND LEAKAGE
+* CORRECTIONS.
+ CALL LCMPUT(KPLIST,'TRANC',NBMIX,2,XSWORK)
+ ENDIF
+ 100 CONTINUE
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(XSWORK)
+ DEALLOCATE(IPOSCT,IFGSCT,INGSCT)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:23:33 +0000