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