1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
*DECK CPOREM
SUBROUTINE CPOREM(NGROUP,NL ,NPROC ,INDPRO,DENCPO,
> DXSMIC,DSCMIC,DXSREM,DSCREM)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Remove Compo isotope xs from macroscopic xs.
*
*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
* NGROUP number of groups condensed.
* NL number of Legendre orders.
* NPROC number of microscopic xs to process.
* INDPRO identifier for xs processing.
* DENCPO Compo isotopes concentration.
* DXSMIC microscopic vector xs.
* DSCMIC microscopic scat matrix xs.
*
*Parameters: input/output
* DXSREM averaged region/group x-s.
* DSCREM scattering rates.
*
*-----------------------------------------------------------------------
*
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NGROUP,NL,NPROC,INDPRO(NPROC)
DOUBLE PRECISION DENCPO,
> DXSMIC(NGROUP,NPROC),
> DSCMIC(NGROUP,NGROUP,NL),
> DXSREM(NGROUP,NPROC),
> DSCREM(NGROUP,NGROUP,NL)
*----
* LOCAL PARAMETERS
*----
INTEGER NDPROC
PARAMETER (NDPROC=20)
INTEGER IGR,JGR,IXSR,IL
*----
* REMOVE STANDARD XS
*----
DO 100 IXSR=1,NDPROC
IF(IXSR.NE.16.AND.INDPRO(IXSR).GT.0) THEN
DO 110 IGR=1,NGROUP
DXSREM(IGR,IXSR)=DXSREM(IGR,IXSR)
> +DENCPO*DXSMIC(IGR,IXSR)
110 CONTINUE
ENDIF
100 CONTINUE
*----
* REMOVE SCATTERING XS
*----
IL=0
DO 120 IXSR=NDPROC+1,NDPROC+NL
IL=IL+1
IF(INDPRO(IXSR).GT.0) THEN
DO 130 IGR=1,NGROUP
DXSREM(IGR,IXSR)=DXSREM(IGR,IXSR)
> +DENCPO*DXSMIC(IGR,IXSR)
DO 131 JGR=1,NGROUP
DSCREM(IGR,JGR,IL)=DSCREM(IGR,JGR,IL)
> +DENCPO*DSCMIC(IGR,JGR,IL)
131 CONTINUE
130 CONTINUE
ENDIF
120 CONTINUE
RETURN
END
|
