1 *
2 * \$Id\$
3 *
4 * \$Log\$
5 * Revision 1.1.1.1  1995/10/24 10:22:00  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/02 29/03/94  15.41.48  by  S.Giani
11 *-- Author :
12       SUBROUTINE XSECN3(KM,KE,RHO,IN,IDICTS,LDICT,ISIGTS,LSIGT,BUF,
13      +IBUF,TCS,LIM,LAST)
14 C       THIS ROUTINE CREATES MACROSCOPIC TOTAL CROSS SECTIONS
15 C       AND THEN MIXES AND THINS THESE CROSS SECTIONS ACCORDING
16 C       TO THE MIXING TABLE
17 #include "geant321/minput.inc"
18 #include "geant321/mconst.inc"
19 #include "geant321/mpoint.inc"
20 #include "geant321/mmicab.inc"
21       DIMENSION BUF(*),IBUF(*),KM(*),KE(*),RHO(*),IN(*),
22      +IDICTS(NNR,NNUC),LDICT(NNR,NNUC),ISIGTS(*),LSIGT(*),TCS(*)
23 C       ASSIGN THE INITIAL VALUES
24 C       LST EQUALS THE LAST POSITION USED IN THE BUF ARRAY
25 C   (I.E. (BUF(LST) = D(LAST)))
26 C       LEN EQUALS THE CORE SPACE AVAILABLE
27       LST=0
28       LEN=LIM-LAST
29       TOL = 1.0
30 C       READ IN TWO CROSS SECTION ARRAYS AND CREATE
31 C       MACROSCOPIC CROSS SECTIONS
32       DO 160 J=1,MEDIA
33          JI=0
34          K=0
35 C       READ IN THE FIRST ARRAY
36          DO 140 IJ=1,NMIX
37             IF(KM(IJ).NE.J)GO TO 140
38             JI=JI+1
39             K=K+1
40             II=IN(IJ)
41             TOL = AMIN1(TCS(LFP210+II-1)/5.,TOL)
42             IF(JI.EQ.2)GO TO 20
43             LZ=LDICT(1,II)
44             ISLZ=IDICTS(1,II)+LMOX2
45             N=LZ
46             IF(LEN.LT.N)GO TO 180
47             NP=LZ/2
48             DO 10 M=1,NP
49                BUF(LST+2*M-1)=TCS(ISLZ+2*(M-1))
50                BUF(LST+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
51    10       CONTINUE
52             GO TO 140
53    20       CONTINUE
54 C       READ IN THE SECOND ARRAY
55             LZ2=LZ+1
56             LZ1=LZ
57             LZ=LDICT(1,II)
58             ISLZ=IDICTS(1,II)+LMOX2
59             N=2*(LZ+LZ1)
60             IF(N.GE.LEN)GO TO 180
61             NP=LZ/2
62             DO 30 M=1,NP
63                BUF(LST+LZ1+2*M-1)=TCS(ISLZ+2*(M-1))
64                BUF(LST+LZ1+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
65    30       CONTINUE
66             GO TO 40
67 C       MIX THE TWO ARRAYS
68    40       K=2
69             L=2
70             IF(BUF(LST+1).NE.1.E-5)GO TO 170
71             IF(BUF(LST+LZ2).NE.1.E-5)GO TO 170
72             NXSEC=1
73             BUF(LST+LZ1+LZ+1)=1.E-5
74             BUF(LST+LZ1+LZ+2)=BUF(LST+2)+BUF(LST+LZ2+1)
75 C       DETERMINE THE NEXT ENERGY POINT
76    50       IF(BUF(LST+1+K).EQ.BUF(LST+LZ2+L))GO TO 90
77             IF(BUF(LST+1+K).LT.BUF(LST+LZ2+L))GO TO 70
78 C       DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+LZ2+L)
79             CALL CTERP(BUF(LST+K-1),BUF(LST+K+1),BUF(LST+LZ2+L),
80      +                BUF(LST+K), BUF(LST+K+2),SIGMA)
81             NXSEC=NXSEC+1
82             LP=LZ1+LZ+1+2*(NXSEC-1)
83             BUF(LST+LP)=BUF(LST+LZ2+L)
84             BUF(LST+LP+1)=BUF(LST+LZ2+L+1)+SIGMA
85             L=L+2
86             IF(L.LT.LZ)GO TO 50
87 C       ALL THE POINTS IN THE SECOND ARRAY HAVE NOW BEEN USED
88    60       NXSEC=NXSEC+1
89             LP=LZ1+LZ+1+2*(NXSEC-1)
90             BUF(LST+LP)=BUF(LST+1+K)
91             BUF(LST+LP+1)=BUF(LST+2+K)
92             K=K+2
93             IF(K.LT.LZ1)GO TO 60
94             GO TO 100
95 C       DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+1+K)
96    70       CALL CTERP(BUF(LST+LZ2+L-2),BUF(LST+LZ2+L),BUF(LST+1+K),
97      +      BUF(LST+LZ2+L-1),BUF(LST+LZ2+L+1),SIGMA)
98             NXSEC=NXSEC+1
99             LP=LZ1+LZ+1+2*(NXSEC-1)
100             BUF(LST+LP)=BUF(LST+1+K)
101             BUF(LST+LP+1)=BUF(LST+K+2)+SIGMA
102             K=K+2
103             IF(K.LT.LZ1)GO TO 50
104 C       ALL THE POINTS IN THE FIRST ARRAY HAVE NOW BEEN USED
105    80       NXSEC=NXSEC+1
106             LP=LZ1+LZ+2*NXSEC-1
107             BUF(LST+LP)=BUF(LST+LZ2+L)
108             BUF(LST+LP+1)=BUF(LST+LZ2+L+1)
109             L=L+2
110             IF(L.LT.LZ)GO TO 80
111             GO TO 100
112 C       THE ENERGY POINTS COINCIDE
113    90       NXSEC=NXSEC+1
114             LP=LZ1+LZ+1+2*(NXSEC-1)
115             BUF(LST+LP)=BUF(LST+LZ2+L)
116             BUF(LST+LP+1)=BUF(LST+2+K)+BUF(LST+LZ2+L+1)
117             L=L+2
118             K=K+2
119             IF((L.LT.LZ).AND.(K.LT.LZ1))GO TO 50
120             IF((L.GT.LZ).AND.(K.LT.LZ1))GO TO 60
121             IF((L.LT.LZ).AND.(K.GT.LZ1))GO TO 80
122 C       FINISHED MIXING NOW THIN
123   100       L=1
124             NXSEC2=1
125             LP=LZ1+LZ
126             BUF(LST+NXSEC2)=BUF(LST+LP+L)
127             BUF(LST+NXSEC2+1)=BUF(LST+LP+L+1)
128             KI=0
129   110       L=L+2
130             KI=KI+1
131 C       CHECK TO SEE IF AT END OF CROSS SECTION ARRAY
132             L2=L+2
133             N=2*NXSEC
134             IF(L2.LT.N)GO TO 120
135 C       FINISHED THINING
136             NXSEC2=NXSEC2+1
137             N=2*(NXSEC2-1)
138             BUF(LST+1+N)=BUF(LST+LP+L)
139             BUF(LST+2+N)=BUF(LST+LP+L+1)
140             LZ=2*NXSEC2
141             JI=1
142             GO TO 140
143   120       DO 130 I=1,KI
144 C       ESTIMATE THE CROSS SECTION AT KI NODES
145                CALL CTERP(BUF(LST+LP+L-2*KI),BUF(LST+LP+L2),
146      +                   BUF(LST+LP+L-2*I+2),BUF(LST+LP+L-2*KI+1),
147      +                   BUF(LST+LP+L2+1),SIGMA)
148                ER=ABS(SIGMA-BUF(LST+LP+L-2*I+3))
149 C       IF ERROR IS WITHIN ALLOWABLE TOLERANCE, CHECK NEXT POINT
150                ERMAX=BUF(LST+LP+L-2*I+3)*TOL
151                IF(ER.LE.ERMAX)GO TO 130
152 C       NOT WITHIN ALLOWABLE TOLERANCE, MUST ADD NODE L-2 TO MESH
153                IF(L.GT.3.AND.KI.GT.1) L = L - 2
154                NXSEC2=NXSEC2+1
155                N=2*(NXSEC2-1)
156                BUF(LST+1+N)=BUF(LST+LP+L)
157                BUF(LST+2+N)=BUF(LST+LP+L+1)
158                KI = 0
159                GO TO 110
160   130       CONTINUE
161 C       ALL KI POINTS ARE WITHIN ALLOWABLE TOLERANCE
162 C       CHECK THE NEXT POINT
163             GO TO 110
164   140    CONTINUE
165 C       FINISHED WITH MEDIUM J, NOW STORE IN CORE
166          N=2*NXSEC2
167          IF(K.EQ.1)N=LZ
168          LSIGT(J)=N
169          ISIGTS(J)=LAST+1-LMOX3
170   150    CONTINUE
171          LAST=LAST+N
172          LST=LST+N
173 C       FINISHED MIXING AND THINING
174   160 CONTINUE
175       GO TO 200
176   170 WRITE(IOUT,10000)BUF(LST+1),BUF(LST+LZ2)
177 10000 FORMAT(' MICAP: ERROR-BEGINNING ENERGY DOES NOT START AT 1.-5',
178      +1P2E12.4)
179       GOTO 190
180   180 CONTINUE
181       L=LEN
182       WRITE(IOUT,10100)L,N
183 10100 FORMAT(' MICAP: NOT ENOUGH ROOM TO MIX CROSS SECTIONS',/,5X,
184      +'SPACE AVAILABLE=',I10,/,5X,'SPACE NEEDED=',I10)
185   190 PRINT '('' CALOR: ERROR in XSECN3 ====> STOP'')'
186       STOP
187   200 RETURN
188       END