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
|
*DECK EPCRMV
SUBROUTINE EPCRMV(IPEPC,IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Extract variances and covariances from database and store on
* EPC data structure.
*
*Copyright:
* Copyright (C) 2009 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
* IPEPC pointer to EPC deat structure.
* IPCOV pointer to vaqriance and cavariance file.
* IPRINT print level.
* IFMT format of covariance file:
* = 1 for ASCII file;
* =-1 for BINARY file.
* NGR number of groups.
* NIS number of isotopes.
* NXS number of cross section types per.
* NCV maximum dimension of symmetrized covariance matrix.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* Subroutine arguments
*----
TYPE(C_PTR) IPEPC
INTEGER IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV
*----
* Local parameters
*----
INTEGER IOUT
CHARACTER NAMSBR*6
PARAMETER (IOUT=6,NAMSBR='EPCRMV')
INTEGER ILCMUP,ILCMDN
PARAMETER (ILCMUP=1,ILCMDN=2)
*----
* Local variables
*----
INTEGER IPRTL,ISO,NTYPE,ITYPE,NXSR,IXSR,IFCV,IPOC,
> ILCV,ICMG,IGR,JGR
CHARACTER ISONAM*12,UNAME*8,RECNAM*12,FNAME*50,XSN*8
INTEGER ITC,NEL
*----
* Allocatable arrays
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IDIS,ICOV
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NAMISO,IDXS
REAL, ALLOCATABLE, DIMENSION(:) :: VAR,COV
*----
* Scratch storage allocation
* IDIS array containing the isotope ID.
* NAMISO array containing the isotope names.
* IDXS array containing the cross section types (names).
* VAR array to store the variances.
* ICOV array to store indices to reconstructe full covariance
* matrix from compressed covariance matrix.
* COV array to store compressed covariance matrix.
*----
ALLOCATE(IDIS(NIS),NAMISO(3,NIS),IDXS(2,NXS),ICOV(NGR))
ALLOCATE(VAR(NGR),COV(NCV))
*----
* Scan over isotopes
*----
IPRTL=IPRINT
IF(IPRTL .GE. 10) THEN
WRITE(IOUT,6000) NAMSBR
ENDIF
IFCV=NGR+1
NXSR=0
CALL LCMSIX(IPEPC,'XSVariances ',ILCMUP)
DO ISO=1,NIS
*----
* Get isotope ID
*----
IF(IFMT .GT. 0) THEN
READ(IPCOV,1000) IDIS(ISO),UNAME,NTYPE,FNAME
ELSE
READ(IPCOV) IDIS(ISO),UNAME,NTYPE,FNAME
ENDIF
IF(IDIS(ISO) .GT. 999) THEN
WRITE(ISONAM,'(I4,8X)') IDIS(ISO)
ELSE IF(IDIS(ISO) .GT. 99) THEN
WRITE(ISONAM,'(I3,9X)') IDIS(ISO)
ELSE IF(IDIS(ISO) .GT. 9) THEN
WRITE(ISONAM,'(I2,10X)') IDIS(ISO)
ELSE
WRITE(ISONAM,'(I1,11X)') IDIS(ISO)
ENDIF
READ(ISONAM,'(3A4)') (NAMISO(ITC,ISO),ITC=1,3)
CALL LCMSIX(IPEPC,ISONAM,ILCMUP)
DO ITYPE=1,NTYPE
*----
* Get xs name and verify if in the list
*----
IF(IFMT .GT. 0) THEN
READ(IPCOV,1001) UNAME
ELSE
READ(IPCOV) UNAME
ENDIF
DO IXSR=1,NXSR
WRITE(XSN,'(2A4)') IDXS(1,IXSR),IDXS(2,IXSR)
IF(XSN .EQ. UNAME) GO TO 100
ENDDO
NXSR=NXSR+1
IF(NXSR .GT. NXS) CALL XABORT(NAMSBR//
>': number of cross section types insufficient')
READ(UNAME,'(2A4)') IDXS(1,NXSR),IDXS(2,NXSR)
100 CONTINUE
*----
* Get variances and covariances
*----
IF(IFMT .GT. 0) THEN
READ(IPCOV,*) (VAR(IGR),IGR=1,NGR)
READ(IPCOV,*) (COV(IGR),IGR=IFCV,NCV)
ELSE
READ(IPCOV) (VAR(IGR),IGR=1,NGR)
READ(IPCOV) (COV(IGR),IGR=IFCV,NCV)
ENDIF
*----
* Compress variance and covariance matrix
*----
IPOC=1
ILCV=IFCV-1
DO IGR=1,NGR
*----
* Store variance for next element
*----
COV(IPOC)=0.01*VAR(IGR)
ICMG=0
*----
* Scan covariance and remove trailing 0.0
* Start at the end of COV for group IGR
*----
DO JGR=NGR-IGR,1,-1
IF(ICMG .EQ. 0) THEN
IF(COV(ILCV+JGR) .NE. 0.0) THEN
*----
* First non 0.0 elements
* Add at the correct position in COV
*----
ICMG=ICMG+1
COV(IPOC+JGR)=COV(ILCV+JGR)
ENDIF
ELSE
*----
* Other elements including 0.0
* Add at the correct position in COV
*----
ICMG=ICMG+1
COV(IPOC+JGR)=COV(ILCV+JGR)
ENDIF
ENDDO
ILCV=ILCV+NGR-IGR
IPOC=IPOC+ICMG+1
ICOV(IGR)=ICMG+1
ENDDO
NEL=IPOC-1
RECNAM=UNAME//' '
CALL LCMPUT(IPEPC,RECNAM,NEL,2,COV)
RECNAM='INDX'//UNAME
CALL LCMPUT(IPEPC,RECNAM,NGR,1,ICOV)
ENDDO
CALL LCMSIX(IPEPC,ISONAM,ILCMDN)
ENDDO
CALL LCMPUT(IPEPC,'NAMEXS ',2*NXSR,3,IDXS)
CALL LCMPUT(IPEPC,'NAMEISO ',3*NIS,3,NAMISO)
CALL LCMSIX(IPEPC,'XSVariances ',ILCMDN)
IF(IPRTL .GE. 10) THEN
WRITE(IOUT,6001) NAMSBR
ENDIF
*----
* Scratch storage deallocation
*----
DEALLOCATE(COV,VAR)
DEALLOCATE(ICOV,IDXS,NAMISO,IDIS)
RETURN
*----
* Formats
*----
1000 FORMAT(I8,5X,A8,5X,I8,5X,A50)
1001 FORMAT(A8)
6000 FORMAT('(* Output from --',A6,'-- follows ')
6001 FORMAT(' Output from --',A6,'-- completed *)')
END
|
