diff options
Diffstat (limited to 'Dragon/src/CPOMAW.f')
| -rw-r--r-- | Dragon/src/CPOMAW.f | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/Dragon/src/CPOMAW.f b/Dragon/src/CPOMAW.f new file mode 100644 index 0000000..bc2980e --- /dev/null +++ b/Dragon/src/CPOMAW.f @@ -0,0 +1,205 @@ +*DECK CPOMAW + SUBROUTINE CPOMAW(IPCPO ,IPRINT,NGROUP,NL ,NPROC ,INDPRO, + > ITYPRO,DXSMAC,DSCMAC,DXSREM,DSCREM,DISFC , + > DMJMAC,IFCDIS,DISFAC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Put macroscopic cross section on Compo. +* +*Copyright: +* Copyright (C) 2007 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 +* IPCPO pointer to the Compo. +* IPRINT print parameter. Equal to zero for no print. +* NGROUP number of groups condensed. +* NL number of Legendre orders. +* NPROC number of microscopic xs to process. +* INDPRO identifier for xs processing. +* ITYPRO identifier for xs processed . +* DXSMAC macroscopic averaged region/group x-s. +* DSCMAC macroscopic scattering. +* DXSREM removed averaged region/group x-s. +* DSCREM removed scattering rates. +* DISFC disadvantage factor. +* DMJMAC energy. +* IFCDIS discontinuity factor present (1) or absent. +* DISFAC discontinuity factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO + INTEGER IPRINT,NGROUP,NL,NPROC,INDPRO(NPROC), + > ITYPRO(NPROC) + REAL DISFC(NGROUP) + DOUBLE PRECISION DXSMAC(NGROUP,NPROC), + > DSCMAC(NGROUP,NGROUP,NL), + > DXSREM(NGROUP,NPROC), + > DSCREM(NGROUP,NGROUP,NL), + > DMJMAC + INTEGER IFCDIS + DOUBLE PRECISION DISFAC(2,NGROUP,3) +*---- +* LOCAL PARAMETERS +*---- + INTEGER NDPROC + REAL CUTOFF + PARAMETER (NDPROC=20,CUTOFF=1.0E-7) + INTEGER IXSR,JXSR,KXSR,IL,IGR,JGR,IORD + REAL CUTLIM + DOUBLE PRECISION DNUFI,DNUFT +*---- +* ALLOCATABLE ARRAYS +* XSREC micro vector xs +* XSCAT compress scattering data +* DISTMP temporary storage for discontinuity factors +*---- + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,DISTMP + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL), + > DISTMP(2,NGROUP)) +*---- +* SAVE AVERAGE XS +*---- + ITYPRO(:NPROC)=1 + CALL LCMSIX(IPCPO,'MACR',1) + XSREC(:NGROUP,:NPROC)=0.0 + XSCAT(:NGROUP,:NGROUP,:NL)=0.0 + DO 100 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 101 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0 + 101 CONTINUE + ENDIF + 100 CONTINUE + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=3 + KXSR=16 + DNUFI=0.0D0 + DNUFT=0.0D0 + DO 120 IGR=1,NGROUP + DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR) + DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR)) + > *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)) + 120 CONTINUE + CUTLIM=ABS(REAL(DNUFT)*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + DNUFI=1.0D0/DNUFI + DNUFT=1.0D0/DNUFT + DO 130 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DNUFI*(DXSMAC(IGR,IXSR) + > -DXSREM(IGR,IXSR))) + 130 CONTINUE + ENDIF + ENDIF + IXSR=6 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=4 + KXSR=3 + DO 140 IGR=1,NGROUP + DNUFI=DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR) + CUTLIM=ABS(REAL(DXSMAC(IGR,JXSR))*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + XSREC(IGR,IXSR)=REAL((DXSMAC(IGR,KXSR) + > -DXSREM(IGR,KXSR))/DNUFI) + ENDIF + 140 CONTINUE + ENDIF + DO 150 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 160 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0 + 160 CONTINUE + ENDIF + 150 CONTINUE + IL=0 + DO 170 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 180 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR)) + CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF) + IF(ABS(XSREC(IGR,IXSR)).LT.CUTLIM) + > XSREC(IGR,IXSR)=0.0 + DO 190 JGR=1,NGROUP + XSCAT(IGR,JGR,IL)=REAL(DSCMAC(IGR,JGR,IL) + > -DSCREM(IGR,JGR,IL)) + CUTLIM=ABS(REAL(DSCMAC(IGR,JGR,IL))*CUTOFF) + IF(ABS(XSCAT(IGR,JGR,IL)).LT.CUTLIM) + > XSCAT(IGR,JGR,IL)=0.0 + 190 CONTINUE + 180 CONTINUE + ENDIF + 170 CONTINUE +*---- +* COMPUTE AVERAGED ENERGY PER FISSION +*---- + JXSR=4 + KXSR=16 + DNUFI=0.0D0 + DNUFT=0.0D0 + DO 200 IGR=1,NGROUP + DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR) + DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR)) + > *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)) + 200 CONTINUE + CUTLIM=ABS(REAL(DNUFT)*CUTOFF) + IF(REAL(DNUFI).GT.CUTLIM) THEN + DMJMAC=DMJMAC/DNUFI + ELSE + DMJMAC=0.0D0 + ENDIF +*---- +* SAVE CPO MICRO +*---- + IORD=1 + CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1), + > XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO) + CALL LCMSIX(IPCPO,'MACR',2) + IXSR=NDPROC+NL+1 + DO 210 IGR=1,NGROUP + XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR)) + 210 CONTINUE + CALL LCMPUT(IPCPO,'OVERV',NGROUP,2,XSREC) + IXSR=16 + DO 220 IGR=1,NGROUP + XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR)) + 220 CONTINUE + CALL LCMPUT(IPCPO,'FLUX-INTG',NGROUP,2,XSREC) + CALL LCMPUT(IPCPO,'FLUXDISAFACT',NGROUP,2,DISFC) + IF(IFCDIS .EQ. 1) THEN + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,1),1) + CALL LCMPUT(IPCPO,'DISFACX',2*NGROUP,2,DISTMP) + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,2),1) + CALL LCMPUT(IPCPO,'DISFACY',2*NGROUP,2,DISTMP) + CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,3),1) + CALL LCMPUT(IPCPO,'DISFACZ',2*NGROUP,2,DISTMP) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DISTMP,XSCAT,XSREC) + RETURN + END |