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
|
*DECK DMA
SUBROUTINE DMA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Set the source of an adjoint fixed source eigenvalue problem. The
* source is the gradient of a macrolib.
*
*Copyright:
* Copyright (C) 2008 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
* NENTRY number of LCM objects or files used by the operator.
* HENTRY name of each LCM object or file:
* HENTRY(1): creation type(L_SOURCE);
* HENTRY(2): read-only type(L_FLUX);
* HENTRY(3): read-only type(L_MACROLIB);
* HENTRY(4): read-only type(L_TRACKING).
* IENTRY type of each LCM object or file:
* =1 LCM memory object; =2 XSM file; =3 sequential binary file;
* =4 sequential ascii file.
* JENTRY access of each LCM object or file:
* =0 the LCM object or file is created;
* =1 the LCM object or file is open for modifications;
* =2 the LCM object or file is open in read-only mode.
* KENTRY LCM object address or file unit number.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
TYPE(C_PTR) KENTRY(NENTRY)
CHARACTER HENTRY(NENTRY)*12
*----
* LOCAL VARIABLES
*----
PARAMETER (NSTATE=40)
TYPE(C_PTR) IPDMA,IPFLX,IPMAC,IPTRK
CHARACTER HSIGN*12,TEXT12*12
INTEGER ISTATE(NSTATE)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMEAD,NMIX,NDGRP,IMERGE,
1 IGCR,MAT,KEY
REAL, ALLOCATABLE, DIMENSION(:) :: VOL
*----
* PARAMETER VALIDATION.
*----
IF(NENTRY.NE.4) CALL XABORT('DMA: FOUR PARAMETERS EXPECTED.')
IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('DMA: LI'
1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.')
IF(JENTRY(1).NE.0) CALL XABORT('DMA: ENTRY IN CREATE MODE EXPE'
1 //'CTED.')
DO I=2,4
IF((JENTRY(I).NE.2).OR.((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)))
1 CALL XABORT('DMA: LINKED LIST OR XSM FILE IN READ-ONLY MODE E'
2 //'XPECTED AT RHS.')
ENDDO
IPDMA=KENTRY(1)
CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN)
IF(HSIGN.NE.'L_FLUX') THEN
TEXT12=HENTRY(2)
CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
1 '. L_FLUX EXPECTED.')
ENDIF
IPFLX=KENTRY(2)
CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN)
IF(HSIGN.EQ.'L_MACROLIB') THEN
IPMAC=KENTRY(3)
ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN
IPMAC=LCMGID(KENTRY(3),'MACROLIB')
ELSE
TEXT12=HENTRY(3)
CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
1 '. L_MACROLIB OR L_LIBRARY EXPECTED.')
ENDIF
CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN)
IF(HSIGN.NE.'L_TRACK') THEN
TEXT12=HENTRY(4)
CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
1 '. L_TRACK EXPECTED.')
ENDIF
IPTRK=KENTRY(4)
*----
* RECOVER STATE VECTOR INFORMATION
*----
CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
NREG=ISTATE(1)
NBMIX=ISTATE(4)
CALL LCMGET(IPFLX,'STATE-VECTOR',ISTATE)
NG=ISTATE(1)
NUN=ISTATE(2)
CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
IF(ISTATE(1).NE.NG) CALL XABORT('DMA: INVALID NUMBER OF GROUPS.')
NMIL=ISTATE(2)
NL=ISTATE(3)
NFM=ISTATE(4)
NED=ISTATE(5)
NDEL=ISTATE(7)
ALLOCATE(NAMEAD(2*NED))
IF(NED.GT.0) CALL LCMGET(IPMAC,'ADDXSNAME-P0',NAMEAD)
*----
* READ INPUT PARAMETERS
*----
ALLOCATE(NMIX(NREG))
CALL LCMGET(IPTRK,'MATCOD',NMIX)
CALL DMAGET(IPDMA,NG,NREG,NBMIX,NMIX,IPRINT,NMERGE,NGCOND)
DEALLOCATE(NMIX)
NCST=(5+NGCOND*NL+2*NFM*(1+NDEL)+NED)*NMERGE*NGCOND
*----
* COMPUTE THE GPT SOURCE
*----
ALLOCATE(NDGRP(NG))
NDGRP(:NG)=0
ALLOCATE(IMERGE(NREG),IGCR(NG),MAT(NREG),KEY(NREG),VOL(NREG))
CALL LCMGET(IPDMA,'REF:IMERGE',IMERGE)
CALL LCMGET(IPDMA,'REF:IGCOND',IGCR)
CALL LCMGET(IPTRK,'MATCOD',MAT)
CALL LCMGET(IPTRK,'KEYFLX',KEY)
CALL LCMGET(IPTRK,'VOLUME',VOL)
IOF=1
JJ=IGCR(1)
DO IND=1,NG
IF(IND.GT.JJ) THEN
IOF=IOF+1
IF(IOF.GT.NGCOND) CALL XABORT('DMA: NGCOND OVERFLOW.')
JJ=IGCR(IOF)
ENDIF
NDGRP(IND)=IOF
ENDDO
CALL DMASOU(IPRINT,IPDMA,IPMAC,IPFLX,NG,NREG,NMIL,NL,NDEL,
1 NED,NAMEAD,NUN,NMERGE,NGCOND,NCST,IMERGE,NDGRP,MAT,KEY,VOL)
DEALLOCATE(VOL,KEY,MAT,IGCR,IMERGE)
DEALLOCATE(NDGRP,NAMEAD)
*----
* SAVE THE SIGNATURE AND STATE VECTOR
*----
HSIGN='L_SOURCE'
CALL LCMPTC(IPDMA,'SIGNATURE',12,HSIGN)
ISTATE(:NSTATE)=0
ISTATE(1)=NG
ISTATE(2)=NUN
ISTATE(3)=0
ISTATE(4)=NCST
ISTATE(5)=NMERGE
ISTATE(6)=NGCOND
IF(IPRINT.GT.0) WRITE(6,100) (ISTATE(I),I=1,6)
CALL LCMPUT(IPDMA,'STATE-VECTOR',NSTATE,1,ISTATE)
RETURN
*
100 FORMAT(/8H OPTIONS/8H -------/
1 7H NG ,I8,28H (NUMBER OF ENERGY GROUPS)/
2 7H NUN ,I8,40H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/
3 7H NDIR ,I8,35H (NUMBER OF DIRECT FIXED SOURCES)/
4 7H NCST ,I8,36H (NUMBER OF ADJOINT FIXED SOURCES)/
5 7H NMERGE,I8,34H (NUMBER OF HOMOGENIZED REGIONS)/
6 7H NGCOND,I8,38H (NUMBER OF CONDENSED ENERGY GROUPS))
END
|
