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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
*DECK D2PMIC
SUBROUTINE D2PMIC( IPDAT, IPMIC , IPRINT, NGP, NBMIX, NBISO,
> NED, NVAR, STAIDX, LXES, LDET, LCOR,
> FLUX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover microscopic cross sections from a microlib object and write
* cross sections for one branch at a fixed burnup point in the INFO
* data block
*
*Author(s):
* J. Taforeau
*
*Parameters: input
* IPDAT address of info data block
* IPMIC address of the microlib object
* NBMIX number of mixturess
* NBISO number of isotopes
* NED number of P0 additional XS
* NGP number of energy groups
* NVAR number of state variables
* STAIDX table of states index order
*
*Parameters:
* IPRINT
* NGP
* LXES
* LDET
* LCOR
* FLUX
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPDAT,IPMIC
INTEGER NBMIX,NBISO,NED,NGP,NVAR
INTEGER STAIDX(NVAR)
REAL FLUX(NGP)
LOGICAL LDET,LXES,LCOR
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPTH,KPTH,JPMIC
INTEGER :: iXE = 0
INTEGER :: iSM = 0
INTEGER :: IMR = 0
INTEGER :: iDT = 0
INTEGER ,DIMENSION(5) :: iCHAIN = 0
INTEGER :: DEB = -999
REAL XEND,SMND,MRND
REAL XSECT(NGP),XENG(NGP),SMNG(NGP),SCAT(NGP),DET(NGP)
REAL NFTOT(NGP),N2N(NGP)
REAL :: NUM = 0.
REAL :: DENO = 0.
REAL DEN(NBISO)
REAL NGXS(5,NGP),RPHI,YLDPM
CHARACTER(LEN=12) HUSE(NBISO),ISOTNAME(NBISO)
CHARACTER*8 XSNAM(12)
! RECOVER ONLY EIGHT FIRST CHARACTER OF ISOTOPES
CHARACTER(LEN=8) ISOTOPES(2),HDET,SMCHAIN(5)
CALL LCMSIX (IPDAT,' ',0)
CALL LCMSIX (IPDAT,'SAPHYB_INFO',1)
CALL LCMSIX (IPDAT,'ISOTOPES',1)
CALL LCMGTC (IPDAT,'XE135',12,ISOTOPES(1))
CALL LCMGTC (IPDAT,'SM149',12,ISOTOPES(2))
CALL LCMGTC (IPDAT,'PM148',12,SMCHAIN(1))
CALL LCMGTC (IPDAT,'PM148M',12,SMCHAIN(2))
CALL LCMGTC (IPDAT,'PM149',12,SMCHAIN(3))
CALL LCMGTC (IPDAT,'PM147',12,SMCHAIN(4))
CALL LCMGTC (IPDAT,'ND147',12,SMCHAIN(5))
IF (LDET) CALL LCMGTC (IPDAT,'DET',12,HDET)
IF(NBMIX.NE.1) THEN
CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
ENDIF
IF(NED.GT.12) THEN
CALL XABORT('@D2P: MORE THAN 12 ADDITIONAL ISOTOPES')
ENDIF
CALL LCMSIX(IPMIC,' ',0)
CALL LCMGET(IPMIC,'ISOTOPESDENS',DEN)
CALL LCMGTC(IPMIC,'ISOTOPESUSED',12,NBISO,HUSE)
CALL LCMGTC(IPMIC,'ISOTOPERNAME',12,NBISO,ISOTNAME)
CALL LCMGTC(IPMIC,'ADDXSNAME-P0',8,NED,XSNAM)
DO I=1,NBISO
IF(INDEX(HUSE(I),ISOTOPES(1))>0) iXE=I
IF(INDEX(HUSE(I),ISOTOPES(2))>0) iSM=I
IF(INDEX(HUSE(I),'*MAC*RES')>0) iMR=I
IF (INDEX(HUSE(I),SMCHAIN(1))>0) iCHAIN(1)=I
IF (INDEX(HUSE(I),SMCHAIN(2))>0) iCHAIN(2)=I
IF (INDEX(HUSE(I),SMCHAIN(3))>0) iCHAIN(3)=I
IF (INDEX(HUSE(I),SMCHAIN(4))>0) iCHAIN(4)=I
IF (INDEX(HUSE(I),SMCHAIN(5))>0) iCHAIN(5)=I
IF (LDET) THEN
IF(INDEX(HUSE(I),HDET)>0) iDT=I
ENDIF
ENDDO
IF (LXES) THEN
! CHECK THE EXISTENCE OF XE AND SM ISOTOPES
IF(iXE==0) THEN
CALL XABORT('@D2PMIC: XE MUST BE A PARTICULARIZED ISOTOPE')
ELSE IF(iSM==0) THEN
CALL XABORT('@D2PMIC: SM MUST BE A PARTICULARIZED ISOTOPE')
ENDIF
XEND=DEN(iXE)
SMND=DEN(iSM)
MRND=DEN(iMR)
CALL LCMSIX(IPMIC,' ',0)
! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR XE
JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
IPMIC=LCMGIL(JPMIC,iXE)
CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
IF(ILONG.NE.NGP) THEN
CALL XABORT('@D2PMIC: INCONSISTENT NUMBERS OF ENERGY GROUP')
ENDIF
! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF XE
CALL LCMGET(IPMIC,'NTOT0',XSECT)
CALL LCMGET(IPMIC,'SIGS00',SCAT)
DO I=1, NGP
XENG(I)=(XSECT(I)-SCAT(I))
IF (XENG(I)<0) THEN
XENG(I)= 0.
WRITE(6,*) '@D2PMIC: WARNING : XE NEGATIVE CROSS SECTION',
> '=> ZERO CROSS SECTION ASSUMED'
ENDIF
ENDDO
! PROCESS MICROSCOPIC TOTAL XS INFORMATION FOR SM
CALL LCMSIX(IPMIC,' ',0)
JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
IPMIC=LCMGIL(JPMIC,iSM)
CALL LCMLEN(IPMIC,'NTOT0',ILONG,ITYLCM)
IF(ILONG.NE.NGP) THEN
CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
ENDIF
XSECT(:NGP)=0.0
SCAT(:NGP)=0.0
! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF SM
CALL LCMGET(IPMIC,'NTOT0',XSECT)
CALL LCMGET(IPMIC,'SIGS00',SCAT)
DO I=1, NGP
SMNG(I)=(XSECT(I)-SCAT(I))
IF (SMNG(I)<0) THEN
SMNG(I)= 0.
WRITE(6,*) '@D2PMIC: WARNING : SM NEGATIVE CROSS SECTION',
> '=> ZERO CROSS SECTION ASSUMED'
ENDIF
ENDDO
ENDIF
IF (LCOR.OR.LXES) THEN
! RECOVER FISSION CROSS SECTION OF MACROSCOPIC RESIDUAL
CALL LCMSIX(IPMIC,' ',0)
JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
IPMIC=LCMGIL(JPMIC,iMR)
CALL LCMLEN(IPMIC,'NFTOT',ILONG,ITYLCM)
CALL LCMGET(IPMIC,'N2N',N2N)
IF(ILONG.NE.NGP) THEN
CALL XABORT('@D2PMIC: MORE THAN ONE MIXTRURE IN SAPHYB')
ENDIF
NFTOT(:NGP)=0
CALL LCMGET(IPMIC,'NFTOT',NFTOT)
NFTOT(:)=NFTOT(:)*MRND
CALL LCMSIX(IPMIC,' ',0)
ENDIF
IF (LCOR) THEN
RPHI=FLUX(1)/FLUX(2)
DO I=1,4
JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
IPMIC=LCMGIL(JPMIC,iCHAIN(I))
CALL LCMGET(IPMIC,'NG',NGXS(I,:))
CALL LCMSIX(IPMIC,' ',0)
ENDDO
NUM=0.
DO I=1,2
NUM=NUM+DEN(iCHAIN(I))*(NGXS(I,1)*RPHI+NGXS(I,2))
ENDDO
DENO=NFTOT(1)*RPHI+NFTOT(2)
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPDAT,'GENPMAXS_INP',1)
CALL LCMGET(IPDAT,'FLAG',DEB)
CALL LCMSIX(IPDAT,' ',0)
IPTH=LCMGID(IPDAT,'TH_DATA')
KPTH=LCMDIL(IPTH,STAIDX(NVAR))
CALL LCMGET(KPTH,'YLDPm',YLDPM)
DENO=DENO*YLDPM
YLDPM=YLDPM*(1+(NUM/DENO))
IF (DEB.EQ.-999) THEN
CALL XABORT ("@D2PMIC : PROBLEM IN YIELD CORRECTION")
ELSE IF (DEB<0) THEN
CALL LCMPUT(KPTH,'YLDPm',1,2,YLDPM)
ENDIF
ENDIF
IF (LDET) THEN
IF(iDT==0) THEN
WRITE(6,*) '@D2PMIC: UNKNOWN ISOTOPE (',HDET,') FOR DETECTOR',
> ' CROSS SECTIONS'
CALL XABORT ('=> PLEASE USE THE DET CARD IN D2P:')
ENDIF
CALL LCMSIX(IPMIC,' ',0)
JPMIC=LCMGID(IPMIC,'ISOTOPESLIST')
IPMIC=LCMGIL(JPMIC,iDT)
CALL LCMLEN(IPMIC,'NFTOT',ILONG,ITYLCM)
PRINT*,'ICI'
IF(ILONG.NE.NGP) THEN
CALL XABORT('@D2PMIC: INCONSISTENT NUMBERS OF ENERGY GROUP')
ENDIF
! CALCULATION OF MICROSCOPIC ABSORPTION CROSS SECTIONS OF XE
CALL LCMGET(IPMIC,'NFTOT',DET)
CALL LCMSIX(IPMIC,' ',0)
ENDIF
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
IPTH=LCMGID(IPDAT,'CROSS_SECT')
KPTH=LCMDIL(IPTH,STAIDX(NVAR))
CALL LCMSIX(KPTH,'MACROLIB_XS',1)
IF (LXES) CALL LCMPUT(KPTH,'SFI',NGP,2,NFTOT)
CALL LCMSIX(KPTH,' ',2)
CALL LCMSIX(KPTH,'MICROLIB_XS',1)
IF (LXES) THEN
CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)
CALL LCMPUT(KPTH,'XEND',1,2,XEND)
CALL LCMPUT(KPTH,'SMND',1,2,SMND)
ENDIF
IF (LDET) CALL LCMPUT(KPTH,'DET',NGP,2,DET)
CALL LCMSIX(KPTH,' ',0)
IF(IPRINT > 1) THEN
WRITE(6,*)
WRITE(6,*) "**************************************************"
WRITE(6,*) "* SUMMARY *"
WRITE(6,*) "**************************************************"
WRITE(6,*)
WRITE(6,*) "**** MICROSCOPIC cross sections ****"
IF (LDET) THEN
WRITE(6,*) "DETECTOR :",DET
ENDIF
IF (LXES) THEN
WRITE(6,*) "XENON ABSORPTION :",XENG
WRITE(6,*) "SAMARIUM ABSORPTION :",SMNG
WRITE(6,*) "XENON NUMBER DENSITY :",XEND
WRITE(6,*) "SAMARIUM NUMBER DENSITY :",SMND
WRITE(6,*)
WRITE(6,*) "**** MACROSCOPIC cross sections(1:NGP) ****"
WRITE(6,*) "FISSION :",NFTOT
WRITE(6,*) "MAC*RES* NUMBER DENSITY :",MRND
ENDIF
IF (LCOR) THEN
WRITE(6,*) "PM149 FISSION YIELD CORRECTED:",YLDPM
ENDIF
ENDIF
END
|
