*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