[u/mrichter/AliRoot.git] / GEANT321 / neutron / xsecn3.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1995/10/24 10:22:00  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/02 29/03/94  15.41.48  by  S.Giani
*-- Author :
      SUBROUTINE XSECN3(KM,KE,RHO,IN,IDICTS,LDICT,ISIGTS,LSIGT,BUF,
     +IBUF,TCS,LIM,LAST)
C       THIS ROUTINE CREATES MACROSCOPIC TOTAL CROSS SECTIONS
C       AND THEN MIXES AND THINS THESE CROSS SECTIONS ACCORDING
C       TO THE MIXING TABLE
#include "geant321/minput.inc"
#include "geant321/mconst.inc"
#include "geant321/mpoint.inc"
#include "geant321/mmicab.inc"
      DIMENSION BUF(*),IBUF(*),KM(*),KE(*),RHO(*),IN(*),
     +IDICTS(NNR,NNUC),LDICT(NNR,NNUC),ISIGTS(*),LSIGT(*),TCS(*)
C       ASSIGN THE INITIAL VALUES
C       LST EQUALS THE LAST POSITION USED IN THE BUF ARRAY
C   (I.E. (BUF(LST) = D(LAST)))
C       LEN EQUALS THE CORE SPACE AVAILABLE
      LST=0
      LEN=LIM-LAST
      TOL = 1.0
C       READ IN TWO CROSS SECTION ARRAYS AND CREATE
C       MACROSCOPIC CROSS SECTIONS
      DO 160 J=1,MEDIA
         JI=0
         K=0
C       READ IN THE FIRST ARRAY
         DO 140 IJ=1,NMIX
            IF(KM(IJ).NE.J)GO TO 140
            JI=JI+1
            K=K+1
            II=IN(IJ)
            TOL = AMIN1(TCS(LFP210+II-1)/5.,TOL)
            IF(JI.EQ.2)GO TO 20
            LZ=LDICT(1,II)
            ISLZ=IDICTS(1,II)+LMOX2
            N=LZ
            IF(LEN.LT.N)GO TO 180
            NP=LZ/2
            DO 10 M=1,NP
               BUF(LST+2*M-1)=TCS(ISLZ+2*(M-1))
               BUF(LST+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
   10       CONTINUE
            GO TO 140
   20       CONTINUE
C       READ IN THE SECOND ARRAY
            LZ2=LZ+1
            LZ1=LZ
            LZ=LDICT(1,II)
            ISLZ=IDICTS(1,II)+LMOX2
            N=2*(LZ+LZ1)
            IF(N.GE.LEN)GO TO 180
            NP=LZ/2
            DO 30 M=1,NP
               BUF(LST+LZ1+2*M-1)=TCS(ISLZ+2*(M-1))
               BUF(LST+LZ1+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
   30       CONTINUE
            GO TO 40
C       MIX THE TWO ARRAYS
   40       K=2
            L=2
            IF(BUF(LST+1).NE.1.E-5)GO TO 170
            IF(BUF(LST+LZ2).NE.1.E-5)GO TO 170
            NXSEC=1
            BUF(LST+LZ1+LZ+1)=1.E-5
            BUF(LST+LZ1+LZ+2)=BUF(LST+2)+BUF(LST+LZ2+1)
C       DETERMINE THE NEXT ENERGY POINT
   50       IF(BUF(LST+1+K).EQ.BUF(LST+LZ2+L))GO TO 90
            IF(BUF(LST+1+K).LT.BUF(LST+LZ2+L))GO TO 70
C       DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+LZ2+L)
            CALL CTERP(BUF(LST+K-1),BUF(LST+K+1),BUF(LST+LZ2+L),
     +                BUF(LST+K), BUF(LST+K+2),SIGMA)
            NXSEC=NXSEC+1
            LP=LZ1+LZ+1+2*(NXSEC-1)
            BUF(LST+LP)=BUF(LST+LZ2+L)
            BUF(LST+LP+1)=BUF(LST+LZ2+L+1)+SIGMA
            L=L+2
            IF(L.LT.LZ)GO TO 50
C       ALL THE POINTS IN THE SECOND ARRAY HAVE NOW BEEN USED
   60       NXSEC=NXSEC+1
            LP=LZ1+LZ+1+2*(NXSEC-1)
            BUF(LST+LP)=BUF(LST+1+K)
            BUF(LST+LP+1)=BUF(LST+2+K)
            K=K+2
            IF(K.LT.LZ1)GO TO 60
            GO TO 100
C       DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+1+K)
   70       CALL CTERP(BUF(LST+LZ2+L-2),BUF(LST+LZ2+L),BUF(LST+1+K),
     +      BUF(LST+LZ2+L-1),BUF(LST+LZ2+L+1),SIGMA)
            NXSEC=NXSEC+1
            LP=LZ1+LZ+1+2*(NXSEC-1)
            BUF(LST+LP)=BUF(LST+1+K)
            BUF(LST+LP+1)=BUF(LST+K+2)+SIGMA
            K=K+2
            IF(K.LT.LZ1)GO TO 50
C       ALL THE POINTS IN THE FIRST ARRAY HAVE NOW BEEN USED
   80       NXSEC=NXSEC+1
            LP=LZ1+LZ+2*NXSEC-1
            BUF(LST+LP)=BUF(LST+LZ2+L)
            BUF(LST+LP+1)=BUF(LST+LZ2+L+1)
            L=L+2
            IF(L.LT.LZ)GO TO 80
            GO TO 100
C       THE ENERGY POINTS COINCIDE
   90       NXSEC=NXSEC+1
            LP=LZ1+LZ+1+2*(NXSEC-1)
            BUF(LST+LP)=BUF(LST+LZ2+L)
            BUF(LST+LP+1)=BUF(LST+2+K)+BUF(LST+LZ2+L+1)
            L=L+2
            K=K+2
            IF((L.LT.LZ).AND.(K.LT.LZ1))GO TO 50
            IF((L.GT.LZ).AND.(K.LT.LZ1))GO TO 60
            IF((L.LT.LZ).AND.(K.GT.LZ1))GO TO 80
C       FINISHED MIXING NOW THIN
  100       L=1
            NXSEC2=1
            LP=LZ1+LZ
            BUF(LST+NXSEC2)=BUF(LST+LP+L)
            BUF(LST+NXSEC2+1)=BUF(LST+LP+L+1)
            KI=0
  110       L=L+2
            KI=KI+1
C       CHECK TO SEE IF AT END OF CROSS SECTION ARRAY
            L2=L+2
            N=2*NXSEC
            IF(L2.LT.N)GO TO 120
C       FINISHED THINING
            NXSEC2=NXSEC2+1
            N=2*(NXSEC2-1)
            BUF(LST+1+N)=BUF(LST+LP+L)
            BUF(LST+2+N)=BUF(LST+LP+L+1)
            LZ=2*NXSEC2
            JI=1
            GO TO 140
  120       DO 130 I=1,KI
C       ESTIMATE THE CROSS SECTION AT KI NODES
               CALL CTERP(BUF(LST+LP+L-2*KI),BUF(LST+LP+L2),
     +                   BUF(LST+LP+L-2*I+2),BUF(LST+LP+L-2*KI+1),
     +                   BUF(LST+LP+L2+1),SIGMA)
               ER=ABS(SIGMA-BUF(LST+LP+L-2*I+3))
C       IF ERROR IS WITHIN ALLOWABLE TOLERANCE, CHECK NEXT POINT
               ERMAX=BUF(LST+LP+L-2*I+3)*TOL
               IF(ER.LE.ERMAX)GO TO 130
C       NOT WITHIN ALLOWABLE TOLERANCE, MUST ADD NODE L-2 TO MESH
               IF(L.GT.3.AND.KI.GT.1) L = L - 2
               NXSEC2=NXSEC2+1
               N=2*(NXSEC2-1)
               BUF(LST+1+N)=BUF(LST+LP+L)
               BUF(LST+2+N)=BUF(LST+LP+L+1)
               KI = 0
               GO TO 110
  130       CONTINUE
C       ALL KI POINTS ARE WITHIN ALLOWABLE TOLERANCE
C       CHECK THE NEXT POINT
            GO TO 110
  140    CONTINUE
C       FINISHED WITH MEDIUM J, NOW STORE IN CORE
         N=2*NXSEC2
         IF(K.EQ.1)N=LZ
         LSIGT(J)=N
         ISIGTS(J)=LAST+1-LMOX3
  150    CONTINUE
         LAST=LAST+N
         LST=LST+N
C       FINISHED MIXING AND THINING
  160 CONTINUE
      GO TO 200
  170 WRITE(IOUT,10000)BUF(LST+1),BUF(LST+LZ2)
10000 FORMAT(' MICAP: ERROR-BEGINNING ENERGY DOES NOT START AT 1.-5',
     +1P2E12.4)
      GOTO 190
  180 CONTINUE
      L=LEN
      WRITE(IOUT,10100)L,N
10100 FORMAT(' MICAP: NOT ENOUGH ROOM TO MIX CROSS SECTIONS',/,5X,
     +'SPACE AVAILABLE=',I10,/,5X,'SPACE NEEDED=',I10)
  190 PRINT '('' CALOR: ERROR in XSECN3 ====> STOP'')'
      STOP
  200 RETURN
      END
Commit	Line	Data
fe4da5cc	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+2M-1)=TCS(ISLZ+2(M-1))
	50	BUF(LST+2M)=TCS(ISLZ+2M-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+2M-1)=TCS(ISLZ+2(M-1))
	64	BUF(LST+LZ1+2M)=TCS(ISLZ+2M-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-2I+2),BUF(LST+LP+L-2KI+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-2I+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