C ******************** ABAREX MAIN *************************************AB 1 C AB 2 C *******************INPUT KEYWORDS AND FORMATS*************************AB 3 C AB 4 C ALL INPUT FORMATS ARE (A2,5X,I3,7F10.4) UNLESS OTHERWISE SPECIFIED. AB 5 C ALL ENERGIES ARE IN MEV(LAB). AB 6 C ALL LENGTHS ARE IN FERMIS. AB 7 C ALL XSECS. ARE IN BARNS OR BARNS/SR IN THE LAB. SYSTEM. AB 8 C ALL ANGLES ARE IN DEGREES(LAB). AB 9 C ANY NUMBER OF CASES CAN BE STACKED AT THE INPUT. AB 10 C KEYWORDS CAN BE IN ANY ORDER EXCEPT WHERE OTHERWISE STATED. AB 11 C EACH CASE MUST END WITH A 'COMPUTE' LINE. AB 12 C AB 13 C ********* START CALCULATIONS, ALWAYS LAST CARD OF GIVEN PROBLEM. AB 14 C 1- 7 'COMPUTE' AB 15 C 8-10 LMAX, MAXIMUM ORBITAL ANGULAR MOMENTUM. AB 16 C DEFAULT = 0, USE ORDINARILY, LMAX DETERMINED INTERNALLY FOR AB 17 C EACH LEVEL SEPARATELY. MAX VALUE = 20. AB 18 C 11-20 E, LAB ENERGY OF INCIDENT NEUTRONS IN MEV. DEFAULT VALUE = 0.8.AB 19 C 21-30 ANO, TARGET MASS NUMBER, DEFAULT = 55.9349. AB 20 C 31-40 ANU, PROJECTILE MASS NUMBER, DEFAULT = 1.008665. AB 21 C 41-50 FNU, WIDTH FLUCTUATION DEGREES OF FREEDOM, DEFAULT = 1 + T**0.6.AB 22 C IF FNU IS NEGATIVE NO FLUCTUATION CORRECTION, I.E. H-F CAL. AB 23 C THERE IS NO FLUCTUATION CORRECTION WHEN CONTINUUM EXCITATIONS AB 24 C ARE INVOLVED IN THE CALCULATION. AB 25 C 51-60 DANG, ANGLE INTERVAL OF DIFFERENTIAL XSEC. DEFAULT = AB 26 C 15 DEG. (LAB) AB 27 C 61-70 C1, ASYMPTOTIC MATCHING RADIUS, DEFAULT VALUE = 15 FM. AB 28 C 71-80 PTS, NO. OF RADIAL INTEGRATION POINTS, DEFAULT = 301.0. AB 29 C SHOULD BE AN ODD NUMBER. AB 30 C AB 31 C ********* PARAMETERS FOR DISPERSION CONTRIBUTION AB 32 C 1- 7 'DISP ' AB 33 C 8-10 BLANK. AB 34 C 11-20 SURF0. AB 35 C 21-30 SURF1. AB 36 C 31-40 SURF2. AB 37 C WHERE A REAL SURFACE POTENTIAL -- AB 38 C V=(SURF0+SURF1*E+SURF2*E**2)*W AB 39 C IS ADDED TO THE REAL POTENTIAL, 'W' IS THE IMAGINARY AB 40 C POTENTIAL AND 'E' THE INCIDENT ENERGY. DEFAULT VALUES OF AB 41 C SURF0, SURF1 AND SURF2 ARE ZERO. ENERGY E IN CM SYSTEM. AB 42 C AB 43 C ********* INPUT CHANGE IN PARAMETERS AB 44 C 1- 7 'INPUT ' AB 45 C CHANGE INPUT PARAMETERS FROM PREVIOUS CASE USING NAMELIST/INPUT/AB 46 C LINES WHICH MUST FOLLOW. NOT PERMITTED FOR FIRST CASE. AB 47 C FOR EXAMPLE -- AB 48 C COMPUTE (FROM PREVIOUS CASE) AB 49 C INPUT AB 50 C &INPUT Z(1)=5.0,VRE=46.0,&END AB 51 C IN THIS EXAMPLE THE ENERGY OF THE PREVIOUS CASE WILL BE CHANGED AB 52 C TO 5.0 MEV, THE REAL POTENTIAL TO 46.0 MEV, AND THE PROBLEM AB 53 C WILL BE RUN AGAIN. THIS IS AN IBM PROCEDURE WHICH MAY NOT AB 54 C EXIST IN ALL FORTRAN. IT IS NOT A RECOMMENDED PROCEDURE FOR AB 55 C ABAREX UNLESS YOU ARE CAREFUL. AB 56 C AB 57 C ********* PRINT TRANS. COEF., S-MATRIX, ETC. AB 58 C 1- 7 'TRANSM ' AB 59 C 8-10 KETA, PRINTS TRANSMISSION COEFFICIENTS, S-MATRIX, STRN. FUNCT., AB 60 C R-PRIME FOR FIRST KETA LEVELS. DEFAULT MEANS KETA = NLEVEL. AB 61 C AB 62 C ********* ENTER REAL OPTICAL POTENTIAL, SAXON-WOODS FORM AB 63 C 1- 7 'REAL ' AB 64 C 8-10 KRE, DUMMY CAN BE ANY VALUE OR OMITTED. TYPICALLY KRE = 1. AB 65 C CODE USES WOODS-SAXON REAL POTENTIAL FORM IN ALL CASES. AB 66 C 11-20 VRE, REAL POTENTIAL STRENGTH IN MEV, ASSUMED TO BE POSITIVE. AB 67 C 21-30 VRE1, LINEAR PARAMETER OF STRENGTH. AB 68 C 31-40 VRE2, QUADRATIC PARAMETER OF STRENGTH. AB 69 C WHERE V = VRE + VRE1*E +VRE2*E**2. E IN CM. AB 70 C 41-50 R1, REAL POTENTIAL REDUCED RADIUS IN FERMIS. AB 71 C 51-60 A1, REAL POTENTIAL DIFFUSENESS IN FERMIS. AB 72 C 61-70 VSR, SPIN-ORBIT STRENGTH IN MEV, ASSUMES REAL SO POTENTIAL, AB 73 C SAME GEOMETRY AS REAL POTENTIAL AND THE THOMAS FORM. IF AB 74 C IDENTICALLY = 0 SO LINE (BELOW) MUST BE INCLUDED IN THE INPUT. AB 75 C AB 76 C ********* ENTER IMAGINARY OPTICAL POTENTIAL AB 77 C 1- 7 'IMAG ' AB 78 C 8-10 KIM, SETS IMAGINARY WELL FORM AS FOLLOWS-- AB 79 C 1 = VOLUME WELL (WOODS-SAXON). AB 80 C 2 = GAUSSIAN-SURFACE WELL (V*EXP(-((R-r)/A)**2). AB 81 C 3 = GAUSSIAN-SURFACE + VOLUME WELL (SUM OF ABOVE). AB 82 C 4 = WOODS-SAXON DERIVATIVE WELL. AB 83 C 5 = WOODS-SAXON DERIVATIVE + VOLUME WELL. AB 84 C IF VIVOL (BELOW) IS USED, KIM = 2 AND 3 ARE AB 85 C EQUIVALENT, THAT IS ALSO TRUE FOR KIM = 4 AND 5. AB 86 C 11-20 VIM, IMAGINARY POTENTIAL STRENGTH IN MEV. AB 87 C 21-30 VIM1, LINEAR PARAMETER OF STRENGTH. AB 88 C 31-40 VIM2, QUADRATIC PARAMETER OF STRENGTH. AB 89 C WHERE VI = VIM + VIM1*E + VIM2*E**2, E IN CM SYSTEM. AB 90 C 41-50 R2, IMAGINARY POTENTIAL REDUCED RADIUS IN FERMIS. AB 91 C 51-60 A2, IMAGINARY POTENTIAL DIFFUSENESS IN FERMIS. AB 92 C 61-70 VIVOL, VOLUME IMAGINARY POTENTIAL STRENGTH IN MEV. AB 93 C 71-80 VOLRAT, RATIO OF VOLUME TO SURFACE POTENTIAL. AB 94 C AB 95 C ********* ENTER SPIN-ORBIT POTENTIAL (VSR (ABOVE) MUST BE 0) AB 96 C 1- 7 'SO ' AB 97 C 8-10 KSO, = 1 FOR THOMAS FORM. THIS FORM IS RECOMMENDED. AB 98 C = 2 WOODS-SAXON VOLUME FORM. AB 99 C = 3 WOODS-SAXON-DERIVATIVE FORM. AB 100 C 11-20 VSR, REAL SPIN-ORBIT STRENGTH IN MEV. AB 101 C 21-30 VS1, IMAGINARY SPIN-ORBIT STRENGTH IN MEV. AB 102 C 31-40 RR1, SO REDUCED RADIUS IN FERMIS. AB 103 C 41-50 AA1, SO DIFFUSENESS IN FERMIS. AB 104 C AB 105 C ********* INPUT TARGET LEVEL DATA AB 106 C 1- 7 'LEVELS ' AB 107 C 8-10 NLE, NUMBER OF DESCRETE TARGET LEVELS, MAXIMUM = 50 AB 108 C 11-20 ZTARGET, TARGET CHARGE NUMBER. DEFAULT = 0 (BLANK) IN WHICH AB 109 C CASE THERE IS NO TARGET LEVEL CONTINUUM. AB 110 C 21-30 ECONT, ENERGY FOR START OF CONTINUUM, DEFAULT ECONT=EX(NLE). AB 111 C 31-40 ESTEP, ENERGY INTERVAL OF CONTINUUM CALCULATIONS, AB 112 C DEFAULT = 0.2 MEV. AB 113 C 41-50 TAU, TEMPERATURE IN CONTINUUM LEVEL-DENSITY FORMULA, AB 114 C RHO(E) =EXP((E-E0T)/TAU). AB 115 C 51-60 E0T, ENERGY SHIFT IN RHO FORMULA. AB 116 C 61-70 SGT, LEVEL DENSITY SPIN CUTOFF PARAMETER. AB 117 C IF TAU = 0.0 TAU, E0T AND SGT AARE COMPUTED INTERNALLY. THEAB 118 C RESULTS MAY NOT BE REALISTIC. INSPECT THEM! AB 119 C UNLESS NLE = 0, NLE CARDS MUST FOLLOW IN THE FORMAT AB 120 C (F9.4,F4.1,I2,I5,F5.4) DESCRIBING THE TARGET STATE FOLLOWED BY AB 121 C EXCITED STATES IN ORDER OF INCREASING ENERGY. THE SPECIFICATIONAB 122 C THESE LEVEL CARDS FOLLOWS -- AB 123 C AB 124 C ********* LEVEL CARDS, FORMAT(F9.4,F4.1,I2,I5,F5.4) AB 125 C 1- 9 EX(I), EXCITATION OF THE I-TH TARGET STATE. AB 126 C 10-13 FI(I), THE STATE SPIN. AB 127 C 14-15 IPI(I), THE STATE PARITY, +1 OR -1, DEFAULT = +1. AB 128 C 16-20 KGP(I), THE STATE GROUP NUMBER. USED FOR SEARCH AND PRINTOUT. AB 129 C XSECS. FOR CONSECUTIVE LEVELS WITH IDENTICAL GROUP NUMBERS ARE AB 130 C ADDED TOGETHER IN PRINTOUT AND/OR SEARCH. AB 131 C IF KGP(1) IS NEGATIVE ONLY THE SHAPE-ELASTIC CROSS SECTION AB 132 C IS CALCULATED AND FITTED. AB 133 C 21-25 GW(I), WEIGHT OF I-TH LEVEL FOR FITTING, DEFAULT=1. AB 134 C AB 135 C ********* SCAN ENERGY RANGE IN CACULATIONS AB 136 C 1- 7 'SCAN ' AB 137 C 8-10 KK, = 0 FOR SIMPLE SCAN, THEN -- AB 138 C 11-20 E1, DESIRED. AB 139 C 21-30 E2, DESIRED. AB 140 C ETC. TO AB 141 C 71-80 E7, DESIRED. AB 142 C REPEAT LINE TO CALCULATE UP TO 50 ENERGIES. AB 143 C KK = 1 FOR INCREMENTAL SCAN, THEN -- AB 144 C 11-20 EI, THE INITIAL ENERGY IN MEV. AB 145 C 21-30 DE, THE ENERGY INCREMENT BETWEEN EI AND EF, MAX. OF 50 STEPS. AB 146 C 31-40 EF, THE FINAL ENERGY. AB 147 C AB 148 C ********* SEARCH FOR PARAMETERS BY FITTING DATA AB 149 C CHI-SQUARE FIT TO TOTAL AND SCATTERING CROSS SECTIONS. AB 150 C FORMAT OF LINE IS (A7,I3,5F10.4,20I). AB 151 C 1- 7 'SEARCH ' AB 152 C 8-10 NOA, NUMBER OF SCATTERING ANGLES WITH DIFFERENTIAL DATA. AB 153 C 11-20 E, LAB. NEUTRON ENERGY OF THE DATA. AB 154 C 21-30 SGTOT, EXP. TOTAL CROSS SECTION, DEFAULT NO TOTAL CROSS SECTION AB 155 C FIT. AB 156 C 31-40 GWTOT, WEIGHT OF TOTAL CROSS SECTION, DEFAULT = 1.0. AB 157 C 41-50 FPRINT, -1.0 PRINTS PARAMETERS AT EACH STEP, DEFAULT NO AB 158 C INTERMEDIATE PRINT OUTS. AB 159 C 51-60 TOL, CONVERGENCE TERMINATION OF FIT, DEFAULT = 0.005. AB 160 C 61-80 KQ(I), 1 OR 0 DEPENDING WHETHER THE PARAMETER IS TO BE AB 161 C FITTED OR NOT. THE ORDER OF THE PARAMETERS IS-- AB 162 C VRE,VRE1,VRE2,R1,A1,VIM,VIM1.VM2,R2,A2,VIVOL,VOLRAT, AB 163 C VSR,VSR1,RR1,AA1. THERE ARE 16 IN TOTAL. KQ(20) MUST AB 164 C BE 5 IF DIFFERENTIAL DATA HAS % ERROR ASSIGNED, AB 165 C AS BELOW. IF WEIGHTING IS PROPORTIONAL TO XSEC. AB 166 C MAGNITUDE KQ(20) IS 0 OR BLANK. BLANKS ARE NOT AB 167 C EQUIVALENT TO '0' IN THE KG(I) STRING AND SHOULD AB 168 C NOT BE USED. EVERY SEARCH LINE MUST BE FOLLOWED BY NOA AB 169 C DIFFERENTIAL DATA LINES AS FOLLOWS -- AB 170 C AB 171 C ********* DIFFERENTIAL DATA INPUT, FORMAT(8F10.4) AB 172 C 1-10 A(I), THE I-TH LABORATORY ANGLE. AB 173 C 11-20 XIN(I,1), EXPERIMENTAL LAB. XSEC. FOR SCATTERING TO THE J-TH AB 174 C ETC. LEVEL AT THE I-TH ANGLE. UP TO SEVEN LEVEL GROUPS AB 175 C 71-80 XIN(I,7), CAN BE FITTED. THERE WILL BE NOA SUCH LINES. IF AB 176 C KQ(20) OF THE SEARCH LINE = 5 THE CORRESPONDING AB 177 C NOA % ERRORS MUST FOLLOW IN THE SAME FORMAT AS AB 178 C FOLLOWS -- AB 179 C 1-10 BLANK AB 180 C 10-20 ERR(I,1), AB 181 C ETC. AB 182 C 71-80 ERR(I,7), AB 183 C ONLY POSITIVE NON-ZERO CROSS SECTIONS ARE FITTED. AB 184 C AB 185 C ********* SEARCH INCLUDING STRENGTH FUNCTIONS AB 186 C STRENGTH-FUNCTION SEARCH LINE MUST BE FIRST SEARCH AB 187 C LINE AND BE FOLLOWED BY A PARAMETER LINE. AFTER THESEAB 188 C TWO LINES ANY COMBINATION OF SEARCH INPUTS MAY BE AB 189 C ADDED. S0, R-PRIME AND S1 MUST ALL BE INTRODUCED. AB 190 C PERCENT ERRORS ARE USED FOR WEIGHTING. AB 191 C THE INPUT IS:- AB 192 C 1- 7 'SEARCH ' AB 193 C 8-10 NOA, MUST BE -1 FOR STRENGTH-FUNCTION INPUT. AB 194 C 11-20 E-LAB IN MEV, DEFAULT VALUE = 1 EV. AB 195 C 21-30 S0 IN UNITS OF 1E-4. AB 196 C 31-40 S0 % ERROR. AB 197 C 41-50 R-PRIME IN UNITS OF FMS. AB 198 C 51-60 R-PRIME % ERROR. AB 199 C 61-70 S1 IN UNITS OF 1E-4. AB 200 C 71-80 S1 % ERROR. AB 201 C THIS LINE MUST BE FOLLOWED BY A LINE IN FORMAT(16I1,F12.6) AB 202 C GIVING:- AB 203 C 1-16 THE 16 '1' OR '0' VALUES INDICATING THE PARAMETERS AB 204 C TO BE SEARCHED AS PER THE GENERAL 'SEARCH' LINE, ABOVE. AB 205 C 17-29 THE CONVERGENCE VALUE TOL, DEFAULT TOL=0.005 AB 206 C AB 207 C THERE MUST BE AT LEAST AS MANY DATA VALUES IN A AB 208 C SEARCH AS THE NUMBER OF PARAMETERS SOUGHT. A AB 209 C NUMBER OF SEARCH SETS CAN BE USED CONCURRENTLY, EACH AB 210 C AT DIFFERENT ENERGIES. WITH NOA EQUAL ZERO A SET OF AB 211 C TOTAL CROSS SECTIONS CAN BE FITTED. TOTAL, AB 212 C DIFERENTIAL AND STRENGTH-FUNCTION SEARCHS CAN BE AB 213 C INTERMIXED, PROVIDING THE STRENGTH-FUNCTION SEARCH AB 214 C INPUT IS GIVEN FIRST. AB 215 C AB 216 C ********* CAPTURE INPUT, GAMMA-PRODUCTION AND RADIATIVE CAPTURE AB 217 C 1- 7 'CAPTURE' AB 218 C 8-10 IABS(NZ), COMPOUND-NUCLEUS CHARGE NUMBER. DEFAULT-READ AB 219 C IN TRANSMISSION COEFFICIENTS. ALL OTHER ENTRIES ON AB 220 C LINE ARE THEN IGNORED. AB 221 C 11-20 TGO, RATIO OF AVERAGE RADIATION WIDTH TO LEVEL SPACING FOR AB 222 C ALL S-WAVE NEUTRONS NEAR THE NEUTRON BINDING ENERGY. AB 223 C DEFAULT- GIANT DIPOLE GAMMA STRENGTH COMPUTED AB 224 C INTERNALLY. AB 225 C 21-30 BN, NEUTRON BINDING ENERGY, DEFAULT = 8 MEV. AB 226 C 31-40 FNUG, GAMMA CHANNEL WIDTH FLUCTION DEGREES OF FREEDOM, AB 227 C DEFAULT = 20. AB 228 C 41-50 GGD, E2 GIANT DIPOLE WIDTH, DEFAULT = 5.0. AB 229 C 51-60 EGD, E2 GIANT DIPOLE ENERGY, DEFAULT = 163.*SQRT(N*Z)/ AB 230 C A**1.333. AB 231 C 61-70 XFR, EXCHANGE FRACTION, DEFAULT = 0.5. AB 232 C 70-80 SG, LEVEL DENSITY SPIN COUTOFF PARAMETER, DEFAULT - AB 233 C INTERNALLY COMPUTED. AB 234 C IF NZ=0 THE CAPTURE LINE MUST BE FOLLOWED AB 235 C BY ONE LINE IN FORMAT(16F5.3), AS FOLLOWS -- AB 236 C 1- 5 TGG(1) WHERE THE TGG(K) ARE THE SUM OF GAMMA TRANSMISSION AB 237 C 6-10 TGG(2) COEFFICIENTS FOR THE K-TH TOTAL ANGULAR MOMENTUM AB 238 C ETC. AND EITHER PARITY. AB 239 C 76-80 TGG(16) AB 240 C AB 241 C ********* N-GAMMA, INCLUDE ONLY EFFECTS OF GAMMA-RAY CHANNELS. AB 242 C 1- 7 'N-GAMMA' AB 243 C PARAMETERS ARE IDENTICAL TO THOSE OF 'CAPTURE' LINE. AB 244 C THE SAME RESULTS ARE OBTAINED WITH THE CAPTURE LINE. AB 245 C AB 246 C ********* FISSION, CALCULATE FISSION CROSS SECTIONS. AB 247 C 1- 7 'FISSION' AB 248 C 8-10 NF, TOTAL ANGULAR MOMENTUM IN THE FISSION CHANNELS. AB 249 C MUST BE FOLLOWED BY LINES IN THE FORMAT(16F5.3) AS FOLLOWS- AB 250 C 1- 5 TF+(1), TF+(I) AND TF-(I) ARE THE TOTAL FISSION TRANSM- AB 251 C 6-10 FN+(1), MISSION COEFFICIENTS FOR THE I-TH TOTAL ANGULAR MOM- AB 252 C 11-15 TF-(2), ENTUM AND + AND- PARITIES, RESPECTIVELY. THE AB 253 C 16-20 FN-(2), FN+(I) AND FN-(I) ARE THE CORRESPONDING WIDTH AB 254 C ETC. FLUCTUATION DEGREEES OF FREEDOM. THE VALUES ARE READ AB 255 C IN FOR THE NF TOTAL ANGULAR MOMENTA. AB 256 C AB 257 C **************************END INPUT OUTLINE **************************AB 258 C AB 259 C AB 260 PROGRAM ABAREX AB 261 IMPLICIT REAL*8(A-H,O-Z) AB 262 INTEGER*2 WKY,NQ,DT(13) AB 263 EXTERNAL FCN AB 264 COMMON AB 265 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32),RPEXP,AB 266 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, AB 267 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,ES,GWS0,GWRP,GWS1, AB 268 XS0EXP,S1EXP,ID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0, AB 269 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,ISTR AB 270 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB AB 271 COMMON /COMN/VRE,VRE1,VRE2,R1,A1,VIM,VIM1,VIM2,R2,A2,VIVOL,C2,VSR,AB 272 XVSI,RR1,AA1,X(20),W(20),KP(16) AB 273 COMMON/ZBLOCK/Z(24000) AB 274 COMMON/QBLOCK/NQ(7600) AB 275 COMMON/ASUR/SURF0,SURF1,SURF2 AB 276 C COMMON/ASUR/ ADDED SO SURFACE REAL POTENTIAL AB 277 C CAN BE INCLUDED AS REQUIRED BY DISPERSION RELATIONS. AB 278 C COMMON ZZBLOC ADDED TO STORE ERRORS AB 279 COMMON/ZZBLOC/ZZ(10000) AB 280 C AB 281 C ZBLOCK STORAGE AB 282 C AB 283 C START LENGTH CONTENTS AB 284 C AB 285 C 1 NOCTOT E, GWTOT, A(NGLES) AB 286 C J2 IC XIN (INPUT CROSS SECTIONS) AB 287 C J3 IC DUM AB 288 C J4 (KIN+1)*IC+5*KIN WA (SEARCH CODE WORK AREA) AB 289 C KR KPT VR (SUBROUTINE ABACUS) AB 290 C KI KPT VI AB 291 C KS KPT VS AB 292 C KX KPT-1 X2 AB 293 C KRE KPT+1 URE AB 294 C KIM KPT+1 UIM AB 295 C KREM KPT+1 UREM AB 296 C KIMM KPT+1 UIMM AB 297 C J5 2*(LMAX(1)+1) CR (PHASE SHIFT FACTOR) AB 298 C J6 2*(LMAX(1)+1) CI (PHASE SHIFT FACTOR) AB 299 C J7 2*SUM(I)(LMAX(I)+1) T (TRANSM. COEFFS.) AB 300 C J8 NLEVL SLC AB 301 C J9 NLEVL SIG AB 302 C J10 2*(LMAX(MAX)+1) P AB 303 C J11 2*(LMAX(MAX)+1) P1 AB 304 C J12 SUM(I)(LMAX+1) B (LEGENDRE COEFF.) AB 305 C J13 SUM(LEVEL)(2*I+1) TP AB 306 C J14 SUM(LEVEL)(2*I+1) TM AB 307 C J15 SUM(LEVEL)(2*I+1) SP (WIDTH DISTR COEFF.) AB 308 C J16 SUM(LEVEL)(2*I+1) SM (WIDTH DISTR COEFF.) AB 309 C J17 2*SUM(I)(LMAX(I)+1) T (GAMCAP) AB 310 C J18 NJMAX-NJMIN+1 TCP (GAMCAP) AB 311 C J19 NJMAX-NJMIN+1 TCM (GAMCAP) AB 312 C J20 2*SUM(I)(LMAX(I)+1) T (CONTINUUM) AB 313 C J21 TCON (CONTINUUM) AB 314 C AB 315 C AB 316 DIMENSION VIN(16),FIN(16),FKY(7),TT(13),A(125),KQ(20),IWA(16) AB 317 DATA DT/'DI','IN','TR','RE','IM','SO','N-','CA','FI','LE', AB 318 X'SC','SE','CO'/ AB 319 DATA TT/'DISP','INPUT','TRANSM','REAL','IMAG','SO','N-GAMMA' AB 320 X,'CAPTURE','FISSION','LEVELS','SCAN','SEARCH','COMPUTE'/ AB 321 EQUIVALENCE (VRE,FIN(1)) AB 322 NAMELIST/INPUT/NLEVEL,FNU,DANG,LMAX,Z,ANO,ANU,EX,FI,IPI,KGP, AB 323 XVRE,VRE1,VRE2,R1,A1,KIM,VIM,VIM1,VIM2,R2,A2,VIVOL,C2,KETA, AB 324 XKSO,VSR,VSI,RR1,AA1,TG0,BN,FNUG,EGD,GGD,XFR,SG,NZ,TGG,TFF,FNF, AB 325 XSURF0,SURF1,SURF2,KSCH AB 326 NZB=24000 AB 327 OPEN(5,FILE='INPUT',STATUS='OLD') AB 328 OPEN(6,FILE='OUTPUT',STATUS='NEW') AB 329 DO 29 I=1,NZB AB 330 Z(I)=0 AB 331 29 CONTINUE AB 332 NQB=7600 AB 333 TOL=0.005 AB 334 DO 5 J=1,20 AB 335 5 W(J)=W(J)*DEXP(X(J)) AB 336 1 CONTINUE AB 337 READ(5,5100,END=999)WKY,IKY,(FKY(J),J=1,7) AB 338 5100 FORMAT(A2,5X,I3,7F10.4) AB 339 WRITE(6,6000) AB 340 6000 FORMAT(1H1,40X,'ABAREX'/41X,'======'//' INPUT DECK :'/) AB 341 IF(WKY.EQ.DT(2))GO TO 3 AB 342 C AB 343 C INITIALIZE VARIABLES. AB 344 GWS0=0D0 AB 345 GWRP=0D0 AB 346 GWS1=0D0 AB 347 NTI=0 AB 348 NOCTOT=0 AB 349 IZ=0 AB 350 IQ=0 AB 351 TG0=0D0 AB 352 KS=0 AB 353 KSC=0 AB 354 KSCH=0 AB 355 NRD=0 AB 356 KG=0 AB 357 N=0 AB 358 IPRINT=0 AB 359 NCONT=0 AB 360 NLEVEL=1 AB 361 NLEVL=1 AB 362 NF=0 AB 363 DANG=0D0 AB 364 EX(1)=0D0 AB 365 FI(1)=0D0 AB 366 ID(1)=0D0 AB 367 GW(1)=1D0 AB 368 KGP(1)=0 AB 369 IPI(1)=+1 AB 370 KETA=0 AB 371 KSO=0 AB 372 KK=0 AB 373 IC=0 AB 374 KIM=2 AB 375 ES=0.0 AB 376 KIN=0 AB 377 ISTR=0 AB 378 SURF0=0D0 AB 379 SURF1=0D0 AB 380 SURF2=0D0 AB 381 DO 2 I=1,16 AB 382 2 FIN(I)=0D0 AB 383 C AB 384 DO 400 K=1,13 AB 385 400 IF(WKY.EQ.DT(K))KK=K AB 386 IF(KK.EQ.0)GO TO 200 AB 387 IF(KK.NE.12)WRITE(6,6100)TT(KK),IKY,(FKY(J),J=1,7) AB 388 6100 FORMAT(10X,A7,I3,7F10.4) AB 389 GO TO (201,202,203,205,206,207,208,209,210,211,212,213,214),KK AB 390 200 READ(5,5100,END=999)WKY,IKY,(FKY(J),J=1,7) AB 391 KK=0 AB 392 DO 300 K=1,13 AB 393 300 IF(WKY.EQ.DT(K))KK=K AB 394 IF(KK.EQ.0)GO TO 200 AB 395 IF(KK.NE.12)WRITE(6,6100)TT(KK),IKY,(FKY(J),J=1,7) AB 396 GO TO (201,202,203,205,206,207,208,209,210,211,212,213,214),KK AB 397 C AB 398 C INPUT DISPERSION PARAMETERS UNDER 'DISP'. AB 399 201 SURF0=FKY(1) AB 400 SURF1=FKY(2) AB 401 SURF2=FKY(3) AB 402 GO TO 200 AB 403 C AB 404 C MODIFY INPUT PARAMETERS USING NAMELIST. AB 405 202 GO TO 3 AB 406 C AB 407 C PRINT TRANSMISSION COEFFICIENTS AND STRENGTH FUNCTIONS. AB 408 203 KETA=IKY AB 409 IF(KETA.EQ.0)KETA=20 AB 410 GO TO 200 AB 411 C AB 412 C INPUT REAL POTENTIAL. AB 413 205 DO 305 M=1,5 AB 414 305 FIN(M)=FKY(M) AB 415 IF(FKY(6))309,200,309 AB 416 309 KSO=1 AB 417 FIN(13)=FKY(6) AB 418 FIN(15)=0D0 AB 419 FIN(16)=0D0 AB 420 GO TO 200 AB 421 C AB 422 C INPUT IMAGINARY POTENTIAL AB 423 206 KIM=IKY AB 424 DO 306 M=1,7 AB 425 MM=M+5 AB 426 306 FIN(MM)=FKY(M) AB 427 IF(FIN( 9).EQ.0D0)FIN( 9)=DABS(FIN(4)) AB 428 IF(FIN(10).EQ.0D0)FIN(10)=DABS(FIN(5)) AB 429 V=FIN(11)+FIN(12) AB 430 IF(V)200,200,406 AB 431 406 IF(KIM.EQ.2)KIM=3 AB 432 IF(KIM.EQ.4)KIM=5 AB 433 GO TO 200 AB 434 C AB 435 C INPUT SPIN-ORBIT POTENTIAL. AB 436 207 KSO=IKY AB 437 DO 307 M=1,4 AB 438 MM=M+12 AB 439 307 FIN(MM)=FKY(M) AB 440 GO TO 200 AB 441 C AB 442 C INPUT N-GAMMA REACTION AB 443 208 KG=1 AB 444 GO TO 308 AB 445 C AB 446 C INPUT CAPTURE REACTION AB 447 209 KG=-1 AB 448 308 CONTINUE AB 449 NZ=IKY AB 450 TG0=FKY(1) AB 451 BN=FKY(2) AB 452 FNUG=FKY(3) AB 453 EGD=FKY(4) AB 454 GGD=FKY(5) AB 455 SA=FKY(6) AB 456 SG=FKY(7) AB 457 IF(BN.EQ.0D0)BN=8D0 AB 458 IF(FNUG.EQ.0D0)FNUG=20D0 AB 459 NG=FNUG/2 AB 460 XFR=0.5D0 AB 461 IF(NZ)303,302,303 AB 462 302 NRD=1 AB 463 READ(5,5330)(TGG(K),K=1,16) AB 464 WRITE(6,6330)(TGG(K),K=1,16) AB 465 TG0=1D0 AB 466 IF(KG.EQ.-1)KG=1 AB 467 303 GO TO 200 AB 468 C AB 469 C INPUT FISSION COEFFICIENTS AB 470 210 NF=IKY AB 471 NF2=2*NF AB 472 DO 317 K=1,32 AB 473 TFF(K)=0D0 AB 474 317 FNF(K)=1D0 AB 475 READ(5,5330)( TFF(K),FNF(K) ,K=1,NF2) AB 476 5330 FORMAT(16F5.3) AB 477 WRITE(6,6330)( TFF(K),FNF(K) ,K=1,NF2) AB 478 6330 FORMAT(10X,16F5.3) AB 479 DO 318 K=1,NF2 AB 480 318 IF(FNF(K).EQ.0D0)FNF(K)=1D0 AB 481 GO TO 200 AB 482 C AB 483 C INPUT LEVELS AB 484 211 NLEVEL=IKY AB 485 C NLEVEL IS THE NO. OF LEVELS. AB 486 NZT=IDINT(FKY(1)) AB 487 ECONT=FKY(2) AB 488 ESTEP=FKY(3) AB 489 TAU=FKY(4) AB 490 E0T=FKY(5) AB 491 SGT=FKY(6) AB 492 MXLVL=50 AB 493 C MXLVL IS MAX. NO. OF LEVELS = 50. AB 494 IF(NZT)415,415,416 AB 495 416 NCONT=-1 AB 496 C NCONT=-1 FOR CONTINUUM,=0 FOR NO CONTINUUM. AB 497 IF(FKY(7).GT.0D0)NCONT=1 AB 498 415 NXLVL=NLEVEL-MXLVL AB 499 C NXLVL TESTS FOR EXCEEDING 50-LEVEL LIMIT, IF EXCEEDED AB 500 C NLEVEL SET TO 50 AB 501 IF(NXLVL)411,411,412 AB 502 412 WRITE(6,6060)MXLVL AB 503 6060 FORMAT(1H0,' DISCRETE TARGET LEVELS LIMITED TO',I3) AB 504 NLEVEL=MXLVL AB 505 411 CONTINUE AB 506 C DEFAULT ESTEP FOR CONTINUUM IS 0.2 MEV. AB 507 IF(ESTEP.EQ.0D0)ESTEP=0.2D0 AB 508 IF(NLEVEL.LE.0)GO TO 200 AB 509 DO 310 I=1,NLEVEL AB 510 READ(5,5050)EX(I),FI(I),IPI(I),KGP(I),GW(I) AB 511 5050 FORMAT(F9.4,F4.1,I2,I5,F5.2) AB 512 IF(IPI(I).EQ.0)IPI(I)=+1 AB 513 IF(GW(I).EQ.0.0D0)GW(I)=1.0D0 AB 514 WRITE(6,6050)EX(I),FI(I),IPI(I),KGP(I),GW(I) AB 515 6050 FORMAT(10X,F9.4,F4.1,I2,I5,F5.2) AB 516 FFI=2D0*FI(I) AB 517 ID(I)=IDINT(FFI) AB 518 310 CONTINUE AB 519 IF(NXLVL.LT.1)GO TO 200 AB 520 DO 311 I=1,NXLVL AB 521 311 READ(5,5051)B AB 522 5051 FORMAT(F9.4) AB 523 GO TO 200 AB 524 C AB 525 C INPUT SCAN AB 526 C CAN NOT BOTH SEARCH AND SCAN IN THE SAME PROBLEM. AB 527 212 IF(KSCH.NE.0)GO TO 200 AB 528 C KSC=0 INITIALLY, SET=1 FOR SCAN AB 529 KSC=1 AB 530 IF(IKY.GT.0)GO TO 114 AB 531 DO 112 I=1,7 AB 532 IF(FKY(I).LE.0D0)GO TO 113 AB 533 C KS IS THE NUMBER OF ENERGIES TO BE SCANNED AB 534 KS=KS+1 AB 535 Z(KS)=FKY(I) AB 536 112 CONTINUE AB 537 GO TO 113 AB 538 114 DO 115 I=1,50 AB 539 KS=KS+1 AB 540 Z(KS)=FKY(1)+DFLOAT(I)*FKY(2)-FKY(2) AB 541 IF((Z(KS)+FKY(2)).GT.FKY(3))GO TO 113 AB 542 115 CONTINUE AB 543 113 GO TO 200 AB 544 C AB 545 C INPUT SEARCH AB 546 213 IF(KSC.GT.0)GO TO 200 AB 547 IF(IKY)262,269,269 AB 548 262 IF(KS.GT.0)GO TO 200 AB 549 ISTR=1 AB 550 ES=FKY(1) AB 551 IF(ES.EQ.0D0)ES=1D-6 AB 552 S0EXP=FKY(2) AB 553 RPEXP=FKY(4) AB 554 IC=3 AB 555 S1EXP=FKY(6) AB 556 KSCH=-3 AB 557 GWS0=FKY(3) AB 558 GWRP=FKY(5) AB 559 GWS1=FKY(7) AB 560 9876 FORMAT(16I1,F12.6) AB 561 READ(5,9876)(KP(JJX),JJX=1,16),XTOL AB 562 IF(XTOL.GT.0.)TOL=XTOL AB 563 KMAG=5 AB 564 268 WRITE(6,6100)TT(12),IKY,(FKY(I),I=1,7) AB 565 GO TO 200 AB 566 269 IF(KSCH.EQ.0)KSCH=1 AB 567 C KSCH=1 FOR SEARCH ON TOTAL XSEC OR DIFFERENTIAL XSEC. AB 568 ISTR=0 AB 569 KS=KS+1 AB 570 IQ=IQ+1 AB 571 NQ(IQ)=0 AB 572 C IF NO TOTAL-CROSS-SECTION FITTING GO TO 221 AB 573 IF(FKY(2))221,221,222 AB 574 222 NQ(IQ)=1 AB 575 IC=IC+1 AB 576 C DEFAULT TOTAL XSEC WT. = 1.0 AB 577 IF(FKY(3).EQ.0D0)FKY(3)=1D0 AB 578 221 IF(FKY(4).NE.0D0)IPRINT=IDINT(FKY(4)) AB 579 IF(FKY(5).GT.0D0)TOL=FKY(5) AB 580 C DECODE PARAMETER SELECTION FOR FITTING AB 581 FKY(6)=FKY(6)*1D-6+1D-11 AB 582 NTO=NQ(IQ) AB 583 IQ=IQ+1 AB 584 NQ(IQ)=IKY AB 585 NOB=IKY AB 586 IQ=IQ+1 AB 587 FQ=0D0 AB 588 DO 230 I=1,10 AB 589 FKY(6)=(FKY(6)-FQ)*1D1 AB 590 KQ(I)=IDINT(FKY(6)) AB 591 230 FQ=DFLOAT(KQ(I)) AB 592 FKY(7)=FKY(7)*1D-6+1D-11 AB 593 FQ=0D0 AB 594 DO 231 I=1,10 AB 595 FKY(7)=(FKY(7)-FQ)*1D1 AB 596 II=I+10 AB 597 KQ(II)=IDINT(FKY(7)) AB 598 231 FQ=DFLOAT(KQ(II)) AB 599 KQS=0 AB 600 DO 235 I=1,16 AB 601 235 KQS=KQS+KQ(I) AB 602 C IF NO FIT PARAMETER GO TO 240, KMAG = 0 USES STATISTICAL WEIGHTS. AB 603 C IF KMAG=5 ERROR IN PERCENTAGE IS READ IN. AB 604 IF(KQS)240,240,242 AB 605 242 DO 244 I=1,16 AB 606 244 KP(I)=KQ(I) AB 607 KMAG=KQ(20) AB 608 240 CONTINUE AB 609 WRITE(6,6110)TT(12),IKY,(FKY(I),I=1,5),(KQ(I),I=1,20) AB 610 6110 FORMAT(10X,A7,I3,5F10.4,20I1) AB 611 IZLAST=IZ AB 612 C INSERT NEW DATA INTO ZBLOCK AB 613 NOC=NOB+1+NTO AB 614 IZ=IZ+NOC AB 615 C IIZ AND IIQ FOR INDEXING ON ERRORS AB 616 IIZ=IZ AB 617 IIQ=IQ AB 618 IF(NTO)180,180,181 AB 619 181 IZ=IZ+1 AB 620 IIZ=IZ AB 621 Z(IZ)=FKY(2) AB 622 180 CONTINUE AB 623 IF(NOB.LT.1)GO TO 35 AB 624 DO 30 J=1,NOB AB 625 IQ=IQ+1 AB 626 NQ(IQ)=0 AB 627 C READ INTO Z(IZ) THE ANGLES AND 7 DIFFERENTIAL XSECS (SGSCT) AB 628 READ(5,5220)A(J), SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 629 XSGSCT(5),SGSCT(6),SGSCT(7) AB 630 5220 FORMAT(8F10.4) AB 631 WRITE(6,6220)A(J), SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 632 XSGSCT(5),SGSCT(6),SGSCT(7) AB 633 6220 FORMAT(10X,8F10.4) AB 634 DO 251 K=1,7 AB 635 L=8-K AB 636 IF(SGSCT(L))251,251,250 AB 637 250 NQ(IQ)=L AB 638 GO TO 252 AB 639 251 CONTINUE AB 640 252 L=NQ(IQ) AB 641 IF(L.LE.0)GO TO 253 AB 642 DO 238 K=1,L AB 643 IQ=IQ+1 AB 644 NQ(IQ)=0 AB 645 IF(SGSCT(K))238,238,236 AB 646 236 NQ(IQ)=1 AB 647 IZ=IZ+1 AB 648 Z(IZ)=SGSCT(K) AB 649 IC=IC+1 AB 650 238 CONTINUE AB 651 253 CONTINUE AB 652 30 CONTINUE AB 653 C READ IN PERCENTAGE ERRORS. AB 654 IF(KMAG.NE.5)GO TO 35 AB 655 DO 530 J=1,NOB AB 656 IIQ=IIQ+1 AB 657 READ(5,5220)BB, SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 658 XSGSCT(5),SGSCT(6),SGSCT(7) AB 659 WRITE(6,6220)BB, SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 660 XSGSCT(5),SGSCT(6),SGSCT(7) AB 661 LL=NQ(IIQ) AB 662 IF(LL.LE.0)GO TO 5253 AB 663 DO 5238 K=1,LL AB 664 IIQ=IIQ+1 AB 665 IF(SGSCT(K))5238,5238,5236 AB 666 5236 IIZ=IIZ+1 AB 667 ZZ(IIZ)=SGSCT(K) AB 668 5238 CONTINUE AB 669 5253 CONTINUE AB 670 530 CONTINUE AB 671 35 CONTINUE AB 672 C PUSH OLD DATA FORWARD IN IN ZBLOCK AB 673 ILONG=IZLAST-NOCTOT AB 674 IF(ILONG.LT.1)GO TO 194 AB 675 DO 187 I=1,ILONG AB 676 J=IZLAST+1-I AB 677 JJ=J+NOC AB 678 Z(JJ)=Z(J) AB 679 ZZ(JJ)=ZZ(J) AB 680 187 CONTINUE AB 681 C INSERT NEW ENERGY, TOTAL WEIGHT, ANGLES INTO ZBLOCK AB 682 194 I=NOCTOT+1 AB 683 Z(I)=FKY(1) AB 684 IF(NTO)188,188,189 AB 685 189 I=I+1 AB 686 Z(I)=FKY(3) AB 687 188 IF(NOB)190,190,191 AB 688 191 DO 192 J=1,NOB AB 689 I=I+1 AB 690 192 Z(I)=A(J) AB 691 190 CONTINUE AB 692 NOCTOT=NOCTOT+NOC AB 693 GO TO 200 AB 694 C AB 695 C INPUT COMPUTE AB 696 214 LMAX=IKY AB 697 C LMAX IS LIMIT ON L, DEFUALT=0 FOR INTERNAL DETERMINATION AB 698 C E=ENERGY, ANO=TARGET MASS,ANU=PROJECTILE MASS(DEFAULT=NEUT) AB 699 C FNU FOR CORRECTION, DEFAULT PAM CALCULATION,= NEGATIVE FOR AB 700 C SIMPLE H-F CALCULATION(I.E., NO WFC) AB 701 C DANG IS ANGULAR STEPS, DEFAULT=15 DEG. AB 702 C MATCHING RADIUS, DEFAULT=15 FM AB 703 C PTS=INTEGRATION MESH, DEFAULT=301 AB 704 E=FKY(1) AB 705 ANO=FKY(2) AB 706 ANU=FKY(3) AB 707 FNU=FKY(4) AB 708 DANG=FKY(5) AB 709 C1=FKY(6) AB 710 PTS=FKY(7) AB 711 C FORCE DEFAULT VALUES FOR TEST CALCULATIONS AB 712 IF(E.EQ.0D0)E=0.8D0 AB 713 IF(ANO.EQ.0D0)ANO=55.9349D0 AB 714 IF(ANU.EQ.0D0)ANU=1.008665D0 AB 715 IF(DANG.EQ.0D0)DANG=15D0 AB 716 IF(C1.EQ.0D0)C1=15D0 AB 717 IF(KS.GT.0)GO TO 220 AB 718 KS=1 AB 719 C E GOES TO Z(1) AB 720 Z(1)=E AB 721 220 CONTINUE AB 722 IF(VRE.NE.0D0)GO TO 217 AB 723 VRE=46.0 AB 724 R1=1.317 AB 725 A1=0.62 AB 726 217 IF(VSR.GT.0D0)GO TO 218 AB 727 KSO=1 AB 728 VSR=7.0 AB 729 RR1=1.317 AB 730 AA1=0.62 AB 731 218 IF(VIM.GT.0D0)GO TO 216 AB 732 KIM=4 AB 733 VIM=14.0 AB 734 R2=1.447 AB 735 A2=0.25 AB 736 216 CONTINUE AB 737 GO TO 316 AB 738 3 READ(5,INPUT) AB 739 316 CONTINUE AB 740 IF(IQ.LE.NQB)GO TO 160 AB 741 C CHECK TO INSURE THAT SEARCH HAS NOT EXCEEDED STORAGE AB 742 IQ=NQB-IQ AB 743 WRITE(6,6300)NQB,IQ AB 744 6300 FORMAT(1H0/' FOR THE SEARCH OPTION THE NUMBER OF ENERGIES * ((NO. AB 745 XOF LEVELS + 1) * NO. OF ANGLES + 3) IS LIMITED TO',I6,'.'/' THIS NAB 746 XUMBER IS EXCEEDED IN THIS INPUT BY',I6) AB 747 STOP AB 748 160 CONTINUE AB 749 IF(KSCH.EQ.0)NOCTOT=KS AB 750 C IF NO CONTINUUM CONTRIBUTIONS AB 751 IF(NLEVEL.EQ.0)NLEVEL=1 AB 752 C SETS ECONT TO EX OF LAST LEVEL AB 753 IF(ECONT.EQ.0D0)ECONT=EX(NLEVEL) AB 754 J1=1 AB 755 J2=J1+NOCTOT AB 756 IF(PTS)50,50,51 AB 757 C SETS INTEGRATION MESH KPT TO DEFAULT 301 OR INPUT VALUE AB 758 50 KPT=301 AB 759 GO TO 52 AB 760 51 KPT=INT(PTS) AB 761 52 CONTINUE AB 762 FF1=FI(1) AB 763 C FF1=GRND. STATE SPIN AB 764 C NGP=KGP=GROUP NUMBER, IF=0 GO TO DEFAULT VALUES. AB 765 R(1)=ANU/ANO AB 766 NGP=KGP(1) AB 767 IF(NGP)76,75,76 AB 768 75 DO 78 I=1,NLEVEL AB 769 78 KGP(I)=I AB 770 76 CONTINUE AB 771 WRITE(6,6001)ANO,ANU,C1,KPT AB 772 6001 FORMAT(1H0///' MASS NUMBERS(TARGET/PROJECTILE) =',F10.6,'/',F9.6/ AB 773 X' ============'// AB 774 X ' OPTICAL MODEL PARAMETERS :',10X,'ASYMPTOPIA=',F8.4,' FM',I15, AB 775 X' POINTS'/' ========================'//' TYPE',7X,'DEPTH',6X, AB 776 X'(E)',6X,'(E*E)',6X,'RADIUS',5X,'DIFF.',3X,'VIVOL',7X,'C2', AB 777 X4X,'VOLINT'/) AB 778 TTEMP=((DACOS(-1D0))*FIN(5))/(FIN(4)*(ANO**0.33333)) AB 779 REALVL=((4*(DACOS(-1D0))*(FIN(4)**3))/3)*(1+TTEMP**2) AB 780 REALVL=FIN(1)*REALVL AB 781 RWW=FIN(9)*(ANO**0.33333) AB 782 TTEMW=(((DACOS(-1D0))*FIN(10))/RWW)**2 AB 783 AGVAL=16*(DACOS(-1D0))*(RWW**2)*FIN(6)*FIN(10)/ANO AB 784 AGVAL=AGVAL*(1+0.333333*TTEMW) AB 785 C END OF VOLUME-INTEGRAL GENERATION AB 786 IF(KIM.NE.4)AGVAL=0D0 AB 787 C SETS R AND A FOR S-O EQUAL TO THAT OF V-R IF THAT OPTION IS USED. AB 788 RS=FIN(15) AB 789 AS=FIN(16) AB 790 IF(RS.EQ.0D0)RS=R1 AB 791 IF(AS.EQ.0D0)AS=A1 AB 792 C PRINTS INITIAL WELL PARAMETERS AB 793 WRITE(6,6101)(FIN(I),I=1,5),REALVL AB 794 WRITE(6,6102)KIM,(FIN(I),I=6,12),AGVAL AB 795 WRITE(6,6103)KSO,(FIN(I),I=13,14),RS,AS AB 796 WRITE(6,6104)SURF0,SURF1,SURF2 AB 797 6101 FORMAT(' REAL 1',5F10.4,20X,1F10.4) AB 798 6102 FORMAT(' IMAG',I5,8F10.4) AB 799 6103 FORMAT(' S.O.',I5,2F10.4,10X,2F10.4) AB 800 6104 FORMAT(' DISP',5X,3F10.4) AB 801 IF((KG.EQ.0).AND.(NCONT.EQ.0))GO TO 328 AB 802 IF(NZ.EQ.0)NZ=NZT AB 803 IF(NZ)312,312,314 AB 804 312 NDEF=1 AB 805 NZ=-NZ AB 806 GO TO 326 AB 807 314 NDEF=0 AB 808 326 AND=DINT(ANO) AB 809 IF(ANO-AND-0.5D0)320,322,322 AB 810 320 NA=AND+1D0 AB 811 GO TO 324 AB 812 322 NA=AND+2D0 AB 813 324 NN=NA-NZ AB 814 NZN=NZ*NN AB 815 AZ=DFLOAT(NZN) AB 816 328 CONTINUE AB 817 IF(KSCH.EQ.0)GO TO 130 AB 818 KIN=0 AB 819 DO 100 I=1,16 AB 820 IF(KP(I).LE.0)GO TO 100 AB 821 KIN=KIN+1 AB 822 VIN(KIN)=FIN(I) AB 823 100 CONTINUE AB 824 IF(KIN.EQ.0)GO TO 131 AB 825 WRITE(6,6003)KIN AB 826 6003 FORMAT(1H0/25X,' SEARCH FOR',I3,' PARAMETERS') AB 827 IF(KMAG-1)101,103,103 AB 828 101 WRITE(6,6005) AB 829 GO TO 104 AB 830 103 WRITE(6,6006) AB 831 104 CONTINUE AB 832 6005 FORMAT(1H+,13X,' CHI-SQUARE') AB 833 6006 FORMAT(1H+,' NORMALIZED LEAST SQUARE') AB 834 L=0 AB 835 N=NOCTOT AB 836 IQ=0 AB 837 IF(KSCH.GT.0)GO TO 330 AB 838 C CHANGES FOR PRINTOUT AND *1D-4 IN STR FN SEARCH AB 839 WRITE(6,6080)ES,S0EXP,GWS0 AB 840 6080 FORMAT(1H0,' AT LAB ENERGY =',F12.8/' S-WAVE STRENGTH FN. ='AB 841 X,F8.4,'D-4 WEIGHT =',F10.4) AB 842 S0EXP=S0EXP*(1D-4) AB 843 WRITE(6,6081)RPEXP,GWRP AB 844 6081 FORMAT(' R - PRIME =',F8.4,' FM WEIGHT =', AB 845 XF10.4) AB 846 WRITE(6,6082)S1EXP,GWS1 AB 847 6082 FORMAT(' P-WAVE STRENGTH FN. =',F8.4,'D-4 WEIGHT =', AB 848 XF10.4) AB 849 S1EXP=S1EXP*(1D-4) AB 850 330 continue AB 851 DO 140 K=1,KS AB 852 IQ=IQ+1 AB 853 L=L+1 AB 854 ECM=Z(L)/(1+R(1)) AB 855 IF(ISTR.EQ.0)WRITE(6,6090)Z(L),ECM AB 856 6090 FORMAT(1H0, ' AT LAB/CM ENERGY =',F10.6,'/',F9.6,' MEV') AB 857 IF(NQ(IQ))139,139,141 AB 858 141 L=L+1 AB 859 N=N+1 AB 860 WRITE(6,6095)Z(N),Z(L) AB 861 6095 FORMAT(1H0,' TOTAL CROSS SECTION DATA',F12.6,' WEIGHT=', AB 862 XF10.4) AB 863 139 CONTINUE AB 864 IQ=IQ+1 AB 865 NOB=NQ(IQ) AB 866 IF(NOB.GT.0)WRITE(6,6097) AB 867 6097 FORMAT(1H0,' SCATTERING DATA'//4X,'ANGLE',5X,'CROSS SECTION DATAB 868 XA FOR SUCCESSIVE LEVEL GROUPS'/) AB 869 IQ=IQ+1 AB 870 NLEVL=1 AB 871 IF(NLEVEL.LT.2)GO TO 3007 AB 872 DO 3010 I=2,NLEVEL AB 873 IF(EX(I).GE.ECM)GO TO 3010 AB 874 R(I)=R(1)*DSQRT(ECM/(ECM-EX(I))) AB 875 IF(R(I).LT.1D0)NLEVL=I AB 876 3010 CONTINUE AB 877 3007 CONTINUE AB 878 IF(NGP)3013,3014,3018 AB 879 3013 NQ(IQ)=1 AB 880 GO TO 3017 AB 881 3014 NQ(IQ)=NLEVL AB 882 GO TO 3017 AB 883 3018 DO 3015 I=1,NLEVL AB 884 J=NLEVL-I+1 AB 885 IF(KGP(J))3015,3015,3016 AB 886 3015 CONTINUE AB 887 3016 NQ(IQ)=IABS(KGP(J)) AB 888 3017 CONTINUE AB 889 IF(NOB.LT.1)GO TO 140 AB 890 DO 142 J=1,NOB AB 891 IQ=IQ+1 AB 892 L=L+1 AB 893 NOM=NQ(IQ) AB 894 MXLVL=0 AB 895 DO 144 I=1,NOM AB 896 IQ=IQ+1 AB 897 SGSCT(I)=0D0 AB 898 IF(NQ(IQ))144,144,143 AB 899 143 N=N+1 AB 900 MXLVL=I AB 901 SGSCT(I)=Z(N) AB 902 144 CONTINUE AB 903 IF(MXLVL.LE.0)GO TO 142 AB 904 WRITE(6,6004)Z(L),(SGSCT(I),I=1,MXLVL) AB 905 6004 FORMAT(1H ,F8.2,7F10.5) AB 906 142 CONTINUE AB 907 140 CONTINUE AB 908 LWA=(KIN+1)*IC+5*KIN AB 909 J3=J2+IC AB 910 J4=J3+IC AB 911 J5=J4+LWA+4+8*KPT AB 912 IF(J5.LE.NZB)GO TO 170 AB 913 J5=NZB-J5 AB 914 WRITE(6,6200)J5 AB 915 6200 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA BY',I6,' REAL*8AB 916 X LOCATIONS.') AB 917 STOP AB 918 170 CONTINUE AB 919 NIT=0 AB 920 KETA=0 AB 921 IF(IPRINT)175,176,175 AB 922 175 IPRINT=1 AB 923 KETA=-1 AB 924 WRITE(6,6010) AB 925 6010 FORMAT(1H1,'GENERATED OPTICAL MODEL PARAMETERS IN SEARCH :',62X, AB 926 X'STATISTIC'//) AB 927 176 IXDUM=IC AB 928 CALL LMDIF1(FCN,IXDUM,KIN,VIN,Z(J3),TOL,INFO,IWA,Z(J4),LWA) AB 929 IC=IXDUM AB 930 WRITE(6,6500)NIT AB 931 6500 FORMAT(1H0,' SEARCH TERMINATED AFTER',I5,' CALLS') AB 932 GO TO (501,501,501,504,505,506,506),INFO AB 933 WRITE(6,6550) AB 934 GO TO 510 AB 935 501 WRITE(6,6551)INFO AB 936 GO TO 510 AB 937 504 WRITE(6,6554) AB 938 GO TO 510 AB 939 505 WRITE(6,6555) AB 940 GO TO 510 AB 941 506 WRITE(6,6556)INFO AB 942 510 CONTINUE AB 943 6550 FORMAT(1H+,37X,'DUE TO IMPROPER INPUT PARAMETERS (INFO=0)') AB 944 6551 FORMAT(1H+,37X,'UPON CONVERGENCE (INFO=',I1,')') AB 945 6554 FORMAT(1H+,36X,'. PARAMETER VECTOR ORTHOGONAL TO JACOBIAN COLUMNS.AB 946 X') AB 947 6555 FORMAT(1H+,36X,'. LIMIT OF ALLOWED CALLS.') AB 948 6556 FORMAT(1H+,36X,'. TOL IS TOO SMALL (INFO=',I1,')') AB 949 KIN=0 AB 950 DO 150 I=1,16 AB 951 IF(KP(I).LE.0)GO TO 150 AB 952 KIN=KIN+1 AB 953 FIN(I)=VIN(KIN) AB 954 150 CONTINUE AB 955 131 KETA=0 AB 956 130 CONTINUE AB 957 J5=J2+4+8*KPT AB 958 KIN=0 AB 959 CALL FCN(0,0,C,D,IFLAG) AB 960 GO TO 1 AB 961 999 STOP AB 962 END AB 963 C **********************************************************************AB 964 SUBROUTINE FCN(MI,NI,FOP,U,IFLAG) AB 965 IMPLICIT REAL*8(A-H,O-Z) AB 966 INTEGER*2 NQ AB 967 COMMON AB 968 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32),RPEXP,AB 969 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, AB 970 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,ES,GWS0,GWRP,GWS1, AB 971 XS0EXP,S1EXP,ID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0, AB 972 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,ISTR AB 973 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB AB 974 COMMON /COMN/FIN(16),X(20),W(20),KP(16) AB 975 COMMON/ZBLOCK/Z(24000) AB 976 COMMON/ZZBLOC/ZZ(10000) AB 977 COMMON/QBLOCK/NQ(7600) AB 978 COMMON/ASUR/SURF0,SURF1,SURF2 AB 979 DIMENSION TPP(20),TMP(20),FOP(1),U(1),AIN(16),MM(50),KD(50,100), AB 980 XLLMX(50) AB 981 KSTOP=0 AB 982 IP=1 AB 983 IZ=0 AB 984 IM=-1 AB 985 NIT=NIT+1 AB 986 NO=0 AB 987 DO 400 I=1,16 AB 988 IF(KIN.LE.0)GO TO 410 AB 989 IF(KP(I))410,410,420 AB 990 420 NO=NO+1 AB 991 GO TO(430,431,431,430,430,430,431,431),I AB 992 430 AIN(I)=DABS(FOP(NO)) AB 993 GO TO 400 AB 994 431 AIN(I)=FOP(NO) AB 995 GO TO 400 AB 996 410 AIN(I)=FIN(I) AB 997 400 CONTINUE AB 998 IF(KETA.LT.0)WRITE(6,6100)(FOP(I),I=1,NO) AB 999 6100 FORMAT(5D12.4) AB 1000 490 CONTINUE AB 1001 KISCH=KIN AB 1002 IF(KSCH.NE.0)KISCH=KISCH+1 AB 1003 C KISCH=1 : SEARCH TERMINATED AB 1004 IF(KISCH.NE.1)GO TO 495 AB 1005 WRITE(6,6001) AB 1006 6001 FORMAT(1H1,' FINAL OPTICAL MODEL PARAMETERS :'/' ================AB 1007 X================' //' TYPE',7X,'DEPTH',6X, AB 1008 X'(E)',6X,'(E*E)',6X,'RADIUS',5X,'DIFF.',3X,'VIVOL',7X,'C2', AB 1009 X4X,'VOLINT'/) AB 1010 TTEMP=((DACOS(-1D0))*AIN(5))/(AIN(4)*(ANO**0.33333)) AB 1011 REALVL=((4*(DACOS(-1D0))*(AIN(4)**3))/3)*(1+TTEMP**2) AB 1012 REALVL=AIN(1)*REALVL AB 1013 RWW=AIN(9)*(ANO**0.33333) AB 1014 TTEMW=(((DACOS(-1D0))*AIN(10))/RWW)**2 AB 1015 AGVAL=16*(DACOS(-1D0))*(RWW**2)*AIN(6)*AIN(10)/ANO AB 1016 AGVAL=AGVAL*(1+0.333333*TTEMW) AB 1017 IF(KIM.NE.4)AGVAL=0D0 AB 1018 RS=AIN(15) AB 1019 AS=AIN(16) AB 1020 IF(RS.EQ.0D0)RS=AIN(4) AB 1021 IF(AS.EQ.0D0)AS=AIN(5) AB 1022 WRITE(6,6101)(AIN(I),I=1,5),REALVL AB 1023 WRITE(6,6102)KIM,(AIN(I),I=6,12),AGVAL AB 1024 WRITE(6,6103)KSO,(AIN(I),I=13,14),RS,AS AB 1025 6101 FORMAT(' REAL 1',5F10.4,20X,1F10.4) AB 1026 6102 FORMAT(' IMAG',I5,8F10.4) AB 1027 6103 FORMAT(' S.O.',I5,2F10.4,10X,2F10.4//) AB 1028 495 CONTINUE AB 1029 NJ2=J2-1 AB 1030 NJ3=0 AB 1031 CHISQ=0D0 AB 1032 NC=0 AB 1033 IF(NCONT.EQ.0)GO TO 3096 AB 1034 IF(TAU.GT.0D0)GO TO 3120 AB 1035 NNT=NN-1 AB 1036 NAT=NA-1 AB 1037 AAT=DFLOAT(NAT) AB 1038 CALL PRSL(NZ,NNT,PRT,SCT) AB 1039 UXT=2.5D0+150D0/AAT AB 1040 EXT=UXT+PRT AB 1041 SAT=(0.00917D0*SCT+0.142D0-0.022D0*NDEF)*AAT AB 1042 E0T=DSQRT(SAT*UXT) AB 1043 TAU=DSQRT(SAT/UXT)-1.5D0/UXT AB 1044 ATAU=DABS(TAU) AB 1045 IF(ATAU-1D-50)3097,3097,3098 AB 1046 3097 NCONT =0 AB 1047 GO TO 3096 AB 1048 3098 TAU=1D0/TAU AB 1049 SGSQT=0.1776D0*E0T*AAT**0.6667D0 AB 1050 SGT=DSQRT(SGSQT/2D0) AB 1051 E0T=DEXP(2D0*E0T)/(16.97056D0*UXT*SGT*DSQRT(E0T)) AB 1052 E0T=EXT-TAU*DLOG(TAU*E0T) AB 1053 3120 SGSQT=2D0*SGT*SGT AB 1054 RHO=(ECONT-E0T)/TAU AB 1055 RHO=DEXP(RHO)/TAU AB 1056 3096 CONTINUE AB 1057 NCNT=NCONT AB 1058 UX=1 AB 1059 IF(KG)3077,3076,3077 AB 1060 3077 IF(NRD.EQ.1)GO TO 3075 AB 1061 IF(EGD)3330,3332,3334 AB 1062 3332 EGD=163D0*DSQRT(AZ)/(NA**1.3333) AB 1063 GO TO 3334 AB 1064 3330 IF(TG0.EQ.0D0)GO TO 3332 AB 1065 KGD=0 AB 1066 GO TO 3335 AB 1067 3334 KGD=1 AB 1068 IF(GGD.LE.0D0)GGD=5D0 AB 1069 3335 CALL PRSL(NZ,NN,PR,SC) AB 1070 KOPG=0 AB 1071 IF(TG0.LT.0)KOPG=1 AB 1072 AA=DFLOAT(NA) AB 1073 H=5.0571D0*AA**0.33333 AB 1074 UX=2.5D0+150D0/AA AB 1075 EXX=UX+PR AB 1076 SSA=SA AB 1077 IF(SSA.GT.0)GO TO 3331 AB 1078 SA=(0.00917D0*SC+0.142D0-0.022D0*NDEF)*AA AB 1079 3331 CONTINUE AB 1080 SGSQ=SG*SG*2D0 AB 1081 IF(SG.EQ.0D0)SGSQ=0.1776D0*DSQRT(SA*UX)*AA**0.66667D0 AB 1082 SIGMA=SGSQ/2D0 AB 1083 SIGMA=DSQRT(SIGMA) AB 1084 ATG0=DABS(TG0) AB 1085 IF(KISCH.GT.1)GO TO 3076 AB 1086 WRITE(6,6311)NA,NZ,NN,BN,FNUG,SIGMA AB 1087 IF(NDEF.EQ.1)WRITE(6,6312) AB 1088 IF(TG0.EQ.0D0)GO TO 3336 AB 1089 WRITE(6,6313)ATG0 AB 1090 3336 CONTINUE AB 1091 IF(KGD.EQ.0)WRITE(6,6314) AB 1092 IF(KGD.EQ.1)WRITE(6,6315)EGD,GGD,XFR AB 1093 IF(KG.GE.0)GO TO 3076 AB 1094 IF(KOPG.LE.0)WRITE(6,6321) AB 1095 IF(KOPG.GT.0)WRITE(6,6322) AB 1096 GO TO 3076 AB 1097 3075 WRITE(6,6316)(TGG(K),K=1,16) AB 1098 3076 CONTINUE AB 1099 6311 FORMAT(1H0/' RADIATIVE CAPTURE INTO COMPOUND NUCLEUS'/ AB 1100 X' =======================================' AB 1101 X //' A=',I3,AB 1102 X' Z=',I3,' N=',I3,5X,F9.3,' MEV NEUTRON BINDING',5X,F6.2,' RADIAB 1103 XATIVE D. OF F.',5X,'SIGMA=',F6.3) AB 1104 6312 FORMAT(1H+,90X,'DEFORMED') AB 1105 6313 FORMAT(1H0,' NORMALIZED TO SLOW S-WAVE NEUTRON GAMMA WIDTHS/SPACIAB 1106 XNGS =',E12.4) AB 1107 6314 FORMAT(1H0,' E1 STRONG COUPLING MODEL') AB 1108 6315 FORMAT(1H0,' E1 GIANT RESONANCE AT ',F7.2,' MEV WIDTH=',F7.2, AB 1109 X' MEV',5X,'EXCHANGE FRACTION=',F4.2) AB 1110 6316 FORMAT(1H0,' GAMMA TRANSMISSION FACTORS(COMPOUND ANG. MOM.) WERE AB 1111 XREAD IN AS'//(8F10.6)) AB 1112 6321 FORMAT(1H0,' BLACK NUCLEUS SECOND CHANCE NEUTRON CHANNELS') AB 1113 6322 FORMAT(1H0,' OPTICAL MODEL SECOND CHANCE NEUTRON CHANNELS') AB 1114 IQ=0 AB 1115 IF(KSCH)140,141,141 AB 1116 140 KSH=KSCH AB 1117 IF(KISCH.EQ.1)WRITE(6,6400)ES AB 1118 6400 FORMAT(1H0,20X,'AT',D12.4,' MEV',8X,'L',5X,'J',6X,'GAMMASQ/D',5X, AB 1119 X'R-INFINITY',6X,'STR.FN.',8X,'R-PRIME') AB 1120 CALL ABACUS(1,ES,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,1,1,J5,J6,J7,KSH) AB 1121 IF(KSH.EQ.-10)GO TO 142 AB 1122 IF(KISCH.EQ.1)GO TO 141 AB 1123 NJ3=1 AB 1124 U(NJ3)=(Z(J5)-S0EXP)*100./(GWS0*S0EXP) AB 1125 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1126 NJ5=J5+1 AB 1127 NJ3=2 AB 1128 U(NJ3)=(Z(NJ5)-RPEXP)*100./(GWRP*RPEXP) AB 1129 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1130 NJ5=NJ5+1 AB 1131 NJ3=3 AB 1132 U(NJ3)=(Z(NJ5)-S1EXP)*100./(GWS1*S1EXP) AB 1133 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1134 141 CONTINUE AB 1135 IF(ISTR.NE.0)GO TO 501 AB 1136 DO 500 KK=1,KS AB 1137 IQ=IQ+1 AB 1138 NTO=NQ(IQ) AB 1139 IQ=IQ+1 AB 1140 NOA=NQ(IQ) AB 1141 IQ=IQ+1 AB 1142 NCONT=NCNT AB 1143 NC=NC+1 AB 1144 ECM=Z(NC)/(1D0+R(1)) AB 1145 FLMB=DSQRT(Z(NC)*ANU)/(1D0+R(1)) AB 1146 FLMB=0.457208D0/FLMB AB 1147 IF((ECONT+ESTEP).GE.ECM)NCONT=0 AB 1148 FFNU=FNU AB 1149 IF(NCONT.NE.0)FFNU=-1D0 AB 1150 NLEVL=1 AB 1151 IF(NLEVEL.LT.2)GO TO 3007 AB 1152 DO 3010 I=2,NLEVEL AB 1153 IF(EX(I).GE.ECM)GO TO 3010 AB 1154 R(I)=R(1)*DSQRT(ECM/(ECM-EX(I))) AB 1155 IF(R(I).LT.1D0)NLEVL=I AB 1156 3010 CONTINUE AB 1157 3007 CONTINUE AB 1158 IF(KISCH.GT.1)GO TO 3094 AB 1159 IF(KSC.GT.0)WRITE(6,6300) AB 1160 6300 FORMAT(1H1) AB 1161 IF(KSCH.NE.0)WRITE(6,6303) AB 1162 6303 FORMAT(1H0//) AB 1163 WRITE(6,6301)KK,Z(NC),ECM,FLMB AB 1164 6301 FORMAT(1H0,'NO.',I2,' ENERGY(LABORATORY/C.M.) =',F10.6,'/',F9.6 AB 1165 X,' MEV',10X,'LAMBDA-BAR =',F9.5,' SQRT-BARN'/' ============') AB 1166 IF(ECM.LT.1D-3)WRITE(6,6331)Z(NC),ECM AB 1167 6331 FORMAT(1H+,32X,D10.3,'/',D10.3) AB 1168 IF(FFNU)3089,3091,3092 AB 1169 3089 WRITE(6,6309) AB 1170 6309 FORMAT(1H0,'NO WIDTH FLUCTUATION CORRECTION') AB 1171 GO TO 3093 AB 1172 3091 WRITE(6,6310) AB 1173 WRITE(6,6319) AB 1174 GO TO 3093 AB 1175 3092 WRITE(6,6310) AB 1176 WRITE(6,6318)FFNU AB 1177 6319 FORMAT(1H+,53X,'ARE COMPUTED INTERNALLY.') AB 1178 6318 FORMAT(1H+,53X,'= ',F5.2) AB 1179 6310 FORMAT(1H0,'NEUTRON CHANNEL WIDTH FLUCTUATION DEGREES OF FREEDOM')AB 1180 3093 CONTINUE AB 1181 WRITE(6,6404) AB 1182 6404 FORMAT(1H0/15X,'TARGET LEVELS'/15X,'============='// AB 1183 X ' LEVEL GROUP ENERGY SPIN PARITY WEIGHT'/) AB 1184 WRITE(6,6302)( I,KGP(I),EX(I),FI(I),IPI(I),GW(I) ,I=1,NLEVL) AB 1185 6302 FORMAT(2I6,F10.4,F7.1,I6,F12.2) AB 1186 IF(NCONT.NE.0)WRITE(6,6308) ECONT,TAU,E0T,SGT,ECONT,RHO AB 1187 6308 FORMAT(1H0/' TARGET LEVEL CONTINUUM STARTS AT',F6.2,' MEV'//' AB 1188 XLEVEL DENSITY PARAMETERS: TEMP. =',F7.3,' MEV',5X,'E0 =',F8.3, AB 1189 X' MEV',5X,'SIGMA =',F8.3//' AT',F7.2,' MEV, COMPUTED TOTAL LEVELAB 1190 X DENSITY =',F8.2,'/MEV') AB 1191 IF(NCONT.GT.0)WRITE(6,6307) AB 1192 IF(NCONT.LT.0)WRITE(6,6306) AB 1193 6306 FORMAT(1H0,' OPTICAL MODEL CONTINUUM CHANNELS') AB 1194 6307 FORMAT(1H0,' BLACK NUCLEUS CONTINUUM CHANNELS') AB 1195 3094 CONTINUE AB 1196 FLMBR=FLMB *FLMB AB 1197 FNUHF=FFNU/2D0 AB 1198 LLMXMX=0 AB 1199 JJ7=0 AB 1200 DO 10 I=1,NLEVL AB 1201 EN=ECM-EX(I) AB 1202 LMXC=LMAX AB 1203 CALL ABACUS(I,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KETA,LMXC,J5,J6,J7AB 1204 X,JJ7) AB 1205 IF(JJ7.EQ.-10)GO TO 142 AB 1206 LLMX(I)=LMXC+1 AB 1207 IF(LLMX(I).GT.LLMXMX)LLMXMX=LLMX(I) AB 1208 10 CONTINUE AB 1209 LLMAX=LLMX(1) AB 1210 LMX=LLMAX-1 AB 1211 J8=JJ7 AB 1212 DO 18 I=1,NLEVL AB 1213 NJ8=J8+I-1 AB 1214 18 Z(NJ8)=0D0 AB 1215 FFF=FF1+0.5 AB 1216 NFF=IDINT(FFF) AB 1217 NJMIN=MAX0(1,NFF-LMX) AB 1218 NJMAX=NFF+LMX AB 1219 IT=MOD(ID(1),2) AB 1220 F0=DFLOAT(IT+1)/2D0 AB 1221 FJMIN=DFLOAT(NJMIN)-F0 AB 1222 FJMAX=DFLOAT(NJMAX)+F0 AB 1223 IF(KIN.LE.0)WRITE(6,6020)LMX,FJMIN,FJMAX AB 1224 6020 FORMAT(1H0,' MAXIMUM NEUTRON L VALUE,(RANGE OF TOTAL J VALUES) =',AB 1225 XI3,', (',F5.1,',',F5.1,')') AB 1226 J9=J8+NLEVL AB 1227 J10=J9+NLEVL AB 1228 J11=J10+2*LLMXMX AB 1229 J12=J11+2*LLMXMX AB 1230 KN=J12-1 AB 1231 DO 50 I=1,NLEVL AB 1232 DO 50 K=1,LLMAX AB 1233 KN=KN+1 AB 1234 50 Z(KN)=0D0 AB 1235 J13=KN+1 AB 1236 IDSUM=0 AB 1237 DO 49 I=1,NLEVL AB 1238 49 IDSUM=IDSUM+ID(I)+1 AB 1239 J14=J13+IDSUM AB 1240 J15=J14+IDSUM AB 1241 J16=J15+IDSUM AB 1242 J17=J16+IDSUM AB 1243 IF(J17.LE.NZB)GO TO 46 AB 1244 J17=NZB-J17 AB 1245 WRITE(6,6250)J17 AB 1246 6250 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA AND DISCRETE NEAB 1247 XUTRON CHANNELS BY',I6,' REAL*8 LOCATIONS.') AB 1248 STOP AB 1249 46 CONTINUE AB 1250 IF((KG.EQ.0).OR.(NRD.EQ.1))GO TO 91 AB 1251 TX=SA/UX AB 1252 TX=DSQRT(TX)-3D0/(2D0*UX) AB 1253 TX=1D0/TX AB 1254 AUX=SA*UX AB 1255 E0=DSQRT(AUX) AB 1256 E02=2D0*E0 AB 1257 E0=DEXP(E02)/(12D0*DSQRT(E0*SGSQ)*UX) AB 1258 E0=TX*E0 AB 1259 E0=EXX-TX*DLOG(E0) AB 1260 IF(TG0)84,82,84 AB 1261 84 ROJ=0D0 AB 1262 CALL GAMMAS(BN,0D0,E0,EXX,TX,SA,PR,H,KGD,EGD,GGD,TEMP) AB 1263 N1=ID(1)-1 AB 1264 N1=IABS(N1) AB 1265 N2=ID(1)+1 AB 1266 DO 80 I=N1,N2,2 AB 1267 N3=I-2 AB 1268 N3=IABS(N3) AB 1269 N4=I+2 AB 1270 DO 80 J=N3,N4,2 AB 1271 DEX=-(J+1)*(J+1)/(SGSQ*4D0) AB 1272 80 ROJ=ROJ+DEXP(DEX)*(J+1)/SGSQ AB 1273 CTG=ATG0/(TEMP*ROJ) AB 1274 GO TO 86 AB 1275 82 CTG=3.3D-06*NN*NZ*GGD*(1D0+0.8D0*XFR)/NA AB 1276 86 CONTINUE AB 1277 IF(KG)71,91,72 AB 1278 71 CALL GAMCAP(H,AIN,TG,TGB,J17,J18,J19,J20,KOPG) AB 1279 GO TO 75 AB 1280 72 CALL GAMMAS(BN,ECM,E0,EXX,TX,SA,PR,H,KGD,EGD,GGD,TG) AB 1281 75 CONTINUE AB 1282 TG1=TG*CTG AB 1283 IF(KG.LT.0)GO TO 92 AB 1284 91 J20=J17 AB 1285 92 IF(NCONT.EQ.0)GO TO 12 AB 1286 LMXC=IDINT(0.22D0*DSQRT(ECM-ECONT)*C1)+2 AB 1287 LLMAXC=LMXC+1 AB 1288 NCSPMX=NJMAX+LMXC-IT+1 AB 1289 LLMXC=2*LMXC+1 AB 1290 LLMXCP=LLMXC+1 AB 1291 J21=J20+LLMXC AB 1292 NTCON=LLMXCP*NCSPMX AB 1293 J22=J21+NTCON-1 AB 1294 IF(J22.LE.NZB)GO TO 26 AB 1295 J22=NZB-J22 AB 1296 WRITE(6,6260)J22 AB 1297 6260 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY CONTINUOUS NEUTRON CHANNELSAB 1298 X AND ALL OTHER REQUIREMENTS BY',I6,' REAL*8 LOCATIONS.') AB 1299 STOP AB 1300 26 CONTINUE AB 1301 DO 20 K=1,NTCON AB 1302 J=J21+K-1 AB 1303 20 Z(J)=0D0 AB 1304 ESTP=ESTEP AB 1305 ECN=ECONT AB 1306 ITW=-1 AB 1307 IF(NCONT.LT.0)ITW=0 AB 1308 14 IF(ECM-ECN)12,12,11 AB 1309 11 IF(ECM-ECN-ESTEP)13,17,17 AB 1310 13 ESTP=ECM-ECN AB 1311 17 CEX=ECN+ESTP/2D0 AB 1312 EN=ECM-CEX AB 1313 DO 19 K=1,LLMXC AB 1314 J=J20+K-1 AB 1315 19 Z(J)=0D0 AB 1316 LM=0D0 AB 1317 CALL ABACUS(ITW,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,IZ,LM,J5,JA,J20,AB 1318 XJB) AB 1319 LLM=2*LM+1 AB 1320 LLM=MIN0(LLM,LLMXC) AB 1321 DO 15 K=1,NCSPMX AB 1322 KB=IT+2*(K-1) AB 1323 FK=DFLOAT(KB+1) AB 1324 DO 15 J=1,LLM AB 1325 NJ20=J20+J-1 AB 1326 NJ21=J21+(K-1)*LLMXCP+J-1 AB 1327 Z(NJ21)=Z(NJ21)+ESTP*FK*Z(NJ20)*DEXP((CEX-E0T)/TAU-0.25D0*FK*FK/ AB 1328 XSGSQT)/(TAU*SGSQT) AB 1329 15 CONTINUE AB 1330 ECN=ECN+ESTEP AB 1331 GO TO 14 AB 1332 12 CONTINUE AB 1333 SGST=0D0 AB 1334 SGCT=0D0 AB 1335 SGGM=0D0 AB 1336 SGCP=0D0 AB 1337 SGFI=0D0 AB 1338 SGLP=0D0 AB 1339 SGCR=0D0 AB 1340 JJJ=0 AB 1341 IF((FNUHF.EQ.0.0).AND.(KETA.GT.0))WRITE(6,6040) AB 1342 6040 FORMAT(1H0,'TRANSMISSION COEFFS. T AND WIDTH FLUCTUATION DEGREES AB 1343 XOF FREEDOM NU FOR TOTAL ANG. MOM. J AND PARITIES (+) AND (-)'//' AB 1344 X2*J LEVEL CHANNEL',5X,'T(+)',11X,'NU(+)',10X,'T(-)',11X,'NU(-)'/AB 1345 X) AB 1346 C TOTAL ANGULAR MOMENTUM J JD=2*J AB 1347 DO 103 NJ=NJMIN,NJMAX AB 1348 JD=2*NJ-IT-1 AB 1349 JJJ=JJJ+1 AB 1350 JJM=2*JJJ AB 1351 JJP=JJM-1 AB 1352 G=(JD+1)/(4D0*FF1+2D0) AB 1353 TPS=0D0 AB 1354 TMS=0D0 AB 1355 DO 150 J=1,20 AB 1356 TPP(J)=1D0 AB 1357 TMP(J)=1D0 AB 1358 150 CONTINUE AB 1359 SGS=0D0 AB 1360 SGC=0D0 AB 1361 NJ7=J7 AB 1362 NJ130=J13-1 AB 1363 NJ140=J14-1 AB 1364 NJ150=J15-1 AB 1365 NJ160=J16-1 AB 1366 DO 200 I=1,NLEVL AB 1367 NKI=2*LLMX(I)-1 AB 1368 MM(I)=0 AB 1369 N=1 AB 1370 JID=JD-ID(I) AB 1371 NKMIN=(1+IABS(JID))/2 AB 1372 NKMAX=(1+JD+ID(I))/2 AB 1373 NKMAX=MIN0(NKMAX,LLMAX) AB 1374 IF(NKMAX-NKMIN)210,220,220 AB 1375 210 IF(I-1)103,103,215 AB 1376 C SELECTION OF PROJECTILE ORBITAL AND TOTAL ANGULAR MOMENTA AB 1377 220 DO 300 NK=NKMIN,NKMAX AB 1378 NKMOD=MOD(NK,2) AB 1379 JPLS=2*NK-NKMOD AB 1380 JMNS=2*NK+NKMOD-1 AB 1381 NJ71=NJ7+JPLS-1 AB 1382 NJ72=NJ7+JMNS-1 AB 1383 ZNJ71=0D0 AB 1384 ZNJ72=0D0 AB 1385 IF(JPLS.LE.NKI)ZNJ71=Z(NJ71) AB 1386 IF(JMNS.LE.NKI)ZNJ72=Z(NJ72) AB 1387 KD(I,N)=2*NK-1 AB 1388 IF(I-1)230,230,240 AB 1389 230 CONTINUE AB 1390 NJ51=J5+JPLS-1 AB 1391 NJ61=J6+JPLS-1 AB 1392 NJ52=J5+JMNS-1 AB 1393 NJ62=J6+JMNS-1 AB 1394 ZNJ51=0D0 AB 1395 ZNJ52=0D0 AB 1396 ZNJ61=0D0 AB 1397 ZNJ62=0D0 AB 1398 IF(JPLS.GT.NKI)GO TO 231 AB 1399 ZNJ51=Z(NJ51)*Z(NJ51) AB 1400 ZNJ61=Z(NJ61)*Z(NJ61) AB 1401 231 IF(JMNS.GT.NKI)GO TO 232 AB 1402 ZNJ52=Z(NJ52)*Z(NJ52) AB 1403 ZNJ62=Z(NJ62)*Z(NJ62) AB 1404 232 CONTINUE AB 1405 SGS=SGS+4D0*(ZNJ51+ZNJ61+ZNJ52+ZNJ62) AB 1406 SGC=SGC+ZNJ71+ZNJ72 AB 1407 240 CONTINUE AB 1408 NJ130=NJ130+1 AB 1409 NJ140=NJ140+1 AB 1410 NJ150=NJ150+1 AB 1411 NJ160=NJ160+1 AB 1412 IF(IPI(I))320,310,310 AB 1413 310 Z(NJ130)=ZNJ71 AB 1414 Z(NJ140)=ZNJ72 AB 1415 GO TO 330 AB 1416 320 Z(NJ130)=ZNJ72 AB 1417 Z(NJ140)=ZNJ71 AB 1418 330 TPS=TPS+Z(NJ130) AB 1419 TMS=TMS+Z(NJ140) AB 1420 Z(NJ150)=FNUHF AB 1421 Z(NJ160)=FNUHF AB 1422 300 N=N+1 AB 1423 MM(I)=N-1 AB 1424 215 NJ7=NJ7+NKI AB 1425 200 CONTINUE AB 1426 IF(KG)61,60,61 AB 1427 61 IF(NRD.EQ.1)GO TO 59 AB 1428 NJ18=J18+NJ-NJMIN AB 1429 NJ19=J19+NJ-NJMIN AB 1430 ROJ=0D0 AB 1431 N1=JD-2 AB 1432 N1=IABS(N1) AB 1433 N2=JD+2 AB 1434 DO 65 J=N1,N2,2 AB 1435 DEX=-(J+1)*(J+1)/(SGSQ*4D0) AB 1436 65 ROJ=ROJ+DEXP(DEX)*(J+1)/SGSQ AB 1437 TG=6.2832*TG1*ROJ AB 1438 IF(KG.GT.0)GO TO 63 AB 1439 TGB1=6.2832*TGB*ROJ AB 1440 TCAP=Z(NJ18)+TGB1 AB 1441 TCAM=Z(NJ19)+TGB1 AB 1442 TCAP=TCAP*CTG AB 1443 TCAM=TCAM*CTG AB 1444 GO TO 63 AB 1445 59 TG=TGG(JJJ) AB 1446 63 TPS=TPS+TG AB 1447 TMS=TMS+TG AB 1448 60 CONTINUE AB 1449 IF(NF)66,66,67 AB 1450 67 TFP=TFF(JJP) AB 1451 TFM=TFF(JJM) AB 1452 FNP=FNF(JJP)/2 AB 1453 FNM=FNF(JJM)/2 AB 1454 TPS=TPS+TFP AB 1455 TMS=TMS+TFM AB 1456 66 CONTINUE AB 1457 IF(NCONT.EQ.0)GO TO 120 AB 1458 TCO=0D0 AB 1459 DO 122 K=1,NCSPMX AB 1460 NJ21=J21+(K-1)*LLMXCP AB 1461 KB=IT+2*(K-1) AB 1462 KID=JD-KB AB 1463 NKMIN=(1+IABS(KID))/2 AB 1464 NKMAX=(1+JD+KB)/2 AB 1465 NKMAX=MIN0(NKMAX,LLMAXC) AB 1466 IF(NKMAX.LT.NKMIN)GO TO 122 AB 1467 DO 123 NK=NKMIN,NKMAX AB 1468 JPLS=2*NK AB 1469 JMNS=JPLS-1 AB 1470 MJ21=NJ21+JPLS-1 AB 1471 KJ21=NJ21+JMNS-1 AB 1472 TCO=TCO+(Z(MJ21)+Z(KJ21)) AB 1473 123 CONTINUE AB 1474 122 CONTINUE AB 1475 TCO=TCO*0.5 AB 1476 TPS=TPS+TCO AB 1477 TMS=TMS+TCO AB 1478 120 CONTINUE AB 1479 SGST=SGST+G*SGS AB 1480 SGCT=SGCT+G*SGC AB 1481 IF(TPS.LE.1D-50)TPS=1D-50 AB 1482 TPS=1D0/TPS AB 1483 IF(TMS.LE.1D-50)TMS=1D-50 AB 1484 TMS=1D0/TMS AB 1485 IF(FNUHF)851,852,853 AB 1486 852 CALL FLUCT(JD,KETA,J13,J14,J15,J16,NLEVL,MM,TPS,TMS) AB 1487 853 DO 850 J=1,20 AB 1488 NJ130=J13-1 AB 1489 NJ140=J14-1 AB 1490 NJ150=J15-1 AB 1491 NJ160=J16-1 AB 1492 DO 800 K=1,NLEVL AB 1493 MMI=MM(K) AB 1494 IF(MMI)800,800,805 AB 1495 805 DO 799 I=1,MMI AB 1496 NJ130=NJ130+1 AB 1497 NJ140=NJ140+1 AB 1498 NJ150=NJ150+1 AB 1499 NJ160=NJ160+1 AB 1500 TPP(J)=TPP(J)*(1D0+X(J)*Z(NJ130)*TPS/Z(NJ150))**Z(NJ150) AB 1501 TMP(J)=TMP(J)*(1D0+X(J)*Z(NJ140)*TMS/Z(NJ160))**Z(NJ160) AB 1502 799 CONTINUE AB 1503 800 CONTINUE AB 1504 FFP=1D0 AB 1505 FFM=1D0 AB 1506 IF(KG)802,801,802 AB 1507 802 FP=1D0+X(J)*TG*TPS/NG AB 1508 FM=1D0+X(J)*TG*TMS/NG AB 1509 DO 810 II=1,NG AB 1510 FFP=FFP*FP AB 1511 810 FFM=FFM*FM AB 1512 801 TPP(J)=FFP*TPP(J) AB 1513 TMP(J)=FFM*TMP(J) AB 1514 IF(NF)850,850,840 AB 1515 840 IF(TFP.GT.0D0)TPP(J)=TPP(J)*(1D0+X(J)*TFP*TPS/FNP)**FNP AB 1516 IF(TFM.GT.0D0)TMP(J)=TMP(J)*(1D0+X(J)*TFM*TMS/FNM)**FNM AB 1517 850 CONTINUE AB 1518 851 CONTINUE AB 1519 C PROJECTILE TOTAL ANG. MOM. K1D=2*J(1), K2D=2*J(2) AB 1520 MM1=MM(1) AB 1521 KJ130=J13-1 AB 1522 KJ140=J14-1 AB 1523 KJ150=J15-1 AB 1524 KJ160=J16-1 AB 1525 DO 102 K1=1,MM1 AB 1526 KJ130=KJ130+1 AB 1527 KJ140=KJ140+1 AB 1528 KJ150=KJ150+1 AB 1529 KJ160=KJ160+1 AB 1530 K1D=KD(1,K1) AB 1531 IF(KG.EQ.0)GO TO 906 AB 1532 IF(FNUHF.LT.0D0)GO TO 907 AB 1533 GP=0D0 AB 1534 GM=0D0 AB 1535 DO 905 J=1,20 AB 1536 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1537 X*(1D0+X(J)*TG*TPS/NG)) AB 1538 905 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1539 X*(1D0+X(J)*TG*TMS/NG)) AB 1540 GO TO 908 AB 1541 907 GP=1D0 AB 1542 GM=1D0 AB 1543 908 CONTINUE AB 1544 TEP=Z(KJ130)*GP*TPS+Z(KJ140)*GM*TMS AB 1545 SGGM=SGGM+TEP*TG*G AB 1546 IF(KG.LT.0)SGCP=SGCP+Z(KJ130)*GP*TPS*TCAP*G+Z(KJ140)*GM*TMS*TCAM*GAB 1547 906 CONTINUE AB 1548 IF(NF.LE.0)GO TO 916 AB 1549 IF(FNUHF.LT.0D0)GO TO 917 AB 1550 GP=0D0 AB 1551 GM=0D0 AB 1552 DO 915 J=1,20 AB 1553 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1554 X*(1D0+X(J)*TFP*TPS/FNP)) AB 1555 915 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1556 X*(1D0+X(J)*TFM*TMS/FNM)) AB 1557 GO TO 918 AB 1558 917 GP=1D0 AB 1559 GM=1D0 AB 1560 918 TEP=Z(KJ130)*TFP*GP*TPS+Z(KJ140)*TFM*GM*TMS AB 1561 SGFI=SGFI+TEP*G AB 1562 916 CONTINUE AB 1563 IF(NCONT.NE.0)SGLP=SGLP+TCO*G*(Z(KJ130)*TPS+Z(KJ140)*TMS) AB 1564 NJ12=J12 AB 1565 NJ130=J13-1 AB 1566 NJ140=J14-1 AB 1567 NJ150=J15-1 AB 1568 NJ160=J16-1 AB 1569 DO 102 I=1,NLEVL AB 1570 NJ8=J8+I-1 AB 1571 MMI=MM(I) AB 1572 IF(MMI)102,102,904 AB 1573 904 DO 101 K2=1,MMI AB 1574 NJ130=NJ130+1 AB 1575 NJ140=NJ140+1 AB 1576 NJ150=NJ150+1 AB 1577 NJ160=NJ160+1 AB 1578 K2D=KD(I,K2) AB 1579 GP=1D0 AB 1580 GM=1D0 AB 1581 IF(FNUHF.LT.0D0)GO TO 910 AB 1582 GP=0D0 AB 1583 GM=0D0 AB 1584 DO 900 J=1,20 AB 1585 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1586 X*(1D0+X(J)*Z(NJ130)*TPS/Z(NJ150))) AB 1587 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1588 X*(1D0+X(J)*Z(NJ140)*TMS/Z(NJ160))) AB 1589 900 CONTINUE AB 1590 IF(I.NE.1)GO TO 910 AB 1591 IF(NJ130.EQ.KJ130)GP=GP*(1D0+Z(KJ150))/Z(KJ150) AB 1592 IF(NJ140.EQ.KJ140)GM=GM*(1D0+Z(KJ160))/Z(KJ160) AB 1593 C COMPUND ELASTIC IS DOUBLED WHEN CONTINUUM LEVELS ARE SPECIFIED. AB 1594 C SGCR IS RESULTING COMPOUND EXCESS. ALL COMPOUND CROSS XSECS AB 159