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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
*DECK MACUPG
SUBROUTINE MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP,
> NBMIXF,NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX,
> IMLOC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Cross section processing in GROUP list directory with update.
*
*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
* KENTRY array of macrolib structures.
* HGROUP character*12 name of GROUP list directory.
* NENTRY number of structures.
* NIFISF maximum number fissile isotopes per mixture.
* NDELF final number of precursor groups.
* NEDF final number of aditional x-s.
* NGROUP number of groups.
* NBMIXF final number of mixtures.
* NIFISS number fissile isotopes per mixture.
* NANISO maximun scattering anisotropy.
* NEDMAC number of aditional edition x-s.
* NTOTMX maximum number of mixtures in input macrolibs.
* ITRANC type of transport correction.
* IPRINT print level.
* NAMEN total number of x-s.
* NUMPX correspondence between old and new 'NUSIGF' arrays.
* IMLOC mixture location.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
CHARACTER HGROUP*12
INTEGER NENTRY,NIFISF,NDELF,NEDF,NGROUP,NBMIXF,NIFISS,NANISO,
> NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN(2*NEDMAC),NUMPX(NBMIXF*NIFISS),
> IMLOC(2,NTOTMX)
TYPE(C_PTR) KENTRY(NENTRY)
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPMACR,JPMACR,KPMACR
INTEGER IOUT,NREACD,NTREA,IGR,IEN,IMIX,IPRG
PARAMETER (IOUT=6,NREACD=14)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IXSPRO
REAL, ALLOCATABLE, DIMENSION(:) :: XSGEN,XSIGS,SCAT
*----
* DATA
*----
CHARACTER NAMREA(NREACD)*12
SAVE NAMREA
DATA NAMREA
> /'NTOT0 ','NTOT1 ','TRANC ','FIXE ',
> 'DIFF ','DIFFX ','DIFFY ','DIFFZ ',
> 'NSPH ','H-FACTOR ','C-FACTOR ','OVERV ',
> 'FLUX-INTG ','FLUX-INTG-P1'/
*----
* SCRATCH STORAGE ALLOCATION
*----
NTREA=NREACD+2*NIFISF*(1+NDELF)+NEDF
ALLOCATE(XSGEN(NBMIXF*(NTREA+2)),XSIGS(NBMIXF*NANISO),
> IXSPRO(NTREA+2*NANISO+1),SCAT(NGROUP*NBMIXF*NANISO))
IXSPRO(:NTREA+2*NANISO+1)=0
IPRG=IPRINT
DO 140 IGR=1,NGROUP
XSGEN(:NBMIXF*(NTREA+2))=0.0
XSIGS(:NBMIXF*NANISO)=0.0
SCAT(:NGROUP*NBMIXF*NANISO)=0.0
DO 150 IEN=1,NENTRY
IPMACR=KENTRY(IEN)
IF(IEN.EQ.1) THEN
* IPMACR IS OPEN IN CREATION/MODIFICATION MODE
JPMACR=LCMLID(IPMACR,HGROUP,NGROUP)
KPMACR=LCMDIL(JPMACR,IGR)
ELSE
* IPMACR IS OPEN IN READ-ONLY MODE
JPMACR=LCMGID(IPMACR,HGROUP)
KPMACR=LCMGIL(JPMACR,IGR)
ENDIF
IF(IPRG.GE.10) WRITE(IOUT,6020) IEN
DO 151 IMIX=1,NTOTMX
IF(IMLOC(1,IMIX).EQ.IEN) THEN
CALL MACRDM(KPMACR,IPRG ,IEN ,NTOTMX,NGROUP,NANISO,
> NBMIXF,NIFISF,NEDF ,NDELF ,NREACD,NTREA ,
> IMLOC ,NAMREA,NAMEN ,NUMPX ,IXSPRO,XSGEN ,
> XSIGS ,SCAT )
GO TO 155
ENDIF
151 CONTINUE
155 CONTINUE
150 CONTINUE
IPMACR=KENTRY(1)
JPMACR=LCMLID(IPMACR,HGROUP,NGROUP)
KPMACR=LCMDIL(JPMACR,IGR)
*----
* FOR TRANC OFF DO NOT SAVE TRANSPORT CORRECTION
*----
IF(ITRANC.EQ.0) IXSPRO(2)=0
CALL MACPRM(KPMACR,IPRG ,NGROUP,NANISO,NBMIXF,NIFISF,
> NEDF ,NDELF ,NREACD,NTREA ,IGR ,NAMREA,
> NAMEN ,IXSPRO,XSGEN ,XSIGS ,SCAT )
IPRG=0
140 CONTINUE
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(SCAT,IXSPRO,XSIGS,XSGEN)
RETURN
6020 FORMAT(' MACUPG: PROCESSING MACROLIB',I12)
END
|
