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
|
*DECK COMDEP
SUBROUTINE COMDEP(IPRINT,IPEDIT,IPWORK,ITRES,NISOP,NOMEVO)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Creation of a lumped depletion chain in the multicompo.
*
*Copyright:
* Copyright (C) 2015 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): A. Hebert
*
*Parameters: input/output
* IPRINT print parameter.
* IPEDIT pointer to the edition object (L_EDIT signature).
* IPWORK pointer to the LCM object where the lumped depletion chain is
* written.
* ITRES creation index for the macroscopic residual (=0: not created;
* =1: not a FP precursor; =2: is a FP precursor).
* NISOP number of user-requested particularized isotopes. Equal to
* zero if all EDI: isotopes are particularized.
* NOMEVO library names of user-requested particularized isotopes.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER IPRINT,ITRES,NISOP
TYPE(C_PTR) IPEDIT,IPWORK
CHARACTER NOMEVO(NISOP)*12
*----
* LOCAL VARIABLES
*----
PARAMETER (NSTATE=40,MAXBCH=500)
INTEGER ISTATE(NSTATE),IHICH(3,MAXBCH)
LOGICAL LISO
CHARACTER TEXT12*12
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: MYLIS,IHREAC
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHISO,IDREA,IPREA
REAL, ALLOCATABLE, DIMENSION(:) :: DDECA
REAL, ALLOCATABLE, DIMENSION(:,:) :: DENER,PRATE,YIELD
*----
* RECOVER DEPLETION INFORMATION FROM EDITION OBJECT
*----
CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1)
IF(NISOP.GT.0) THEN
CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE)
NBISO=ISTATE(1)
IF(ITRES.EQ.2) NBISO=NBISO+1
NBFISS=ISTATE(2)
NBDPF=ISTATE(3)
NSUPS=ISTATE(7)
NREAC=ISTATE(8)
NFATH=ISTATE(9)
MAXFP=NBDPF+30 ! reserve 30 location for lumped fp daughters
ALLOCATE(IHISO(3,NBISO),MYLIS(NBISO),IHREAC(2*NREAC),
1 IDREA(NREAC,NBISO),DENER(NREAC,NBISO),DDECA(NBISO),
2 IPREA(NFATH,NBISO),PRATE(NFATH,NBISO),YIELD(NBFISS,MAXFP))
CALL LCMGET(IPEDIT,'ISOTOPESDEPL',IHISO)
CALL LCMGET(IPEDIT,'CHARGEWEIGHT',MYLIS)
CALL LCMGET(IPEDIT,'DEPLETE-IDEN',IHREAC)
CALL LCMGET(IPEDIT,'DEPLETE-REAC',IDREA)
CALL LCMGET(IPEDIT,'DEPLETE-ENER',DENER)
CALL LCMGET(IPEDIT,'DEPLETE-DECA',DDECA)
CALL LCMGET(IPEDIT,'PRODUCE-REAC',IPREA)
CALL LCMGET(IPEDIT,'PRODUCE-RATE',PRATE)
IF(NBFISS*NBDPF.GT.0) THEN
CALL LCMGET(IPEDIT,'FISSIONYIELD',YIELD)
ENDIF
*----
* DESCRIBE FISSILE ISOTOPE *MAC*RES
*----
IF(ITRES.EQ.2) THEN
IF(IPRINT.GT.1) THEN
WRITE(6,'(/42H COMDEP: ADD *MAC*RES RESIDUAL ISOTOPE TO ,
1 17HDEPLETION CHAINS.)')
ENDIF
TEXT12='*MAC*RES'
READ(TEXT12,'(3A4)') (IHISO(I0,NBISO),I0=1,3)
MYLIS(NBISO)=0
IDREA(:,NBISO)=0
DENER(:,NBISO)=0.0
IDREA(1,NBISO)=4
DDECA(NBISO)=0.0
IPREA(:,NBISO)=0
PRATE(:,NBISO)=0.0
ENDIF
*----
* CREATE LUMPED DEPLETION CHAIN
*----
CALL LCMSIX(IPWORK,'DEPL-CHAIN',1)
LISO=.FALSE.
NBCH=0
DO 20 ISO=1,NBISO
WRITE(TEXT12,'(3A4)') (IHISO(I0,ISO),I0=1,3)
DO JSO=1,NISOP
IF((TEXT12.EQ.NOMEVO(JSO)).AND.(TEXT12.NE.'*MAC*RES')) THEN
NBCH=NBCH+1
IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.')
READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3)
GO TO 20
ENDIF
ENDDO
IF((TEXT12.EQ.'*MAC*RES').AND.(ITRES.EQ.2)) THEN
NBCH=NBCH+1
IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.')
READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3)
ENDIF
20 CONTINUE
CALL EDILUM(IPRINT,IPWORK,MAXFP,NBISO,NBFISS,NBDPF,NSUPS,
1 NREAC,NFATH,NBCH,IHICH,IHISO,MYLIS,IHREAC,IDREA,DENER,DDECA,
2 IPREA,PRATE,YIELD,LISO,NBFISS,NBCH)
DEALLOCATE(YIELD,PRATE,IPREA,DDECA,DENER,IDREA,IHREAC,MYLIS,
1 IHISO)
ELSE
*----
* RECOVER THE DEPLETION CHAIN WITHOUT LUMPING
*----
CALL LCMSIX(IPWORK,'DEPL-CHAIN',1)
CALL LCMEQU(IPEDIT,IPWORK)
ENDIF
CALL LCMSIX(IPWORK,' ',2)
CALL LCMSIX(IPEDIT,' ',2)
RETURN
END
|
