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 1595 SGST=3.141592D0*FLMBR*SGST 1596 SGCT=3.141592D0*FLMBR*SGCT 1597 CORRED=1D0 1598 IF(NCONT.EQ.0)GO TO 530 1599 SGCR=3.141592D0*FLMBR*SGCR 1600 CORRED=SGCT/(SGCR+SGCT) 1601 530 CONTINUE 1602 SGTT=SGST+SGCT 1603 COEFF=3.141592D0*FLMBR*CORRED 1604 IF(KG.NE.0)SGGM=SGGM*COEFF 1605 IF(KG.LT.0)SGCP=SGCP*COEFF 1606 IF(NF.GT.0)SGFI=SGFI*COEFF 1607 IF(NCONT.NE.0)SGLP=SGLP*COEFF 1608 J80=J8+NLEVL-1 1609 SGSM=SGGM+SGFI+SGLP 1610 DO 510 I=J8,J80 1611 Z(I)=Z(I)*COEFF 1612 510 SGSM=SGSM+Z(I) 1613 SGET=SGST+Z(J8) 1614 IF(KIN)34,34,35 1615 34 NNL=MIN0(NLEVL,10) 1616 J81=J8+NNL-1 1617 IF(SGTT-999.9999D0)37,37,38 1618 37 WRITE(6,6006)SGTT,SGCT,SGST,SGET,(Z(I),I=J8,J81) 1619 GO TO 39 1620 38 WRITE(6,6007)SGTT,SGCT,SGST,SGET,(Z(I),I=J8,J81) 1621 39 CONTINUE 1622 J82=J8+10 1623 J83=J8+NLEVL-1 1624 IF(NLEVL.GT.10)WRITE(6,6009)(Z(I),I=J82,J83) 1625 6009 FORMAT(1H ,22X,10F9.5) 1626 IF(NCONT.NE.0)WRITE(6,6011)SGLP 1627 6011 FORMAT(1H ,' CONTINUUM LEVELS =',F9.5) 1628 IF(KG.NE.0)WRITE(6,6008)SGGM 1629 IF(KG.LT.0)WRITE(6,6010)SGCP 1630 IF(NF.GT.0)WRITE(6,6012)SGFI 1631 WRITE(6,6013)SGSM 1632 WRITE(2,2223)SGTT*ABUND,SGCT*ABUND,SGST*ABUND,SGET*ABUND, 1633 2 Z(J8)*ABUND,SGLP*ABUND,SGGM*ABUND,SGCP*ABUND,SGFI*ABUND, 1634 3 SGSM*ABUND 1635 C SGTT=TOTAL XSEC 1636 C SGCT=ABSORPTION XSEC 1637 C SGST=SHAPE-ELASTIC XSEC 1638 C SGET=TOTAL ELASTIC XSEC 1639 C Z(I),I=J8,J81=COMPOUND EXCITATION XSECS 1640 C Z(J8)=COMPOUND ELASTIC XSEC 1641 C SGGM=GAMMA XSEC 1642 C SGCP=CAPTURE CROSS SECTION 1643 C SGFI=FISSION XSEC 1644 C SGSM=TOTAL COMPOUND XSEC 1645 C SGLP=CONTINUUM XSEC 1646 2223 FORMAT(1P5E17.10) 1647 6006 FORMAT(1H /' INTEGRATED CROSS SECTIONS IN BARNS'/ 1648 &' ==================================' //16X,'TOTAL =' 1649 &, F9.5/11X,'ABSORPTION =', F9.5/8X,'SHAPE ELASTIC =', F9.5/8X,'TOT 1650 &AL ELASTIC =', F9.5/' COMPOUND EXCITATIONS =',10F9.5) 1651 6007 FORMAT(1H /' INTEGRATED CROSS SECTIONS IN BARNS'/ 1652 &' ==================================' //16X,'TOTAL =' 1653 &,D12.5/11X,'ABSORPTION =',D12.5/8X,'SHAPE ELASTIC =',D12.5/8X,'TOT 1654 &AL ELASTIC =',D12.5/' COMPOUND EXCITATIONS =',10F9.5) 1655 6008 FORMAT(1H ,' N-GAMMA =',F9.5) 1656 6010 FORMAT(1H ,' RADIATIVE CAPTURE =',F9.5) 1657 6012 FORMAT(1H ,' FISSION =',F9.5) 1658 6013 FORMAT(1H ,' TOTAL COMPOUND =',F9.5) 1659 36 CONTINUE 1660 IF((KSCH.NE.0).AND.(NTO.GT.0))NC=NC+1 1661 GO TO 520 1662 35 IF(NTO)520,520,31 1663 31 NJ2=NJ2+1 1664 NJ3=NJ3+1 1665 NC=NC+1 1666 C ERROR WEIGHTING ON CROSS SECTION 1667 IF(KMAG.NE.5)GO TO 5900 1668 U(NJ3)=((SGTT-Z(NJ2))*100.0*Z(NC))/Z(NJ2) 1669 GO TO 5901 1670 5900 U(NJ3)=(SGTT-Z(NJ2))*DSQRT(Z(NC)/Z(NJ2)) 1671 5901 CHISQ=CHISQ+U(NJ3)*U(NJ3) 1672 520 FF=FLMBR/(8*(ID(1)+1)) 1673 NJ12=J12 1674 DO 700 I=1,NLEVL 1675 NSGN=+1 1676 IC=ID(I)-ID(1) 1677 IF(MOD(IC,4).EQ.0)NSGN=-1 1678 DO 600 NLL=1,LLMAX 1679 MJ12=NJ12+NLL-1 1680 Z(MJ12)=FF*Z(MJ12)*NSGN 1681 600 CONTINUE 1682 NJ12=NJ12+LLMAX 1683 700 CONTINUE 1684 C ANGULAR DISTRIBUTION Y=LAB ANGLE Z=COS(C.M. ANGLE) 1685 IF(KISCH)130,130,131 1686 130 IF(DANG.LT.0D0)GO TO 2000 1687 GO TO 132 1688 131 IF(NOA.EQ.0)GO TO 2000 1689 132 CONTINUE 1690 IF(KIN)625,625,630 1691 625 WRITE( 6,6050) 1692 6050 FORMAT(1H /' LABORATORY CROSS SECTION IN BARNS PER STERADIAN'/ 1693 & ' ==============================================='/) 1694 WRITE( 6,6052) 1695 6052 FORMAT(1H ,' ANGLE S.E. C.E. LEVEL GROUP CROSS SECTI 1696 &ONS'/) 1697 IF(KSCH.NE.0)GO TO 630 1698 NANG=1+180D0/DANG 1699 GO TO 635 1700 630 NANG=NOA 1701 635 FRANG=DATAN(1D0)/45D0 1702 DO 1000 M=1,NANG 1703 IQ=IQ+1 1704 IF(KSCH)650,640,650 1705 640 Y=(M-1)*DANG 1706 GO TO 660 1707 650 NC=NC+1 1708 Y=Z(NC) 1709 660 CONTINUE 1710 NJ12=J12 1711 DO 1020 I=1,NLEVL 1712 NJ9=J9+I-1 1713 RR=R(I) 1714 CALL CMC(Y,RR,FRANG,F,LMX,I,J10,J11) 1715 IF(I.GT.1)GO TO 1017 1716 AR=Z(J5) 1717 AI=Z(J6) 1718 BR=0D0 1719 BI=0D0 1720 L=0 1721 DO 1050 L=1,LMX 1722 K=L+1 1723 NJ10=J10+L 1724 NJ11=J11+L 1725 NJ51=J5+2*L-1 1726 NJ52=NJ51+1 1727 NJ61=J6+2*L-1 1728 NJ62=NJ61+1 1729 AR=AR+Z(NJ10)*((L+1)*Z(NJ52)+L*Z(NJ51)) 1730 AI=AI+Z(NJ10)*((L+1)*Z(NJ62)+L*Z(NJ61)) 1731 BR=BR+Z(NJ11)*(Z(NJ52)-Z(NJ51)) 1732 BI=BI+Z(NJ11)*(Z(NJ62)-Z(NJ61)) 1733 1050 CONTINUE 1734 SGSE=FLMBR*(AR*AR+AI*AI+BR*BR+BI*BI)*F 1735 1017 CONTINUE 1736 Z(NJ9)=0D0 1737 DO 1030 N=1,LLMAX 1738 MJ12=NJ12+N-1 1739 NJ10=J10-1+2*N-1 1740 Z(NJ9)=Z(NJ9)+Z(NJ10)*Z(MJ12) 1741 1030 CONTINUE 1742 Z(NJ9)=Z(NJ9)*F*CORRED 1743 NJ12=NJ12+LLMAX 1744 1020 CONTINUE 1745 SIG3=Z(J9) 1746 Z(J9)=Z(J9)+SGSE 1747 IF(KGP(1).LT.0)Z(J9)=SGSE 1748 I=J9-1 1749 ILVL=0 1750 DO 51 K=1,NLEVL 1751 NJ9=J9+K-1 1752 IF(KGP(K))51,51,52 1753 52 J=K-1 1754 KGPM=KGP(J) 1755 IF(K.EQ.1)KGPM=0 1756 IF(KGP(K)-KGPM)53,53,54 1757 53 Z(I)=Z(I)+Z(NJ9) 1758 GO TO 51 1759 54 I=I+1 1760 Z(I)=Z(NJ9) 1761 ILVL=ILVL+1 1762 GW(ILVL)=GW(K) 1763 51 CONTINUE 1764 IF(KIN)40,40,41 1765 40 NL=MIN0(ILVL,9) 1766 J90=J9+NL-1 1767 6234 FORMAT(4E17.10) 1768 C Y=ANGLE 1769 C SGSE=SHAPE-ELASTIC XSEC 1770 C SIG3=COMPOUND ELASTIC 1771 C Z(I),I=J91,J92=DIFFERENTIAL XSECS 1772 C ELASTIC AND UP TO EIGHT INELASTICS 1773 C FSORT(4)=FOUR INELASTIC GROUPS POSSIBLE FOR SEARCHES 1774 C SETUP INELASTIC SEARCH BLOCKS 1775 DO 6235 JDIF=1,4 1776 6235 FSORT(JDIF)=0.0 1777 DO 6236 JDIF=2,ILVL 1778 IF(ISORT(JDIF).EQ.0)GO TO 6236 1779 NJN=ISORT(JDIF) 1780 FSORT(NJN)=FSORT(NJN)+Z(J9+JDIF-1)*ABUND 1781 6236 CONTINUE 1782 WRITE(2,6234)Y,SGSE*ABUND,SIG3*ABUND,Z(J9)*ABUND,(FSORT(I),I=1,4) 1783 WRITE( 6,6200)Y,SGSE,SIG3,(Z(I),I=J9,J90) 1784 6200 FORMAT(1H ,F8.2,11F10.5) 1785 IF(ILVL.LE.9)GO TO 47 1786 J91=J9+9 1787 J92=J9+ILVL-1 1788 IF(ILVL.GT.9) WRITE( 6,6220)(Z(I),I=J91,J92) 1789 6220 FORMAT(39X,8F10.5) 1790 47 CONTINUE 1791 43 CONTINUE 1792 41 NOM=NQ(IQ) 1793 IF(KIN)44,44,48 1794 44 IQ=IQ+NOM 1795 GO TO 1000 1796 48 DO 42 I=1,NOM 1797 IQ=IQ+1 1798 NJ9=J9+I-1 1799 IF(NQ(IQ))42,42,45 1800 45 NJ2=NJ2+1 1801 NJ3=NJ3+1 1802 IF(KMAG.NE.5)GO TO 24 1803 IF(NISO.EQ.1)GO TO 1 1804 IF(IJK.LT.NISO)WRITE(2,1111)Z(NJ9)*ABUND 1805 1111 FORMAT(1PE17.10) 1806 IF(IJK.LT.NISO)GO TO 42 1807 C LAST ISOTOPE 1808 REWIND 2 1809 Z(NJ9)=Z(NJ9)*ABUND 1810 KKM=(M-1)*NOM+I 1811 DO 8129 KKK=1,KKM 1812 READ(2,1111)DUM 1813 8129 CONTINUE 1814 Z(NJ9)=Z(NJ9)+DUM 1815 DO 8130 KKK=1,NISO-2 1816 DO 8131 JJJ=1,NANG 1817 READ(2,1111)DUM 1818 8131 CONTINUE 1819 Z(NJ9)=Z(NJ9)+DUM 1820 8130 CONTINUE 1821 1822 1 CONTINUE 1823 U(NJ3)=((Z(NJ9)-Z(NJ2))*GW(I)*100.0)/(ZZ(NJ2)*Z(NJ2)) 1824 GO TO 5903 1825 C 1826 24 CONTINUE 1827 IF(NISO.EQ.1)GO TO 2 1828 IF(IJK.LT.NISO)WRITE(2,1111)Z(NJ9)*ABUND 1829 IF(IJK.LT.NISO)GO TO 42 1830 C LAST ISOTOPE 1831 REWIND 2 1832 Z(NJ9)=Z(NJ9)*ABUND 1833 KKM=(M-1)*NOM+I 1834 DO 8132 KKK=1,KKM 1835 READ(2,1111)DUM 1836 8132 CONTINUE 1837 Z(NJ9)=Z(NJ9)+DUM 1838 1839 DO 8133 KKK=1,NISO-2 1840 DO 8134 JJJ=1,NANG 1841 READ(2,1111)DUM 1842 8134 CONTINUE 1843 Z(NJ9)=Z(NJ9)+DUM 1844 8133 CONTINUE 1845 2 U(NJ3)=(Z(NJ9)-Z(NJ2))*DSQRT(GW(I)/Z(NJ2)) 1846 5903 CHISQ=CHISQ+U(NJ3)*U(NJ3) 1847 42 CONTINUE 1848 1000 CONTINUE 1849 2000 CONTINUE 1850 NCONT=NCNT 1851 500 CONTINUE 1852 8124 CONTINUE 1853 IF(KETA.LT.0)WRITE( 6,6110)CHISQ 1854 6110 FORMAT(100X,F17.6) 1855 1856 IF(NISO.GT.1.AND.KIN.LE.0)THEN 1857 WRITE( 6,6111) 1858 6111 FORMAT(1H /, 1859 2 ' ***********************************'/ 1860 2 ' ** **'/ 1861 2 ' ** ELEMENTAL CROSS SECTION **'/ 1862 2 ' ** **'/ 1863 2 ' ***********************************') 1864 IF(NOFIT.EQ.0.AND.NOEN.LE.1)GO TO 6241 1865 IF(NOEN.GT.1.OR.NODIF.LE.0)GO TO 6230 1866 6241 REWIND 2 1867 DO 6218 I=1,NISO 1868 IF(I.NE.1)GO TO 6216 1869 READ(2,2223)SGTT,SGCT,SGST,SGET,ZDUM,SGLP,SGGM,SGCP,SGFI,SGSM 1870 DO 6210 J=1,NANG 1871 6112 READ(2,6234)(XYZ(J,K),K=1,4) 1872 READ(2,6234)(FYZ(J,K),K=1,4) 1873 IF(J.GE.2.AND.XYZ(J,1).LE.0.)GO TO 6112 1874 6210 CONTINUE 1875 GO TO 6215 1876 6216 READ(2,2223)AA1, AA2, AA3, AA4, AA5, AA6, AA7, AA8, AA9, AA10 1877 SGTT=SGTT+AA1 1878 SGCT=SGCT+AA2 1879 SGST=SGST+AA3 1880 SGET=SGET+AA4 1881 ZDUM=ZDUM+AA5 1882 SGLP=SGLP+AA6 1883 SGGM=SGGM+AA7 1884 SGCP=SGCP+AA8 1885 SGFI=SGFI+AA9 1886 SGSM=SGSM+AA10 1887 DO 6214 J=1,NANG 1888 6113 READ(2,6234)(XXZ(J,K),K=1,4) 1889 READ(2,6234)(FXZ(J,K),K=1,4) 1890 IF(J.GE.2.AND.XXZ(J,1).LE.0.)GO TO 6113 1891 DO 6211 K=1,4 1892 FYZ(J,K)=FYZ(J,K)+FXZ(J,K) 1893 6211 CONTINUE 1894 DO 6212 K=2,4 1895 XYZ(J,K)=XYZ(J,K)+XXZ(J,K) 1896 6212 CONTINUE 1897 6214 CONTINUE 1898 6215 CONTINUE 1899 6218 CONTINUE 1900 WRITE( 6,6016)SGTT,SGCT,SGST,SGET,ZDUM 1901 6016 FORMAT(/,1H ,' INTEGRATED CROSS SECTIONS IN BARNS'/ 1902 &' ===================================' //16X, 1903 &'TOTAL =',F9.5/11X,'ABSORPTION =',F9.5/8X,'SHAPE ELASTIC =', 1904 &F9.5/8X,'TOTAL ELASTIC =',F9.5/' COMPOUND ELASTIC =',F9.5) 1905 IF(NCONT.NE.0)WRITE( 6,6011)SGLP 1906 IF(KG.NE.0)WRITE( 6,6008)SGGM 1907 IF(KG.LT.0)WRITE( 6,6010)SGCP 1908 IF(NF.GT.0)WRITE( 6,6012)SGFI 1909 WRITE( 6,6013)SGSM 1910 WRITE( 6,6050) 1911 WRITE( 6,6052) 1912 KSORT=0 1913 DO 6221 J=1,NLEVEL 1914 IF(ISORT(J).GE.KSORT)KSORT=ISORT(J) 1915 6221 CONTINUE 1916 DO 6219 J=1,NANG 1917 WRITE( 6,6200)(XYZ(J,K),K=1,4),(FYZ(J,K),K=1,KSORT) 1918 6219 CONTINUE 1919 END IF 1920 GO TO 6240 1921 6230 WRITE(6,6231) 1922 6231 FORMAT(//,'ELEMENTAL VALUES NOT CALCULATED DUE TO AMBIGUITIES',/, 1923 &'IN ANGLE AND/OR ENERGY. CONTRUCT ELEMENTAL VALUES FROM',/, 1924 &'COMPONENTS ABOVE AS DESIRED.') 1925 6240 CONTINUE 1926 SA=SSA 1927 RETURN 1928 142 IF(KISCH.LE.1)GO TO 144 1929 DO 145 IU=2,MI 1930 145 U(IU)=1D10 1931 RETURN 1932 144 WRITE( 6,6500) 1933 6500 FORMAT(1H0,' VIMAG NONPOSITIVE - EXECUTION TERMINATES.') 1934 END 1935 C ********************************************************************** 1936 SUBROUTINE ABACUS(N,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KETA,LMAX,J5 1937 X,J6,J7,JJ7) 1938 IMPLICIT REAL*8 (A-H,O-Z) 1939 IMPLICIT INTEGER*4(I-N) 1940 COMPLEX*16 DEX,RTL 1941 COMMON/ASUR/SURF0,SURF1,SURF2 1942 COMMON/ZBLOCK/Z(24000) 1943 COMMON/ISOTOPE/ASYMM,ZT,VECR,VECI,NISO,ISORT(50) 1944 DIMENSION FJ(21),FN(21),AIN(1) 1945 S0=0D0 1946 S1=0D0 1947 KR=J5-4-8*KPT 1948 KI=KR+KPT 1949 KS=KI+KPT 1950 KX=KS+KPT 1951 KREP=KX+KPT-1 1952 KIMP=KREP+KPT+1 1953 KREM=KIMP+KPT+1 1954 KIMM=KREM+KPT+1 1955 IF(LMAX.EQ.0)LMAX=IDINT(0.22D0*DSQRT(EN)*C1)+3 1956 NOC=2*LMAX+1 1957 IF(N-1)5,6,7 1958 6 J6=J5+NOC 1959 J7=J6+NOC 1960 IF(JJ7.GE.0)JJ7=J7 1961 NJ5=J5 1962 NJ6=J6 1963 7 NJ7=JJ7 1964 GO TO 8 1965 5 NJ7=J7 1966 JJ7=J7 1967 8 CONTINUE 1968 KPM=KPT-1 1969 KPHF=KPM/2 1970 A1=AIN(5) 1971 A2=AIN(10) 1972 C2=AIN(12) 1973 RQ1=AIN(15) 1974 AQ1=AIN(16) 1975 IF(RQ1.EQ.0D0)RQ1=AIN(4) 1976 IF(AQ1.EQ.0D0)AQ1=AIN(5) 1977 OT=1D0/3D0 1978 CRA=ANO**OT 1979 P1=AIN(4)*CRA 1980 P2=AIN(9)*CRA 1981 PP1=RQ1*CRA 1982 ARED=ANO/(ANO+ANU) 1983 IF(KIM.EQ.1) C2=1. 1984 DELTAR=C1/KPM 1985 VREM=1.D60 1986 VIMM=1.D60 1987 KIM2=MOD(KIM,2) 1988 ENA=DABS(EN) 1989 CAPK=0.218719D0*DSQRT(ANU*ARED*ENA) 1990 SURFF=SURF0+EN*(SURF1+SURF2*EN) 1991 VREAL=AIN(1)+EN*(AIN(2)+AIN(3)*EN)-ASYMM*VECR 1992 IF(DABS(VREAL).LT.1D-5)VREAL=1D-5 1993 IF(N.LT.0)GO TO 350 1994 VIMAG=AIN(6)+EN*(AIN(7)+AIN(8)*EN)-ASYMM*VECI 1995 IF(VIMAG.GE.1D-5)GO TO 13 1996 JJ7=-10 1997 RETURN 1998 13 IF(AIN(11).EQ.0.0)GO TO 26 1999 VIV=AIN(11)+EN*(AIN(7)+AIN(8)*EN) 2000 VIMAG=VIV+VIMAG 2001 C2=VIV/VIMAG 2002 26 IF(VREAL.EQ.VREM) GO TO 40 2003 VREM=VREAL 2004 R=0. 2005 DO 30 I=1,KPT 2006 JR=KR+I-1 2007 EX=(R-P1)/A1 2008 IF(EX.LT.64D0)GO TO 28 2009 Z(JR)=0D0 2010 GO TO 30 2011 28 IF(EX.GT.-64D0)GO TO 29 2012 Z(JR)=-VREAL 2013 GO TO 30 2014 29 Z(JR)=-VREAL/(DEXP(EX)+1D0) 2015 30 R=R+DELTAR 2016 R=0D0 2017 GO TO(39,35,37),KSO 2018 DO 32 I=2,KPT 2019 JS=KS+I-1 2020 32 Z(JS)=0D0 2021 GO TO 40 2022 39 ZS=2.D0/AQ1 2023 DO 34 I=2,KPT 2024 JS=KS+I-1 2025 R=R+DELTAR 2026 EX=(R-PP1)/AQ1 2027 IF(EX.LT.32D0.AND.EX.GT.-32D0) GO TO 33 2028 Z(JS)=0D0 2029 GO TO 34 2030 33 VSRM=1D0/(DEXP(EX)+1D0) 2031 Z(JS)=VSRM*(1D0-VSRM)*ZS/R 2032 34 CONTINUE 2033 GO TO 40 2034 35 DO 36 I=2,KPT 2035 JR=KR+I-1 2036 JS=KS+I-1 2037 36 Z(JS)=-Z(JR)/VREAL 2038 GO TO 40 2039 37 ZS=2.D0/A1 2040 DO 38 I=2,KPT 2041 JR=KR+I-1 2042 JS=KS+I-1 2043 R=R+DELTAR 2044 ZR=-Z(JR)/VREAL 2045 38 Z(JS)=(ZR-ZR*ZR)*ZS/R 2046 40 IF(VIMAG.EQ.VIMM) GO TO 55 2047 VIMM=VIMAG 2048 DO 41 I=1,KPT 2049 JI=KI+I-1 2050 41 Z(JI)=0D0 2051 IF(KIM.EQ.0) GO TO 55 2052 R=0. 2053 KQ=0 2054 IF(A2.LE.0.) GO TO 42 2055 IF(A2.NE.A1.OR.P2.NE.P1) KQ=1 2056 42 IF(KIM2.EQ.0) GO TO 48 2057 ZS=C2*VIMAG 2058 IF(KQ.EQ.0) GO TO 45 2059 DO 44 I=1,KPT 2060 JI=KI+I-1 2061 EX=(R-P2)/A2 2062 IF(EX.GE.64D0) GO TO 44 2063 IF(EX.GT.-64D0) GO TO 43 2064 Z(JI)=-ZS 2065 GO TO 44 2066 43 Z(JI)=-ZS/(DEXP(EX)+1D0) 2067 44 R=R+DELTAR 2068 GO TO 47 2069 45 ZS=ZS/VREAL 2070 DO 46 I=1,KPT 2071 JR=KR+I-1 2072 JI=KI+I-1 2073 46 Z(JI)=ZS*Z(JR) 2074 47 IF(KIM.EQ.1) GO TO 55 2075 48 ZS=C2*VIMAG-VIMAG 2076 IF(KIM.GT.3) GO TO 50 2077 R=0. 2078 DO 49 I=1,KPT 2079 JI=KI+I-1 2080 EX=(R-P2)/A2 2081 EX=EX*EX 2082 IF(EX.LT.100.) Z(JI)=Z(JI)+ZS*DEXP(-EX) 2083 JR=KR+I-1 2084 IF(EX.LT.100.) Z(JR)=Z(JR)+SURFF*ZS*DEXP(-EX) 2085 49 R=R+DELTAR 2086 GO TO 55 2087 50 IF(KQ.EQ.1) GO TO 52 2088 ZS=-4.*ZS 2089 DO 51 I=1,KPT 2090 JR=KR+I-1 2091 JI=KI+I-1 2092 ZR=Z(JR)/VREAL 2093 Z(JR)=Z(JR)+(ZR*ZR+ZR)*ZS*SURFF 2094 51 Z(JI)=(ZR*ZR+ZR)*ZS+Z(JI) 2095 GO TO 55 2096 52 R=0. 2097 ZS=4.*ZS 2098 DO 53 I=1,KPT 2099 JI=KI+I-1 2100 EX=(R-P2)/A2 2101 IF(EX.GE.64D0.OR.EX.LE.-64D0) GO TO 53 2102 EX=DEXP(EX) 2103 Z(JI)=Z(JI)+ZS*EX/((EX+1D0)*(EX+1D0)) 2104 JR=KR+I-1 2105 Z(JR)=Z(JR)+SURFF*ZS*EX/((EX+1D0)*(EX+1D0)) 2106 53 R=R+DELTAR 2107 55 CAPX=CAPK*C1 2108 DELTAX=CAPK*DELTAR 2109 D0=DELTAX*DELTAX 2110 DO 57 I=1,KPM 2111 JX=KX+I-1 2112 Z(JX)=D0*I*I 2113 57 Z(JX)=1D0/Z(JX) 2114 D1=D0/ENA 2115 D2=2.-D0 2116 LS=0 2117 FJ(1)=DSIN(CAPX)/CAPX 2118 FN(1)=-DCOS(CAPX)/CAPX 2119 FJ(2)=FJ(1)/CAPX+FN(1) 2120 FN(2)=FN(1)/CAPX-FJ(1) 2121 IF(LMAX.LE.1)GO TO 220 2122 LLIM=LMAX+1 2123 DO 200 LL=3,LLIM 2124 FJ(LL)=(LL+LL-3)*FJ(LL-1)/CAPX-FJ(LL-2) 2125 FN(LL)=(LL+LL-3)*FN(LL-1)/CAPX-FN(LL-2) 2126 FTEST=DABS(FJ(LL))+DABS(FN(LL)) 2127 IF(FTEST.GT.1D30)GO TO 210 2128 200 CONTINUE 2129 GO TO 220 2130 210 LMAX=LL 2131 220 CONTINUE 2132 IF(JJ7.LT.0)GO TO 355 2133 IF((KIN.NE.0).OR.(KETA.LE.0))GO TO 360 2134 IF(KETA.GE.N)WRITE(6,6010)N,EN,CAPK 2135 6010 FORMAT(1H0/10X,'O. M. OUTPUT FOR LEVEL',I3,8X,'CHANNEL ENERGY=', 2136 XF9.4,' MEV',8X,' WAVE NUMBER=',F10.6//' L J',16X,'ETA', 2137 X22X,'T',6X,'GAMMASQ/D',5X,'R-INFINITY',6X,'STR.FN.',8X,'R-PRIME'/) 2138 IF(N.NE.1)GO TO 360 2139 355 RTEIN=1.D6*EN 2140 RTEIN=1D0/DSQRT(RTEIN) 2141 350 CONTINUE 2142 RO=CAPK*P1 2143 ROSQ=RO*RO 2144 IF(N.GE.0)GO TO 360 2145 RI=RO*DSQRT(1D0+VREAL/ENA) 2146 RX=1D0/(2D0*RO) 2147 360 CONTINUE 2148 DO 100 L=LS,LMAX 2149 IF(N.LT.0)GO TO 300 2150 FL=L 2151 LL1=L+1 2152 FL0=LL1 2153 D3=FL*FL0*D0 2154 GSUBL=-CAPX*FN(LL1) 2155 DUM7=GSUBL**2 2156 FSUBL= CAPX*FJ(LL1) 2157 DUM8=FSUBL**2 2158 DUM6=GSUBL*FSUBL 2159 DUM78=DUM7+DUM8 2160 DUM4 =DUM7-DUM8 2161 SSUBL=CAPX/DUM78 2162 IF(L.GT.0) GO TO 63 2163 GLP=-FSUBL 2164 FLP= GSUBL 2165 GO TO 64 2166 63 GLP=-CAPX*FN(L)+FL*FN(LL1) 2167 FLP= CAPX*FJ(L)-FL*FJ(LL1) 2168 64 DELSL=(FSUBL*FLP+GSUBL*GLP)*SSUBL 2169 Z(KREP)=0D0 2170 Z(KIMP)=0D0 2171 JRE=KREP+1 2172 JIM=KIMP+1 2173 Z(JRE)=1D-8 2174 Z(JIM)=1D-8 2175 IF(L.EQ.0) GO TO 80 2176 S2=AIN(13)*D1 2177 S2I=AIN(14)*D1 2178 SO=-FL*S2 2179 SOI=-FL*S2I 2180 S2=FL0*S2 2181 S2I=FL0*S2I 2182 Z(KREM)=0D0 2183 Z(KIMM)=0D0 2184 JREM=KREM+1 2185 JIMM=KIMM+1 2186 Z(JREM)=1D-8 2187 Z(JIMM)=1D-8 2188 DO 78 I=1,KPM 2189 MX=KX+I-1 2190 IR=KR+I 2191 II=KI+I 2192 IS=KS+I 2193 IRE=KREP+I 2194 IIM=KIMP+I 2195 IREM=KREM+I 2196 IIMM=KIMM+I 2197 MRE=IRE-1 2198 MIM=IIM-1 2199 MREM=IREM-1 2200 MIMM=IIMM-1 2201 NRE=IRE+1 2202 NIM=IIM+1 2203 NREM=IREM+1 2204 NIMM=IIMM+1 2205 DR =D2+D3*Z(MX)+D1*Z(IR) 2206 DR1=DR+SO*Z(IS) 2207 DI =D1*Z(II) 2208 DI1=DI+SOI*Z(IS) 2209 DR2=DR+S2*Z(IS) 2210 DI2=DI+S2I*Z(IS) 2211 Z(NREM)=DR2*Z(IREM)-DI2*Z(IIMM)-Z(MREM) 2212 Z(NIMM)=DR2*Z(IIMM)+DI2*Z(IREM)-Z(MIMM) 2213 Z(NRE )=DR1*Z(IRE )-DI1*Z(IIM )-Z(MRE ) 2214 Z(NIM )=DR1*Z(IIM )+DI1*Z(IRE )-Z(MIM ) 2215 IF(DABS(Z(MRE)).LE.1.D24) GO TO 78 2216 Z(IRE )=1D-30*Z(IRE) 2217 Z(NRE )=1D-30*Z(NRE) 2218 Z(IIM )=1D-30*Z(IIM) 2219 Z(NIM )=1D-30*Z(NIM) 2220 Z(IREM)=1D-30*Z(IREM) 2221 Z(NREM)=1D-30*Z(NREM) 2222 Z(IIMM)=1D-30*Z(IIMM) 2223 Z(NIMM)=1D-30*Z(NIMM) 2224 78 CONTINUE 2225 J=2 2226 NREM=KREM+KPT 2227 IREM=NREM-1 2228 MREM=IREM-1 2229 NIMM=KIMM+KPT 2230 IIMM=NIMM-1 2231 MIMM=IIMM-1 2232 DRE=Z(NREM)-Z(MREM) 2233 DIM=Z(NIMM)-Z(MIMM) 2234 DEN=(Z(IREM)*Z(IREM)+Z(IIMM)*Z(IIMM))/KPHF 2235 FLR=(Z(IREM)*DRE+Z(IIMM)*DIM)/DEN 2236 FLI=(Z(IREM)*DIM-Z(IIMM)*DRE)/DEN 2237 GO TO 89 2238 80 DO 86 I=1,KPM 2239 MX=KX+I-1 2240 IR=KR+I 2241 II=KI+I 2242 IS=KS+I 2243 IRE=KREP+I 2244 IIM=KIMP+I 2245 MRE=IRE-1 2246 MIM=IIM-1 2247 NRE=IRE+1 2248 NIM=IIM+1 2249 DR1=D2+D3*Z(MX)+D1*Z(IR) 2250 DI1=D1*Z(II) 2251 Z(NRE)=DR1*Z(IRE)-DI1*Z(IIM)-Z(MRE) 2252 Z(NIM)=DR1*Z(IIM)+DI1*Z(IRE)-Z(MIM) 2253 IF(DABS(Z(MRE)).LE.1.D24) GO TO 86 2254 Z(IRE )=1D-30*Z(IRE) 2255 Z(NRE )=1D-30*Z(NRE) 2256 Z(IIM )=1D-30*Z(IIM) 2257 Z(NIM )=1D-30*Z(NIM) 2258 86 CONTINUE 2259 88 J=1 2260 IF(N.LT.0)GO TO 370 2261 NRE=KREP+KPT 2262 IRE=NRE-1 2263 MRE=IRE-1 2264 NIM=KIMP+KPT 2265 IIM=NIM-1 2266 MIM=IIM-1 2267 DRE=Z(NRE)-Z(MRE) 2268 DIM=Z(NIM)-Z(MIM) 2269 DEN=(Z(IRE)*Z(IRE)+Z(IIM)*Z(IIM))/KPHF 2270 FLR=(Z(IRE)*DRE+Z(IIM)*DIM)/DEN 2271 FLI=(Z(IRE)*DIM-Z(IIM)*DRE)/DEN 2272 89 DUM1=FLR-DELSL 2273 DUM2=DUM1**2 2274 DUM1=SSUBL*DUM1 2275 DUM5=(FLI+SSUBL)*(FLI-SSUBL)+DUM2 2276 DEN=((FLI-SSUBL)**2+DUM2)*DUM78 2277 ETARE=(DUM4*DUM5+4.*DUM1*DUM6)/DEN 2278 ETAIM=2.*(DUM1*DUM4-DUM5*DUM6)/DEN 2279 ETIMSQ=ETAIM*ETAIM 2280 TL =1.0-ETARE*ETARE-ETIMSQ 2281 GO TO 400 2282 300 CONTINUE 2283 J=2 2284 P=1D0 2285 S=0D0 2286 IF(L.EQ.0)GO TO 310 2287 RR=1D0 2288 DO 320 M=1,L 2289 M1=M+L 2290 M2=2*M 2291 M3=L-M 2292 RR=RR*RX*RX 2293 FNF=FFAC(M1)*FFAC(M2)/(FFAC(M3)*FFAC(M)*FFAC(M)) 2294 P=P+FNF*RR 2295 S=S-FNF*M2*RR*RX 2296 320 CONTINUE 2297 GO TO 315 2298 310 J=1 2299 315 CONTINUE 2300 P=RO/P 2301 S=P*S 2302 TL=4D0*RI*P/(S*S+(P+RI)*(P+RI)) 2303 ETIMSQ=1D0 2304 370 CONTINUE 2305 400 CONTINUE 2306 JJ=3+2*(L-J) 2307 IF(JJ7.LT.0)GO TO 385 2308 IF((KIN.NE.0).OR.(KETA.LE.0))GO TO 91 2309 IF(KETA.GE.N)WRITE(6,6000)L,JJ,ETARE,ETAIM,TL 2310 6000 FORMAT(1H ,2I5,'/2',F16.6,F12.6,F16.6) 2311 385 IF(N.NE.1)GO TO 384 2312 SFF=1-TL 2313 RPR=-DATAN2(ETAIM,ETARE)/(2D0*CAPK) 2314 IF(L-1)380,382,384 2315 380 SS=0D0 2316 PP=RO 2317 XI=2D0*RO 2318 SFF=-RTEIN*DLOG(SFF)/6.28318D0 2319 S0=SFF 2320 GO TO 383 2321 382 SS=ROSQ/(1D0+ROSQ) 2322 PP=SS*RO 2323 XI=RO-DATAN(RO) 2324 SFF=-RTEIN*DLOG(SFF)*(1D0+ROSQ)/(J*9.42478D0*ROSQ) 2325 S1=S1+SFF 2326 RPR=RPR*(1D0+ROSQ)/(10D6*EN) 2327 383 DEX=DCMPLX(0D0,XI) 2328 DEX=CDEXP(DEX)*DCMPLX(ETARE,ETAIM) 2329 RTL=(DEX-(1D0,0D0))/(DCMPLX(SS,PP)*DEX-DCMPLX(SS,-PP)) 2330 RINF=DREAL(RTL) 2331 STRF=DIMAG(RTL)/3.14159 2332 IF(KIN.NE.0)GO TO 384 2333 IF(JJ7)96,96,97 2334 96 WRITE(6,6001)L,JJ 2335 6001 FORMAT(1H0,39X,I8,I5,'/2') 2336 97 WRITE(6,6002)STRF,RINF,SFF,RPR 2337 6002 FORMAT(1H ,53X,2F15.4,2D14.4) 2338 384 IF(JJ7.LT.0)GO TO 95 2339 IF((TL.LT.-1D-6).OR.(TL.GT.1D0))WRITE(6,6030)N,L,JJ,TL,ETARE, 2340 XETAIM 2341 6030 FORMAT(1H0,' C A U T I O N : FOR LEVEL NO.',I3,5X,'L =',I3,5X,'J = 2342 X',I3,'/2',5X,'T =',D14.6,5X,'ETA = (',D14.6,',',D14.6,')') 2343 91 IF(N.NE.1)GO TO 90 2344 Z(NJ5)=ETAIM/2D0 2345 Z(NJ6)=(1D0-ETARE)/2D0 2346 NJ5=NJ5+1 2347 NJ6=NJ6+1 2348 90 Z(NJ7)=TL 2349 IF(TL.LT.1D-30)Z(NJ7)=0D0 2350 NJ7=NJ7+1 2351 95 IF(J.EQ.2) GO TO 88 2352 IF(JJ7.LT.0)GO TO 100 2353 IF(L.EQ.LMAX)GO TO 99 2354 IF((TL.LT.1D-5).AND.(ETIMSQ.LT.1D-10))GO TO 102 2355 GO TO 100 2356 99 IF((TL.GT.1D-3).AND.(N.GT.0))WRITE(6,6040)N,TL,LMAX 2357 6040 FORMAT(1H0,' C A U T I O N : FOR LEVEL',I3,' T =',F10.6,' FOR 2358 XINTERNALLY COMPUTED LMAX =',I3/) 2359 100 CONTINUE 2360 GO TO 900 2361 102 NOC=2*L+1 2362 IF(N.NE.1)GO TO 701 2363 LDF=2*(LMAX-L) 2364 J6=J5+NOC 2365 J6M=J6+NOC-1 2366 DO 700 J=J6,J6M 2367 K=J+LDF 2368 700 Z(J)=Z(K) 2369 J7=J6M+1 2370 JJ7=J7 2371 J7M=J7+NOC-1 2372 DO 600 J=J7,J7M 2373 K=J+2*LDF 2374 600 Z(J)=Z(K) 2375 701 LMAX=L 2376 900 JJ7=JJ7+NOC 2377 IF(JJ7.GT.2)GO TO 990 2378 Z(J5)=S0 2379 NJ5=J5+1 2380 Z(NJ5)=RPR 2381 NJ5=NJ5+1 2382 Z(NJ5)=S1 2383 990 RETURN 2384 END 2385 C ********************************************************************** 2386 SUBROUTINE CMC(Y,R,FRANG,F,LMX,I,J10,J11) 2387 IMPLICIT INTEGER*4(I-N) 2388 IMPLICIT REAL*8(A-H,O-Z) 2389 COMMON/ZBLOCK/Z(24000) 2390 IF(Y.EQ.0D0)GO TO 711 2391 IF(Y.EQ.180D0)GO TO 712 2392 IF(Y-90D0)705,710,715 2393 705 S=1D0 2394 GO TO 730 2395 715 S=-1D0 2396 730 Q=FRANG*Y 2397 Q=DTAN(Q) 2398 Q=Q*Q 2399 C=1D0+(1D0-R*R)*Q 2400 C=DSQRT(C) 2401 Q=(S*C-R*Q)/(1D0+Q) 2402 GO TO 720 2403 710 Q=-R 2404 GO TO 720 2405 711 Q=1D0 2406 GO TO 720 2407 712 Q=-1D0 2408 720 F=1D0+R*R+2D0*R*Q 2409 F=F*DSQRT(F)/(1D0+R*Q) 2410 Z(J10)=1D0 2411 J101=J10+1 2412 Z(J101)=Q 2413 V=1D0-Q*Q 2414 V=DSQRT(V) 2415 IF(I.GT.1)GO TO 10 2416 Z(J11)=0D0 2417 J111=J11+1 2418 Z(J111)=V 2419 10 NUMT=2*LMX+1 2420 IF(NUMT.LT.3)GO TO 1011 2421 DO 1010 J=3,NUMT 2422 NJ10=J10+J-1 2423 K=J-1 2424 NJ101=NJ10-1 2425 L=J-2 2426 NJ102=NJ10-2 2427 Z(NJ10)=((2*K-1)*Q*Z(NJ101)-L*Z(NJ102))/K 2428 IF (I.GT.1)GO TO 1010 2429 NJ11=J11+J-1 2430 NJ111=NJ11-1 2431 NJ112=NJ11-2 2432 Z(NJ11)=((2*K-1)*Q*Z(NJ111)-K*Z(NJ112))/L 2433 1010 CONTINUE 2434 1011 RETURN 2435 END 2436 FUNCTION FFAC(N) 2437 IMPLICIT INTEGER*4(I-N) 2438 IMPLICIT REAL*8(A-H,O-Z) 2439 FFAC=1D0 2440 IF(N)2,2,3 2441 3 DO 10 I=1,N 2442 10 FFAC=FFAC*I 2443 2 RETURN 2444 END 2445 C ********************************************************************** 2446 SUBROUTINE FLUCT(JD,KETA,J13,J14,J15,J16,NLEVL,MM,TPS,TMS) 2447 IMPLICIT INTEGER*4(I-N) 2448 IMPLICIT REAL*8(A-H,O-Z) 2449 DIMENSION MM(1) 2450 COMMON/ZBLOCK/Z(24000) 2451 NJ130=J13-1 2452 NJ140=J14-1 2453 NJ150=J15-1 2454 NJ160=J16-1 2455 DO 350 I=1,NLEVL 2456 IF(MM(I).LT.1)GO TO 350 2457 MMI=MM(I) 2458 DO 360 N=1,MMI 2459 NJ130=NJ130+1 2460 NJ140=NJ140+1 2461 NJ150=NJ150+1 2462 NJ160=NJ160+1 2463 Z(NJ150)=0D0 2464 IF(TPS.LT.0.04D0)GO TO 370 2465 Z(NJ150)=Z(NJ130)**1.212D0-0.78D0 2466 TST=DABS(Z(NJ150)) 2467 IF(TST.LT.10D-10)GO TO 370 2468 IF(TPS.LT.10D10)Z(NJ150)=Z(NJ150)/DEXP(0.228D0/TPS) 2469 370 Z(NJ150)=Z(NJ150)+1.78D0 2470 Z(NJ160)=0D0 2471 IF(TMS.LT.0.04D0)GO TO 380 2472 Z(NJ160)=Z(NJ140)**1.212D0-0.78D0 2473 TST=DABS(Z(NJ160)) 2474 IF(TST.LT.10D-10)GO TO 380 2475 IF(TMS.LT.10D10)Z(NJ160)=Z(NJ160)/DEXP(0.228D0/TMS) 2476 380 Z(NJ160)=Z(NJ160)+1.78D0 2477 IF(KETA.GE.I)WRITE(6,6030)JD,I,N,Z(NJ130),Z(NJ150),Z(NJ140), 2478 XZ(NJ160) 2479 6030 FORMAT(1H ,2I5,I7,4F15.6) 2480 Z(NJ150)=Z(NJ150)/2D0 2481 Z(NJ160)=Z(NJ160)/2D0 2482 360 CONTINUE 2483 350 CONTINUE 2484 RETURN 2485 END 2486 C ********************************************************************** 2487 SUBROUTINE GAMCAP(B,AIN,TG,TGB,J17,J18,J19,J20,KOPG) 2488 IMPLICIT INTEGER*4(I-N) 2489 IMPLICIT REAL*8(A-H,O-Z) 2490 COMMON 2491 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32), 2492 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, 2493 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,IEGD, 2494 XID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0,NOEN,NODIF, 2495 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,NOFIT 2496 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB 2497 COMMON/ZBLOCK/Z(24000) 2498 DIMENSION AIN(1),LLMX(50) 2499 KTA=0 2500 NINT=0 2501 J18=0 2502 TGU=0D0 2503 TGB=0D0 2504 ELIM=BN+ECM 2505 ELO=0D0 2506 IF(0.05D0.GE.ECM)EHI=ELO+ECM 2507 IF(0.05D0.GE.ECM)GO TO 41 2508 40 EHI=ELO+0.05D0 2509 41 IF(EHI.GE.ELIM)EHI=ELIM 2510 EPS=(EHI+ELO)/2D0 2511 ESQ=EPS*EPS 2512 TINT=(EHI-ELO)*EPS*ESQ 2513 EEE=-EGD*EGD+ESQ 2514 IF(KGD.EQ.1)TINT=TINT*EPS/(ESQ*GGD*GGD+EEE*EEE) 2515 EXC=BN+ECM-EPS 2516 IF(EXC-EXX)42,42,46 2517 42 EBYT=(EXC-E0)/TX 2518 TINT=TINT*DEXP(EBYT)/TX 2519 GO TO 44 2520 46 EBYT=DSQRT(SA*(EXC-PR)) 2521 DEN=B*EBYT*(EXC-PR) 2522 TINT=TINT*DEXP(2D0*EBYT)/DEN 2523 44 CONTINUE 2524 IF(EPS-ECM)30,32,32 2525 30 TGU=TGU+TINT 2526 EEI=ECM-EPS 2527 NINT=NINT+1 2528 CALL GAMMAS(BN,EEI,E0,EXX,TX,SA,PR,B,KGD,EGD,GGD,TMP) 2529 TMP=TMP*CTG 2530 JK7=J17 2531 DO 82 I=1,NLEVL 2532 IF(EEI.LT.EX(I))GO TO 82 2533 LMX=LMAX 2534 EN=EEI-EX(I) 2535 K=-1 2536 IF(KOPG.GT.0)K=0 2537 CALL ABACUS(K,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KTA,LMX,J5,JA,JK7, 2538 XJJ17) 2539 LLMX(I)=LMX+1 2540 LLMX(I+NLEVL)=JK7 2541 J18=MAX0(J18,JJ17) 2542 JK7=JJ17 2543 82 CONTINUE 2544 IF (NINT.GT.1) GO TO 91 2545 J19=J18+NJMAX-NJMIN+1 2546 J20=J19+NJMAX-NJMIN+1 2547 IF(J20.LE.NZB)GO TO 90 2548 J20=NZB-J20 2549 WRITE(6,6000)J20 2550 6000 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA, DISCRETE NEUTR 2551 XON AND GAMMA CHANNELS BY',I6,' REAL*8 LOCATIONS.') 2552 STOP 2553 90 CONTINUE 2554 DO 10 J=J18,J20-1 2555 10 Z(J)=0D0 2556 91 DO 84 NJ=NJMIN,NJMAX 2557 NJ18=J18+NJ-NJMIN 2558 NJ19=J19+NJ-NJMIN 2559 JD=2*NJ-IT-1 2560 N1=JD-2 2561 N1=IABS(N1) 2562 N2=JD+2 2563 RPS=0D0 2564 RMS=0D0 2565 DO 65 J=N1,N2,2 2566 DEX=-(J+1)*(J+1)/(SGSQ*4D0) 2567 RO=0D0 2568 M1=J-2 2569 M1=IABS(M1) 2570 M2=J+2 2571 DO 66 K=M1,M2,2 2572 DEY=-(K+1)*(K+1)/(SGSQ*4D0) 2573 66 RO=RO+DEXP(DEY)*(K+1) 2574 RO=6.2836*RO/SGSQ 2575 ROJ=6.2836*(J+1)*DEXP(DEX)/SGSQ 2576 TPS=0D0 2577 TMS=0D0 2578 DO 200 I=1,NLEVL 2579 IF(EEI.LT.EX(I))GO TO 200 2580 NJ17=LLMX(I+NLEVEL) 2581 JID=JD-ID(I) 2582 NKMIN=(1+IABS(JID))/2 2583 NKMAX=(1+JD+ID(I))/2 2584 NKMAX=MIN0(NKMAX,LLMX(I)) 2585 IF(NKMAX-NKMIN)200,220,220 2586 220 DO 300 NK=NKMIN,NKMAX 2587 NKMOD=MOD(NK,2) 2588 JPLS=2*NK-NKMOD 2589 JMNS=2*NK+NKMOD-1 2590 NJ171=NJ17+JPLS-1 2591 NJ172=NJ17+JMNS-1 2592 IF(IPI(I)+IPI(1))310,320,310 2593 310 TPS=TPS+Z(NJ171) 2594 TMS=TMS+Z(NJ172) 2595 GO TO 300 2596 320 TPS=TPS+Z(NJ172) 2597 TMS=TMS+Z(NJ171) 2598 300 CONTINUE 2599 200 CONTINUE 2600 TIP=TMP*RO 2601 TPS=TPS+TIP 2602 TMS=TMS+TIP 2603 TPS=TMP/TPS 2604 TMS=TMP/TMS 2605 RJ=RO*ROJ 2606 RPS=RPS+RJ*TMS 2607 RMS=RMS+RJ*TPS 2608 65 CONTINUE 2609 Z(NJ18)=Z(NJ18)+TINT*RPS 2610 Z(NJ19)=Z(NJ19)+TINT*RMS 2611 84 CONTINUE 2612 GO TO 34 2613 32 TGB=TGB+TINT 2614 34 CONTINUE 2615 IF(EHI.EQ.ELIM)GO TO 50 2616 ELO=EHI 2617 GO TO 40 2618 50 TG=TGU+TGB 2619 RETURN 2620 END 2621 C ********************************************************************** 2622 SUBROUTINE GAMMAS(BN,ECM,E0,EX,TX,SA,PR,B,KGD,EGD,GGD,TG) 2623 IMPLICIT INTEGER*4(I-N) 2624 IMPLICIT REAL*8(A-H,O-Z) 2625 TG=0D0 2626 ELIM=BN+ECM 2627 ELO=0D0 2628 40 EHI=ELO+0.05D0 2629 IF(EHI.GE.ELIM)EHI=ELIM 2630 EPS=(EHI+ELO)/2D0 2631 ESQ=EPS*EPS 2632 TINT=(EHI-ELO)*EPS*ESQ 2633 EEE=-EGD*EGD+ESQ 2634 IF(KGD.EQ.1)TINT=TINT*EPS/(ESQ*GGD*GGD+EEE*EEE) 2635 EXC=BN+ECM-EPS 2636 IF(EXC-EX)42,42,46 2637 42 EBYT=(EXC-E0)/TX 2638 TINT=TINT*DEXP(EBYT)/TX 2639 GO TO 44 2640 46 EBYT=DSQRT(SA*(EXC-PR)) 2641 DEN=B*EBYT*(EXC-PR) 2642 TINT=TINT*DEXP(2D0*EBYT)/DEN 2643 44 CONTINUE 2644 TG=TG+TINT 2645 IF(EHI.EQ.ELIM)GO TO 50 2646 ELO=EHI 2647 GO TO 40 2648 50 RETURN 2649 END 2650 C ********************************************************************** 2651 SUBROUTINE PRSL(NZ,NN,PR,SC) 2652 IMPLICIT INTEGER*4(I-N) 2653 IMPLICIT REAL*8(A-H,O-Z) 2654 DIMENSION JZ(44),JN(70),KZ(88),KN(140) 2655 DATA JZ/246,209,162,162,183,173,135,154,120,106,136,143,117,124, 2656 2120,128,128,135,136,119,114,112,158,117,118,122,97,92,62,68,64,72, 2657 375,71,87,83,89,79,89,78,69,61,72,77/ 2658 DATA JN/267,180,167,186,204,164,144,154,130,127,129,141,150,150, 2659 2143,188,147,157,146,93,72,112,129,94,124,125,114,132,115,124,143, 2660 3109,120,104,70,85,76,92,99,110,92,73,70,87,61,69,55,40,73,58,86, 2661 4113,84,79,82,71,41,38,67,61,78,67,67,79,60,57,49,43,50,39/ 2662 DATA KZ/291,417,572,780,897,970,1010,1070,1138,1207,1255,1324,1393 2663 2,1471,1553,1637,1736,1852,1844,1819,1768,1709,1665,1666,1659,1635, 2664 31618,1641,1660,1654,1642,1684,1722,1742,1752,1782,1819,1858,1911, 2665 41983,1914,1835,1740,1654,1568,1475,1371,1287,1218,1161,1109,1078, 2666 51053,1041,1021,985,936,897,856,813,768,733,711,716,705,681,656,695 2667 6,752,803,841,886,771,638,547,478,437,417,412,429,461,504,548,596, 2668 7640,687,720,774/ 2669 DATA KN/680,753,755,721,744,807,894,981,1060,1139,1254,1368,1434, 2670 21419,1383,1350,1300,1213,1260,1326,1413,1492,1560,1638,1708,1755, 2671 31798,1833,1856,1871,1865,1855,1852,1834,1801,1738,1656,1562,1438, 2672 41288,1324,1371,1440,1516,1589,1643,1697,1759,1808,1872,1922,1951, 2673 51973,1991,2006,2016,2009,1983,1941,1906,1866,1773,1703,1644,1600, 2674 61533,1449,1342,1228,1114,1010,909,1000,1064,1118,1170,1222,1271, 2675 71305,1299,1262,1211,1166,1121,1081,1038,1003,965,938,899,862,833, 2676 8810,782,756,733,715,683,669,655,653,649,639,582,526,453,383,308, 2677 9237,172,105,27,-69,-169,-258,-316,-172,-41,71,166,262,322,376,410, 2678 A446,483,509,518,517,510,505,504,503,499,498,511,527,539,537,530/ 2679 SC=0D0 2680 PR=0D0 2681 IF((NZ.LT.11).OR.(NN.LT.11))GO TO 10 2682 IF((NZ.GT.98).OR.(NN.GT.150))GO TO 10 2683 IN=NN-10 2684 IZ=NZ-10 2685 SC=(DFLOAT(KN(IN))-DFLOAT(KZ(IZ)))/100D0 2686 NZHF=NZ/2 2687 NNHF=NN/2 2688 NZCK=2*NZHF 2689 NNCK=2*NNHF 2690 IZ=NZHF-5 2691 IN=NNHF-5 2692 IF(NZCK.EQ.NZ)PR=PR+DFLOAT(JZ(IZ))/100D0 2693 IF(NNCK.EQ.NN)PR=PR+DFLOAT(JN(IN))/100D0 2694 10 RETURN 2695 END 2696 C ********************************************************************** 2697 BLOCK DATA 2698 IMPLICIT REAL*8(A-H,O-Z) 2699 COMMON /COMN/FIN(16),X(20),W(20),KP(16) 2700 DATA KP/1,2*0,3*1,2*0,2*1,6*0/, 2701 XFIN/50D0,2*0D0,1.2,0.6,14D0,2*0D0,1.3,0.5,2*0D0,7D0,0D0,1.2,0.6/ 2702 DATA X/0.07054,0.372127,0.916582,1.707307,2.749199,4.048925,5.6151 2703 X75,7.459017,9.594393,12.038803,14.814293,17.948896,21.478788,25.45 2704 X1703,29.932555,35.013434,40.833057,47.619994,55.810796,66.524417/ 2705 DATA W/0.168747,0.291254,0.266686,0.166002,.0748261,0.0249644,0.00 2706 X620255,0.00114496,0.000155742,0.154014D-4,0.108649D-5,0.533012D-7, 2707 X0.175798D-8,0.37255D-10,0.476753D-12,0.337284D-14,0.115501D-16,0.1 2708 X53952D-19,0.528644D-23,0.165646D-27/ 2709 END 2710 2711 C ********************************************************************* 2712 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) 2713 IMPLICIT INTEGER*4(I-N) 2714 INTEGER M,N,INFO,LWA 2715 INTEGER IWA(N) 2716 DOUBLE PRECISION TOL 2717 DOUBLE PRECISION X(N),FVEC(M),WA(LWA) 2718 EXTERNAL FCN 2719 C ********** 2720 C 2721 C SUBROUTINE LMDIF1 2722 C 2723 C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF 2724 C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE 2725 C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE 2726 C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A 2727 C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS 2728 C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. 2729 C 2730 C THE SUBROUTINE STATEMENT IS 2731 C 2732 C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) 2733 C 2734 C WHERE 2735 C 2736 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH 2737 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED 2738 C IN AN EXTERNAL STATEMENT IN THE USER CALLING 2739 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. 2740 C 2741 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) 2742 C INTEGER M,N,IFLAG 2743 C DOUBLE PRECISION X(N),FVEC(M) 2744 C ---------- 2745 C CALCULATE THE FUNCTIONS AT X AND 2746 C RETURN THIS VECTOR IN FVEC. 2747 C ---------- 2748 C RETURN 2749 C END 2750 C 2751 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS 2752 C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. 2753 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. 2754 C 2755 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 2756 C OF FUNCTIONS. 2757 C 2758 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 2759 C OF VARIABLES. N MUST NOT EXCEED M. 2760 C 2761 C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN 2762 C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X 2763 C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. 2764 C 2765 C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS 2766 C THE FUNCTIONS EVALUATED AT THE OUTPUT X. 2767 C 2768 C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS 2769 C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE 2770 C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT 2771 C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT 2772 C MOST TOL. 2773 C 2774 C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS 2775 C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) 2776 C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, 2777 C INFO IS SET AS FOLLOWS. 2778 C 2779 C INFO = 0 IMPROPER INPUT PARAMETERS. 2780 C 2781 C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR 2782 C IN THE SUM OF SQUARES IS AT MOST TOL. 2783 C 2784 C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR 2785 C BETWEEN X AND THE SOLUTION IS AT MOST TOL. 2786 C 2787 C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. 2788 C 2789 C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE 2790 C JACOBIAN TO MACHINE PRECISION. 2791 C 2792 C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR 2793 C EXCEEDED 200*(N+1). 2794 C 2795 C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN 2796 C THE SUM OF SQUARES IS POSSIBLE. 2797 C 2798 C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN 2799 C THE APPROXIMATE SOLUTION X IS POSSIBLE. 2800 C 2801 C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. 2802 C 2803 C WA IS A WORK ARRAY OF LENGTH LWA. 2804 C 2805 C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 2806 C M*N+5*N+M. 2807 C 2808 C SUBPROGRAMS CALLED 2809 C 2810 C USER-SUPPLIED ...... FCN 2811 C 2812 C MINPACK-SUPPLIED ... LMDIF 2813 C 2814 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 2815 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 2816 C 2817 C ********** 2818 INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT 2819 DOUBLE PRECISION EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO 2820 DATA FACTOR,ZERO /1.0D2,0.0D0/ 2821 INFO = 0 2822 C 2823 C CHECK THE INPUT PARAMETERS FOR ERRORS. 2824 C 2825 IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO 2826 * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 2827 C 2828 C CALL LMDIF. 2829 C 2830 MAXFEV = 200*(N + 1) 2831 FTOL = TOL 2832 XTOL = TOL 2833 GTOL = ZERO 2834 EPSFCN = ZERO 2835 MODE = 1 2836 NPRINT = 0 2837 MP5N = M + 5*N 2838 CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), 2839 * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, 2840 * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) 2841 IF (INFO .EQ. 8) INFO = 4 2842 10 CONTINUE 2843 RETURN 2844 C 2845 C LAST CARD OF SUBROUTINE LMDIF1. 2846 C 2847 END 2848 DOUBLE PRECISION FUNCTION DPMPAR(I) 2849 IMPLICIT INTEGER*4(I-N) !PTG8/91 2850 INTEGER I 2851 C ********** 2852 C 2853 C FUNCTION DPMPAR 2854 C 2855 C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS 2856 C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY 2857 C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE 2858 C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED 2859 C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. 2860 C 2861 C THE FUNCTION STATEMENT IS 2862 C 2863 C DOUBLE PRECISION FUNCTION DPMPAR(I) 2864 C 2865 C WHERE 2866 C 2867 C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH 2868 C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS 2869 C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE 2870 C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE 2871 C 2872 C DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, 2873 C 2874 C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, 2875 C 2876 C DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. 2877 C 2878 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 2879 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 2880 C 2881 C ********** 2882 INTEGER MCHEPS(4) 2883 INTEGER MINMAG(4) 2884 INTEGER MAXMAG(4) 2885 DOUBLE PRECISION DMACH(3) 2886 EQUIVALENCE (DMACH(1),MCHEPS(1)) 2887 EQUIVALENCE (DMACH(2),MINMAG(1)) 2888 EQUIVALENCE (DMACH(3),MAXMAG(1)) 2889 C 2890 C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, 2891 C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, 2892 C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. 2893 C 2894 C DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 / 2895 C DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 / 2896 C DATA MAXMAG(1),MAXMAG(2) / Z7FFFFFFF, ZFFFFFFFF / 2897 C 2898 C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. 2899 C 2900 C DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / 2901 C DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / 2902 C DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / 2903 C 2904 C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. 2905 C 2906 C DATA MCHEPS(1) / 15614000000000000000B / 2907 C DATA MCHEPS(2) / 15010000000000000000B / 2908 C 2909 C DATA MINMAG(1) / 00604000000000000000B / 2910 C DATA MINMAG(2) / 00000000000000000000B / 2911 C 2912 C DATA MAXMAG(1) / 37767777777777777777B / 2913 C DATA MAXMAG(2) / 37167777777777777777B / 2914 C 2915 C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). 2916 C 2917 C DATA MCHEPS(1),MCHEPS(2) / "114400000000, "000000000000 / 2918 C DATA MINMAG(1),MINMAG(2) / "033400000000, "000000000000 / 2919 C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "344777777777 / 2920 C 2921 C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). 2922 C 2923 C DATA MCHEPS(1),MCHEPS(2) / "104400000000, "000000000000 / 2924 C DATA MINMAG(1),MINMAG(2) / "000400000000, "000000000000 / 2925 C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "377777777777 / 2926 C 2927 C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING (VAX-JFW) 2928 C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). 2929 C 2930 C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / 2931 C DATA MINMAG(1),MINMAG(2) / 128, 0 / 2932 C DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / 2933 C 2934 C DATA MCHEPS(1),MCHEPS(2) / O04500000000, O00000000000 / 2935 C DATA MINMAG(1),MINMAG(2) / O00040000000, O00000000000 / 2936 C DATA MAXMAG(1),MAXMAG(2) / O17777777777, O37777777777 / 2937 C 2938 C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING 2939 C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). 2940 C 2941 C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / 2942 C DATA MCHEPS(3),MCHEPS(4) / 0, 0 / 2943 C 2944 C DATA MINMAG(1),MINMAG(2) / 128, 0 / 2945 C DATA MINMAG(3),MINMAG(4) / 0, 0 / 2946 C 2947 C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / 2948 C DATA MAXMAG(3),MAXMAG(4) / -1, -1 / 2949 C 2950 C DATA MCHEPS(1),MCHEPS(2) / O022400, O000000 / 2951 C DATA MCHEPS(3),MCHEPS(4) / O000000, O000000 / 2952 C 2953 C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / 2954 C DATA MINMAG(3),MINMAG(4) / O000000, O000000 / 2955 C 2956 C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / 2957 C DATA MAXMAG(3),MAXMAG(4) / O177777, O177777 / 2958 C 2959 C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. 2960 C 2961 C DATA MCHEPS(1) / O1451000000000000 / 2962 C DATA MCHEPS(2) / O0000000000000000 / 2963 C 2964 C DATA MINMAG(1) / O1771000000000000 / 2965 C DATA MINMAG(2) / O7770000000000000 / 2966 C 2967 C DATA MAXMAG(1) / O0777777777777777 / 2968 C DATA MAXMAG(2) / O7777777777777777 / 2969 C 2970 C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. 2971 C 2972 C DATA MCHEPS(1) / O1451000000000000 / 2973 C DATA MCHEPS(2) / O0000000000000000 / 2974 C 2975 C DATA MINMAG(1) / O1771000000000000 / 2976 C DATA MINMAG(2) / O0000000000000000 / 2977 C 2978 C DATA MAXMAG(1) / O0777777777777777 / 2979 C DATA MAXMAG(2) / O0007777777777777 / 2980 C 2981 C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. 2982 C 2983 C DATA MCHEPS(1) / ZCC6800000 / 2984 C DATA MCHEPS(2) / Z000000000 / 2985 C 2986 C DATA MINMAG(1) / ZC00800000 / 2987 C DATA MINMAG(2) / Z000000000 / 2988 C 2989 C DATA MAXMAG(1) / ZDFFFFFFFF / 2990 C DATA MAXMAG(2) / ZFFFFFFFFF / 2991 C 2992 C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. 2993 C 2994 C DATA MCHEPS(1),MCHEPS(2) / O170640000000, O000000000000 / 2995 C DATA MINMAG(1),MINMAG(2) / O000040000000, O000000000000 / 2996 C DATA MAXMAG(1),MAXMAG(2) / O377777777777, O777777777777 / 2997 C 2998 C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. 2999 C 3000 C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - 3001 C STATIC DMACH(3) 3002 C 3003 C DATA MINMAG/20K,3*0/,MAXMAG/77777K,3*177777K/ 3004 C DATA MCHEPS/32020K,3*0/ 3005 C 3006 C MACHINE CONSTANTS FOR THE HARRIS 220. 3007 C 3008 C DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000334 / 3009 C DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / 3010 C DATA MAXMAG(1),MAXMAG(2) / '37777777, '37777577 / 3011 C 3012 C MACHINE CONSTANTS FOR THE CRAY-1. 3013 C 3014 C DATA MCHEPS(1) / 0376424000000000000000B / 3015 C DATA MCHEPS(2) / 0000000000000000000000B / 3016 C 3017 C DATA MINMAG(1) / 0200034000000000000000B / 3018 C DATA MINMAG(2) / 0000000000000000000000B / 3019 C 3020 C DATA MAXMAG(1) / 0577777777777777777777B / 3021 C DATA MAXMAG(2) / 0000007777777777777776B / 3022 C 3023 C MACHINE CONSTANTS FOR THE PRIME 400. 3024 C 3025 C DATA MCHEPS(1),MCHEPS(2) / :10000000000, :00000000123 / 3026 C DATA MINMAG(1),MINMAG(2) / :10000000000, :00000100000 / 3027 C DATA MAXMAG(1),MAXMAG(2) / :17777777777, :37777677776 / 3028 C 3029 DMACH(1)=2.**(-53) 3030 DMACH(2)=1.D-38 3031 DMACH(3)=1.D+38 3032 DPMPAR = DMACH(I) 3033 RETURN 3034 C 3035 C LAST CARD OF FUNCTION DPMPAR. 3036 C 3037 END 3038 DOUBLE PRECISION FUNCTION ENORM(N,X) 3039 IMPLICIT INTEGER*4(I-N) !PTG8/91 3040 INTEGER N 3041 DOUBLE PRECISION X(N) 3042 C ********** 3043 C 3044 C FUNCTION ENORM 3045 C 3046 C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE 3047 C EUCLIDEAN NORM OF X. 3048 C 3049 C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF 3050 C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE 3051 C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS 3052 C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS 3053 C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED 3054 C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. 3055 C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS 3056 C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN 3057 C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT 3058 C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS 3059 C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. 3060 C 3061 C THE FUNCTION STATEMENT IS 3062 C 3063 C DOUBLE PRECISION FUNCTION ENORM(N,X) 3064 C 3065 C WHERE 3066 C 3067 C N IS A POSITIVE INTEGER INPUT VARIABLE. 3068 C 3069 C X IS AN INPUT ARRAY OF LENGTH N. 3070 C 3071 C SUBPROGRAMS CALLED 3072 C 3073 C FORTRAN-SUPPLIED ... DABS,DSQRT 3074 C 3075 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 3076 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 3077 C 3078 C ********** 3079 INTEGER I 3080 DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS, 3081 * X1MAX,X3MAX,ZERO 3082 DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ 3083 S1 = ZERO 3084 S2 = ZERO 3085 S3 = ZERO 3086 X1MAX = ZERO 3087 X3MAX = ZERO 3088 FLOATN = N 3089 AGIANT = RGIANT/FLOATN 3090 DO 90 I = 1, N 3091 XABS = DABS(X(I)) 3092 IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 3093 IF (XABS .LE. RDWARF) GO TO 30 3094 C 3095 C SUM FOR LARGE COMPONENTS. 3096 C 3097 IF (XABS .LE. X1MAX) GO TO 10 3098 S1 = ONE + S1*(X1MAX/XABS)**2 3099 X1MAX = XABS 3100 GO TO 20 3101 10 CONTINUE 3102 S1 = S1 + (XABS/X1MAX)**2 3103 20 CONTINUE 3104 GO TO 60 3105 30 CONTINUE 3106 C 3107 C SUM FOR SMALL COMPONENTS. 3108 C 3109 IF (XABS .LE. X3MAX) GO TO 40 3110 S3 = ONE + S3*(X3MAX/XABS)**2 3111 X3MAX = XABS 3112 GO TO 50 3113 40 CONTINUE 3114 IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 3115 50 CONTINUE 3116 60 CONTINUE 3117 GO TO 80 3118 70 CONTINUE 3119 C 3120 C SUM FOR INTERMEDIATE COMPONENTS. 3121 C 3122 S2 = S2 + XABS**2 3123 80 CONTINUE 3124 90 CONTINUE 3125 C 3126 C CALCULATION OF NORM. 3127 C 3128 IF (S1 .EQ. ZERO) GO TO 100 3129 ENORM = X1MAX*DSQRT(S1+(S2/X1MAX)/X1MAX) 3130 GO TO 130 3131 100 CONTINUE 3132 IF (S2 .EQ. ZERO) GO TO 110 3133 IF (S2 .GE. X3MAX) 3134 * ENORM = DSQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) 3135 IF (S2 .LT. X3MAX) 3136 * ENORM = DSQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) 3137 GO TO 120 3138 110 CONTINUE 3139 ENORM = X3MAX*DSQRT(S3) 3140 120 CONTINUE 3141 130 CONTINUE 3142 RETURN 3143 C 3144 C LAST CARD OF FUNCTION ENORM. 3145 C 3146 END 3147 SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) 3148 IMPLICIT INTEGER*4(I-N) !PTG8/91 3149 INTEGER M,N,LDFJAC,IFLAG 3150 DOUBLE PRECISION EPSFCN 3151 DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) 3152 C ********** 3153 C 3154 C SUBROUTINE FDJAC2 3155 C 3156 C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION 3157 C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED 3158 C PROBLEM OF M FUNCTIONS IN N VARIABLES. 3159 C 3160 C THE SUBROUTINE STATEMENT IS 3161 C 3162 C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) 3163 C 3164 C WHERE 3165 C 3166 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH 3167 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED 3168 C IN AN EXTERNAL STATEMENT IN THE USER CALLING 3169 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. 3170 C 3171 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) 3172 C INTEGER M,N,IFLAG 3173 C DOUBLE PRECISION X(N),FVEC(M) 3174 C ---------- 3175 C CALCULATE THE FUNCTIONS AT X AND 3176 C RETURN THIS VECTOR IN FVEC. 3177 C ---------- 3178 C RETURN 3179 C END 3180 C 3181 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS 3182 C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. 3183 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. 3184 C 3185 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 3186 C OF FUNCTIONS. 3187 C 3188 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 3189 C OF VARIABLES. N MUST NOT EXCEED M. 3190 C 3191 C X IS AN INPUT ARRAY OF LENGTH N. 3192 C 3193 C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE 3194 C FUNCTIONS EVALUATED AT X. 3195 C 3196 C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE 3197 C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. 3198 C 3199 C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M 3200 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. 3201 C 3202 C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE 3203 C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. 3204 C 3205 C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE 3206 C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS 3207 C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE 3208 C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS 3209 C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE 3210 C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE 3211 C PRECISION. 3212 C 3213 C WA IS A WORK ARRAY OF LENGTH M. 3214 C 3215 C SUBPROGRAMS CALLED 3216 C 3217 C USER-SUPPLIED ...... FCN 3218 C 3219 C MINPACK-SUPPLIED ... DPMPAR 3220 C MINPACK-SUPPLIED ... DPMPAR 3221 C 3222 C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT 3223 C 3224 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 3225 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 3226 C 3227 C ********** 3228 INTEGER I,J 3229 DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO 3230 DOUBLE PRECISION DPMPAR 3231 DATA ZERO /0.0D0/ 3232 C 3233 C EPSMCH IS THE MACHINE PRECISION. 3234 C 3235 EPSMCH = DPMPAR(1) 3236 C 3237 EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) 3238 DO 20 J = 1, N 3239 TEMP = X(J) 3240 H = EPS*DABS(TEMP) 3241 IF (H .EQ. ZERO) H = EPS 3242 X(J) = TEMP + H 3243 CALL FCN(M,N,X,WA,IFLAG) 3244 IF (IFLAG .LT. 0) GO TO 30 3245 X(J) = TEMP 3246 DO 10 I = 1, M 3247 FJAC(I,J) = (WA(I) - FVEC(I))/H 3248 10 CONTINUE 3249 20 CONTINUE 3250 30 CONTINUE 3251 RETURN 3252 C 3253 C LAST CARD OF SUBROUTINE FDJAC2. 3254 C 3255 END 3256 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, 3257 * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, 3258 * IPVT,QTF,WA1,WA2,WA3,WA4) 3259 IMPLICIT INTEGER*4(I-N) !PTG8/91 3260 INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC 3261 INTEGER IPVT(N) 3262 DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR 3263 DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), 3264 * WA1(N),WA2(N),WA3(N),WA4(M) 3265 EXTERNAL FCN 3266 C ********** 3267 C 3268 C SUBROUTINE LMDIF 3269 C 3270 C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF 3271 C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF 3272 C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A 3273 C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS 3274 C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. 3275 C 3276 C THE SUBROUTINE STATEMENT IS 3277 C 3278 C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, 3279 C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, 3280 C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) 3281 C 3282 C WHERE 3283 C 3284 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH 3285 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED 3286 C IN AN EXTERNAL STATEMENT IN THE USER CALLING 3287 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. 3288 C 3289 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) 3290 C INTEGER M,N,IFLAG 3291 C DOUBLE PRECISION X(N),FVEC(M) 3292 C ---------- 3293 C CALCULATE THE FUNCTIONS AT X AND 3294 C RETURN THIS VECTOR IN FVEC. 3295 C ---------- 3296 C RETURN 3297 C END 3298 C 3299 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS 3300 C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. 3301 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. 3302 C 3303 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 3304 C OF FUNCTIONS. 3305 C 3306 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 3307 C OF VARIABLES. N MUST NOT EXCEED M. 3308 C 3309 C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN 3310 C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X 3311 C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. 3312 C 3313 C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS 3314 C THE FUNCTIONS EVALUATED AT THE OUTPUT X. 3315 C 3316 C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION 3317 C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE 3318 C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. 3319 C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED 3320 C IN THE SUM OF SQUARES. 3321 C 3322 C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION 3323 C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE 3324 C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE 3325 C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. 3326 C 3327 C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION 3328 C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND 3329 C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE 3330 C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY 3331 C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS 3332 C OF THE JACOBIAN. 3333 C 3334 C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION 3335 C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST 3336 C MAXFEV BY THE END OF AN ITERATION. 3337 C 3338 C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE 3339 C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS 3340 C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE 3341 C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS 3342 C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE 3343 C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE 3344 C PRECISION. 3345 C 3346 C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE 3347 C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG 3348 C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS 3349 C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. 3350 C 3351 C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE 3352 C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, 3353 C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER 3354 C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. 3355 C 3356 C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE 3357 C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF 3358 C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE 3359 C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE 3360 C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. 3361 C 3362 C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED 3363 C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, 3364 C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST 3365 C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND 3366 C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE 3367 C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS 3368 C OF FCN WITH IFLAG = 0 ARE MADE. 3369 C 3370 C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS 3371 C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) 3372 C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, 3373 C INFO IS SET AS FOLLOWS. 3374 C 3375 C INFO = 0 IMPROPER INPUT PARAMETERS. 3376 C 3377 C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS 3378 C IN THE SUM OF SQUARES ARE AT MOST FTOL. 3379 C 3380 C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES 3381 C IS AT MOST XTOL. 3382 C 3383 C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. 3384 C 3385 C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY 3386 C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN 3387 C ABSOLUTE VALUE. 3388 C 3389 C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR 3390 C EXCEEDED MAXFEV. 3391 C 3392 C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN 3393 C THE SUM OF SQUARES IS POSSIBLE. 3394 C 3395 C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN 3396 C THE APPROXIMATE SOLUTION X IS POSSIBLE. 3397 C 3398 C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE 3399 C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. 3400 C 3401 C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF 3402 C CALLS TO FCN. 3403 C 3404 C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX 3405 C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH 3406 C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT 3407 C 3408 C T T T 3409 C P *(JAC *JAC)*P = R *R, 3410 C 3411 C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL 3412 C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) 3413 C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL 3414 C PART OF FJAC CONTAINS INFORMATION GENERATED DURING 3415 C THE COMPUTATION OF R. 3416 C 3417 C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M 3418 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. 3419 C 3420 C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT 3421 C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, 3422 C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS 3423 C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR 3424 C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. 3425 C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. 3426 C 3427 C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS 3428 C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. 3429 C 3430 C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. 3431 C 3432 C WA4 IS A WORK ARRAY OF LENGTH M. 3433 C 3434 C SUBPROGRAMS CALLED 3435 C 3436 C USER-SUPPLIED ...... FCN 3437 C 3438 C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC 3439 C 3440 C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD 3441 C 3442 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 3443 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 3444 C 3445 C ********** 3446 INTEGER I,IFLAG,ITER,J,L 3447 DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, 3448 * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, 3449 * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO 3450 DOUBLE PRECISION DPMPAR,ENORM 3451 DATA ONE,P1,P5,P25,P75,P0001,ZERO 3452 * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ 3453 C 3454 C EPSMCH IS THE MACHINE PRECISION. 3455 C 3456 EPSMCH = DPMPAR(1) 3457 C 3458 INFO = 0 3459 IFLAG = 0 3460 NFEV = 0 3461 C 3462 C CHECK THE INPUT PARAMETERS FOR ERRORS. 3463 C 3464 IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M 3465 * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO 3466 * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 3467 IF (MODE .NE. 2) GO TO 20 3468 DO 10 J = 1, N 3469 IF (DIAG(J) .LE. ZERO) GO TO 300 3470 10 CONTINUE 3471 20 CONTINUE 3472 C 3473 C EVALUATE THE FUNCTION AT THE STARTING POINT 3474 C AND CALCULATE ITS NORM. 3475 C 3476 IFLAG = 1 3477 CALL FCN(M,N,X,FVEC,IFLAG) 3478 NFEV = 1 3479 IF (IFLAG .LT. 0) GO TO 300 3480 FNORM = ENORM(M,FVEC) 3481 C 3482 C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. 3483 C 3484 PAR = ZERO 3485 ITER = 1 3486 C 3487 C BEGINNING OF THE OUTER LOOP. 3488 C 3489 30 CONTINUE 3490 C 3491 C CALCULATE THE JACOBIAN MATRIX. 3492 C 3493 IFLAG = 2 3494 CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) 3495 NFEV = NFEV + N 3496 IF (IFLAG .LT. 0) GO TO 300 3497 C 3498 C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. 3499 C 3500 IF (NPRINT .LE. 0) GO TO 40 3501 IFLAG = 0 3502 IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) 3503 IF (IFLAG .LT. 0) GO TO 300 3504 40 CONTINUE 3505 C 3506 C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. 3507 C 3508 CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) 3509 C 3510 C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING 3511 C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. 3512 C 3513 IF (ITER .NE. 1) GO TO 80 3514 IF (MODE .EQ. 2) GO TO 60 3515 DO 50 J = 1, N 3516 DIAG(J) = WA2(J) 3517 IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE 3518 50 CONTINUE 3519 60 CONTINUE 3520 C 3521 C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X 3522 C AND INITIALIZE THE STEP BOUND DELTA. 3523 C 3524 DO 70 J = 1, N 3525 WA3(J) = DIAG(J)*X(J) 3526 70 CONTINUE 3527 XNORM = ENORM(N,WA3) 3528 DELTA = FACTOR*XNORM 3529 IF (DELTA .EQ. ZERO) DELTA = FACTOR 3530 80 CONTINUE 3531 C 3532 C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN 3533 C QTF. 3534 C 3535 DO 90 I = 1, M 3536 WA4(I) = FVEC(I) 3537 90 CONTINUE 3538 DO 130 J = 1, N 3539 IF (FJAC(J,J) .EQ. ZERO) GO TO 120 3540 SUM = ZERO 3541 DO 100 I = J, M 3542 SUM = SUM + FJAC(I,J)*WA4(I) 3543 100 CONTINUE 3544 TEMP = -SUM/FJAC(J,J) 3545 DO 110 I = J, M 3546 WA4(I) = WA4(I) + FJAC(I,J)*TEMP 3547 110 CONTINUE 3548 120 CONTINUE 3549 FJAC(J,J) = WA1(J) 3550 QTF(J) = WA4(J) 3551 130 CONTINUE 3552 C 3553 C COMPUTE THE NORM OF THE SCALED GRADIENT. 3554 C 3555 GNORM = ZERO 3556 IF (FNORM .EQ. ZERO) GO TO 170 3557 DO 160 J = 1, N 3558 L = IPVT(J) 3559 IF (WA2(L) .EQ. ZERO) GO TO 150 3560 SUM = ZERO 3561 DO 140 I = 1, J 3562 SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) 3563 140 CONTINUE 3564 GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) 3565 150 CONTINUE 3566 160 CONTINUE 3567 170 CONTINUE 3568 C 3569 C TEST FOR CONVERGENCE OF THE GRADIENT NORM. 3570 C 3571 IF (GNORM .LE. GTOL) INFO = 4 3572 IF (INFO .NE. 0) GO TO 300 3573 C 3574 C RESCALE IF NECESSARY. 3575 C 3576 IF (MODE .EQ. 2) GO TO 190 3577 DO 180 J = 1, N 3578 DIAG(J) = DMAX1(DIAG(J),WA2(J)) 3579 180 CONTINUE 3580 190 CONTINUE 3581 C 3582 C BEGINNING OF THE INNER LOOP. 3583 C 3584 200 CONTINUE 3585 C 3586 C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. 3587 C 3588 CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, 3589 * WA3,WA4) 3590 C 3591 C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. 3592 C 3593 DO 210 J = 1, N 3594 WA1(J) = -WA1(J) 3595 WA2(J) = X(J) + WA1(J) 3596 WA3(J) = DIAG(J)*WA1(J) 3597 210 CONTINUE 3598 PNORM = ENORM(N,WA3) 3599 C 3600 C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. 3601 C 3602 IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) 3603 C 3604 C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. 3605 C 3606 IFLAG = 1 3607 CALL FCN(M,N,WA2,WA4,IFLAG) 3608 NFEV = NFEV + 1 3609 IF (IFLAG .LT. 0) GO TO 300 3610 FNORM1 = ENORM(M,WA4) 3611 C 3612 C COMPUTE THE SCALED ACTUAL REDUCTION. 3613 C 3614 ACTRED = -ONE 3615 IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 3616 C 3617 C COMPUTE THE SCALED PREDICTED REDUCTION AND 3618 C THE SCALED DIRECTIONAL DERIVATIVE. 3619 C 3620 DO 230 J = 1, N 3621 WA3(J) = ZERO 3622 L = IPVT(J) 3623 TEMP = WA1(L) 3624 DO 220 I = 1, J 3625 WA3(I) = WA3(I) + FJAC(I,J)*TEMP 3626 220 CONTINUE 3627 230 CONTINUE 3628 TEMP1 = ENORM(N,WA3)/FNORM 3629 TEMP2 = (DSQRT(PAR)*PNORM)/FNORM 3630 PRERED = TEMP1**2 + TEMP2**2/P5 3631 DIRDER = -(TEMP1**2 + TEMP2**2) 3632 C 3633 C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED 3634 C REDUCTION. 3635 C 3636 RATIO = ZERO 3637 IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED 3638 C 3639 C UPDATE THE STEP BOUND. 3640 C 3641 IF (RATIO .GT. P25) GO TO 240 3642 IF (ACTRED .GE. ZERO) TEMP = P5 3643 IF (ACTRED .LT. ZERO) 3644 * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) 3645 IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 3646 DELTA = TEMP*DMIN1(DELTA,PNORM/P1) 3647 PAR = PAR/TEMP 3648 GO TO 260 3649 240 CONTINUE 3650 IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 3651 DELTA = PNORM/P5 3652 PAR = P5*PAR 3653 250 CONTINUE 3654 260 CONTINUE 3655 C 3656 C TEST FOR SUCCESSFUL ITERATION. 3657 C 3658 IF (RATIO .LT. P0001) GO TO 290 3659 C 3660 C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. 3661 C 3662 DO 270 J = 1, N 3663 X(J) = WA2(J) 3664 WA2(J) = DIAG(J)*X(J) 3665 270 CONTINUE 3666 DO 280 I = 1, M 3667 FVEC(I) = WA4(I) 3668 280 CONTINUE 3669 XNORM = ENORM(N,WA2) 3670 FNORM = FNORM1 3671 ITER = ITER + 1 3672 290 CONTINUE 3673 C 3674 C TESTS FOR CONVERGENCE. 3675 C 3676 IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL 3677 * .AND. P5*RATIO .LE. ONE) INFO = 1 3678 IF (DELTA .LE. XTOL*XNORM) INFO = 2 3679 IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL 3680 * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 3681 IF (INFO .NE. 0) GO TO 300 3682 C 3683 C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. 3684 C 3685 IF (NFEV .GE. MAXFEV) INFO = 5 3686 IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH 3687 * .AND. P5*RATIO .LE. ONE) INFO = 6 3688 IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 3689 IF (GNORM .LE. EPSMCH) INFO = 8 3690 IF (INFO .NE. 0) GO TO 300 3691 C 3692 C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. 3693 C 3694 IF (RATIO .LT. P0001) GO TO 200 3695 C 3696 C END OF THE OUTER LOOP. 3697 C 3698 GO TO 30 3699 300 CONTINUE 3700 C 3701 C TERMINATION, EITHER NORMAL OR USER IMPOSED. 3702 C 3703 IF (IFLAG .LT. 0) INFO = IFLAG 3704 IFLAG = 0 3705 IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) 3706 RETURN 3707 C 3708 C LAST CARD OF SUBROUTINE LMDIF. 3709 C 3710 END 3711 SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, 3712 * WA2) 3713 IMPLICIT INTEGER*4(I-N) !PTG8/91 3714 INTEGER N,LDR 3715 INTEGER IPVT(N) 3716 DOUBLE PRECISION DELTA,PAR 3717 DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N), 3718 * WA2(N) 3719 C ********** 3720 C 3721 C SUBROUTINE LMPAR 3722 C 3723 C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL 3724 C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, 3725 C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER 3726 C PAR SUCH THAT IF X SOLVES THE SYSTEM 3727 C 3728 C A*X = B , SQRT(PAR)*D*X = 0 , 3729 C 3730 C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN 3731 C NORM OF D*X, THEN EITHER PAR IS ZERO AND 3732 C 3733 C (DXNORM-DELTA) .LE. 0.1*DELTA , 3734 C 3735 C OR PAR IS POSITIVE AND 3736 C 3737 C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . 3738 C 3739 C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM 3740 C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE 3741 C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF 3742 C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL 3743 C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL 3744 C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS 3745 C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, 3746 C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT 3747 C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT 3748 C 3749 C T T T 3750 C P *(A *A + PAR*D*D)*P = S *S . 3751 C 3752 C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. 3753 C 3754 C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE 3755 C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS 3756 C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST 3757 C VALUE OBTAINED SO FAR. 3758 C 3759 C THE SUBROUTINE STATEMENT IS 3760 C 3761 C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, 3762 C WA1,WA2) 3763 C 3764 C WHERE 3765 C 3766 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. 3767 C 3768 C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE 3769 C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. 3770 C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE 3771 C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE 3772 C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. 3773 C 3774 C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N 3775 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. 3776 C 3777 C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE 3778 C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P 3779 C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. 3780 C 3781 C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE 3782 C DIAGONAL ELEMENTS OF THE MATRIX D. 3783 C 3784 C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST 3785 C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. 3786 C 3787 C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER 3788 C BOUND ON THE EUCLIDEAN NORM OF D*X. 3789 C 3790 C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN 3791 C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. 3792 C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. 3793 C 3794 C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST 3795 C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, 3796 C FOR THE OUTPUT PAR. 3797 C 3798 C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE 3799 C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. 3800 C 3801 C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. 3802 C 3803 C SUBPROGRAMS CALLED 3804 C 3805 C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV 3806 C 3807 C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT 3808 C 3809 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 3810 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 3811 C 3812 C ********** 3813 INTEGER I,ITER,J,JM1,JP1,K,L,NSING 3814 DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, 3815 * SUM,TEMP,ZERO 3816 DOUBLE PRECISION DPMPAR,ENORM 3817 DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ 3818 C 3819 C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. 3820 C 3821 DWARF = DPMPAR(2) 3822 C 3823 C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE 3824 C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. 3825 C 3826 NSING = N 3827 DO 10 J = 1, N 3828 WA1(J) = QTB(J) 3829 IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 3830 IF (NSING .LT. N) WA1(J) = ZERO 3831 10 CONTINUE 3832 IF (NSING .LT. 1) GO TO 50 3833 DO 40 K = 1, NSING 3834 J = NSING - K + 1 3835 WA1(J) = WA1(J)/R(J,J) 3836 TEMP = WA1(J) 3837 JM1 = J - 1 3838 IF (JM1 .LT. 1) GO TO 30 3839 DO 20 I = 1, JM1 3840 WA1(I) = WA1(I) - R(I,J)*TEMP 3841 20 CONTINUE 3842 30 CONTINUE 3843 40 CONTINUE 3844 50 CONTINUE 3845 DO 60 J = 1, N 3846 L = IPVT(J) 3847 X(L) = WA1(J) 3848 60 CONTINUE 3849 C 3850 C INITIALIZE THE ITERATION COUNTER. 3851 C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST 3852 C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. 3853 C 3854 ITER = 0 3855 DO 70 J = 1, N 3856 WA2(J) = DIAG(J)*X(J) 3857 70 CONTINUE 3858 DXNORM = ENORM(N,WA2) 3859 FP = DXNORM - DELTA 3860 IF (FP .LE. P1*DELTA) GO TO 220 3861 C 3862 C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON 3863 C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF 3864 C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. 3865 C 3866 PARL = ZERO 3867 IF (NSING .LT. N) GO TO 120 3868 DO 80 J = 1, N 3869 L = IPVT(J) 3870 WA1(J) = DIAG(L)*(WA2(L)/DXNORM) 3871 80 CONTINUE 3872 DO 110 J = 1, N 3873 SUM = ZERO 3874 JM1 = J - 1 3875 IF (JM1 .LT. 1) GO TO 100 3876 DO 90 I = 1, JM1 3877 SUM = SUM + R(I,J)*WA1(I) 3878 90 CONTINUE 3879 100 CONTINUE 3880 WA1(J) = (WA1(J) - SUM)/R(J,J) 3881 110 CONTINUE 3882 TEMP = ENORM(N,WA1) 3883 PARL = ((FP/DELTA)/TEMP)/TEMP 3884 120 CONTINUE 3885 C 3886 C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. 3887 C 3888 DO 140 J = 1, N 3889 SUM = ZERO 3890 DO 130 I = 1, J 3891 SUM = SUM + R(I,J)*QTB(I) 3892 130 CONTINUE 3893 L = IPVT(J) 3894 WA1(J) = SUM/DIAG(L) 3895 140 CONTINUE 3896 GNORM = ENORM(N,WA1) 3897 PARU = GNORM/DELTA 3898 IF (PARU .EQ. ZERO) PARU = DWARF/DMIN1(DELTA,P1) 3899 C 3900 C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), 3901 C SET PAR TO THE CLOSER ENDPOINT. 3902 C 3903 PAR = DMAX1(PAR,PARL) 3904 PAR = DMIN1(PAR,PARU) 3905 IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM 3906 C 3907 C BEGINNING OF AN ITERATION. 3908 C 3909 150 CONTINUE 3910 ITER = ITER + 1 3911 C 3912 C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. 3913 C 3914 IF (PAR .EQ. ZERO) PAR = DMAX1(DWARF,P001*PARU) 3915 TEMP = DSQRT(PAR) 3916 DO 160 J = 1, N 3917 WA1(J) = TEMP*DIAG(J) 3918 160 CONTINUE 3919 CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) 3920 DO 170 J = 1, N 3921 WA2(J) = DIAG(J)*X(J) 3922 170 CONTINUE 3923 DXNORM = ENORM(N,WA2) 3924 TEMP = FP 3925 FP = DXNORM - DELTA 3926 C 3927 C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE 3928 C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL 3929 C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. 3930 C 3931 IF (DABS(FP) .LE. P1*DELTA 3932 * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP 3933 * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 3934 C 3935 C COMPUTE THE NEWTON CORRECTION. 3936 C 3937 DO 180 J = 1, N 3938 L = IPVT(J) 3939 WA1(J) = DIAG(L)*(WA2(L)/DXNORM) 3940 180 CONTINUE 3941 DO 210 J = 1, N 3942 WA1(J) = WA1(J)/SDIAG(J) 3943 TEMP = WA1(J) 3944 JP1 = J + 1 3945 IF (N .LT. JP1) GO TO 200 3946 DO 190 I = JP1, N 3947 WA1(I) = WA1(I) - R(I,J)*TEMP 3948 190 CONTINUE 3949 200 CONTINUE 3950 210 CONTINUE 3951 TEMP = ENORM(N,WA1) 3952 PARC = ((FP/DELTA)/TEMP)/TEMP 3953 C 3954 C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. 3955 C 3956 IF (FP .GT. ZERO) PARL = DMAX1(PARL,PAR) 3957 IF (FP .LT. ZERO) PARU = DMIN1(PARU,PAR) 3958 C 3959 C COMPUTE AN IMPROVED ESTIMATE FOR PAR. 3960 C 3961 PAR = DMAX1(PARL,PAR+PARC) 3962 C 3963 C END OF AN ITERATION. 3964 C 3965 GO TO 150 3966 220 CONTINUE 3967 C 3968 C TERMINATION. 3969 C 3970 IF (ITER .EQ. 0) PAR = ZERO 3971 RETURN 3972 C 3973 C LAST CARD OF SUBROUTINE LMPAR. 3974 C 3975 END 3976 SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) 3977 IMPLICIT INTEGER*4(I-N) !PTG8/91 3978 INTEGER M,N,LDA,LIPVT 3979 INTEGER IPVT(LIPVT) 3980 LOGICAL PIVOT 3981 DOUBLE PRECISION A(LDA,N),RDIAG(N),ACNORM(N),WA(N) 3982 C ********** 3983 C 3984 C SUBROUTINE QRFAC 3985 C 3986 C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN 3987 C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE 3988 C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL 3989 C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL 3990 C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, 3991 C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR 3992 C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM 3993 C 3994 C T 3995 C I - (1/U(K))*U*U 3996 C 3997 C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF 3998 C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST 3999 C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. 4000 C 4001 C THE SUBROUTINE STATEMENT IS 4002 C 4003 C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) 4004 C 4005 C WHERE 4006 C 4007 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 4008 C OF ROWS OF A. 4009 C 4010 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER 4011 C OF COLUMNS OF A. 4012 C 4013 C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR 4014 C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT 4015 C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT 4016 C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL 4017 C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL 4018 C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). 4019 C 4020 C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M 4021 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. 4022 C 4023 C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, 4024 C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, 4025 C THEN NO COLUMN PIVOTING IS DONE. 4026 C 4027 C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT 4028 C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. 4029 C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. 4030 C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. 4031 C 4032 C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, 4033 C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN 4034 C LIPVT MUST BE AT LEAST N. 4035 C 4036 C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE 4037 C DIAGONAL ELEMENTS OF R. 4038 C 4039 C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE 4040 C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. 4041 C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE 4042 C WITH RDIAG. 4043 C 4044 C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA 4045 C CAN COINCIDE WITH RDIAG. 4046 C 4047 C SUBPROGRAMS CALLED 4048 C 4049 C MINPACK-SUPPLIED ... DPMPAR,ENORM 4050 C 4051 C FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0 4052 C 4053 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 4054 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 4055 C 4056 C ********** 4057 INTEGER I,J,JP1,K,KMAX,MINMN 4058 DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO 4059 DOUBLE PRECISION DPMPAR,ENORM 4060 DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ 4061 C 4062 C EPSMCH IS THE MACHINE PRECISION. 4063 C 4064 EPSMCH = DPMPAR(1) 4065 C 4066 C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. 4067 C 4068 DO 10 J = 1, N 4069 ACNORM(J) = ENORM(M,A(1,J)) 4070 RDIAG(J) = ACNORM(J) 4071 WA(J) = RDIAG(J) 4072 IF (PIVOT) IPVT(J) = J 4073 10 CONTINUE 4074 C 4075 C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. 4076 C 4077 MINMN = MIN0(M,N) 4078 DO 110 J = 1, MINMN 4079 IF (.NOT.PIVOT) GO TO 40 4080 C 4081 C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. 4082 C 4083 KMAX = J 4084 DO 20 K = J, N 4085 IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K 4086 20 CONTINUE 4087 IF (KMAX .EQ. J) GO TO 40 4088 DO 30 I = 1, M 4089 TEMP = A(I,J) 4090 A(I,J) = A(I,KMAX) 4091 A(I,KMAX) = TEMP 4092 30 CONTINUE 4093 RDIAG(KMAX) = RDIAG(J) 4094 WA(KMAX) = WA(J) 4095 K = IPVT(J) 4096 IPVT(J) = IPVT(KMAX) 4097 IPVT(KMAX) = K 4098 40 CONTINUE 4099 C 4100 C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE 4101 C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. 4102 C 4103 AJNORM = ENORM(M-J+1,A(J,J)) 4104 IF (AJNORM .EQ. ZERO) GO TO 100 4105 IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM 4106 DO 50 I = J, M 4107 A(I,J) = A(I,J)/AJNORM 4108 50 CONTINUE 4109 A(J,J) = A(J,J) + ONE 4110 C 4111 C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS 4112 C AND UPDATE THE NORMS. 4113 C 4114 JP1 = J + 1 4115 IF (N .LT. JP1) GO TO 100 4116 DO 90 K = JP1, N 4117 SUM = ZERO 4118 DO 60 I = J, M 4119 SUM = SUM + A(I,J)*A(I,K) 4120 60 CONTINUE 4121 TEMP = SUM/A(J,J) 4122 DO 70 I = J, M 4123 A(I,K) = A(I,K) - TEMP*A(I,J) 4124 70 CONTINUE 4125 IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 4126 TEMP = A(J,K)/RDIAG(K) 4127 RDIAG(K) = RDIAG(K)*DSQRT(DMAX1(ZERO,ONE-TEMP**2)) 4128 IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 4129 RDIAG(K) = ENORM(M-J,A(JP1,K)) 4130 WA(K) = RDIAG(K) 4131 80 CONTINUE 4132 90 CONTINUE 4133 100 CONTINUE 4134 RDIAG(J) = -AJNORM 4135 110 CONTINUE 4136 RETURN 4137 C 4138 C LAST CARD OF SUBROUTINE QRFAC. 4139 C 4140 END 4141 SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) 4142 IMPLICIT INTEGER*4(I-N) !PTG8/91 4143 INTEGER N,LDR 4144 INTEGER IPVT(N) 4145 DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) 4146 C ********** 4147 C 4148 C SUBROUTINE QRSOLV 4149 C 4150 C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, 4151 C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH 4152 C SOLVES THE SYSTEM 4153 C 4154 C A*X = B , D*X = 0 , 4155 C 4156 C IN THE LEAST SQUARES SENSE. 4157 C 4158 C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM 4159 C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE 4160 C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF 4161 C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL 4162 C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL 4163 C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS 4164 C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, 4165 C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM 4166 C A*X = B, D*X = 0, IS THEN EQUIVALENT TO 4167 C 4168 C T T 4169 C R*Z = Q *B , P *D*P*Z = 0 , 4170 C 4171 C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, 4172 C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV 4173 C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT 4174 C 4175 C T T T 4176 C P *(A *A + D*D)*P = S *S . 4177 C 4178 C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. 4179 C 4180 C THE SUBROUTINE STATEMENT IS 4181 C 4182 C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) 4183 C 4184 C WHERE 4185 C 4186 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. 4187 C 4188 C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE 4189 C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. 4190 C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE 4191 C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE 4192 C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. 4193 C 4194 C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N 4195 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. 4196 C 4197 C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE 4198 C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P 4199 C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. 4200 C 4201 C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE 4202 C DIAGONAL ELEMENTS OF THE MATRIX D. 4203 C 4204 C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST 4205 C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. 4206 C 4207 C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST 4208 C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. 4209 C 4210 C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE 4211 C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. 4212 C 4213 C WA IS A WORK ARRAY OF LENGTH N. 4214 C 4215 C SUBPROGRAMS CALLED 4216 C 4217 C FORTRAN-SUPPLIED ... DABS,DSQRT 4218 C 4219 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. 4220 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE 4221 C 4222 C ********** 4223 INTEGER I,J,JP1,K,KP1,L,NSING 4224 DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO 4225 DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ 4226 C 4227 C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. 4228 C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. 4229 C 4230 DO 20 J = 1, N 4231 DO 10 I = J, N 4232 R(I,J) = R(J,I) 4233 10 CONTINUE 4234 X(J) = R(J,J) 4235 WA(J) = QTB(J) 4236 20 CONTINUE 4237 C 4238 C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. 4239 C 4240 DO 100 J = 1, N 4241 C 4242 C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE 4243 C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. 4244 C 4245 L = IPVT(J) 4246 IF (DIAG(L) .EQ. ZERO) GO TO 90 4247 DO 30 K = J, N 4248 SDIAG(K) = ZERO 4249 30 CONTINUE 4250 SDIAG(J) = DIAG(L) 4251 C 4252 C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D 4253 C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B 4254 C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. 4255 C 4256 QTBPJ = ZERO 4257 DO 80 K = J, N 4258 C 4259 C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE 4260 C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. 4261 C 4262 IF (SDIAG(K) .EQ. ZERO) GO TO 70 4263 IF (DABS(R(K,K)) .GE. DABS(SDIAG(K))) GO TO 40 4264 COTAN = R(K,K)/SDIAG(K) 4265 SIN = P5/DSQRT(P25+P25*COTAN**2) 4266 COS = SIN*COTAN 4267 GO TO 50 4268 40 CONTINUE 4269 TAN = SDIAG(K)/R(K,K) 4270 COS = P5/DSQRT(P25+P25*TAN**2) 4271 SIN = COS*TAN 4272 50 CONTINUE 4273 C 4274 C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND 4275 C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). 4276 C 4277 R(K,K) = COS*R(K,K) + SIN*SDIAG(K) 4278 TEMP = COS*WA(K) + SIN*QTBPJ 4279 QTBPJ = -SIN*WA(K) + COS*QTBPJ 4280 WA(K) = TEMP 4281 C 4282 C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. 4283 C 4284 KP1 = K + 1 4285 IF (N .LT. KP1) GO TO 70 4286 DO 60 I = KP1, N 4287 TEMP = COS*R(I,K) + SIN*SDIAG(I) 4288 SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) 4289 R(I,K) = TEMP 4290 60 CONTINUE 4291 70 CONTINUE 4292 80 CONTINUE 4293 90 CONTINUE 4294 C 4295 C STORE THE DIAGONAL ELEMENT OF S AND RESTORE 4296 C THE CORRESPONDING DIAGONAL ELEMENT OF R. 4297 C 4298 SDIAG(J) = R(J,J) 4299 R(J,J) = X(J) 4300 100 CONTINUE 4301 C 4302 C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS 4303 C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. 4304 C 4305 NSING = N 4306 DO 110 J = 1, N 4307 IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 4308 IF (NSING .LT. N) WA(J) = ZERO 4309 110 CONTINUE 4310 IF (NSING .LT. 1) GO TO 150 4311 DO 140 K = 1, NSING 4312 J = NSING - K + 1 4313 SUM = ZERO 4314 JP1 = J + 1 4315 IF (NSING .LT. JP1) GO TO 130 4316 DO 120 I = JP1, NSING 4317 SUM = SUM + R(I,J)*WA(I) 4318 120 CONTINUE 4319 130 CONTINUE 4320 WA(J) = (WA(J) - SUM)/SDIAG(J) 4321 140 CONTINUE 4322 150 CONTINUE 4323 C 4324 C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. 4325 C 4326 DO 160 J = 1, N 4327 L = IPVT(J) 4328 X(L) = WA(J) 4329 160 CONTINUE 4330 RETURN 4331 C 4332 C LAST CARD OF SUBROUTINE QRSOLV. 4333 C 4334 END 4335 FUNCTION TLEFT(X) 4336 TLEFT=1.0E06 4337 RETURN 4338 END 4339 4340 C VAX G_FLOATING FORTRAN VERSION APRIL 1988 R.OSBORN AND G.L.GOODMAN 4341 FUNCTION CLEBSH (A, B, X, Y, CIN, ZIN) 4342 C 4343 C COMPUTES CLEBSCH-GORDAN AND 3-J COEFICENTS. 4344 C 4345 C THIS ROUTINE COMPUTES THE CLEBSH GORDAN OR 3-J COEFICENT FOR 4346 C A GIVEN SET OF J'S AND M'S. THE INPUT CONSISTS OF 6 INTEGERS THAT 4347 C ARE TWICE THE VALUES OF THE J'S AND M'S. IN THIS MANNER 4348 C HALF-INTEGER ANGULAR MOMENTA CAN BE ACCOMMODATED. 4349 C 4350 C A FACTORIZATION OF THE RACAH SUM SUGGESTED BY 4351 C J. G. WILLS, COMPUTER PHYSICS COMM. 2, 381 (1971) 4352 C IS USED. THE REQUIRED FACTORIALS THAT MULTIPLY THE SUM ARE 4353 C FOUND IN ONE OF 3 WAYS: 4354 C FOR J1+J2+J3 < 96, A TABLE OF SQRT(FACTORIAL) IS USED; 4355 C FOR 95 < J1+J2+J3 < 1000, A TABLE OF LOG(FACTORIAL) IS USED; 4356 C FOR 1000 <= J1+J2+J3, THE LOG GAMMA FUNCTION IS USED. 4357 C 4358 C THESE CHOICES REPRESENT REASONABLE TRADE OFFS BETWEEN SIZE AND 4359 C SPEED CONSIDERATIONS. BY RECOMPILING THE BLOCK DATA PROGRAMS 4360 C FOR THE /FACTRL/ OR /LOGFAC/ COMMON BLOCKS, ONE CAN CHANGE 4361 C THE ABOVE BOUNDRIES TO EITHER REDUCE CORE (IF ONE IS NOT 4362 C INTERESTED IN LARGE J'S) OR INCREASE THE SPEED FOR LARGE J'S. 4363 C 4364 C THE MAGNITUDE OF THE J'S AND M'S THAT CAN BE ACCOMMODATED BY 4365 C THIS ROUTINE IS DETERMINED BY CANCELLATIONS IN THE 4366 C RACAH SUM. AS CAN BE SEEN IN THE TABLE BELOW, IF ALL THREE J'S 4367 C GET LARGE, SEVERE CANCELLATION SETS IN FOR EACH J OF THE ORDER OF 4368 C 75, WHILE OVERFLOWS BEGIN TO OCCUR FOR THE J'S OF THE ORDER OF 4369 C 150. HOWEVER IF ONE OF THE J'S IS HELD SMALL, THE PRECISION 4370 C REMAINS GOOD FOR VERY LARGE VALUES OF THE OTHER TWO J'S AND THERE 4371 C ARE NO OVERFLOW PROBLEMS (THE LARGEST VALUES TRIED WERE 2000 AS 4372 C IS SHOWN IN THE TABLE). 4373 C 4374 C A SPECIAL CASE IS USED FOR M1 = M2 = M3 = 0. ALL THREE J'S 4375 C MAY THEN BE VERY LARGE. 4376 C 4377 C EACH LINE IN THE FOLLOWING TABLE IS THE RESULT OF SEVERAL 4378 C THOUSAND EVALUATIONS OF CLEBSH GORDAN COEFFICENTS FOR J'S AND 4379 C M'S IN THE RANGES INDICATED. PRECISIONS WERE DETERMINED BY 4380 C COMPARING THE RESULTS TO A QUADRUPOLE PRECISION CLEBSCH GORDAN 4381 C ROUTINE. IT IS NOT SIGNIFICANT THAT J3 WAS HELD SMALL; ANY 4382 C OF THE J'S MAY BE KEPT SMALL WITH THE SAME TIMING AND RELATIVE 4383 C ERROR RESULTS. THE EXECUTION TIMES ARE GIVEN IN MICROSECONDS. 4384 C 4385 C J1, J2 J3 M1, M2 TIMES RMS ABSOLUTE 4386 C RANGE RANGE LIMIT /195 /75 ERROR 4387 C 0 5 0 5 5 40 340 1E-16 4388 C 5 10 0 10 10 48 425 8E-17 4389 C 10 15 0 25 13 51 465 8E-17 4390 C 15 30 0 47 30 59 560 7E-17 4391 C 33 42 0 75 42 84 715 9E-13 4392 C 50 52 0 100 52 95 835 2E-10 4393 C 74 75 0 150 75 103 935 2E-5 4394 C 100 0 200 100 124 1175 .6 4395 C 150 0 300 150 205 2000 4E+8 SOME OVERFLOWS 4396 C 100 0 10 10 63 455 2E-15 4397 C 400 0 10 10 63 455 1E-14 4398 C 500 0 10 10 465 3500 6E-14 4399 C 500 0 10 500 470 6E-14 NOTE LARGE M1, M2 4400 C 2000 0 10 10 460 2E-13 4401 C 0 10 0 10 0 37 185 8E-17 M1=M2=M3=0 4402 C 100 100 0 37 210 5E-15 4403 C 300 300 0 38 215 3E-12 4404 C 500 500 0 172 1320 4405 C 1000 1000 0 174 3E-12 4406 C 4407 C NO EVALUATION OF CLEBSCH-GORDAN COEFICENTS THAT WERE TRIVIALLY 4408 C ZERO WERE INCLUDED IN THE ABOVE TIMINGS. THE LONG EXECUTION 4409 C TIMES FOR THE J1, J2 > 500 ENTRIES ARE DUE TO THE USE OF 4410 C THE LOG GAMMA FUNCTION. THEY MAY BE REDUCED BY INCREASING THE 4411 C SIZE OF THE /LOGFAC/ TABLE. 4412 C 4413 C 4414 C THERE ARE THREE ENTRIES: 4415 C 4416 C CLEBSH (2*J1, 2*J2, 2*M1, 2*M2, 2*J3, 2*M3) RETURNS A 4417 C DOUBLE PRECISION CLEBSCH-GORDAN COEFICENT. 4418 C THREEJ (2*J1, 2*J2, 2*J3, 2*M1, 2*M2, 2*M3) RETURNS A 4419 C DOUBLE PRECISION 3-J SYMBOL (M3 = -(M1+M2)). 4420 C COFCG (2*J1, 2*J2, 2*M1, 2*M2, 2*J3, 2*M3) RETURNS A 4421 C SINGLE PRECISION CLEBSCH-GORDAN COEFICENT. 4422 C 4423 C IN ALL CASES THE TRIANGLE INEQUALITIES, THE REQUIREMENTS THAT 4424 C EACH (J, M) SATISFY |M| <= J, AND THE REQUIREMENT THAT 4425 C M1+M2 = M3 (FOR 3-J M1+M2+M3 = 0) ARE CHECKED. IF THEY ARE 4426 C VIOLATED, 0 IS RETURNED. HOWEVER NO CHECK IS MADE TO VERIFY 4427 C THAT EACH (J, M) PAIR IS EITHER 1/2 INTEGER OR INTEGER NOR 4428 C THAT J1+J2+J3 IS INTEGER. THE USER MUST INSURE THAT 4429 C 2*J+2*M IS EVEN AND THAT 2*J1+2*J2+2*J3 IS EVEN. 4430 C IF THIS IS NOT SO, MEANINGLESS RESULTS WILL BE RETURNED. 4431 C 4432 C CORE REQUIREMENTS (BASE 10): 4433 C 4434 C CLEBSH 4088 BYTES 4435 C /FACTRL/ 798 MAY BE REDUCED 4436 C /LOGFAC/ 8028 MAY BE REDUCED OR INCREASED 4437 C DLGAMA 1008 (NOT KNOWN FOR VAX/VMS VERSION) 4438 C TOTAL 13,922 4439 C 4440 C ALSO "DSQRT", "DLOG", "DEXP" AND THE FORTRAN I/O PACKAGE ARE USED 4441 C SINCE THESE ARE LIKELY TO BE USED BY OTHER PARTS OF YOUR 4442 C PROGRAM, THEY ARE NOT INCLUDED IN THE ABOVE (THE FORTRAN I/O 4443 C PACKAGE IS USED BY DLOG, DEXP, AND DSQRT). THE /FACTRL/ 4444 C AND /LOGFAC/ COMMON BLOCKS AND THE "DLGAMA" FUNCTION WILL BE 4445 C SHARED WITH "SIXJ" AND "RACAH" SHOULD YOU ALSO USE THEM. 4446 C 4447 C IN THE VAX/VMS VERSION, THE NAG ROUTINE S14ABF IS USED WITHIN 4448 C THE DUMMY ROUTINE DLGAMA. THIS MAY BE EASILY CHANGED TO USE 4449 C ANOTHER LIBRARY ROUTINE. IF TRANSFERING THIS PROGRAM TO 4450 C ANOTHER SITE, IT IS IMPORTANT TO CHECK THAT S14ABF IS THE 4451 C DOUBLE PRECISION VERSION (RATHER THAN S14ABE) IN THE LOCAL 4452 C NAG LIBRARY. THE SOURCE OF DLGAMA IS AT THE END OF THIS FILE. 4453 C R.OSBORN 4/10/88 4454 C 4455 C 4456 C S. PIEPER 4457 C 4458 C 4/5/71 4459 C 8/21/72 ARGONNE VERSION IN DOUBLE PRECISION 4460 C 8/25/72 INTEGER INPUT VERSION 4461 C 9/3/72 SPEEDED UP VERSION, ALSO QUITE ACCURATE 4462 C 9/7/72 USE SQRT OF FACTORIALS AND BINOMIAL COFS 4463 C 9/8/72 SINGLE AND DOUBLE PRECISION ENTRY POINTS 4464 C 10/22/72 ALMOST COMPLETE REWRITE FOR RACAH FORMULA 4465 C 10/23/72 ADD SPECIAL CASE FOR M1 = M2 = M3 = 0 AND 3-J ENTRY 4466 C 5/17/73 CORRECT SIGN ERROR IN THREEJ 4467 C 6/18/74 - TOTALLY NEW METHOD 4468 C 7/8/74 - USE "XL" FUNCTIONS FOR SPEED, REDUCED SIZE. 4469 C 9/11/74 - CORRECT THREEJ DOUBLE/SINGLE PRECISION ERROR 4470 C 4/8/88 - MODIFIED FOR USE ON VAX/VMS - R.OSBORN AND G.L.GOODMAN 4471 C 4472 C 4473 C 4474 IMPLICIT INTEGER*4 (A-C, I-Z), REAL*8 (D-H) 4475 C 4476 REAL*8 SUM,ANSWER 4477 REAL*8 CLEBSH, THREEJ, THRJ 4478 REAL*8 DLGAMA 4479 C 4480 COMMON /FACTRL/ MAXFAC, ISPACE, FACTBL(97) 4481 C 4482 REAL*8 LF 4483 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) 4484 C 4485 C FOLLOWING ARE THE VAX FORTRAN FUNCTIONS THAT WE USE. 4486 C BTEST CHECKS TO SEE IF A BIT IS ON. 4487 C BTEST(I,0) CHECKS FOR I BEING ODD, BTEST(I,1) CHECKS FOR I/2 BEING 4488 C ISHFT(I,-1) SHIFTS THE BITS IN I ONE TO THE RIGHT = /2 4489 C 4490 C 4491 LOGICAL DBLSW, THRESW, BTEST 4492 REAL*4 COFCG 4493 C 4494 C 4495 C FOLLOWING ARRAYS ARE DEFINED TO ALLOW USE OF LOOPS TO SHORTEN CODE 4496 C 4497 DIMENSION DRAY(9) 4498 C 4499 EQUIVALENCE (DRAY(1), DA1), (DRAY(2), DA2), (DRAY(3), DA3), 4500 1 (DRAY(4), DY1), (DRAY(5), DX2), (DRAY(6), DY2), (DRAY(7), DX1), 4501 2 (DRAY(8), DZ1), (DRAY(9), DZ2) 4502 C 4503 C FOLLOWING DUMMY EXTERNAL CAUSES THE FACTORIAL TABLES TO BE DEFINED 4504 C 4505 EXTERNAL FACDUM, LOGDUM 4506 C 4507 C 4508 C CLEBSH IS THE AMD COMPATIBLE ENTRY POINT 4509 C 4510 C 4511 C 4512 THRESW = .FALSE. 4513 DBLSW = .TRUE. 4514 GO TO 10 4515 C 4516 C COFCG IS SINGLE PRECISION ENTRY 4517 C 4518 ENTRY COFCG (A, B, X, Y, CIN, ZIN) 4519 THRESW = .FALSE. 4520 DBLSW = .FALSE. 4521 C 4522 10 Z = ZIN 4523 C 4524 20 C = CIN 4525 C 4526 C 4527 IF (Z .EQ. X+Y) GO TO 120 4528 C 4529 110 CLEBSH=0.0 4530 RETURN 4531 C 4532 C 4533 C 4534 C X1 = J1 + M1 ; ETC. 4535 C 4536 C THE FOLLOWING ISHFT FUNCTIONS EFFECT A DIVIDE BY 2 4537 C TO GET FROM THE 2*J STUFF TO J STUFF SINCE THE 3 4538 C (J+M)'S MUST BE INTEGERS. 4539 C 4540 120 X1 = ISHFT(A+X, -1) 4541 Y1 = ISHFT(B+Y, -1) 4542 Z1 = ISHFT(C+Z, -1) 4543 C 4544 C THE ISHFT INSTRUCTION IS A LOGICAL SHIFT. THUS IT CONVERTS 4545 C A NEGATIVE NUMBER INTO A LARGE POSITIVE NUMBER WHICH WILL LOUSE 4546 C UP THE TRIANGLE CONDITION CHECKS. HERE WE CHECK TO SEE IF ANY OF 4547 C THE THREE NUMBERS HAD SIGN BITS THAT WERE SHIFTED INTO THE FIRST 4548 C POSITION. IF SO THEN THE CORRESPONDING M WAS GREATER THAN J SO 4549 C WE JUST RETURN 0. 4550 C ALL OF THIS IS TO AVOID DIVIDES BY 2 WHICH ARE VERY SLOW ON 4551 C THE IBM/195. 4552 C 4553 C T30 IS THE LOCATION OF THE SHIFTED SIGN BIT AND IS 30 FOR THE 4554 C VAX FORTRAN USED HERE 4555 T30 = 30 4556 C 4557 IF (BTEST(X1,T30).OR.BTEST(Y1,T30).OR.BTEST(Z1,T30)) GO TO 110 4558 C 4559 C X2 = J1 - M1 ; ETC 4560 C 4561 X2 = X1 - X 4562 Y2 = Y1 - Y 4563 Z2 = Z1 - Z 4564 C 4565 C R = J1+J2+J3 + 1 4566 C 4567 R = X1 + Y1 + Z2 + 1 4568 C 4569 C A(I) = J1+J2+J3 - 2J(I) ; A1 = -J1 + J2 + J3 , ETC. 4570 C 4571 A1 = R-1 - A 4572 A2 = R-1 - B 4573 A3 = R-1 - C 4574 C 4575 C B1 = J3 - J1 - M2 ; B2 = J3 - J2 + M1 4576 C 4577 B1 = A1 - Y1 4578 B2 = A2 - X2 4579 C 4580 C WE WILL NEED THESE FLOATING POINT NUMBERS AT VARIOUS PLACES 4581 C 4582 DA1 = A1 4583 DA2 = A2 4584 DA3 = A3 4585 DY1 = Y1 4586 DX2 = X2 4587 C 4588 DB1 = DA1 - DY1 4589 DB2 = DA2 - DX2 4590 C 4591 SUM = 1 4592 C 4593 NMIN = MAX0 (0, -B1, -B2) 4594 NMAX = MIN0 (A3, X2, Y1) 4595 C 4596 C THIS ONE CHECK MAKES SURE OF THE FOLLOWING 4597 C 1) ALL 3 TRIANGLE RULES 4598 C 2) |M| <= J FOR ALL 3 CASES 4599 C 3) J >= 0 FOR ALL 3 CASES 4600 C 4601 IF (NMAX - NMIN) 110, 300, 200 4602 C 4603 C IS IT THE ALL M = 0 CASE 4604 C 4605 200 IF (IABS(X)+IABS(Y) .EQ. 0) GO TO 500 4606 C 4607 C PREPARE TO DO THE SUM 4608 DX = NMAX 4609 E1 = -DX 4610 E2 = -DB1-DX 4611 E3 = -DB2 - DX 4612 E4 = DA3 - (DX-1) 4613 E5 = DX2 - (DX-1) 4614 E6 = DY1 - (DX-1) 4615 C 4616 F1 = E1*E2*E3 4617 F4 = E4*E5*E6 4618 C 4619 NMAXM2 = NMAX - 2 4620 SUM = 1 + F4/F1 4621 IF (NMAXM2 .LT. NMIN) GO TO 300 4622 C 4623 G1 = (E1+1)*(E2+1)*(E3+1) - F1 4624 G4 = (E4+1)*(E5+1)*(E6+1) - F4 4625 H1 = (E1+2)*(E2+2)*(E3+2) - G1 - G1 - F1 4626 H4 = (E4+2)*(E5+2)*(E6+2) - G4 - G4 - F4 4627 C 4628 C COMPUTE THE SUM IN THE RACAH FORMULA 4629 C 4630 DO 259 N = NMIN, NMAXM2 4631 F1 = F1 + G1 4632 F4 = F4 + G4 4633 G1 = G1 + H1 4634 G4 = G4 + H4 4635 H1 = H1 + 6 4636 H4 = H4 + 6 4637 SUM = 1 + SUM*(F4/F1) 4638 259 CONTINUE 4639 C 4640 C NOW WE NEED THE FACTORIALS OUTSIDE THE SUM 4641 C 4642 300 IF (R .LE. MAXFAC) GO TO 400 4643 C 4644 C 4645 C SOME OF THE FACTORIALS WILL BE TOO LARGE TO USE THE TABLE. 4646 C WE USE ONE OF TWO METHODS* 4647 C 4648 C 1) FOR MODERATELY SIZED J'S WE USE A TABLE OF 4649 C LOG FACTORIALS. 4650 C 4651 C 2) FOR TRUELY LARGE J'S WE USED THE LOG GAMMA FUNCTION 4652 C TO GET THE LOGS OF THE FACTORIALS. 4653 C 4654 C 4655 IF (R .GT. MAXLF) GO TO 350 4656 C 4657 C THIS IS THE MODERATELY LARGE REGION - USE TABLE 4658 C 4659 C 4660 E = LF(1+A3) - LF(1+NMIN) - LF(1+A3-NMIN) 4661 1 + LF(1+A1) - LF(1+B1+NMIN) - LF(1+Y1-NMIN) 4662 2 + LF(1+A2) - LF(1+B2+NMIN) - LF(1+X2-NMIN) 4663 E2 = .5*(-LF(1+A1) - LF(1+A2) - LF(1+A3) + LF(1+X1) + LF(1+X2) 4664 1 + LF(1+Y1) + LF(1+Y2) + LF(1+Z1) + LF(1+Z2) - LF(1+R) 4665 2 + LF(2+C) - LF(1+C) ) 4666 C 4667 IF (DABS(E) .GT. 40) GO TO 330 4668 C 4669 C SUM*E**2 MUST BE AN INTEGER. 4670 C SINCE E IS NOT VERY LARGE IS IS LIKELY TO BE MEANINGFUL TO 4671 C ATTEMPT TO FORCE THE INTEGER RESULT. 4672 C 4673 SUM = ANINT(SUM*DEXP(E)) 4674 C 4675 ANSWER = DEXP(E2)*SUM 4676 GO TO 450 4677 C 4678 C HERE E IS LARGE AND AN ATTEMPT TO INTERGERIZE SUM*EXP(E) WOUL 4679 C NOT BE SIGNIFICANT ON A 16 PLACE MACHINE. INSTEAD WE SPREAD 4680 C THE E FACTOR AMOUNGST THE OTHER STUFF IN AN ATTEMPT TO 4681 C AVOID OVERFLOWS. 4682 C 4683 330 E = E + E2 4684 ANSWER = DEXP(E)*SUM 4685 GO TO 450 4686 C 4687 C FOR LARGE VALUES OF J, WE USE THE LOG GAMMA FUNTION TO DIRECTLY 4688 C FIND THE LOG OF THE COMPLETE MESS OF OUTSIDE FACTORIALS. 4689 C 4690 C HERE WE AVOID INTEGER TO DOUBLE CONVERSIONS 4691 C 4692 350 DX1 = DA2 + DA3 - DX2 4693 DC = C 4694 DN = NMIN 4695 DZ1 = DX1 + DY1 - DA3 4696 DY2 = DA1 + DA3 - DY1 4697 DZ2 = DC - DZ1 4698 C 4699 E = DLOG(DC+1) - DLGAMA(2+DX1+DY1+DZ2) 4700 DO 369 I = 1, 9 4701 E = E + DLGAMA(1+DRAY(I)) 4702 369 CONTINUE 4703 E = .5*E 4704 DA1 = DB1 + (DN+1) 4705 DA2 = DB2 + (DN+1) 4706 DA3 = DA3 - (DN-1) 4707 DY1 = DY1 - (DN-1) 4708 DX2 = DX2 - (DN-1) 4709 DY2 = (DN+1) 4710 DO 379 I = 1, 6 4711 E = E - DLGAMA(DRAY(I)) 4712 379 CONTINUE 4713 C 4714 ANSWER = DEXP(E) * SUM 4715 C 4716 GO TO 450 4717 C 4718 C WE CAN USE THE FACTORIAL TABLES AND NOT WORRY 4719 C 4720 400 F1 = FACTBL(1+A1) 4721 F2 = FACTBL(1+A2) 4722 F3 = FACTBL(1+A3) 4723 C 4724 C HERE WE FORCE THE SUM OF PRODUCTS OF 3 BINOMIAL 4725 C COEFFICENTS TO BE AN INTEGER 4726 C 4727 E = (F3/(FACTBL(1+NMIN)*FACTBL(1+A3-NMIN))) 4728 1 * (F2/(FACTBL(1+X2-NMIN)*FACTBL(1+B2+NMIN))) 4729 2 * (F1/(FACTBL(1+Y1-NMIN)*FACTBL(1+B1+NMIN))) 4730 SUM = ANINT(E*SUM*E) 4731 C 4732 C FOR THE FOLLOWING NOTE THAT R = J1+J2+J3 + 1 4733 ANSWER = SUM * (FACTBL(1+X1)*FACTBL(1+X2)/(F3*F2)) 4734 1 * (FACTBL(1+Y1)*FACTBL(1+Y2)/F1) 4735 2 * (FACTBL(2+C)/FACTBL(1+C)) 4736 3 * (FACTBL(1+Z1)*FACTBL(1+Z2)/FACTBL(1+R)) 4737 C 4738 450 IF (BTEST(NMIN,0)) ANSWER = -ANSWER 4739 GO TO 800 4740 C 4741 C 4742 C 4743 C USE SPECIAL CASE FOR M1 = M2 = M3 = 0 SINCE RACAH IS 4744 C NOT TRIVIAL FOR THAT CASE 4745 C 4746 C 4747 C RESULT IS 0 IF J1+J2+J3 IS ODD 4748 500 IF (.NOT.BTEST(R,0)) GO TO 110 4749 JSUM = R-1 4750 IF (R .GT. MAXFAC) GO TO 550 4751 C 4752 C USE THE FACTORIAL TABLES 4753 C 4754 ANSWER = ((FACTBL(1+A1)*FACTBL(1+A2))/FACTBL(1+R)) 4755 1 * ((FACTBL(2+C)*FACTBL(1+A3))/FACTBL(1+C)) 4756 2 * (FACTBL(1+JSUM/2)/ 4757 3 (FACTBL(1+A1/2)*FACTBL(1+A2/2)*FACTBL(1+A3/2)) )**2 4758 GO TO 570 4759 C 4760 C USE LOG(FACTORIAL) 4761 C 4762 C IN THE FOLLOWING WE USE ISHFT( ,-1) TO MAKE A /2. 4763 C 4764 550 IF (R .GT. MAXLF) GO TO 560 4765 E = .5 * (LF(1+A1) + LF(1+A2) + LF(1+A3) 4766 1 + LF(2+C) - LF(1+C) - LF(1+R) ) 4767 2 - LF(1+ISHFT(A1,-1)) - LF(1+ISHFT(A2,-1)) - LF(1+ISHFT(A3,-1)) 4768 3 + LF(1+ISHFT(JSUM,-1)) 4769 C 4770 GO TO 565 4771 C 4772 560 DJSUM = DA1 + DA2 + DA3 4773 E = DLOG(DFLOAT(C+1)) - DLGAMA(DJSUM+2) 4774 E2 = -DLGAMA(.5*DJSUM+1) 4775 DO 564 I = 1, 3 4776 E = E + DLGAMA(1+DRAY(I)) 4777 E2 = E2 + DLGAMA(1 + .5*DRAY(I)) 4778 564 CONTINUE 4779 E = .5*E - E2 4780 C 4781 C 4782 565 ANSWER = DEXP(E) 4783 C 4784 C GET PHASE 4785 570 IF (BTEST(A3,1)) ANSWER = -ANSWER 4786 C 4787 C DETERMINE THE REQUESTED OUTPUT MODE 4788 C 4789 C WAS A 3-J REQUESTED 4790 800 IF (THRESW) GO TO 950 4791 C 4792 810 IF (DBLSW) GO TO 850 4793 C 4794 C ROUND THE ANSWER TO SINGLE PRECISION 4795 C 4796 COFCG = REAL(ANSWER) 4797 RETURN 4798 C 4799 C DOUBLE PRECISION ENTRY USED 4800 C 4801 850 CLEBSH = ANSWER 4802 RETURN 4803 C 4804 C THIS IS AVAILABLE ONLY IN DOUBLE PRECISION 4805 C 4806 ENTRY THRJ(A,B,CIN,X,Y,ZIN) 4807 ENTRY THREEJ (A, B, CIN, X, Y, ZIN) 4808 C 4809 Z = -ZIN 4810 THRESW = .TRUE. 4811 DBLSW = .TRUE. 4812 GO TO 20 4813 C 4814 C NOW PUT IN THE 3-J FACTOR 4815 C 4816 950 TEMP = A2-Z2 4817 IF (BTEST(TEMP,0)) ANSWER = -ANSWER 4818 IF (C .GT. MAXFAC-1) GO TO 970 4819 ANSWER = ANSWER * (FACTBL(1+C)/FACTBL(2+C)) 4820 GO TO 810 4821 970 ANSWER = ANSWER / DSQRT(C+1.D0) 4822 GO TO 810 4823 C 4824 END 4825 FUNCTION SIXJ (A, B, C, X, Y, Z) 4826 C 4827 C 4828 C COMPUTES 6-J AND RACAH COEFFICIENTS. 4829 C 4830 C THIS ROUTINE COMPUTES THE 6-J OR RACAH COEFFICIENT FOR 4831 C A GIVEN SET OF J'S. THE INPUT CONSISTS OF 6 INTEGERS THAT 4832 C ARE TWICE THE VALUES OF THE J'S. IN THIS MANNER 4833 C HALF-INTEGER ANGULAR MOMENTA CAN BE ACCOMODATED. 4834 C 4835 C FOR THE FOLLOWING DISCUSSION CONSIDER THE 6-J COEFFICENT: 4836 C 4837 C ( J1 J2 J3 ) 4838 C ( J4 J5 J6 ) 4839 C 4840 C 4841 C A FACTORIZATION OF THE RACAH SUM SUGGESTED BY 4842 C J. G. WILLS, COMPUTER PHYSICS COMM. 2, 381 (1971) 4843 C IS USED. THE REQUIRED FACTORIALS THAT MULTIPLY THE SUM ARE 4844 C FOUND IN ONE OF 3 WAYS: 4845 C FOR J1+J2+J4+J5 < 96, A TABLE OF SQRT(FACTORIAL) IS USE 4846 C FOR 95 < J1+J2+J4+J5 < 1000, A TABLE OF LOG(FACTORIAL) IS USED; 4847 C FOR 1000 <= J1+J2+J4+J5, LOG GAMMA IS USED. 4848 C 4849 C THESE CHOICES REPRESENT REASONABLE TRADE OFFS BETWEEN SIZE AND 4850 C SPEED CONSIDERATIONS. BY RECOMPILING THE BLOCK DATA PROGRAMS 4851 C FOR THE /FACTRL/ OR /LOGFAC/ COMMON BLOCKS, ONE CAN CHANGE 4852 C THE ABOVE BOUNDRIES TO EITHER REDUCE CORE (IF ONE IS NOT 4853 C INTERESTED IN LARGE J'S) OR INCREASE THE SPEED FOR LARGE J'S. 4854 C 4855 C THE MAGNITUDE OF THE J'S AND M'S THAT CAN BE ACCOMODATED BY 4856 C THIS ROUTINE IS DETERMINED BY CANCELLATIONS IN THE 4857 C RACAH SUM. AS CAN BE SEEN IN THE TABLE BELOW, IF ALL SIX J'S 4858 C GET LARGE, SEVERE CANCELLATION SETS IN FOR EACH J OF THE ORDER OF 4859 C 100. HOWEVER IF THREE OF THE J'S ARE HELD SMALL, THE PRECISION 4860 C REMAINS GOOD FOR VERY LARGE VALUES OF THE OTHER THREE J'S AND 4861 C THERE ARE NO OVERFLOW PROBLEMS (THE LARGEST VALUES TRIED WERE 4862 C 500 AS SHOWN IN THE TABLE). 4863 C 4864 C 4865 C EACH LINE IN THE FOLLOWING TABLE IS THE RESULT OF SEVERAL 4866 C THOUSAND EVALUATIONS OF 6-J COEFFICENTS FOR J'S 4867 C IN THE RANGES INDICATED. PRECISIONS WERE DETERMINED BY 4868 C COMPARING THE RESULTS TO A QUADRUPOLE PRECISION 6-J 4869 C ROUTINE. IT IS NOT SIGNIFICANT THAT J3, J4 AND J5 WERE HELD 4870 C SMALL; ANY THREE OF THE J'S MAY BE KEPT SMALL WITH THE SAME TIMIN 4871 C AND RELATIVE ERROR RESULTS. THE TIMING INFORMATION 4872 C IS IN MICROSECONDS. 4873 C 4874 C 4875 C J1, J2, J6 J3, J4, J5 TIMES RMS ABSOLUTE 4876 C RANGE RANGE /195 /75 ERROR 4877 C 0 5 0 5 49 400 4E-17 4878 C 5 10 0 10 64 615 7E-18 4879 C 10 15 0 25 59 550 5E-18 4880 C 15 30 0 47 73 650 2E-16 4881 C 33 42 0 75 95 790 2E-15 4882 C 50 52 0 100 112 1020 3E-13 4883 C 75 0 150 130 1140 3E-10 4884 C 100 0 200 146 1315 5E-6 4885 C 150 150 575 5520 3E+2 4886 C 4887 C 50 0 10 68 485 9E-16 4888 C 100 0 10 68 485 7E-16 4889 C 400 0 10 70 478 6E-15 4890 C 500 0 10 670 5080 9E-15 4891 C 4892 C 4893 C NO EVALUATION OF 6-J COEFICENTS THAT WERE TRIVIALLY 4894 C ZERO WERE INCLUDED IN THE ABOVE RESULTS. THE LONG EXECUTION 4895 C TIMES IN THE LAST LINE OF THE TABLE ARE DUE TO THE USE OF THE 4896 C LOG GAMMA FUNCTION. THEY MAY BE MADE COMPARABLE TO THE TIMES IN 4897 C THE PREVIOUS LINE BY INCREASING THE SIZE OF THE /LOGFAC/ 4898 C TABLE. 4899 C 4900 C 4901 C THERE ARE THREE ENTRIES: 4902 C 4903 C SIXJ (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6) RETURNS THE 4904 C DOUBLE PRECISION 6-J COEFICENT. 4905 C ( J1 J2 J3 ) 4906 C ( J4 J5 J6 ) 4907 C 4908 C RACAH (2*J1, 2*J2, 2*J5, 2*J4, 2*J3, 2*J6) RETURNS THE 4909 C DOUBLE PRECISION RACAH SYMBOL 4910 C W (J1, J2, J5, J4; J3, J6) 4911 C 4912 C COF6J (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6) RETURNS A 4913 C PROPERLY ROUNDED SINGLE PRECISION 6-J COEFICENT. 4914 C 4915 C IN ALL CASES THE TRIANGLE INEQUALITIES ARE CHECKED. IF THEY ARE 4916 C VIOLATED, 0 IS RETURNED. HOWEVER NO CHECK IS MADE TO VERIFY 4917 C THAT J1+J2+J3, J4+J2+J6, J1+J5+J6, AND J4+J5+J3 ARE 4918 C INTEGERS. THE USER MUST INSURE THAT 2*J1 + 2*J2 + 2*J3, ETC, 4919 C ARE EVEN. IF THIS IS NOT SO MEANINGLESS RESULTS WILL BE RETURNED 4920 C 4921 C CORE REQUIREMENTS (BASE 10): 4922 C 4923 C SIXJ 4000 BYTES 4924 C /FACTRL/ 798 MAY BE MADE SMALLER 4925 C /LOGFAC/ 8028 MAY BE MADE SMALLER OR LARGER 4926 C DLGAMA 1008 4927 C TOTAL 13,834 4928 C 4929 C IN ADDITION "DEXP" AND THE FORTRAN I/O PACKAGE WILL BE USED. 4930 C SINCE THESE ARE LIKELY TO BE USED BY OTHER PARTS OF YOUR 4931 C PROGRAM, THEY ARE NOT INCLUDED IN THE ABOVE (THE FORTRAN I/O 4932 C PACKAGE IS CALLED ONLY BY DEXP). THE /FACTRL/ 4933 C AND /LOGFAC/ COMMON BLOCKS AND THE "DLGAMA" FUNCTION WILL BE 4934 C SHARED WITH "CLEBSH" AND "THREEJ" SHOULD YOU ALSO USE THEM. 4935 C 4936 C 4937 C S. PIEPER 4938 C 4939 C 4/1/71 MODIVIED FROM COFJU TO GIVE 6-J 4940 C 8/21/72 ARGONNE DOUBLE PRECISION VERSION 4941 C 9/5/72 INTEGER VERSION -- S. PIEPER 4942 C 9/6/72 USE SQRT OF BINOMIAL COFS AND FACTORIALS 4943 C 9/8/72 SINGLE AND DOUBLE PRECISION ENTRY POINTS 4944 C 9/23/73 SIXJ AND RACAH ENTRIES. 4945 C 7/6/74 - MAJOR REWRITE - TOTALLY NEW METHOD 4946 C APRIL 1988 - MOVE TO VAX/VMS R.OSBORN AND G.L.GOODMAN 4947 C 4948 IMPLICIT INTEGER*4 (A-C, I-Z), REAL*8 (D-H) 4949 C 4950 REAL*8 SUM, ANSWER, SIXJ, RACAH, DLGAMA 4951 REAL*4 COF6J 4952 LOGICAL DBLSW, RACHSW, BTEST 4953 C 4954 COMMON /FACTRL/ MAXFAC, ISPACE, FACTBL(97) 4955 C 4956 REAL*8 LF 4957 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) 4958 C 4959 C 4960 C THE FOLLOWING FAKE EXTERNALS DRAG IN THE REQUIRED BLOCK DATAS 4961 C FOR THE ABOVE COMMON BLOCKS 4962 C 4963 EXTERNAL FACDUM, LOGDUM 4964 C 4965 CCCCC********** 4966 CCCC COMMON /NUMBLK/ NUMIT, IBIG, INOTSO, ILF, E, SUM 4967 CCCCC********** 4968 C 4969 C WE USE THE FOLLOWING VAX FORTRAN FUNCTIONS: 4970 C BTEST - TESTS TO SEE IF A BIT IS ON. BTEST(I, 0) IS TRUE 4971 C IF I IS ODD. 4972 C ISHFT(N,-1) SHIFTS THE BITS IN N ONE TO THE RIGHT = /2 4973 C 4974 C 4975 DIMENSION DRAY(8) 4976 EQUIVALENCE (DA1, DRAY(1)), (DA2, DRAY(2)), 4977 1 (DA3, DRAY(3)), (DA4, DRAY(4)), 4978 2 (DC, DRAY(5)), (DZ, DRAY(7)) 4979 C 4980 C 4981 C SIXJ IS THE DOUBLE PRECISON ENTRY POINT 4982 C 4983 DBLSW = .TRUE. 4984 RACHSW = .FALSE. 4985 GO TO 100 4986 C 4987 C COF6J IS THE SINGLE PRECISION ENTRY POINT 4988 C 4989 ENTRY COF6J (A, B, C, X, Y, Z) 4990 DBLSW = .FALSE. 4991 RACHSW = .FALSE. 4992 GO TO 100 4993 C 4994 C RACAH ENTRY IS DOUBLE PRECISION 4995 C 4996 ENTRY RACAH (A, B, Y, X, C, Z) 4997 C 4998 RACHSW = .TRUE. 4999 DBLSW = .TRUE. 5000 C 5001 C 5002 C 5003 C 5004 100 SUM=1 5005 C 5006 CCCCC**************** 5007 CCCC NUMIT = 0 5008 CCCCC**************** 5009 C 5010 C 5011 A2 = ISHFT(X+Y-C, -1) 5012 A3 = ISHFT(A+Y-Z, -1) 5013 A4 = ISHFT(B+X-Z, -1) 5014 A1 = ISHFT(A+B-C, -1) 5015 C 5016 C THE ISHFT IS A LOGICAL SHIFT AND HENCE CONVERTS NEGATIVE 5017 C QUANTITIES INTO VERY LARGE POSITIVE QUANTITIES. IF ANY OF 5018 C THE AI'S ARE NEGATIVE, THEN THE CORRESPONDING TRIANGLE 5019 C IS VIOLATED. WE TEST FOR THAT CASE HERE. 5020 C 5021 IF (BTEST(A1,30) .OR. BTEST(A2,30) .OR. 5022 1 BTEST(A3,30) .OR. BTEST(A4,30)) GO TO 900 5023 C 5024 C B1 = J3 +J6 - J1 - J4 5025 C B2 = J3 + J6 - J2 - J5 5026 C R = J1 + J2 + J4 + J5 + 1 5027 B1 = Y - A2 - A3 5028 B2 = A3 - A1 + Z - Y 5029 C 5030 R = A1 + A2 + C + 1 5031 C 5032 NMAX = MIN0 (A1, A2, A3, A4) 5033 NMIN = MAX0 (0, -B1, -B2) 5034 C 5035 C 5036 CCCCC*************** 5037 CCCC NUMIT = NMAX - NMIN + 1 5038 CCCCC*************** 5039 C 5040 C CONVERT VARIOUS INTEGERS TO DOUBLE PRECISON FOR NOW AND 5041 C POSSIBLY LATER. 5042 C 5043 DA1 = A1 5044 DA2 = A2 5045 DA3 = A3 5046 DA4 = A4 5047 DY = Y 5048 DZ = Z 5049 DC = C 5050 DB1 = DY - DA2 - DA3 5051 DB2 = DA3 - DA1 + DZ - DY 5052 DR = DA1 + DA2 + DC + 1 5053 DN = NMIN 5054 DX = NMAX 5055 C 5056 C THIS ONE TEST CHECKS ALL 12 INEQUALITIES IMPLIED BY THE 5057 C 4 TRIANGLE CONDITIONS. 5058 C 5059 IF (NMAX - NMIN) 900, 300, 200 5060 C 5061 200 D1 = DA1 - (DX-1) 5062 D2 = DA2 - (DX-1) 5063 D3 = DA3 - (DX-1) 5064 D4 = DA4 - (DX-1) 5065 D5 = -DX 5066 D6 = -DB1 - DX 5067 D7 = -DB2 - DX 5068 D8 = DR - (DX-1) 5069 C 5070 E1 = D1*D2*D3*D4 5071 E5 = D5*D6*D7*D8 5072 C 5073 NMAXM2 = NMAX-2 5074 SUM = 1 + E1/E5 5075 IF (NMAXM2 .LT. NMIN) GO TO 300 5076 C 5077 F1 = (D1+1)*(D2+1)*(D3+1)*(D4+1) - E1 5078 F5 = (D5+1)*(D6+1)*(D7+1)*(D8+1) - E5 5079 C 5080 G1 = (D1+2)*(D2+2)*(D3+2)*(D4+2) - F1 - F1 - E1 5081 G5 = (D5+2)*(D6+2)*(D7+2)*(D8+2) - F5 - F5 - E5 5082 C 5083 H1 = (D1+3)*(D2+3)*(D3+3)*(D4+3) - 3*(G1+F1) - E1 5084 H5 = (D5+3)*(D6+3)*(D7+3)*(D8+3) - 3*(G5+F5) - E5 5085 C 5086 C COMPUTE THE SUM IN THE RACAH FORMULA 5087 C 5088 DO 259 N = NMIN, NMAXM2 5089 E1 = E1 + F1 5090 E5 = E5 + F5 5091 F1 = F1 + G1 5092 F5 = F5 + G5 5093 G1 = G1 + H1 5094 G5 = G5 + H5 5095 H1 = H1 + 24 5096 H5 = H5 + 24 5097 SUM = 1 + SUM*(E1/E5) 5098 259 CONTINUE 5099 C 5100 C NOW WE NEED THE OUTSIDE FACTORIALS 5101 C WE USE ONE OF 3 METHODS DEPENDING ON THE SIZE OF J1+J2+J4+J5 5102 C 1) A TABLE OF SQRT(FACTORIALS) 5103 C 2) A TABLE OF LN(FACTORIALS) 5104 C 3) LN(GAMMA) FUNCTION 5105 C 5106 300 IF (R .GT. MAXFAC) GO TO 400 5107 C 5108 C FIRST THE STUFF WE FACTORED OUT OF THE SUM 5109 C 5110 E = FACTBL(1+R-NMIN) / (FACTBL(1+NMIN) 5111 1 * FACTBL(1+B1+NMIN) * FACTBL(1+B2+NMIN) * FACTBL(1+A1-NMIN) 5112 2 * FACTBL(1+A2-NMIN) * FACTBL(1+A3-NMIN) * FACTBL(1+A4-NMIN) ) 5113 C 5114 C SUM IS AN INTEGER NOW 5115 C 5116 SUM = ANINT(E*SUM*E) 5117 C 5118 C AND NOW THE OUTSIDE FACTORS 5119 C 5120 C 5121 DENOM = (FACTBL(2+A1+C)/(FACTBL(1+A1)*FACTBL(1+A4+B1) 5122 1 *FACTBL(1+A3+B2))) 5123 2 * (FACTBL(2+A2+C)/(FACTBL(1+A2)*FACTBL(1+A3+B1) 5124 3 *FACTBL(1+A4+B2))) 5125 4 * (FACTBL(2+A3+Z)/(FACTBL(1+A3)*FACTBL(1+A2+B1) 5126 5 *FACTBL(1+A1+B2))) 5127 6 * (FACTBL(2+A4+Z)/(FACTBL(1+A4)*FACTBL(1+A1+B1) 5128 7 *FACTBL(1+A2+B2))) 5129 ANSWER = SUM/(DENOM) 5130 GO TO 600 5131 C 5132 C TRY FOR LOG FACTORIAL TABLE 5133 C 5134 400 IF (R .GT. MAXLF) GO TO 500 5135 C 5136 CCCCC********** 5137 CCCC IBIG = IBIG + 1 5138 CCCC ILF = ILF + 1 5139 CCCCC************ 5140 C 5141 E = LF(1+R-NMIN) - LF(1+NMIN) 5142 1 - LF(1+B1+NMIN) - LF(1+B2+NMIN) - LF(1+A1-NMIN) 5143 2 - LF(1+A2-NMIN) - LF(1+A3-NMIN) - LF(1+A4-NMIN) 5144 E2 = .5 * ( LF(1+A1) + LF(1+A4+B1) + LF(1+A3+B2) 5145 1 - LF(2+A1+C) 5146 2 + LF(1+A2) + LF(1+A3+B1) + LF(1+A4+B2) - LF(2+A2+C) 5147 3 + LF(1+A3) + LF(1+A2+B1) + LF(1+A1+B2) - LF(2+A3+Z) 5148 4 + LF(1+A4) + LF(1+A1+B1) + LF(1+A2+B2) - LF(2+A4+Z) ) 5149 C 5150 C AT THIS POINT IT WOULD BE POSSIBLE TO TRY TO INTERGERIZE 5151 C SUM*EXP(E). HOWEVER, TESTS SHOW THAT IN PRACTICE THIS WOULD 5152 C BE USEFUL (RESULT < 10**18) LESS THAN 1% OF THE TIME SO 5153 C WE DON'T BOTHER WITH IT. 5154 C 5155 450 ANSWER = DEXP(E+E2) * SUM 5156 GO TO 600 5157 C 5158 C HERE THE J'S ARE VERY LARGE - WE USE LN(GAMMA) 5159 C 5160 500 DRAY(6) = DC 5161 DRAY(8) = DZ 5162 E2 = 0 5163 E = DLGAMA(1-DN+DR) - DLGAMA(1+DN) 5164 1 - DLGAMA(1+DN+DB1) - DLGAMA(1+DN+DB2) 5165 DO 549 I = 1, 4 5166 E2 = E2 + DLGAMA(1+DRAY(I)) + DLGAMA(1+DB1+DRAY(I)) 5167 1 + DLGAMA(1+DB2+DRAY(I)) - DLGAMA(2+DRAY(I)+DRAY(4+I)) 5168 E = E - DLGAMA(1-DN+DRAY(I)) 5169 549 CONTINUE 5170 E = E + .5*E2 5171 C 5172 CCCC IBIG = IBIG + 1 5173 CCCCC*************** 5174 CCCCC 5175 ANSWER = DEXP(E) * SUM 5176 C 5177 C NOW GET THE SIGN CORRECT 5178 C 5179 600 TEMP = NMIN + R 5180 IF (.NOT. BTEST(TEMP, 0)) ANSWER = -ANSWER 5181 C 5182 C 5183 C CALCULATION OF THE 6-J COMPLETED; WAS RACAH REQUESTED 5184 C 5185 700 IF (.NOT. RACHSW) GO TO 800 5186 C 5187 C YES, CONVERT THE SIGN 5188 IF (.NOT. BTEST(R, 0)) ANSWER = -ANSWER 5189 C 5190 C WHAT PRECISION WAS REQUESTED FOR THE RESULT 5191 C 5192 800 IF (DBLSW) GO TO 850 5193 C 5194 C ROUND THE ANSWER TO SINGLE PRECISION 5195 C 5196 COF6J = REAL(ANSWER) 5197 RETURN 5198 C 5199 C DOUBLE PRECISION ENTRY POINT WAS USED 5200 C 5201 850 SIXJ = ANSWER 5202 RETURN 5203 C 5204 C THE TRIANGLE RULES ARE NOT SATISFIED 5205 C 5206 900 COF6J = 0 5207 IF (DBLSW) SIXJ = 0 5208 RETURN 5209 END 5210 FUNCTION WIG9J ( J1, J2, J3, J4, J5, J6, J7, 5211 1 J8, J9 ) 5212 C 5213 C 5214 C COMPUTES 9-J COEFICENTS. 5215 C 5216 C 5217 C THIS ROUTNE COMPUTES THE WIGNER 9-J COEFICENT 5218 C 5219 C ( J1 J2 J3 ) 5220 C ( J4 J5 J6 ) 5221 C ( J7 J8 J9 ) 5222 C 5223 C THE INPUT CONSISTS OF 9 INTEGERS THAT ARE TWICE THE CORRESPONDING 5224 C J'S. IN THIS MANNER HALF-INTEGER ANGULAR MOMENTA CAN BE 5225 C ACCOMODATED. 5226 C 5227 C THE STANDARD METHOD (COMPUTING A SUM OF PRODUCTS OF THREE 6-J'S) 5228 C IS USED. ALL OF THE FACTORIALS COMMON TO ALL TERMS IN THE SUM ARE 5229 C FACTORED OUT AND EVALUATED ONLY ONCE. SIMILARLY ALL THE INTEGER TO 5230 C REAL CONVERSIONS AND OTHER SETUP REQUIRED FOR TH 6-J CALCULATIONS 5231 C ARE CARRIED OUT ONLY ONCE. TO EVALUATE THE 6-J'S A FACTORIZATION O 5232 C THE RACAH SUM SUGGESTED BY 5233 C J. G. WILLS, COMPUTER PHYSICS COMM. 2, 38 (1971) 5234 C IS USED. THE LOGARITHMS OF THE REQUIRED FACTORIALS ARE FOUND 5235 C EITHER FROM A TABLE OF LOG(FACTORIAL) OR BY USING THE LOG GAMMA 5236 C FUNCTION. IN THE PRESENT IMPLIMENTATION, THE TABLE CONTAINS THE 5237 C FIRST 1001 FACTORIALS. THIS SIZE MAY BE REDUCED (TO SAVE CORE) OR 5238 C INCREASED (TO SAVE TIME FOR VERY LARGE J'S) BY RECOMPILING THE 5239 C /LOGFAC/ COMMON BLOCK. 5240 C 5241 C THE MAGNITUDE OF THE J'S THAT CAN BE ACCOMODATED BY THIS ROUTINE 5242 C IS DETERMINED BY CANCELLATIONS IN THE RACAH AND 9-J SUMS. AS CAN B 5243 C SEEN IN THE TABLE BELOW, FAIRLY SEVERE CANCELLATIONS OCCUR WHEN ALL 5244 C NINE J'S ARE OF THE ORDER OF 50. COMPLETE LOSS OF SIGNIFICANCE AND 5245 C EXTENSIVE NUMERIC OVERFLOWS OCCUR WHEN ALL THE J'S ARE 75. HOWEVER 5246 C IF FIVE OF THE J'S REMAIN SMALL WHILE THE OTHER FOUR GET LARGE, THE 5247 C THE LARGE J'S MAY GET VERY LARGE. 5248 C 5249 C THE NUMBER OF TERMS IN THE 9-J SUM IS 5250 C N = MIN ( J1+J9 , J2+J6 , J4+J8 ) - 5251 C MAX ( |J1-J9| , |J2-J6| , |J4-J8| ) + 1 5252 C NO ATTEMPT IS MADE TO MINIMIZE N BY INTERCHANGING ROWS OR COLUMNS. 5253 C IT MAY BE ADVANTAGEOUS TO THE USER TO ARRANGE THE J'S SUCH THAT N 5254 C IS MINIMIZED (AT LEAST APPROXIMATELY). IN PARTICULAR IT SHOULD BE 5255 C NOTICED THAT J3, J5, AND J7 ARE NOT USED IN DETERMINING N SO 5256 C THAT A ZERO VALUE OF ONE OF THESE IS "WASTED". 5257 C 5258 C EACH LINE IN THE FOLLOWING TABLE IS THE RESULT OF SEVERAL THOUSAN 5259 C COMPUTATIONS WITH J'S IN THE INDICATED RANGES. ERRORS WERE 5260 C DETERMINED BY COMPARASON WITH QUADRUPOLE PRECISION 9-J VALUES. 5261 C EXECUTION TIMES FOR THE 370/195 ARE GIVEN IN MICROSECONDS. NONE OF 5262 C THE 9-J'S EVALUATED WERE TRIVIALLY ZERO. 5263 C 5264 C J1 J2 J5 J3 J6 J9 J4 J7 J8 TIME RMS RELATIVE 5265 C RANGE RANGE FIXED VALUES ERROR 5266 C 5267 C 1/2 - 5/2 1/2 - 5/2 3/2 3/2 3/2 300 1E-14 5268 C 5 - 10 5 - 10 15/2 8 17/2 1450 1E-12 5269 C 15 - 30 0 - 47 25 45/2 20 3000 3E-12 5270 C 5271 C 50 - 54 50 - 54 51 52 107/2 34000 4E-8 5272 C 25 - 30 1/2 - 5 55/2 5 5/2 450 2E-14 5273 C 25 - 30 5 - 10 55/2 7 15/2 1600 2E-13 5274 C 250 1/2 - 5 505/2 2 5/2 440 2E-13 5275 C 250 5 - 10 505/2 7 15/2 1680 5E-13 5276 C 500 1/2 - 5 1005/2 2 5/2 4850 2E-12 5277 C 500 5 - 10 1005/2 7 15/2 13800 2E-12 5278 C 2500 1/2 - 5 5005/2 2 5/2 4700 2E-12 5279 C 2500 5 - 10 5005/2 7 15/2 13700 2E-12 5280 C 5281 C 5282 C USAGE: 5283 C 5284 C WIG9J (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6, 2*J7, 2*J8, 2*J9) 5285 C 5286 C RETURNS THE DOUBLE PRECISION 9-J COEFICENT. THE TRIANGLE RULES ARE 5287 C CHECKED AND 0 IS RETURNED IF THEY ARE VIOLATED. HOWEVER NO CHECK I 5288 C MADE FOR INVALID COMBINATIONS OF HALF-INTEGER AND INTEGERS J'S. TH 5289 C USER MUST INSURE THAT TWICE THE SUM OF THE J'S IN EACH ROW AND 5290 C COLUMN IS EVEN. IF THIS IS NOT SO, MEANINGLESS RESULTS WILL BE 5291 C RETURNED. 5292 C 5293 C CORE REQUIREMENTS (BASE 10): 5294 C 5295 C WIG9J 4878 5296 C /LOGFAC/ 8028 (MAY BE REDUCED OR INCREASED) 5297 C DLGAMA 1008 5298 C TOTAL 13914 5299 C 5300 C IN ADDITION "DEXP" AND THE FORTRAN I/O PACKAGE ARE REQUIRED. 5301 C THESE ARE NOT INCLUDED IN THE ABOVE SINCE YOU ARE LIKELY TO USE THE 5302 C ANYWAY. /LOGFAC/ WILL BE SHARED WITH THE CLEBSCH AND 5303 C 6-J ROUTINES SHOULD YOU USE THEM. 5304 C 5305 C 5306 C S. PIEPER 5307 C 5308 C 9/6/74 - FIRST VERSION 5309 C 4/11/88 - VAX/VMS VERSION - R.OSBORN AND G.L.GOODMAN 5310 C 5311 C 5312 C 5313 IMPLICIT INTEGER*4 (A-C, I-R, T-Z), REAL*8 (D-H, S) 5314 C 5315 REAL*8 WIG9J, DLGAMA 5316 C 5317 REAL*8 LF 5318 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) 5319 C 5320 C 5321 C THE FOLLOWING FAKE EXTERNALS DRAG IN THE REQUIRED BLOCK DATAS 5322 C FOR THE ABOVE COMMON BLOCK 5323 C 5324 EXTERNAL LOGDUM 5325 C 5326 CCCCC********** 5327 CCCC COMMON /NUMBLK/ NUMIT, NUM6J, BIGOUT, BIGIN, SUMLOG, SUMOUT 5328 CCCCC********** 5329 C 5330 C WE USE THE FOLLOWING VAX FORTRAN FUNCTIONS: 5331 C BTEST - TESTS TO SEE IF A BIT IS ON. BTEST(I, 0) IS TRUE 5332 C IF I IS ODD. 5333 C ISHFT(N,-1) SHIFTS THE BITS IN N ONE TO THE RIGHT = /2 5334 C 5335 LOGICAL BTEST 5336 C 5337 REAL*8 ZERONE(2) / 0.D0, 1.D0 / 5338 C 5339 DIMENSION J1S(5), J2S(5), J3S(5) 5340 DIMENSION AS(4, 3), BS(2, 3), DAS(4, 3), DBS(2, 3), 5341 1 MX2S(3), MN2S(3), MN1S(3), RS(3), DRS(3), 5342 2 DMN1S(3), DMN2S(3), DMX2S(3), IDS(2, 3) 5343 DIMENSION SUMS(3) 5344 C 5345 C FOLLOWING IS FACTORIAL(N-1) 5346 C 5347 DLF(N) = DLGAMA(DFLOAT(N)) 5348 C 5349 CCCCC**************** 5350 CCCC NUMIT = 0 5351 CCCC NUM6J = 0 5352 CCCC BIGOUT = 0 5353 CCCC BIGIN = 0 5354 CCCCC**************** 5355 C 5356 C 5357 C 5358 C PICK UP THE J'S IN THE APPROPRIATE ORDER 5359 C NOTE THAT THE JIS ARRAYS REALLY CONTAIN 2*J 5360 C 5361 J1S(1) = J1 5362 J1S(2) = J6 5363 J1S(3) = J8 5364 J2S(1) = J2 5365 J2S(2) = J4 5366 J2S(3) = J9 5367 J3S(1) = J3 5368 J3S(2) = J5 5369 J3S(3) = J7 5370 C 5371 C EXPAND THE ARRAYS TO ALLOW CYCLIC INDICES 5372 C AFTER THIS IS DONE THE 3 6-J'S ARE 5373 C ( J1S(I) J2S(I) J3S(I) ) 5374 C ( J1S(I+1) J2S(I+2) X ) 5375 C FOR I = 1, 2, 3. 5376 C 5377 DO 59 I = 1, 2 5378 J1S(I+3) = J1S(I) 5379 J2S(I+3) = J2S(I) 5380 J3S(I+3) = J3S(I) 5381 59 CONTINUE 5382 C 5383 C DETERMIN THE RANGE OF 2*X 5384 C 5385 XSTART = IABS(J2S(1) - J1S(2)) 5386 XEND = J2S(1) + J1S(2) 5387 XSUM = XEND 5388 DO 129 I = 2, 3 5389 XSTART = MAX0 ( XSTART, IABS(J2S(I)-J1S(I+1)) ) 5390 XPIECE = J2S(I) + J1S(I+1) 5391 XEND = MIN0 ( XEND, XPIECE) 5392 XSUM = XSUM + XPIECE 5393 129 CONTINUE 5394 C 5395 IF (XEND .LT. XSTART) GO TO 900 5396 C 5397 XSUM = XSUM - XEND 5398 C 5399 C EXTRACT 1/2 INTEGER PART OF X AND CONVERT 2*X TO INTPART(X) 5400 C 5401 XHALF = 0 5402 IF ( BTEST(XSTART, 0) ) XHALF = 1 5403 XSTART = ISHFT(XSTART, -1) 5404 XEND = ISHFT(XEND, -1) 5405 XSUM = ISHFT(XSUM, -1) 5406 DXHALF = ZERONE(XHALF+1) 5407 DX = XSTART - 1 5408 XSUM = XSUM + 1 5409 C 5410 CCCCC****************** 5411 CCCC NUMIT = XEND - XSTART + 1 5412 CCCCC****************** 5413 C 5414 C SETUP THE J1+J2-J3, ETC 5415 C 5416 DO 159 I = 1, 3 5417 C 5418 C THE AS, FOR EACH 6-J THEY ARE 5419 C A1 = J1+J2-J3 5420 C A2 = J4+J5-J3 5421 C A3 = J1+J5-J6 5422 C A4 = J4+J2-J6 5423 C IN A3 AND A4 THE J6 = X IS LEFT OUT. 5424 C 5425 AS(1,I) = ISHFT (J1S(I)+J2S(I)-J3S(I), -1) 5426 AS(2,I) = ISHFT (J1S(I+1)+J2S(I+2)-J3S(I), -1) 5427 AS(3,I) = ISHFT (J1S(I)+J2S(I+2), -1) 5428 AS(4,I) = ISHFT (J2S(I)+J1S(I+1), -1) 5429 C 5430 C NOW MAKE SURE NONE OF THEM ARE NEGATIVE WHICH WOULD INDICATE 5431 C A VIOLATION OF THE TRIANGLE RULES. 5432 C 5433 IF (BTEST(AS(1,I),30) .OR. BTEST(AS(2,I),30)) GO TO 900 5434 C 5435 C MAKE SURE NO SUPER LARGE INTEGERS SNEAK THROUGH 5436 C AS(3,I) = IBCLR(AS(3,I),30) 5437 C AS(4,I) = IBCLR(AS(4,I),30) 5438 C 5439 C THE BS, FOR EACH 6-J THEY ARE 5440 C B1 = J3 + J6 - J1 - J4 5441 C B2 = J3 + J6 - J2 - J5 5442 C THE J6 = X IS LEFT OUT 5443 C 5444 BS(1,I) = J2S(I+2) - AS(2,I) - AS(3,I) 5445 BS(2,I) = J1S(I) - AS(1,I) - AS(3,I) 5446 C 5447 159 CONTINUE 5448 C 5449 C SETUP THE QUANTITIES FOR EACH OF THE 3 6-J SUMS. 5450 C THESE INCLUDE THE STARTING MIN AND MAX VALUES, ETC. 5451 C 5452 DO 299 I = 1, 3 5453 MN1S(I) = MIN0(AS(1,I), AS(2,I)) 5454 MN2S(I) = MIN0(AS(3,I), AS(4,I)) 5455 MX2S(I) = -MIN0(BS(1,I), BS(2,I)) 5456 RS(I) = 1 + XHALF + AS(3,I) + AS(4,I) 5457 DO 239 J = 1, 4 5458 DAS(J,I) = AS(J,I) 5459 239 CONTINUE 5460 DBS(1,I) = BS(1,I) 5461 DBS(2,I) = BS(2,I) 5462 DRS(I) = 1 + DXHALF + DAS(3,I) + DAS(4,I) 5463 DMN1S(I) = MN1S(I) 5464 DMN2S(I) = MN2S(I) 5465 DMX2S(I) = MX2S(I) 5466 C 5467 C THESE ARE INDICES FOR THE 4 FACTORIALTS THAT DEPEND ON X 5468 C 5469 IDS(1,I) = AS(2,I) + BS(2,I) 5470 IDS(2,I) = AS(1,I) + BS(1,I) 5471 299 CONTINUE 5472 C 5473 C FIND THE LOG OF THE OUTSIDE FACTORS NOW 5474 C IT WILL BE USED IN EACH TERM OF THE 9-J SUM TO AVOID UNDER/OVER 5475 C FLOW PROBLEMS. 5476 C 5477 C 5478 C THESE ARE ALL THE TRIANGLE FACTORIALS THAT COMPLTELY FACTOR OUT 5479 C OF THE SUM 5480 C 5481 SUMOUT = 0 5482 C 5483 C XSUM IS >= ANY OF THE REQUIRED FACTORIAL ARGUMENTS 5484 C 5485 IF (XSUM .GT. MAXLF) GO TO 350 5486 C 5487 C WE CAN USE THE LOG(FACTORIAL) TABLE 5488 C 5489 DO 339 I = 1, 3 5490 DO 339 J = 1, 2 5491 SUMOUT = SUMOUT + 5492 1 LF(1+AS(J,I)) - LF(2+J3S(I)+AS(J,I)) 5493 2 + LF(1-AS(J,I)+J1S(I-1+J)) 5494 3 + LF(1-AS(J,I)+J2S(I-2+2*J)) 5495 339 CONTINUE 5496 GO TO 400 5497 C 5498 C WE MUST USE LOG GAMMA 5499 C 5500 350 DO 359 I = 1, 3 5501 DO 359 J = 1, 2 5502 SUMOUT = SUMOUT + 5503 1 DLGAMA(1+DAS(J,I)) - DLF(2+J3S(I)+AS(J,I)) 5504 2 + DLF(1-AS(J,I)+J1S(I-1+J)) 5505 3 + DLF(1-AS(J,I)+J2S(I-2+2*J)) 5506 359 CONTINUE 5507 C 5508 CCCCC************ 5509 CCCC BIGOUT = 1 5510 CCCCC*********** 5511 C 5512 400 SUMOUT = .5*SUMOUT 5513 C 5514 C WE ARE NOW READY TO DO THE 9-J LOOP 5515 C 5516 WIG9J = 0 5517 C 5518 DO 799 X = XSTART, XEND 5519 DX = DX + 1 5520 C 5521 C DO THE PARTS OF EACH 6-J THAT DEPEND ON X 5522 C 5523 SUMLOG = SUMOUT 5524 ISIGN = 0 5525 C 5526 DO 759 I = 1, 3 5527 C 5528 C GET THE COEFFICENTS FOR THIS 6-J 5529 C 5530 MX2 = MX2S(I) - X 5531 MN2 = MN2S(I) - X 5532 NMAX = MN1S(I) 5533 DNMAX = DMN1S(I) 5534 DNMIN = 0 5535 NMIN = 0 5536 C 5537 C GET THE RANGE OF THE 6-J SUM 5538 C 5539 IF (MN2 .GE. NMAX) GO TO 520 5540 NMAX = MN2 5541 DNMAX = DMN2S(I) - DX 5542 C 5543 520 IF (MX2 .LE. 0) GO TO 540 5544 NMIN = MX2 5545 DNMIN = DMX2S(I) - DX 5546 C 5547 540 SUM = 1 5548 ISIGN = ISIGN + NMIN 5549 C 5550 C 5551 C THIS ONE TEST CHECKS ALL 12 INEQUALITIES IMPLIED BY THE 5552 C 4 TRIANGLE CONDITIONS.FOR THE GIVEN 6-J. 5553 C 5554 IF (NMAX - NMIN) 900, 700, 600 5555 C 5556 600 D1 = DAS(1,I) - (DNMAX-1) 5557 D2 = DAS(2,I) - (DNMAX-1) 5558 D8 = DRS(I) - (DNMAX-1) 5559 D3 = DAS(3,I) - (DNMAX-1+DX) 5560 D4 = DAS(4,I) - (DNMAX-1+DX) 5561 D5 = -DNMAX 5562 D6 = -DBS(1,I) - (DX + DNMAX) 5563 D7 = -DBS(2,I) - (DX + DNMAX) 5564 C 5565 E1 = D1*D2*D3*D4 5566 E5 = D5*D6*D7*D8 5567 C 5568 NMAXM2 = NMAX-2 5569 SUM = 1 + E1/E5 5570 IF (NMAXM2 .LT. NMIN) GO TO 700 5571 C 5572 F1 = (D1+1)*(D2+1)*(D3+1)*(D4+1) - E1 5573 F5 = (D5+1)*(D6+1)*(D7+1)*(D8+1) - E5 5574 C 5575 G1 = (D1+2)*(D2+2)*(D3+2)*(D4+2) - F1 - F1 - E1 5576 G5 = (D5+2)*(D6+2)*(D7+2)*(D8+2) - F5 - F5 - E5 5577 C 5578 H1 = (D1+3)*(D2+3)*(D3+3)*(D4+3) - 3*(G1+F1) - E1 5579 H5 = (D5+3)*(D6+3)*(D7+3)*(D8+3) - 3*(G5+F5) - E5 5580 C 5581 C COMPUTE THE SUM IN THE RACAH FORMULA 5582 C 5583 DO 659 N = NMIN, NMAXM2 5584 E1 = E1 + F1 5585 E5 = E5 + F5 5586 F1 = F1 + G1 5587 F5 = F5 + G5 5588 G1 = G1 + H1 5589 G5 = G5 + H5 5590 H1 = H1 + 24 5591 H5 = H5 + 24 5592 SUM = 1 + SUM*(E1/E5) 5593 659 CONTINUE 5594 C 5595 C 5596 700 SUMS(I) = SUM 5597 C 5598 CCCCC*********** 5599 CCCC NUM6J = NUM6J + NMAX - NMIN + 1 5600 CCCCC************ 5601 C 5602 C HERE ARE THE PARTS OF THE FACTORIALS FOR NMIN AND ALSO THOSE 5603 C FACTORIALS THAT DEPEND ON X 5604 C 5605 IF (RS(I) .GT. MAXLF) GO TO 730 5606 C 5607 C WE CAN USE THE LOG FACTORIAL TABLE 5608 C 5609 SUMLOG = SUMLOG + 5610 1 LF(1-X+AS(4,I)) + LF(1+X+IDS(1,I)) 5611 2 + LF(1+X+IDS(2,I)) - LF(2+XHALF+X+AS(4,I)) 5612 3 + LF(1-NMIN+RS(I)) - LF(1+NMIN) 5613 4 - LF(1+NMIN+X+BS(1,I)) - LF(1+NMIN+X+BS(2,I)) 5614 5 - LF(1-NMIN+AS(1,I)) - LF(1-NMIN+AS(2,I)) 5615 6 - LF(1-NMIN-X+AS(3,I)) - LF(1-NMIN-X+AS(4,I)) 5616 C 5617 GO TO 759 5618 C 5619 C WE MUST USE LOG GAMMA 5620 C 5621 730 SUMLOG = SUMLOG + 5622 1 DLGAMA(1-DX+DAS(4,I)) + DLGAMA(1+DX+DAS(2,I)+DBS(2,I)) 5623 1 + DLGAMA(1+DX+DAS(1,I)+DBS(1,I)) 5624 2 - DLGAMA(2+DXHALF+DX+DAS(4,I)) 5625 3 + DLGAMA(1-DNMIN+DRS(I)) - DLGAMA(1+DNMIN) 5626 4 - DLGAMA(1+DNMIN+DX+DBS(1,I)) 5627 4 - DLGAMA(1+DNMIN+DX+DBS(2,I)) 5628 5 - DLGAMA(1-DNMIN+DAS(1,I)) - DLGAMA(1-DNMIN+DAS(2,I)) 5629 6 - DLGAMA(1-DNMIN-DX+DAS(3,I)) 5630 7 - DLGAMA(1-DNMIN-DX+DAS(4,I)) 5631 C 5632 CCCCC*************** 5633 CCCC BIGIN = 1 5634 CCCCC************** 5635 C 5636 759 CONTINUE 5637 C 5638 C NOW MULTIPLY THE 3 6-J PARTS TOGETHER AND SUM 5639 C 5640 SUMP = SUMS(1) * SUMS(2) * DEXP(SUMLOG) * SUMS(3) 5641 1 * (1+DXHALF+(DX+DX)) 5642 C 5643 IF (BTEST(ISIGN, 0)) SUMP = -SUMP 5644 WIG9J = WIG9J + SUMP 5645 C 5646 799 CONTINUE 5647 C 5648 C 5649 C 5650 RETURN 5651 C 5652 C THE TRIANGLE RULES ARE NOT SATISFIED 5653 C 5654 900 WIG9J = 0 5655 RETURN 5656 END 5657 BLOCKDATA FACDUM 5658 C 5659 C BLOCK DATA TO DEFINE THE SQRT(FACTORIAL) TABLE 5660 C 5661 C THE TABLE IS USED BY THE CLEBSH, THREEJ, SIXJ AND RACAH 5662 C ROUTINES. 5663 C 5664 C IT MAY BE INCLUDED IN YOUR LOAD MODULE FOR OTHER PURPOSES 5665 C BY PLACING A DUMMY EXTERNAL CARD OF THE FORM 5666 C EXTERNAL FACDUM 5667 C IN YOUR SOURCE. 5668 C 5669 C THE FORM OF THE TABLE IS 5670 C 5671 C COMMON / FACTRL / MAX, ISPACE, TABLE 5672 C 5673 C 5674 C MAX IS THE MAXIMUM NUMBER WHOSE SQRT(FACTORIAL) IS 5675 C IN TABLE. TABLE HAS MAX+1 ELEMENTS. 5676 C IN THE PRESENT VERSION: 5677 C MAX = 96 (DETERMINED BY EXPONENT RANGE) 5678 C ISPACE IS NOT USED. 5679 C TABLE IS THE TABLE. THE FIRST ELEMENT CORRESPONDS TO 0. 5680 C 5681 C 6/30/74 - FIRST VERSION - S. PIEPER 5682 C 4/10/88 - VAX/VMS VERSION - R. OSBORN AND G.L.GOODMAN 5683 C 5684 C 5685 INTEGER*4 MAXFAC, SP1 5686 REAL*8 FACTBL 5687 COMMON /FACTRL/ MAXFAC, SP1, FACTBL(97) 5688 C 5689 C 5690 DATA MAXFAC /96/ 5691 C 5692 C THESE ARE THE SQUARE ROOTS OF FACTORIALS. 5693 C 5694 C THEY ARE STORED UP TO THE EXPONENT RANGE OF THE MACHINE. 5695 C 5696 DATA FACTBL( 1) / 0.1000000000000000D+01 / 5697 DATA FACTBL( 2) / 0.1000000000000000D+01 / 5698 DATA FACTBL( 3) / 0.1414213562373095D+01 / 5699 DATA FACTBL( 4) / 0.2449489742783178D+01 / 5700 DATA FACTBL( 5) / 0.4898979485566356D+01 / 5701 DATA FACTBL( 6) / 0.1095445115010332D+02 / 5702 DATA FACTBL( 7) / 0.2683281572999748D+02 / 5703 DATA FACTBL( 8) / 0.7099295739719539D+02 / 5704 DATA FACTBL( 9) / 0.2007984063681781D+03 / 5705 DATA FACTBL(10) / 0.6023952191045344D+03 / 5706 DATA FACTBL(11) / 0.1904940943966505D+04 / 5707 DATA FACTBL(12) / 0.6317974358922328D+04 / 5708 DATA FACTBL(13) / 0.2188610518114176D+05 / 5709 DATA FACTBL(14) / 0.7891147445080469D+05 / 5710 DATA FACTBL(15) / 0.2952597012800765D+06 / 5711 DATA FACTBL(16) / 0.1143535905863913D+07 / 5712 DATA FACTBL(17) / 0.4574143623455652D+07 / 5713 DATA FACTBL(18) / 0.1885967730625315D+08 / 5714 DATA FACTBL(19) / 0.8001483428544984D+08 / 5715 DATA FACTBL(20) / 0.3487765766344294D+09 / 5716 DATA FACTBL(21) / 0.1559776268628498D+10 / 5717 DATA FACTBL(22) / 0.7147792818185865D+10 / 5718 DATA FACTBL(23) / 0.3352612008237171D+11 / 5719 DATA FACTBL(24) / 0.1607856235454059D+12 / 5720 DATA FACTBL(25) / 0.7876854713229383D+12 / 5721 DATA FACTBL(26) / 0.3938427356614691D+13 / 5722 DATA FACTBL(27) / 0.2008211794424596D+14 / 5723 DATA FACTBL(28) / 0.1043497458090740D+15 / 5724 DATA FACTBL(29) / 0.5521669535672285D+15 / 5725 DATA FACTBL(30) / 0.2973510046012911D+16 / 5726 DATA FACTBL(31) / 0.1628658527169496D+17 / 5727 DATA FACTBL(32) / 0.9067986906793549D+17 / 5728 DATA FACTBL(33) / 0.5129628026803635D+18 / 5729 DATA FACTBL(34) / 0.2946746955341073D+19 / 5730 DATA FACTBL(35) / 0.1718233974287565D+20 / 5731 DATA FACTBL(36) / 0.1016520927791757D+21 / 5732 DATA FACTBL(37) / 0.6099125566750542D+21 / 5733 DATA FACTBL(38) / 0.3709953246501409D+22 / 5734 DATA FACTBL(39) / 0.2286968774309350D+23 / 5735 DATA FACTBL(40) / 0.1428211541796153D+24 / 5736 DATA FACTBL(41) / 0.9032802905233224D+24 / 5737 DATA FACTBL(42) / 0.5783815921445271D+25 / 5738 DATA FACTBL(43) / 0.3748341123420972D+26 / 5739 DATA FACTBL(44) / 0.2457951648494613D+27 / 5740 DATA FACTBL(45) / 0.1630420674178431D+28 / 5741 DATA FACTBL(46) / 0.1093719437815202D+29 / 5742 DATA FACTBL(47) / 0.7417966136220958D+29 / 5743 DATA FACTBL(48) / 0.5085501366740237D+30 / 5744 DATA FACTBL(49) / 0.3523338699662023D+31 / 5745 DATA FACTBL(50) / 0.2466337089763416D+32 / 5746 DATA FACTBL(51) / 0.1743963680863606D+33 / 5747 DATA FACTBL(52) / 0.1245439180886559D+34 / 5748 DATA FACTBL(53) / 0.8980989654316716D+34 / 5749 DATA FACTBL(54) / 0.6538259159791714D+35 / 5750 DATA FACTBL(55) / 0.4804619624270389D+36 / 5751 DATA FACTBL(56) / 0.3563201278858420D+37 / 5752 DATA FACTBL(57) / 0.2666455677120592D+38 / 5753 DATA FACTBL(58) / 0.2013129889124823D+39 / 5754 DATA FACTBL(59) / 0.1533154046820762D+40 / 5755 DATA FACTBL(60) / 0.1177637968756484D+41 / 5756 DATA FACTBL(61) / 0.9121944481710788D+41 / 5757 DATA FACTBL(62) / 0.7124466393192018D+42 / 5758 DATA FACTBL(63) / 0.5609810447812647D+43 / 5759 DATA FACTBL(64) / 0.4452649004137245D+44 / 5760 DATA FACTBL(65) / 0.3562119203309796D+45 / 5761 DATA FACTBL(66) / 0.2871872314724746D+46 / 5762 DATA FACTBL(67) / 0.2333120097803461D+47 / 5763 DATA FACTBL(68) / 0.1909741105966688D+48 / 5764 DATA FACTBL(69) / 0.1574812859496909D+49 / 5765 DATA FACTBL(70) / 0.1308137807832727D+50 / 5766 DATA FACTBL(71) / 0.1094466613011557D+51 / 5767 DATA FACTBL(72) / 0.9222139602976428D+51 / 5768 DATA FACTBL(73) / 0.7825244940376377D+52 / 5769 DATA FACTBL(74) / 0.6685892207860282D+53 / 5770 DATA FACTBL(75) / 0.5751421947239992D+54 / 5771 DATA FACTBL(76) / 0.4980877514193197D+55 / 5772 DATA FACTBL(77) / 0.4342228346904444D+56 / 5773 DATA FACTBL(78) / 0.3810289910601106D+57 / 5774 DATA FACTBL(79) / 0.3365156932181068D+58 / 5775 DATA FACTBL(80) / 0.2991016905800262D+59 / 5776 DATA FACTBL(81) / 0.2675246849288189D+60 / 5777 DATA FACTBL(82) / 0.2407722164359370D+61 / 5778 DATA FACTBL(83) / 0.2180285150390389D+62 / 5779 DATA FACTBL(84) / 0.1986334304622628D+63 / 5780 DATA FACTBL(85) / 0.1820505461284133D+64 / 5781 DATA FACTBL(86) / 0.1678423103505356D+65 / 5782 DATA FACTBL(87) / 0.1556505553593457D+66 / 5783 DATA FACTBL(88) / 0.1451811729660402D+67 / 5784 DATA FACTBL(89) / 0.1361920123419132D+68 / 5785 DATA FACTBL(90) / 0.1284832874770429D+69 / 5786 DATA FACTBL(91) / 0.1218899489080934D+70 / 5787 DATA FACTBL(92) / 0.1162756005221389D+71 / 5788 DATA FACTBL(93) / 0.1115276380752381D+72 / 5789 DATA FACTBL(94) / 0.1075533591796017D+73 / 5790 DATA FACTBL(95) / 0.1042768505784838D+74 / 5791 DATA FACTBL(96) / 0.1016365017512855D+75 / 5792 DATA FACTBL(97) / 0.9958302741285533D+75 / 5793 END 5794 C 5795 C 5796 BLOCKDATA LOGDUM 5797 C 5798 C BLOCK DATA TO DEFINE THE LOG(FACTORIAL) TABLE. 5799 C 5800 C THIS TABLE IS USED BY THE CLEBSH, THREEJ, SIXJ AND RACAH 5801 C ROUTINES. 5802 C 5803 C IT MAY BE INCLUDED IN YOUR LOAD MODULE FOR OTHER PURPOSES 5804 C BY PLACING A DUMMY EXTERNAL CARD OF THE FORM 5805 C EXTERNAL LOGDUM 5806 C IN YOUR SOURCE. 5807 C 5808 C THE FORM OF THE TABLE IS 5809 C 5810 C COMMON / LOGFAC / MAX, ISPACE, TABLE 5811 C 5812 C 5813 C MAX IS THE MAXIMUM NUMBER WHOSE LOG(FACTORIAL) IS 5814 C IN TABLE. TABLE HAS MAX+1 ELEMENTS. 5815 C IN THE PRESENT VERSION: 5816 C MAX = 1000 5817 C ISPACE IS NOT USED. 5818 C TABLE IS THE TABLE. THE FIRST ELEMENT CORRESPONDS TO 0. 5819 C 5820 C 6/30/74 - FIRST VERSION - S. PIEPER 5821 C 4/10/88 - VAX/VMS VERSION - R. OSBORN AND G.L.GOODMAN 5822 C 5823 C 5824 INTEGER*4 MAXLF, SP2 5825 REAL*8 LF 5826 COMMON /LOGFAC/ MAXLF, SP2, LF(1001) 5827 C 5828 DATA MAXLF /1000/ 5829 C 5830 DATA LF( 1) / 0.0 / 5831 DATA LF( 2) / 0.0 / 5832 DATA LF( 3) / 0.6931471805599453D+00 / 5833 DATA LF( 4) / 0.1791759469228055D+01 / 5834 DATA LF( 5) / 0.3178053830347946D+01 / 5835 DATA LF( 6) / 0.4787491742782046D+01 / 5836 DATA LF( 7) / 0.6579251212010101D+01 / 5837 DATA LF( 8) / 0.8525161361065414D+01 / 5838 DATA LF( 9) / 0.1060460290274525D+02 / 5839 DATA LF( 10) / 0.1280182748008147D+02 / 5840 DATA LF( 11) / 0.1510441257307552D+02 / 5841 DATA LF( 12) / 0.1750230784587389D+02 / 5842 DATA LF( 13) / 0.1998721449566188D+02 / 5843 DATA LF( 14) / 0.2255216385312342D+02 / 5844 DATA LF( 15) / 0.2519122118273868D+02 / 5845 DATA LF( 16) / 0.2789927138384089D+02 / 5846 DATA LF( 17) / 0.3067186010608067D+02 / 5847 DATA LF( 18) / 0.3350507345013689D+02 / 5848 DATA LF( 19) / 0.3639544520803305D+02 / 5849 DATA LF( 20) / 0.3933988418719949D+02 / 5850 DATA LF( 21) / 0.4233561646075349D+02 / 5851 DATA LF( 22) / 0.4538013889847691D+02 / 5852 DATA LF( 23) / 0.4847118135183522D+02 / 5853 DATA LF( 24) / 0.5160667556776437D+02 / 5854 DATA LF( 25) / 0.5478472939811232D+02 / 5855 DATA LF( 26) / 0.5800360522298052D+02 / 5856 DATA LF( 27) / 0.6126170176100200D+02 / 5857 DATA LF( 28) / 0.6455753862700633D+02 / 5858 DATA LF( 29) / 0.6788974313718154D+02 / 5859 DATA LF( 30) / 0.7125703896716801D+02 / 5860 DATA LF( 31) / 0.7465823634883017D+02 / 5861 DATA LF( 32) / 0.7809222355331531D+02 / 5862 DATA LF( 33) / 0.8155795945611504D+02 / 5863 DATA LF( 34) / 0.8505446701758152D+02 / 5864 DATA LF( 35) / 0.8858082754219768D+02 / 5865 DATA LF( 36) / 0.9213617560368709D+02 / 5866 DATA LF( 37) / 0.9571969454214320D+02 / 5867 DATA LF( 38) / 0.9933061245478743D+02 / 5868 DATA LF( 39) / 0.1029681986145138D+03 / 5869 DATA LF( 40) / 0.1066317602606435D+03 / 5870 DATA LF( 41) / 0.1103206397147574D+03 / 5871 DATA LF( 42) / 0.1140342117814617D+03 / 5872 DATA LF( 43) / 0.1177718813997451D+03 / 5873 DATA LF( 44) / 0.1215330815154386D+03 / 5874 DATA LF( 45) / 0.1253172711493569D+03 / 5875 DATA LF( 46) / 0.1291239336391272D+03 / 5876 DATA LF( 47) / 0.1329525750356163D+03 / 5877 DATA LF( 48) / 0.1368027226373264D+03 / 5878 DATA LF( 49) / 0.1406739236482343D+03 / 5879 DATA LF( 50) / 0.1445657439463449D+03 / 5880 DATA LF( 51) / 0.1484777669517730D+03 / 5881 DATA LF( 52) / 0.1524095925844974D+03 / 5882 DATA LF( 53) / 0.1563608363030788D+03 / 5883 DATA LF( 54) / 0.1603311282166309D+03 / 5884 DATA LF( 55) / 0.1643201122631952D+03 / 5885 DATA LF( 56) / 0.1683274454484277D+03 / 5886 DATA LF( 57) / 0.1723527971391628D+03 / 5887 DATA LF( 58) / 0.1763958484069974D+03 / 5888 DATA LF( 59) / 0.1804562914175438D+03 / 5889 DATA LF( 60) / 0.1845338288614495D+03 / 5890 DATA LF( 61) / 0.1886281734236716D+03 / 5891 DATA LF( 62) / 0.1927390472878449D+03 / 5892 DATA LF( 63) / 0.1968661816728900D+03 / 5893 DATA LF( 64) / 0.2010093163992815D+03 / 5894 DATA LF( 65) / 0.2051681994826412D+03 / 5895 DATA LF( 66) / 0.2093425867525368D+03 / 5896 DATA LF( 67) / 0.2135322414945633D+03 / 5897 DATA LF( 68) / 0.2177369341139542D+03 / 5898 DATA LF( 69) / 0.2219564418191303D+03 / 5899 DATA LF( 70) / 0.2261905483237276D+03 / 5900 DATA LF( 71) / 0.2304390435657770D+03 / 5901 DATA LF( 72) / 0.2347017234428183D+03 / 5902 DATA LF( 73) / 0.2389783895618343D+03 / 5903 DATA LF( 74) / 0.2432688490029827D+03 / 5904 DATA LF( 75) / 0.2475729140961869D+03 / 5905 DATA LF( 76) / 0.2518904022097232D+03 / 5906 DATA LF( 77) / 0.2562211355500095D+03 / 5907 DATA LF( 78) / 0.2605649409718632D+03 / 5908 DATA LF( 79) / 0.2649216497985528D+03 / 5909 DATA LF( 80) / 0.2692910976510198D+03 / 5910 DATA LF( 81) / 0.2736731242856937D+03 / 5911 DATA LF( 82) / 0.2780675734403661D+03 / 5912 DATA LF( 83) / 0.2824742926876304D+03 / 5913 DATA LF( 84) / 0.2868931332954270D+03 / 5914 DATA LF( 85) / 0.2913239500942703D+03 / 5915 DATA LF( 86) / 0.2957666013507607D+03 / 5916 DATA LF( 87) / 0.3002209486470142D+03 / 5917 DATA LF( 88) / 0.3046868567656687D+03 / 5918 DATA LF( 89) / 0.3091641935801469D+03 / 5919 DATA LF( 90) / 0.3136528299498790D+03 / 5920 DATA LF( 91) / 0.3181526396202093D+03 / 5921 DATA LF( 92) / 0.3226634991267262D+03 / 5922 DATA LF( 93) / 0.3271852877037752D+03 / 5923 DATA LF( 94) / 0.3317178871969285D+03 / 5924 DATA LF( 95) / 0.3362611819791985D+03 / 5925 DATA LF( 96) / 0.3408150588707990D+03 / 5926 DATA LF( 97) / 0.3453794070622669D+03 / 5927 DATA LF( 98) / 0.3499541180407703D+03 / 5928 DATA LF( 99) / 0.3545390855194408D+03 / 5929 DATA LF( 100) / 0.3591342053695754D+03 / 5930 DATA LF( 101) / 0.3637393755555635D+03 / 5931 DATA LF( 102) / 0.3683544960724047D+03 / 5932 DATA LF( 103) / 0.3729794688856890D+03 / 5933 DATA LF( 104) / 0.3776141978739187D+03 / 5934 DATA LF( 105) / 0.3822585887730600D+03 / 5935 DATA LF( 106) / 0.3869125491232176D+03 / 5936 DATA LF( 107) / 0.3915759882173296D+03 / 5937 DATA LF( 108) / 0.3962488170517915D+03 / 5938 DATA LF( 109) / 0.4009309482789158D+03 / 5939 DATA LF( 110) / 0.4056222961611449D+03 / 5940 DATA LF( 111) / 0.4103227765269373D+03 / 5941 DATA LF( 112) / 0.4150323067282496D+03 / 5942 DATA LF( 113) / 0.4197508055995447D+03 / 5943 DATA LF( 114) / 0.4244781934182571D+03 / 5944 DATA LF( 115) / 0.4292143918666516D+03 / 5945 DATA LF( 116) / 0.4339593239950148D+03 / 5946 DATA LF( 117) / 0.4387129141861212D+03 / 5947 DATA LF( 118) / 0.4434750881209189D+03 / 5948 DATA LF( 119) / 0.4482457727453846D+03 / 5949 DATA LF( 120) / 0.4530248962384961D+03 / 5950 DATA LF( 121) / 0.4578123879812782D+03 / 5951 DATA LF( 122) / 0.4626081785268749D+03 / 5952 DATA LF( 123) / 0.4674121995716082D+03 / 5953 DATA LF( 124) / 0.4722243839269806D+03 / 5954 DATA LF( 125) / 0.4770446654925856D+03 / 5955 DATA LF( 126) / 0.4818729792298880D+03 / 5956 DATA LF( 127) / 0.4867092611368394D+03 / 5957 DATA LF( 128) / 0.4915534482232980D+03 / 5958 DATA LF( 129) / 0.4964054784872176D+03 / 5959 DATA LF( 130) / 0.5012652908915793D+03 / 5960 DATA LF( 131) / 0.5061328253420349D+03 / 5961 DATA LF( 132) / 0.5110080226652360D+03 / 5962 DATA LF( 133) / 0.5158908245878224D+03 / 5963 DATA LF( 134) / 0.5207811737160442D+03 / 5964 DATA LF( 135) / 0.5256790135159951D+03 / 5965 DATA LF( 136) / 0.5305842882944335D+03 / 5966 DATA LF( 137) / 0.5354969431801695D+03 / 5967 DATA LF( 138) / 0.5404169241059977D+03 / 5968 DATA LF( 139) / 0.5453441777911549D+03 / 5969 DATA LF( 140) / 0.5502786517242856D+03 / 5970 DATA LF( 141) / 0.5552202941468948D+03 / 5971 DATA LF( 142) / 0.5601690540372730D+03 / 5972 DATA LF( 143) / 0.5651248810948743D+03 / 5973 DATA LF( 144) / 0.5700877257251342D+03 / 5974 DATA LF( 145) / 0.5750575390247102D+03 / 5975 DATA LF( 146) / 0.5800342727671308D+03 / 5976 DATA LF( 147) / 0.5850178793888391D+03 / 5977 DATA LF( 148) / 0.5900083119756179D+03 / 5978 DATA LF( 149) / 0.5950055242493819D+03 / 5979 DATA LF( 150) / 0.6000094705553274D+03 / 5980 DATA LF( 151) / 0.6050201058494237D+03 / 5981 DATA LF( 152) / 0.6100373856862386D+03 / 5982 DATA LF( 153) / 0.6150612662070849D+03 / 5983 DATA LF( 154) / 0.6200917041284773D+03 / 5984 DATA LF( 155) / 0.6251286567308910D+03 / 5985 DATA LF( 156) / 0.6301720818478102D+03 / 5986 DATA LF( 157) / 0.6352219378550597D+03 / 5987 DATA LF( 158) / 0.6402781836604080D+03 / 5988 DATA LF( 159) / 0.6453407786934350D+03 / 5989 DATA LF( 160) / 0.6504096828956552D+03 / 5990 DATA LF( 161) / 0.6554848567108891D+03 / 5991 DATA LF( 162) / 0.6605662610758735D+03 / 5992 DATA LF( 163) / 0.6656538574111059D+03 / 5993 DATA LF( 164) / 0.6707476076119127D+03 / 5994 DATA LF( 165) / 0.6758474740397369D+03 / 5995 DATA LF( 166) / 0.6809534195136375D+03 / 5996 DATA LF( 167) / 0.6860654073019940D+03 / 5997 DATA LF( 168) / 0.6911834011144107D+03 / 5998 DATA LF( 169) / 0.6963073650938140D+03 / 5999 DATA LF( 170) / 0.7014372638087371D+03 / 6000 DATA LF( 171) / 0.7065730622457874D+03 / 6001 DATA LF( 172) / 0.7117147258022900D+03 / 6002 DATA LF( 173) / 0.7168622202791034D+03 / 6003 DATA LF( 174) / 0.7220155118736012D+03 / 6004 DATA LF( 175) / 0.7271745671728158D+03 / 6005 DATA LF( 176) / 0.7323393531467393D+03 / 6006 DATA LF( 177) / 0.7375098371417774D+03 / 6007 DATA LF( 178) / 0.7426859868743513D+03 / 6008 DATA LF( 179) / 0.7478677704246434D+03 / 6009 DATA LF( 180) / 0.7530551562304841D+03 / 6010 DATA LF( 181) / 0.7582481130813743D+03 / 6011 DATA LF( 182) / 0.7634466101126401D+03 / 6012 DATA LF( 183) / 0.7686506167997169D+03 / 6013 DATA LF( 184) / 0.7738601029525583D+03 / 6014 DATA LF( 185) / 0.7790750387101673D+03 / 6015 DATA LF( 186) / 0.7842953945352457D+03 / 6016 DATA LF( 187) / 0.7895211412089589D+03 / 6017 DATA LF( 188) / 0.7947522498258135D+03 / 6018 DATA LF( 189) / 0.7999886917886434D+03 / 6019 DATA LF( 190) / 0.8052304388037031D+03 / 6020 DATA LF( 191) / 0.8104774628758635D+03 / 6021 DATA LF( 192) / 0.8157297363039102D+03 / 6022 DATA LF( 193) / 0.8209872316759379D+03 / 6023 DATA LF( 194) / 0.8262499218648428D+03 / 6024 DATA LF( 195) / 0.8315177800239061D+03 / 6025 DATA LF( 196) / 0.8367907795824699D+03 / 6026 DATA LF( 197) / 0.8420688942417004D+03 / 6027 DATA LF( 198) / 0.8473520979704384D+03 / 6028 DATA LF( 199) / 0.8526403650011329D+03 / 6029 DATA LF( 200) / 0.8579336698258575D+03 / 6030 DATA LF( 201) / 0.8632319871924055D+03 / 6031 DATA LF( 202) / 0.8685352921004646D+03 / 6032 DATA LF( 203) / 0.8738435597978657D+03 / 6033 DATA LF( 204) / 0.8791567657769075D+03 / 6034 DATA LF( 205) / 0.8844748857707518D+03 / 6035 DATA LF( 206) / 0.8897978957498902D+03 / 6036 DATA LF( 207) / 0.8951257719186797D+03 / 6037 DATA LF( 208) / 0.9004584907119451D+03 / 6038 DATA LF( 209) / 0.9057960287916464D+03 / 6039 DATA LF( 210) / 0.9111383630436113D+03 / 6040 DATA LF( 211) / 0.9164854705743287D+03 / 6041 DATA LF( 212) / 0.9218373287078048D+03 / 6042 DATA LF( 213) / 0.9271939149824768D+03 / 6043 DATA LF( 214) / 0.9325552071481862D+03 / 6044 DATA LF( 215) / 0.9379211831632081D+03 / 6045 DATA LF( 216) / 0.9432918211913357D+03 / 6046 DATA LF( 217) / 0.9486670995990199D+03 / 6047 DATA LF( 218) / 0.9540469969525603D+03 / 6048 DATA LF( 219) / 0.9594314920153494D+03 / 6049 DATA LF( 220) / 0.9648205637451659D+03 / 6050 DATA LF( 221) / 0.9702141912915183D+03 / 6051 DATA LF( 222) / 0.9756123539930360D+03 / 6052 DATA LF( 223) / 0.9810150313749083D+03 / 6053 DATA LF( 224) / 0.9864222031463685D+03 / 6054 DATA LF( 225) / 0.9918338491982235D+03 / 6055 DATA LF( 226) / 0.9972499496004279D+03 / 6056 DATA LF( 227) / 0.1002670484599700D+04 / 6057 DATA LF( 228) / 0.1008095434617182D+04 / 6058 DATA LF( 229) / 0.1013524780246136D+04 / 6059 DATA LF( 230) / 0.1018958502249690D+04 / 6060 DATA LF( 231) / 0.1024396581558613D+04 / 6061 DATA LF( 232) / 0.1029838999269135D+04 / 6062 DATA LF( 233) / 0.1035285736640802D+04 / 6063 DATA LF( 234) / 0.1040736775094367D+04 / 6064 DATA LF( 235) / 0.1046192096209725D+04 / 6065 DATA LF( 236) / 0.1051651681723869D+04 / 6066 DATA LF( 237) / 0.1057115513528895D+04 / 6067 DATA LF( 238) / 0.1062583573670030D+04 / 6068 DATA LF( 239) / 0.1068055844343701D+04 / 6069 DATA LF( 240) / 0.1073532307895633D+04 / 6070 DATA LF( 241) / 0.1079012946818975D+04 / 6071 DATA LF( 242) / 0.1084497743752466D+04 / 6072 DATA LF( 243) / 0.1089986681478622D+04 / 6073 DATA LF( 244) / 0.1095479742921963D+04 / 6074 DATA LF( 245) / 0.1100976911147256D+04 / 6075 DATA LF( 246) / 0.1106478169357801D+04 / 6076 DATA LF( 247) / 0.1111983500893733D+04 / 6077 DATA LF( 248) / 0.1117492889230361D+04 / 6078 DATA LF( 249) / 0.1123006317976526D+04 / 6079 DATA LF( 250) / 0.1128523770872991D+04 / 6080 DATA LF( 251) / 0.1134045231790853D+04 / 6081 DATA LF( 252) / 0.1139570684729985D+04 / 6082 DATA LF( 253) / 0.1145100113817496D+04 / 6083 DATA LF( 254) / 0.1150633503306224D+04 / 6084 DATA LF( 255) / 0.1156170837573242D+04 / 6085 DATA LF( 256) / 0.1161712101118401D+04 / 6086 DATA LF( 257) / 0.1167257278562880D+04 / 6087 DATA LF( 258) / 0.1172806354647775D+04 / 6088 DATA LF( 259) / 0.1178359314232697D+04 / 6089 DATA LF( 260) / 0.1183916142294397D+04 / 6090 DATA LF( 261) / 0.1189476823925412D+04 / 6091 DATA LF( 262) / 0.1195041344332735D+04 / 6092 DATA LF( 263) / 0.1200609688836496D+04 / 6093 DATA LF( 264) / 0.1206181842868674D+04 / 6094 DATA LF( 265) / 0.1211757791971820D+04 / 6095 DATA LF( 266) / 0.1217337521797806D+04 / 6096 DATA LF( 267) / 0.1222921018106588D+04 / 6097 DATA LF( 268) / 0.1228508266764988D+04 / 6098 DATA LF( 269) / 0.1234099253745499D+04 / 6099 DATA LF( 270) / 0.1239693965125101D+04 / 6100 DATA LF( 271) / 0.1245292387084099D+04 / 6101 DATA LF( 272) / 0.1250894505904979D+04 / 6102 DATA LF( 273) / 0.1256500307971275D+04 / 6103 DATA LF( 274) / 0.1262109779766460D+04 / 6104 DATA LF( 275) / 0.1267722907872848D+04 / 6105 DATA LF( 276) / 0.1273339678970515D+04 / 6106 DATA LF( 277) / 0.1278960079836232D+04 / 6107 DATA LF( 278) / 0.1284584097342419D+04 / 6108 DATA LF( 279) / 0.1290211718456110D+04 / 6109 DATA LF( 280) / 0.1295842930237931D+04 / 6110 DATA LF( 281) / 0.1301477719841100D+04 / 6111 DATA LF( 282) / 0.1307116074510434D+04 / 6112 DATA LF( 283) / 0.1312757981581372D+04 / 6113 DATA LF( 284) / 0.1318403428479015D+04 / 6114 DATA LF( 285) / 0.1324052402717177D+04 / 6115 DATA LF( 286) / 0.1329704891897445D+04 / 6116 DATA LF( 287) / 0.1335360883708265D+04 / 6117 DATA LF( 288) / 0.1341020365924025D+04 / 6118 DATA LF( 289) / 0.1346683326404161D+04 / 6119 DATA LF( 290) / 0.1352349753092273D+04 / 6120 DATA LF( 291) / 0.1358019634015254D+04 / 6121 DATA LF( 292) / 0.1363692957282425D+04 / 6122 DATA LF( 293) / 0.1369369711084693D+04 / 6123 DATA LF( 294) / 0.1375049883693710D+04 / 6124 DATA LF( 295) / 0.1380733463461049D+04 / 6125 DATA LF( 296) / 0.1386420438817389D+04 / 6126 DATA LF( 297) / 0.1392110798271713D+04 / 6127 DATA LF( 298) / 0.1397804530410516D+04 / 6128 DATA LF( 299) / 0.1403501623897021D+04 / 6129 DATA LF( 300) / 0.1409202067470412D+04 / 6130 DATA LF( 301) / 0.1414905849945068D+04 / 6131 DATA LF( 302) / 0.1420612960209817D+04 / 6132 DATA LF( 303) / 0.1426323387227192D+04 / 6133 DATA LF( 304) / 0.1432037120032701D+04 / 6134 DATA LF( 305) / 0.1437754147734107D+04 / 6135 DATA LF( 306) / 0.1443474459510715D+04 / 6136 DATA LF( 307) / 0.1449198044612667D+04 / 6137 DATA LF( 308) / 0.1454924892360254D+04 / 6138 DATA LF( 309) / 0.1460654992143228D+04 / 6139 DATA LF( 310) / 0.1466388333420126D+04 / 6140 DATA LF( 311) / 0.1472124905717605D+04 / 6141 DATA LF( 312) / 0.1477864698629784D+04 / 6142 DATA LF( 313) / 0.1483607701817594D+04 / 6143 DATA LF( 314) / 0.1489353905008134D+04 / 6144 DATA LF( 315) / 0.1495103297994042D+04 / 6145 DATA LF( 316) / 0.1500855870632868D+04 / 6146 DATA LF( 317) / 0.1506611612846454D+04 / 6147 DATA LF( 318) / 0.1512370514620332D+04 / 6148 DATA LF( 319) / 0.1518132566003112D+04 / 6149 DATA LF( 320) / 0.1523897757105897D+04 / 6150 DATA LF( 321) / 0.1529666078101691D+04 / 6151 DATA LF( 322) / 0.1535437519224821D+04 / 6152 DATA LF( 323) / 0.1541212070770365D+04 / 6153 DATA LF( 324) / 0.1546989723093588D+04 / 6154 DATA LF( 325) / 0.1552770466609380D+04 / 6155 DATA LF( 326) / 0.1558554291791710D+04 / 6156 DATA LF( 327) / 0.1564341189173076D+04 / 6157 DATA LF( 328) / 0.1570131149343974D+04 / 6158 DATA LF( 329) / 0.1575924162952358D+04 / 6159 DATA LF( 330) / 0.1581720220703123D+04 / 6160 DATA LF( 331) / 0.1587519313357584D+04 / 6161 DATA LF( 332) / 0.1593321431732961D+04 / 6162 DATA LF( 333) / 0.1599126566701877D+04 / 6163 DATA LF( 334) / 0.1604934709191858D+04 / 6164 DATA LF( 335) / 0.1610745850184834D+04 / 6165 DATA LF( 336) / 0.1616559980716659D+04 / 6166 DATA LF( 337) / 0.1622377091876623D+04 / 6167 DATA LF( 338) / 0.1628197174806975D+04 / 6168 DATA LF( 339) / 0.1634020220702458D+04 / 6169 DATA LF( 340) / 0.1639846220809839D+04 / 6170 DATA LF( 341) / 0.1645675166427449D+04 / 6171 DATA LF( 342) / 0.1651507048904732D+04 / 6172 DATA LF( 343) / 0.1657341859641795D+04 / 6173 DATA LF( 344) / 0.1663179590088961D+04 / 6174 DATA LF( 345) / 0.1669020231746334D+04 / 6175 DATA LF( 346) / 0.1674863776163366D+04 / 6176 DATA LF( 347) / 0.1680710214938423D+04 / 6177 DATA LF( 348) / 0.1686559539718370D+04 / 6178 DATA LF( 349) / 0.1692411742198145D+04 / 6179 DATA LF( 350) / 0.1698266814120347D+04 / 6180 DATA LF( 351) / 0.1704124747274830D+04 / 6181 DATA LF( 352) / 0.1709985533498296D+04 / 6182 DATA LF( 353) / 0.1715849164673894D+04 / 6183 DATA LF( 354) / 0.1721715632730828D+04 / 6184 DATA LF( 355) / 0.1727584929643962D+04 / 6185 DATA LF( 356) / 0.1733457047433437D+04 / 6186 DATA LF( 357) / 0.1739331978164289D+04 / 6187 DATA LF( 358) / 0.1745209713946069D+04 / 6188 DATA LF( 359) / 0.1751090246932469D+04 / 6189 DATA LF( 360) / 0.1756973569320958D+04 / 6190 DATA LF( 361) / 0.1762859673352408D+04 / 6191 DATA LF( 362) / 0.1768748551310741D+04 / 6192 DATA LF( 363) / 0.1774640195522566D+04 / 6193 DATA LF( 364) / 0.1780534598356831D+04 / 6194 DATA LF( 365) / 0.1786431752224468D+04 / 6195 DATA LF( 366) / 0.1792331649578050D+04 / 6196 DATA LF( 367) / 0.1798234282911452D+04 / 6197 DATA LF( 368) / 0.1804139644759506D+04 / 6198 DATA LF( 369) / 0.1810047727697675D+04 / 6199 DATA LF( 370) / 0.1815958524341716D+04 / 6200 DATA LF( 371) / 0.1821872027347354D+04 / 6201 DATA LF( 372) / 0.1827788229409962D+04 / 6202 DATA LF( 373) / 0.1833707123264235D+04 / 6203 DATA LF( 374) / 0.1839628701683879D+04 / 6204 DATA LF( 375) / 0.1845552957481293D+04 / 6205 DATA LF( 376) / 0.1851479883507263D+04 / 6206 DATA LF( 377) / 0.1857409472650653D+04 / 6207 DATA LF( 378) / 0.1863341717838101D+04 / 6208 DATA LF( 379) / 0.1869276612033721D+04 / 6209 DATA LF( 380) / 0.1875214148238803D+04 / 6210 DATA LF( 381) / 0.1881154319491524D+04 / 6211 DATA LF( 382) / 0.1887097118866651D+04 / 6212 DATA LF( 383) / 0.1893042539475257D+04 / 6213 DATA LF( 384) / 0.1898990574464438D+04 / 6214 DATA LF( 385) / 0.1904941217017026D+04 / 6215 DATA LF( 386) / 0.1910894460351313D+04 / 6216 DATA LF( 387) / 0.1916850297720778D+04 / 6217 DATA LF( 388) / 0.1922808722413808D+04 / 6218 DATA LF( 389) / 0.1928769727753431D+04 / 6219 DATA LF( 390) / 0.1934733307097050D+04 / 6220 DATA LF( 391) / 0.1940699453836173D+04 / 6221 DATA LF( 392) / 0.1946668161396159D+04 / 6222 DATA LF( 393) / 0.1952639423235949D+04 / 6223 DATA LF( 394) / 0.1958613232847818D+04 / 6224 DATA LF( 395) / 0.1964589583757116D+04 / 6225 DATA LF( 396) / 0.1970568469522017D+04 / 6226 DATA LF( 397) / 0.1976549883733272D+04 / 6227 DATA LF( 398) / 0.1982533820013959D+04 / 6228 DATA LF( 399) / 0.1988520272019244D+04 / 6229 DATA LF( 400) / 0.1994509233436133D+04 / 6230 DATA LF( 401) / 0.2000500697983241D+04 / 6231 DATA LF( 402) / 0.2006494659410548D+04 / 6232 DATA LF( 403) / 0.2012491111499167D+04 / 6233 DATA LF( 404) / 0.2018490048061114D+04 / 6234 DATA LF( 405) / 0.2024491462939075D+04 / 6235 DATA LF( 406) / 0.2030495350006181D+04 / 6236 DATA LF( 407) / 0.2036501703165783D+04 / 6237 DATA LF( 408) / 0.2042510516351226D+04 / 6238 DATA LF( 409) / 0.2048521783525630D+04 / 6239 DATA LF( 410) / 0.2054535498681673D+04 / 6240 DATA LF( 411) / 0.2060551655841371D+04 / 6241 DATA LF( 412) / 0.2066570249055867D+04 / 6242 DATA LF( 413) / 0.2072591272405217D+04 / 6243 DATA LF( 414) / 0.2078614719998178D+04 / 6244 DATA LF( 415) / 0.2084640585972003D+04 / 6245 DATA LF( 416) / 0.2090668864492234D+04 / 6246 DATA LF( 417) / 0.2096699549752495D+04 / 6247 DATA LF( 418) / 0.2102732635974294D+04 / 6248 DATA LF( 419) / 0.2108768117406819D+04 / 6249 DATA LF( 420) / 0.2114805988326741D+04 / 6250 DATA LF( 421) / 0.2120846243038018D+04 / 6251 DATA LF( 422) / 0.2126888875871701D+04 / 6252 DATA LF( 423) / 0.2132933881185737D+04 / 6253 DATA LF( 424) / 0.2138981253364783D+04 / 6254 DATA LF( 425) / 0.2145030986820015D+04 / 6255 DATA LF( 426) / 0.2151083075988939D+04 / 6256 DATA LF( 427) / 0.2157137515335209D+04 / 6257 DATA LF( 428) / 0.2163194299348437D+04 / 6258 DATA LF( 429) / 0.2169253422544019D+04 / 6259 DATA LF( 430) / 0.2175314879462947D+04 / 6260 DATA LF( 431) / 0.2181378664671635D+04 / 6261 DATA LF( 432) / 0.2187444772761738D+04 / 6262 DATA LF( 433) / 0.2193513198349982D+04 / 6263 DATA LF( 434) / 0.2199583936077985D+04 / 6264 DATA LF( 435) / 0.2205656980612085D+04 / 6265 DATA LF( 436) / 0.2211732326643174D+04 / 6266 DATA LF( 437) / 0.2217809968886523D+04 / 6267 DATA LF( 438) / 0.2223889902081619D+04 / 6268 DATA LF( 439) / 0.2229972120991995D+04 / 6269 DATA LF( 440) / 0.2236056620405070D+04 / 6270 DATA LF( 441) / 0.2242143395131983D+04 / 6271 DATA LF( 442) / 0.2248232440007429D+04 / 6272 DATA LF( 443) / 0.2254323749889507D+04 / 6273 DATA LF( 444) / 0.2260417319659552D+04 / 6274 DATA LF( 445) / 0.2266513144221985D+04 / 6275 DATA LF( 446) / 0.2272611218504151D+04 / 6276 DATA LF( 447) / 0.2278711537456171D+04 / 6277 DATA LF( 448) / 0.2284814096050784D+04 / 6278 DATA LF( 449) / 0.2290918889283199D+04 / 6279 DATA LF( 450) / 0.2297025912170942D+04 / 6280 DATA LF( 451) / 0.2303135159753706D+04 / 6281 DATA LF( 452) / 0.2309246627093209D+04 / 6282 DATA LF( 453) / 0.2315360309273041D+04 / 6283 DATA LF( 454) / 0.2321476201398524D+04 / 6284 DATA LF( 455) / 0.2327594298596565D+04 / 6285 DATA LF( 456) / 0.2333714596015516D+04 / 6286 DATA LF( 457) / 0.2339837088825031D+04 / 6287 DATA LF( 458) / 0.2345961772215925D+04 / 6288 DATA LF( 459) / 0.2352088641400039D+04 / 6289 DATA LF( 460) / 0.2358217691610100D+04 / 6290 DATA LF( 461) / 0.2364348918099583D+04 / 6291 DATA LF( 462) / 0.2370482316142579D+04 / 6292 DATA LF( 463) / 0.2376617881033661D+04 / 6293 DATA LF( 464) / 0.2382755608087747D+04 / 6294 DATA LF( 465) / 0.2388895492639974D+04 / 6295 DATA LF( 466) / 0.2395037530045561D+04 / 6296 DATA LF( 467) / 0.2401181715679687D+04 / 6297 DATA LF( 468) / 0.2407328044937356D+04 / 6298 DATA LF( 469) / 0.2413476513233273D+04 / 6299 DATA LF( 470) / 0.2419627116001719D+04 / 6300 DATA LF( 471) / 0.2425779848696424D+04 / 6301 DATA LF( 472) / 0.2431934706790440D+04 / 6302 DATA LF( 473) / 0.2438091685776025D+04 / 6303 DATA LF( 474) / 0.2444250781164517D+04 / 6304 DATA LF( 475) / 0.2450411988486213D+04 / 6305 DATA LF( 476) / 0.2456575303290247D+04 / 6306 DATA LF( 477) / 0.2462740721144479D+04 / 6307 DATA LF( 478) / 0.2468908237635367D+04 / 6308 DATA LF( 479) / 0.2475077848367858D+04 / 6309 DATA LF( 480) / 0.2481249548965269D+04 / 6310 DATA LF( 481) / 0.2487423335069171D+04 / 6311 DATA LF( 482) / 0.2493599202339277D+04 / 6312 DATA LF( 483) / 0.2499777146453328D+04 / 6313 DATA LF( 484) / 0.2505957163106980D+04 / 6314 DATA LF( 485) / 0.2512139248013697D+04 / 6315 DATA LF( 486) / 0.2518323396904634D+04 / 6316 DATA LF( 487) / 0.2524509605528535D+04 / 6317 DATA LF( 488) / 0.2530697869651617D+04 / 6318 DATA LF( 489) / 0.2536888185057470D+04 / 6319 DATA LF( 490) / 0.2543080547546945D+04 / 6320 DATA LF( 491) / 0.2549274952938050D+04 / 6321 DATA LF( 492) / 0.2555471397065845D+04 / 6322 DATA LF( 493) / 0.2561669875782337D+04 / 6323 DATA LF( 494) / 0.2567870384956380D+04 / 6324 DATA LF( 495) / 0.2574072920473567D+04 / 6325 DATA LF( 496) / 0.2580277478236136D+04 / 6326 DATA LF( 497) / 0.2586484054162861D+04 / 6327 DATA LF( 498) / 0.2592692644188958D+04 / 6328 DATA LF( 499) / 0.2598903244265982D+04 / 6329 DATA LF( 500) / 0.2605115850361734D+04 / 6330 DATA LF( 501) / 0.2611330458460156D+04 / 6331 DATA LF( 502) / 0.2617547064561241D+04 / 6332 DATA LF( 503) / 0.2623765664680933D+04 / 6333 DATA LF( 504) / 0.2629986254851032D+04 / 6334 DATA LF( 505) / 0.2636208831119104D+04 / 6335 DATA LF( 506) / 0.2642433389548379D+04 / 6336 DATA LF( 507) / 0.2648659926217667D+04 / 6337 DATA LF( 508) / 0.2654888437221258D+04 / 6338 DATA LF( 509) / 0.2661118918668836D+04 / 6339 DATA LF( 510) / 0.2667351366685387D+04 / 6340 DATA LF( 511) / 0.2673585777411105D+04 / 6341 DATA LF( 512) / 0.2679822147001309D+04 / 6342 DATA LF( 513) / 0.2686060471626348D+04 / 6343 DATA LF( 514) / 0.2692300747471519D+04 / 6344 DATA LF( 515) / 0.2698542970736974D+04 / 6345 DATA LF( 516) / 0.2704787137637638D+04 / 6346 DATA LF( 517) / 0.2711033244403120D+04 / 6347 DATA LF( 518) / 0.2717281287277628D+04 / 6348 DATA LF( 519) / 0.2723531262519888D+04 / 6349 DATA LF( 520) / 0.2729783166403053D+04 / 6350 DATA LF( 521) / 0.2736036995214629D+04 / 6351 DATA LF( 522) / 0.2742292745256382D+04 / 6352 DATA LF( 523) / 0.2748550412844265D+04 / 6353 DATA LF( 524) / 0.2754809994308330D+04 / 6354 DATA LF( 525) / 0.2761071485992651D+04 / 6355 DATA LF( 526) / 0.2767334884255242D+04 / 6356 DATA LF( 527) / 0.2773600185467980D+04 / 6357 DATA LF( 528) / 0.2779867386016522D+04 / 6358 DATA LF( 529) / 0.2786136482300228D+04 / 6359 DATA LF( 530) / 0.2792407470732086D+04 / 6360 DATA LF( 531) / 0.2798680347738632D+04 / 6361 DATA LF( 532) / 0.2804955109759874D+04 / 6362 DATA LF( 533) / 0.2811231753249216D+04 / 6363 DATA LF( 534) / 0.2817510274673382D+04 / 6364 DATA LF( 535) / 0.2823790670512342D+04 / 6365 DATA LF( 536) / 0.2830072937259238D+04 / 6366 DATA LF( 537) / 0.2836357071420309D+04 / 6367 DATA LF( 538) / 0.2842643069514818D+04 / 6368 DATA LF( 539) / 0.2848930928074979D+04 / 6369 DATA LF( 540) / 0.2855220643645888D+04 / 6370 DATA LF( 541) / 0.2861512212785447D+04 / 6371 DATA LF( 542) / 0.2867805632064293D+04 / 6372 DATA LF( 543) / 0.2874100898065733D+04 / 6373 DATA LF( 544) / 0.2880398007385667D+04 / 6374 DATA LF( 545) / 0.2886696956632523D+04 / 6375 DATA LF( 546) / 0.2892997742427186D+04 / 6376 DATA LF( 547) / 0.2899300361402931D+04 / 6377 DATA LF( 548) / 0.2905604810205353D+04 / 6378 DATA LF( 549) / 0.2911911085492301D+04 / 6379 DATA LF( 550) / 0.2918219183933810D+04 / 6380 DATA LF( 551) / 0.2924529102212037D+04 / 6381 DATA LF( 552) / 0.2930840837021190D+04 / 6382 DATA LF( 553) / 0.2937154385067467D+04 / 6383 DATA LF( 554) / 0.2943469743068989D+04 / 6384 DATA LF( 555) / 0.2949786907755737D+04 / 6385 DATA LF( 556) / 0.2956105875869483D+04 / 6386 DATA LF( 557) / 0.2962426644163733D+04 / 6387 DATA LF( 558) / 0.2968749209403661D+04 / 6388 DATA LF( 559) / 0.2975073568366042D+04 / 6389 DATA LF( 560) / 0.2981399717839197D+04 / 6390 DATA LF( 561) /