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
|
*DECK LIBECC
SUBROUTINE LIBECC(IPDRL,NGRO,IL,AWR,ENER,DELTA,DELECC,IGECCO,
> SCAT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Construct the scattering matrix using analytical scattering kernels.
*
*Copyright:
* Copyright (C) 2025 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
* IPDRL pointer to the draglib (L_DRAGLIB signature).
* NGRO number of energy groups.
* IL Legendre order (=0: isotropic kernel in LAB).
* AWR mass ratio for current isotope.
* ENER energy limits of the coarse groups.
* DELTA lethargy widths of the coarse groups.
* DELECC lethargy widths of eccolib libraries.
* IGECCO number of equal-width lethargy groups with eccolib libraries.
* IMPX print flag.
*
*Parameters: output
* SCAT scattering matrix.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPDRL
INTEGER NGRO,IL,IGECCO
REAL AWR,ENER(NGRO+1),DELTA(NGRO),DELECC,SCAT(NGRO,NGRO)
*----
* LOCAL VARIABLES
*----
PARAMETER(MAXEDI=47,MAXTRA=10000)
CHARACTER CM*2
CHARACTER(LEN=8), SAVE, DIMENSION(MAXEDI) :: NAMEDI=
> (/ 'NELAS ','N2N ','N3N ','NNP ','N4N ',
> 'NINEL001','NINEL002','NINEL003','NINEL004','NINEL005',
> 'NINEL006','NINEL007','NINEL008','NINEL009','NINEL010',
> 'NINEL011','NINEL012','NINEL013','NINEL014','NINEL015',
> 'NINEL016','NINEL017','NINEL018','NINEL019','NINEL020',
> 'NINEL021','NINEL022','NINEL023','NINEL024','NINEL025',
> 'NINEL026','NINEL027','NINEL028','NINEL029','NINEL030',
> 'NINEL031','NINEL032','NINEL033','NINEL034','NINEL035',
> 'NINEL036','NINEL037','NINEL038','NINEL039','NINEL040',
> 'NINEL041','NINEL '/)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ
REAL, ALLOCATABLE, DIMENSION(:) :: GAR,PRI,STIS,UUU,QQ
REAL, ALLOCATABLE, DIMENSION(:,:) :: SSS2
LOGICAL, ALLOCATABLE, DIMENSION(:) :: LPAR
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(NJJ(NGRO),IJJ(NGRO),GAR(NGRO*NGRO))
ALLOCATE(PRI(MAXTRA),STIS(NGRO),UUU(NGRO))
ALLOCATE(LPAR(MAXEDI),SSS2(NGRO,MAXEDI),QQ(MAXEDI))
*----
* RECOVER CROSS SECTIONS CONTRIBUTING TO THE SCATTERING MATRIX
*----
SSS2(:NGRO,:MAXEDI)=0.0
LPAR(:MAXEDI)=.FALSE.
QQ(:MAXEDI)=0.0
DO I=1,MAXEDI
CALL LCMLEN(IPDRL,NAMEDI(I),LENGT,ITYLCM)
IF(LENGT.GT.0) THEN
LPAR(I)=.TRUE.
CALL LCMGET(IPDRL,NAMEDI(I),SSS2(1,I))
DO IG1=1,NGRO
IF(NAMEDI(I).EQ.'N2N') THEN
SSS2(IG1,I)=2.0*SSS2(IG1,I)
ELSE IF(NAMEDI(I).EQ.'N3N') THEN
SSS2(IG1,I)=3.0*SSS2(IG1,I)
ELSE IF(NAMEDI(I).EQ.'N4N') THEN
SSS2(IG1,I)=4.0*SSS2(IG1,I)
ENDIF
ENDDO
DO IG1=NGRO,1,-1
IF(SSS2(IG1,I).NE.0.0) EXIT
QQ(I)=-ENER(IG1)
ENDDO
ENDIF
ENDDO
*----
* CONSTRUCT THE SCATTERING MATRIX
*----
WRITE (CM,'(I2.2)') IL
CALL LCMGET(IPDRL,'NJJS'//CM,NJJ)
CALL LCMGET(IPDRL,'IJJS'//CM,IJJ)
LENGT=0
DO IG1=1,NGRO
LENGT=LENGT+NJJ(IG1)
ENDDO
GAR(:LENGT)=0.0
CALL LCMGET(IPDRL,'SCAT'//CM,GAR)
UUU(1)=DELTA(1)
DO IG1=2,NGRO
UUU(IG1)=UUU(IG1-1)+DELTA(IG1)
ENDDO
IGAR=0
SCAT(:NGRO,:NGRO)=0.0
DO IG1=1,IGECCO
DO I=1,MAXEDI
IF(LPAR(I)) THEN
IF(NAMEDI(I).EQ.'NELAS') THEN
CALL LIBPRI(MAXTRA,DELECC,AWR,0,IL,NPRI,PRI)
ELSE
! treshold reaction
IF(ENER(IG1).LE.-QQ(I)*(AWR+1.0)/AWR) CYCLE
CALL LIBPRQ(MAXTRA,DELECC,AWR,ENER(IG1),QQ(I),0,IL,
> NPRI,PRI)
ENDIF
DO IPRI=1,NPRI
IG2=IG1+IPRI-1 ! IG2 <-- IG1
IF(IG2.GT.IGECCO) EXIT
SCAT(IG2,IG1)=SCAT(IG2,IG1)+PRI(IPRI)*SSS2(IG1,I)
ENDDO
ENDIF
ENDDO
IGAR=IGAR+NJJ(IG1)
ENDDO ! IG1
DO IG2=IGECCO+1,NGRO
DO IG1=IJJ(IG2),IJJ(IG2)-NJJ(IG2)+1,-1
IGAR=IGAR+1
SCAT(IG2,IG1)=GAR(IGAR)
ENDDO
ENDDO ! IG2
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(QQ,SSS2,LPAR)
DEALLOCATE(UUU,STIS,PRI)
DEALLOCATE(GAR,IJJ,NJJ)
RETURN
END
|
