C ******************** ABAREX MAIN *************************************AB 1 C AB 2 C *******************INPUT KEYWORDS AND FORMATS*************************AB 3 C AB 4 C ALL INPUT FORMATS ARE (A2,5X,I3,7F10.4) UNLESS OTHERWISE SPECIFIED. AB 5 C ALL ENERGIES ARE IN MEV(LAB). AB 6 C ALL LENGTHS ARE IN FERMIS. AB 7 C ALL XSECS. ARE IN BARNS OR BARNS/SR IN THE LAB. SYSTEM. AB 8 C ALL ANGLES ARE IN DEGREES(LAB). AB 9 C ANY NUMBER OF CASES CAN BE STACKED AT THE INPUT. AB 10 C KEYWORDS CAN BE IN ANY ORDER EXCEPT WHERE OTHERWISE STATED. AB 11 C EACH CASE MUST END WITH A 'COMPUTE' LINE. AB 12 C AB 13 C ********* START CALCULATIONS, ALWAYS LAST CARD OF GIVEN PROBLEM. AB 14 C 1- 7 'COMPUTE' AB 15 C 8-10 LMAX, MAXIMUM ORBITAL ANGULAR MOMENTUM. AB 16 C DEFAULT = 0, USE ORDINARILY, LMAX DETERMINED INTERNALLY FOR AB 17 C EACH LEVEL SEPARATELY. MAX VALUE = 20. AB 18 C 11-20 E, LAB ENERGY OF INCIDENT NEUTRONS IN MEV. DEFAULT VALUE = 0.8.AB 19 C 21-30 ANO, TARGET MASS NUMBER, DEFAULT = 55.9349. AB 20 C 31-40 ANU, PROJECTILE MASS NUMBER, DEFAULT = 1.008665. AB 21 C 41-50 FNU, WIDTH FLUCTUATION DEGREES OF FREEDOM, DEFAULT = 1 + T**0.6.AB 22 C IF FNU IS NEGATIVE NO FLUCTUATION CORRECTION, I.E. H-F CAL. AB 23 C THERE IS NO FLUCTUATION CORRECTION WHEN CONTINUUM EXCITATIONS AB 24 C ARE INVOLVED IN THE CALCULATION. AB 25 C 51-60 DANG, ANGLE INTERVAL OF DIFFERENTIAL XSEC. DEFAULT = AB 26 C 15 DEG. (LAB) AB 27 C 61-70 C1, ASYMPTOTIC MATCHING RADIUS, DEFAULT VALUE = 15 FM. AB 28 C 71-80 PTS, NO. OF RADIAL INTEGRATION POINTS, DEFAULT = 301.0. AB 29 C SHOULD BE AN ODD NUMBER. AB 30 C AB 31 C ********* PARAMETERS FOR DISPERSION CONTRIBUTION AB 32 C 1- 7 'DISP ' AB 33 C 8-10 BLANK. AB 34 C 11-20 SURF0. AB 35 C 21-30 SURF1. AB 36 C 31-40 SURF2. AB 37 C WHERE A REAL SURFACE POTENTIAL -- AB 38 C V=(SURF0+SURF1*E+SURF2*E**2)*W AB 39 C IS ADDED TO THE REAL POTENTIAL, 'W' IS THE IMAGINARY AB 40 C POTENTIAL AND 'E' THE INCIDENT ENERGY. DEFAULT VALUES OF AB 41 C SURF0, SURF1 AND SURF2 ARE ZERO. ENERGY E IN CM SYSTEM. AB 42 C AB 43 C ********* INPUT CHANGE IN PARAMETERS AB 44 C 1- 7 'INPUT ' AB 45 C CHANGE INPUT PARAMETERS FROM PREVIOUS CASE USING NAMELIST/INPUT/AB 46 C LINES WHICH MUST FOLLOW. NOT PERMITTED FOR FIRST CASE. AB 47 C FOR EXAMPLE -- AB 48 C COMPUTE (FROM PREVIOUS CASE) AB 49 C INPUT AB 50 C &INPUT Z(1)=5.0,VRE=46.0,&END AB 51 C IN THIS EXAMPLE THE ENERGY OF THE PREVIOUS CASE WILL BE CHANGED AB 52 C TO 5.0 MEV, THE REAL POTENTIAL TO 46.0 MEV, AND THE PROBLEM AB 53 C WILL BE RUN AGAIN. THIS IS AN IBM PROCEDURE WHICH MAY NOT AB 54 C EXIST IN ALL FORTRAN. IT IS NOT A RECOMMENDED PROCEDURE FOR AB 55 C ABAREX UNLESS YOU ARE CAREFUL. AB 56 C AB 57 C ********* PRINT TRANS. COEF., S-MATRIX, ETC. AB 58 C 1- 7 'TRANSM ' AB 59 C 8-10 KETA, PRINTS TRANSMISSION COEFFICIENTS, S-MATRIX, STRN. FUNCT., AB 60 C R-PRIME FOR FIRST KETA LEVELS. DEFAULT MEANS KETA = NLEVEL. AB 61 C AB 62 C ********* ENTER REAL OPTICAL POTENTIAL, SAXON-WOODS FORM AB 63 C 1- 7 'REAL ' AB 64 C 8-10 KRE, DUMMY CAN BE ANY VALUE OR OMITTED. TYPICALLY KRE = 1. AB 65 C CODE USES WOODS-SAXON REAL POTENTIAL FORM IN ALL CASES. AB 66 C 11-20 VRE, REAL POTENTIAL STRENGTH IN MEV, ASSUMED TO BE POSITIVE. AB 67 C 21-30 VRE1, LINEAR PARAMETER OF STRENGTH. AB 68 C 31-40 VRE2, QUADRATIC PARAMETER OF STRENGTH. AB 69 C WHERE V = VRE + VRE1*E +VRE2*E**2. E IN CM. AB 70 C 41-50 R1, REAL POTENTIAL REDUCED RADIUS IN FERMIS. AB 71 C 51-60 A1, REAL POTENTIAL DIFFUSENESS IN FERMIS. AB 72 C 61-70 VSR, SPIN-ORBIT STRENGTH IN MEV, ASSUMES REAL SO POTENTIAL, AB 73 C SAME GEOMETRY AS REAL POTENTIAL AND THE THOMAS FORM. IF AB 74 C IDENTICALLY = 0 SO LINE (BELOW) MUST BE INCLUDED IN THE INPUT. AB 75 C AB 76 C ********* ENTER IMAGINARY OPTICAL POTENTIAL AB 77 C 1- 7 'IMAG ' AB 78 C 8-10 KIM, SETS IMAGINARY WELL FORM AS FOLLOWS-- AB 79 C 1 = VOLUME WELL (WOODS-SAXON). AB 80 C 2 = GAUSSIAN-SURFACE WELL (V*EXP(-((R-r)/A)**2). AB 81 C 3 = GAUSSIAN-SURFACE + VOLUME WELL (SUM OF ABOVE). AB 82 C 4 = WOODS-SAXON DERIVATIVE WELL. AB 83 C 5 = WOODS-SAXON DERIVATIVE + VOLUME WELL. AB 84 C IF VIVOL (BELOW) IS USED, KIM = 2 AND 3 ARE AB 85 C EQUIVALENT, THAT IS ALSO TRUE FOR KIM = 4 AND 5. AB 86 C 11-20 VIM, IMAGINARY POTENTIAL STRENGTH IN MEV. AB 87 C 21-30 VIM1, LINEAR PARAMETER OF STRENGTH. AB 88 C 31-40 VIM2, QUADRATIC PARAMETER OF STRENGTH. AB 89 C WHERE VI = VIM + VIM1*E + VIM2*E**2, E IN CM SYSTEM. AB 90 C 41-50 R2, IMAGINARY POTENTIAL REDUCED RADIUS IN FERMIS. AB 91 C 51-60 A2, IMAGINARY POTENTIAL DIFFUSENESS IN FERMIS. AB 92 C 61-70 VIVOL, VOLUME IMAGINARY POTENTIAL STRENGTH IN MEV. AB 93 C 71-80 VOLRAT, RATIO OF VOLUME TO SURFACE POTENTIAL. AB 94 C AB 95 C ********* ENTER SPIN-ORBIT POTENTIAL (VSR (ABOVE) MUST BE 0) AB 96 C 1- 7 'SO ' AB 97 C 8-10 KSO, = 1 FOR THOMAS FORM. THIS FORM IS RECOMMENDED. AB 98 C = 2 WOODS-SAXON VOLUME FORM. AB 99 C = 3 WOODS-SAXON-DERIVATIVE FORM. AB 100 C 11-20 VSR, REAL SPIN-ORBIT STRENGTH IN MEV. AB 101 C 21-30 VS1, IMAGINARY SPIN-ORBIT STRENGTH IN MEV. AB 102 C 31-40 RR1, SO REDUCED RADIUS IN FERMIS. AB 103 C 41-50 AA1, SO DIFFUSENESS IN FERMIS. AB 104 C AB 105 C ********* INPUT TARGET LEVEL DATA AB 106 C 1- 7 'LEVELS ' AB 107 C 8-10 NLE, NUMBER OF DESCRETE TARGET LEVELS, MAXIMUM = 50 AB 108 C 11-20 ZTARGET, TARGET CHARGE NUMBER. DEFAULT = 0 (BLANK) IN WHICH AB 109 C CASE THERE IS NO TARGET LEVEL CONTINUUM. AB 110 C 21-30 ECONT, ENERGY FOR START OF CONTINUUM, DEFAULT ECONT=EX(NLE). AB 111 C 31-40 ESTEP, ENERGY INTERVAL OF CONTINUUM CALCULATIONS, AB 112 C DEFAULT = 0.2 MEV. AB 113 C 41-50 TAU, TEMPERATURE IN CONTINUUM LEVEL-DENSITY FORMULA, AB 114 C RHO(E) =EXP((E-E0T)/TAU). AB 115 C 51-60 E0T, ENERGY SHIFT IN RHO FORMULA. AB 116 C 61-70 SGT, LEVEL DENSITY SPIN CUTOFF PARAMETER. AB 117 C IF TAU = 0.0 TAU, E0T AND SGT AARE COMPUTED INTERNALLY. THEAB 118 C RESULTS MAY NOT BE REALISTIC. INSPECT THEM! AB 119 C UNLESS NLE = 0, NLE CARDS MUST FOLLOW IN THE FORMAT AB 120 C (F9.4,F4.1,I2,I5,F5.4) DESCRIBING THE TARGET STATE FOLLOWED BY AB 121 C EXCITED STATES IN ORDER OF INCREASING ENERGY. THE SPECIFICATIONAB 122 C THESE LEVEL CARDS FOLLOWS -- AB 123 C AB 124 C ********* LEVEL CARDS, FORMAT(F9.4,F4.1,I2,I5,F5.4) AB 125 C 1- 9 EX(I), EXCITATION OF THE I-TH TARGET STATE. AB 126 C 10-13 FI(I), THE STATE SPIN. AB 127 C 14-15 IPI(I), THE STATE PARITY, +1 OR -1, DEFAULT = +1. AB 128 C 16-20 KGP(I), THE STATE GROUP NUMBER. USED FOR SEARCH AND PRINTOUT. AB 129 C XSECS. FOR CONSECUTIVE LEVELS WITH IDENTICAL GROUP NUMBERS ARE AB 130 C ADDED TOGETHER IN PRINTOUT AND/OR SEARCH. AB 131 C IF KGP(1) IS NEGATIVE ONLY THE SHAPE-ELASTIC CROSS SECTION AB 132 C IS CALCULATED AND FITTED. AB 133 C 21-25 GW(I), WEIGHT OF I-TH LEVEL FOR FITTING, DEFAULT=1. AB 134 C AB 135 C ********* SCAN ENERGY RANGE IN CACULATIONS AB 136 C 1- 7 'SCAN ' AB 137 C 8-10 KK, = 0 FOR SIMPLE SCAN, THEN -- AB 138 C 11-20 E1, DESIRED. AB 139 C 21-30 E2, DESIRED. AB 140 C ETC. TO AB 141 C 71-80 E7, DESIRED. AB 142 C REPEAT LINE TO CALCULATE UP TO 50 ENERGIES. AB 143 C KK = 1 FOR INCREMENTAL SCAN, THEN -- AB 144 C 11-20 EI, THE INITIAL ENERGY IN MEV. AB 145 C 21-30 DE, THE ENERGY INCREMENT BETWEEN EI AND EF, MAX. OF 50 STEPS. AB 146 C 31-40 EF, THE FINAL ENERGY. AB 147 C AB 148 C ********* SEARCH FOR PARAMETERS BY FITTING DATA AB 149 C CHI-SQUARE FIT TO TOTAL AND SCATTERING CROSS SECTIONS. AB 150 C FORMAT OF LINE IS (A7,I3,5F10.4,20I). AB 151 C 1- 7 'SEARCH ' AB 152 C 8-10 NOA, NUMBER OF SCATTERING ANGLES WITH DIFFERENTIAL DATA. AB 153 C 11-20 E, LAB. NEUTRON ENERGY OF THE DATA. AB 154 C 21-30 SGTOT, EXP. TOTAL CROSS SECTION, DEFAULT NO TOTAL CROSS SECTION AB 155 C FIT. AB 156 C 31-40 GWTOT, WEIGHT OF TOTAL CROSS SECTION, DEFAULT = 1.0. AB 157 C 41-50 FPRINT, -1.0 PRINTS PARAMETERS AT EACH STEP, DEFAULT NO AB 158 C INTERMEDIATE PRINT OUTS. AB 159 C 51-60 TOL, CONVERGENCE TERMINATION OF FIT, DEFAULT = 0.005. AB 160 C 61-80 KQ(I), 1 OR 0 DEPENDING WHETHER THE PARAMETER IS TO BE AB 161 C FITTED OR NOT. THE ORDER OF THE PARAMETERS IS-- AB 162 C VRE,VRE1,VRE2,R1,A1,VIM,VIM1.VM2,R2,A2,VIVOL,VOLRAT, AB 163 C VSR,VSR1,RR1,AA1. THERE ARE 16 IN TOTAL. KQ(20) MUST AB 164 C BE 5 IF DIFFERENTIAL DATA HAS % ERROR ASSIGNED, AB 165 C AS BELOW. IF WEIGHTING IS PROPORTIONAL TO XSEC. AB 166 C MAGNITUDE KQ(20) IS 0 OR BLANK. BLANKS ARE NOT AB 167 C EQUIVALENT TO '0' IN THE KG(I) STRING AND SHOULD AB 168 C NOT BE USED. EVERY SEARCH LINE MUST BE FOLLOWED BY NOA AB 169 C DIFFERENTIAL DATA LINES AS FOLLOWS -- AB 170 C AB 171 C ********* DIFFERENTIAL DATA INPUT, FORMAT(8F10.4) AB 172 C 1-10 A(I), THE I-TH LABORATORY ANGLE. AB 173 C 11-20 XIN(I,1), EXPERIMENTAL LAB. XSEC. FOR SCATTERING TO THE J-TH AB 174 C ETC. LEVEL AT THE I-TH ANGLE. UP TO SEVEN LEVEL GROUPS AB 175 C 71-80 XIN(I,7), CAN BE FITTED. THERE WILL BE NOA SUCH LINES. IF AB 176 C KQ(20) OF THE SEARCH LINE = 5 THE CORRESPONDING AB 177 C NOA % ERRORS MUST FOLLOW IN THE SAME FORMAT AS AB 178 C FOLLOWS -- AB 179 C 1-10 BLANK AB 180 C 10-20 ERR(I,1), AB 181 C ETC. AB 182 C 71-80 ERR(I,7), AB 183 C ONLY POSITIVE NON-ZERO CROSS SECTIONS ARE FITTED. AB 184 C AB 185 C ********* SEARCH INCLUDING STRENGTH FUNCTIONS AB 186 C STRENGTH-FUNCTION SEARCH LINE MUST BE FIRST SEARCH AB 187 C LINE AND BE FOLLOWED BY A PARAMETER LINE. AFTER THESEAB 188 C TWO LINES ANY COMBINATION OF SEARCH INPUTS MAY BE AB 189 C ADDED. S0, R-PRIME AND S1 MUST ALL BE INTRODUCED. AB 190 C PERCENT ERRORS ARE USED FOR WEIGHTING. AB 191 C THE INPUT IS:- AB 192 C 1- 7 'SEARCH ' AB 193 C 8-10 NOA, MUST BE -1 FOR STRENGTH-FUNCTION INPUT. AB 194 C 11-20 E-LAB IN MEV, DEFAULT VALUE = 1 EV. AB 195 C 21-30 S0 IN UNITS OF 1E-4. AB 196 C 31-40 S0 % ERROR. AB 197 C 41-50 R-PRIME IN UNITS OF FMS. AB 198 C 51-60 R-PRIME % ERROR. AB 199 C 61-70 S1 IN UNITS OF 1E-4. AB 200 C 71-80 S1 % ERROR. AB 201 C THIS LINE MUST BE FOLLOWED BY A LINE IN FORMAT(16I1,F12.6) AB 202 C GIVING:- AB 203 C 1-16 THE 16 '1' OR '0' VALUES INDICATING THE PARAMETERS AB 204 C TO BE SEARCHED AS PER THE GENERAL 'SEARCH' LINE, ABOVE. AB 205 C 17-29 THE CONVERGENCE VALUE TOL, DEFAULT TOL=0.005 AB 206 C AB 207 C THERE MUST BE AT LEAST AS MANY DATA VALUES IN A AB 208 C SEARCH AS THE NUMBER OF PARAMETERS SOUGHT. A AB 209 C NUMBER OF SEARCH SETS CAN BE USED CONCURRENTLY, EACH AB 210 C AT DIFFERENT ENERGIES. WITH NOA EQUAL ZERO A SET OF AB 211 C TOTAL CROSS SECTIONS CAN BE FITTED. TOTAL, AB 212 C DIFERENTIAL AND STRENGTH-FUNCTION SEARCHS CAN BE AB 213 C INTERMIXED, PROVIDING THE STRENGTH-FUNCTION SEARCH AB 214 C INPUT IS GIVEN FIRST. AB 215 C AB 216 C ********* CAPTURE INPUT, GAMMA-PRODUCTION AND RADIATIVE CAPTURE AB 217 C 1- 7 'CAPTURE' AB 218 C 8-10 IABS(NZ), COMPOUND-NUCLEUS CHARGE NUMBER. DEFAULT-READ AB 219 C IN TRANSMISSION COEFFICIENTS. ALL OTHER ENTRIES ON AB 220 C LINE ARE THEN IGNORED. AB 221 C 11-20 TGO, RATIO OF AVERAGE RADIATION WIDTH TO LEVEL SPACING FOR AB 222 C ALL S-WAVE NEUTRONS NEAR THE NEUTRON BINDING ENERGY. AB 223 C DEFAULT- GIANT DIPOLE GAMMA STRENGTH COMPUTED AB 224 C INTERNALLY. AB 225 C 21-30 BN, NEUTRON BINDING ENERGY, DEFAULT = 8 MEV. AB 226 C 31-40 FNUG, GAMMA CHANNEL WIDTH FLUCTION DEGREES OF FREEDOM, AB 227 C DEFAULT = 20. AB 228 C 41-50 GGD, E2 GIANT DIPOLE WIDTH, DEFAULT = 5.0. AB 229 C 51-60 EGD, E2 GIANT DIPOLE ENERGY, DEFAULT = 163.*SQRT(N*Z)/ AB 230 C A**1.333. AB 231 C 61-70 XFR, EXCHANGE FRACTION, DEFAULT = 0.5. AB 232 C 70-80 SG, LEVEL DENSITY SPIN COUTOFF PARAMETER, DEFAULT - AB 233 C INTERNALLY COMPUTED. AB 234 C IF NZ=0 THE CAPTURE LINE MUST BE FOLLOWED AB 235 C BY ONE LINE IN FORMAT(16F5.3), AS FOLLOWS -- AB 236 C 1- 5 TGG(1) WHERE THE TGG(K) ARE THE SUM OF GAMMA TRANSMISSION AB 237 C 6-10 TGG(2) COEFFICIENTS FOR THE K-TH TOTAL ANGULAR MOMENTUM AB 238 C ETC. AND EITHER PARITY. AB 239 C 76-80 TGG(16) AB 240 C AB 241 C ********* N-GAMMA, INCLUDE ONLY EFFECTS OF GAMMA-RAY CHANNELS. AB 242 C 1- 7 'N-GAMMA' AB 243 C PARAMETERS ARE IDENTICAL TO THOSE OF 'CAPTURE' LINE. AB 244 C THE SAME RESULTS ARE OBTAINED WITH THE CAPTURE LINE. AB 245 C AB 246 C ********* FISSION, CALCULATE FISSION CROSS SECTIONS. AB 247 C 1- 7 'FISSION' AB 248 C 8-10 NF, TOTAL ANGULAR MOMENTUM IN THE FISSION CHANNELS. AB 249 C MUST BE FOLLOWED BY LINES IN THE FORMAT(16F5.3) AS FOLLOWS- AB 250 C 1- 5 TF+(1), TF+(I) AND TF-(I) ARE THE TOTAL FISSION TRANSM- AB 251 C 6-10 FN+(1), MISSION COEFFICIENTS FOR THE I-TH TOTAL ANGULAR MOM- AB 252 C 11-15 TF-(2), ENTUM AND + AND- PARITIES, RESPECTIVELY. THE AB 253 C 16-20 FN-(2), FN+(I) AND FN-(I) ARE THE CORRESPONDING WIDTH AB 254 C ETC. FLUCTUATION DEGREEES OF FREEDOM. THE VALUES ARE READ AB 255 C IN FOR THE NF TOTAL ANGULAR MOMENTA. AB 256 C AB 257 C **************************END INPUT OUTLINE **************************AB 258 C AB 259 C AB 260 PROGRAM ABAREX AB 261 IMPLICIT REAL*8(A-H,O-Z) AB 262 INTEGER*2 WKY,NQ,DT(13) AB 263 EXTERNAL FCN AB 264 COMMON AB 265 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32),RPEXP,AB 266 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, AB 267 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,ES,GWS0,GWRP,GWS1, AB 268 XS0EXP,S1EXP,ID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0, AB 269 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,ISTR AB 270 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB AB 271 COMMON /COMN/VRE,VRE1,VRE2,R1,A1,VIM,VIM1,VIM2,R2,A2,VIVOL,C2,VSR,AB 272 XVSI,RR1,AA1,X(20),W(20),KP(16) AB 273 COMMON/ZBLOCK/Z(24000) AB 274 COMMON/QBLOCK/NQ(7600) AB 275 COMMON/ASUR/SURF0,SURF1,SURF2 AB 276 C COMMON/ASUR/ ADDED SO SURFACE REAL POTENTIAL AB 277 C CAN BE INCLUDED AS REQUIRED BY DISPERSION RELATIONS. AB 278 C COMMON ZZBLOC ADDED TO STORE ERRORS AB 279 COMMON/ZZBLOC/ZZ(10000) AB 280 C AB 281 C ZBLOCK STORAGE AB 282 C AB 283 C START LENGTH CONTENTS AB 284 C AB 285 C 1 NOCTOT E, GWTOT, A(NGLES) AB 286 C J2 IC XIN (INPUT CROSS SECTIONS) AB 287 C J3 IC DUM AB 288 C J4 (KIN+1)*IC+5*KIN WA (SEARCH CODE WORK AREA) AB 289 C KR KPT VR (SUBROUTINE ABACUS) AB 290 C KI KPT VI AB 291 C KS KPT VS AB 292 C KX KPT-1 X2 AB 293 C KRE KPT+1 URE AB 294 C KIM KPT+1 UIM AB 295 C KREM KPT+1 UREM AB 296 C KIMM KPT+1 UIMM AB 297 C J5 2*(LMAX(1)+1) CR (PHASE SHIFT FACTOR) AB 298 C J6 2*(LMAX(1)+1) CI (PHASE SHIFT FACTOR) AB 299 C J7 2*SUM(I)(LMAX(I)+1) T (TRANSM. COEFFS.) AB 300 C J8 NLEVL SLC AB 301 C J9 NLEVL SIG AB 302 C J10 2*(LMAX(MAX)+1) P AB 303 C J11 2*(LMAX(MAX)+1) P1 AB 304 C J12 SUM(I)(LMAX+1) B (LEGENDRE COEFF.) AB 305 C J13 SUM(LEVEL)(2*I+1) TP AB 306 C J14 SUM(LEVEL)(2*I+1) TM AB 307 C J15 SUM(LEVEL)(2*I+1) SP (WIDTH DISTR COEFF.) AB 308 C J16 SUM(LEVEL)(2*I+1) SM (WIDTH DISTR COEFF.) AB 309 C J17 2*SUM(I)(LMAX(I)+1) T (GAMCAP) AB 310 C J18 NJMAX-NJMIN+1 TCP (GAMCAP) AB 311 C J19 NJMAX-NJMIN+1 TCM (GAMCAP) AB 312 C J20 2*SUM(I)(LMAX(I)+1) T (CONTINUUM) AB 313 C J21 TCON (CONTINUUM) AB 314 C AB 315 C AB 316 DIMENSION VIN(16),FIN(16),FKY(7),TT(13),A(125),KQ(20),IWA(16) AB 317 DATA DT/'DI','IN','TR','RE','IM','SO','N-','CA','FI','LE', AB 318 X'SC','SE','CO'/ AB 319 DATA TT/'DISP','INPUT','TRANSM','REAL','IMAG','SO','N-GAMMA' AB 320 X,'CAPTURE','FISSION','LEVELS','SCAN','SEARCH','COMPUTE'/ AB 321 EQUIVALENCE (VRE,FIN(1)) AB 322 NAMELIST/INPUT/NLEVEL,FNU,DANG,LMAX,Z,ANO,ANU,EX,FI,IPI,KGP, AB 323 XVRE,VRE1,VRE2,R1,A1,KIM,VIM,VIM1,VIM2,R2,A2,VIVOL,C2,KETA, AB 324 XKSO,VSR,VSI,RR1,AA1,TG0,BN,FNUG,EGD,GGD,XFR,SG,NZ,TGG,TFF,FNF, AB 325 XSURF0,SURF1,SURF2,KSCH AB 326 NZB=24000 AB 327 OPEN(5,FILE='INPUT',STATUS='OLD') AB 328 OPEN(6,FILE='OUTPUT',STATUS='NEW') AB 329 DO 29 I=1,NZB AB 330 Z(I)=0 AB 331 29 CONTINUE AB 332 NQB=7600 AB 333 TOL=0.005 AB 334 DO 5 J=1,20 AB 335 5 W(J)=W(J)*DEXP(X(J)) AB 336 1 CONTINUE AB 337 READ(5,5100,END=999)WKY,IKY,(FKY(J),J=1,7) AB 338 5100 FORMAT(A2,5X,I3,7F10.4) AB 339 WRITE(6,6000) AB 340 6000 FORMAT(1H1,40X,'ABAREX'/41X,'======'//' INPUT DECK :'/) AB 341 IF(WKY.EQ.DT(2))GO TO 3 AB 342 C AB 343 C INITIALIZE VARIABLES. AB 344 GWS0=0D0 AB 345 GWRP=0D0 AB 346 GWS1=0D0 AB 347 NTI=0 AB 348 NOCTOT=0 AB 349 IZ=0 AB 350 IQ=0 AB 351 TG0=0D0 AB 352 KS=0 AB 353 KSC=0 AB 354 KSCH=0 AB 355 NRD=0 AB 356 KG=0 AB 357 N=0 AB 358 IPRINT=0 AB 359 NCONT=0 AB 360 NLEVEL=1 AB 361 NLEVL=1 AB 362 NF=0 AB 363 DANG=0D0 AB 364 EX(1)=0D0 AB 365 FI(1)=0D0 AB 366 ID(1)=0D0 AB 367 GW(1)=1D0 AB 368 KGP(1)=0 AB 369 IPI(1)=+1 AB 370 KETA=0 AB 371 KSO=0 AB 372 KK=0 AB 373 IC=0 AB 374 KIM=2 AB 375 ES=0.0 AB 376 KIN=0 AB 377 ISTR=0 AB 378 SURF0=0D0 AB 379 SURF1=0D0 AB 380 SURF2=0D0 AB 381 DO 2 I=1,16 AB 382 2 FIN(I)=0D0 AB 383 C AB 384 DO 400 K=1,13 AB 385 400 IF(WKY.EQ.DT(K))KK=K AB 386 IF(KK.EQ.0)GO TO 200 AB 387 IF(KK.NE.12)WRITE(6,6100)TT(KK),IKY,(FKY(J),J=1,7) AB 388 6100 FORMAT(10X,A7,I3,7F10.4) AB 389 GO TO (201,202,203,205,206,207,208,209,210,211,212,213,214),KK AB 390 200 READ(5,5100,END=999)WKY,IKY,(FKY(J),J=1,7) AB 391 KK=0 AB 392 DO 300 K=1,13 AB 393 300 IF(WKY.EQ.DT(K))KK=K AB 394 IF(KK.EQ.0)GO TO 200 AB 395 IF(KK.NE.12)WRITE(6,6100)TT(KK),IKY,(FKY(J),J=1,7) AB 396 GO TO (201,202,203,205,206,207,208,209,210,211,212,213,214),KK AB 397 C AB 398 C INPUT DISPERSION PARAMETERS UNDER 'DISP'. AB 399 201 SURF0=FKY(1) AB 400 SURF1=FKY(2) AB 401 SURF2=FKY(3) AB 402 GO TO 200 AB 403 C AB 404 C MODIFY INPUT PARAMETERS USING NAMELIST. AB 405 202 GO TO 3 AB 406 C AB 407 C PRINT TRANSMISSION COEFFICIENTS AND STRENGTH FUNCTIONS. AB 408 203 KETA=IKY AB 409 IF(KETA.EQ.0)KETA=20 AB 410 GO TO 200 AB 411 C AB 412 C INPUT REAL POTENTIAL. AB 413 205 DO 305 M=1,5 AB 414 305 FIN(M)=FKY(M) AB 415 IF(FKY(6))309,200,309 AB 416 309 KSO=1 AB 417 FIN(13)=FKY(6) AB 418 FIN(15)=0D0 AB 419 FIN(16)=0D0 AB 420 GO TO 200 AB 421 C AB 422 C INPUT IMAGINARY POTENTIAL AB 423 206 KIM=IKY AB 424 DO 306 M=1,7 AB 425 MM=M+5 AB 426 306 FIN(MM)=FKY(M) AB 427 IF(FIN( 9).EQ.0D0)FIN( 9)=DABS(FIN(4)) AB 428 IF(FIN(10).EQ.0D0)FIN(10)=DABS(FIN(5)) AB 429 V=FIN(11)+FIN(12) AB 430 IF(V)200,200,406 AB 431 406 IF(KIM.EQ.2)KIM=3 AB 432 IF(KIM.EQ.4)KIM=5 AB 433 GO TO 200 AB 434 C AB 435 C INPUT SPIN-ORBIT POTENTIAL. AB 436 207 KSO=IKY AB 437 DO 307 M=1,4 AB 438 MM=M+12 AB 439 307 FIN(MM)=FKY(M) AB 440 GO TO 200 AB 441 C AB 442 C INPUT N-GAMMA REACTION AB 443 208 KG=1 AB 444 GO TO 308 AB 445 C AB 446 C INPUT CAPTURE REACTION AB 447 209 KG=-1 AB 448 308 CONTINUE AB 449 NZ=IKY AB 450 TG0=FKY(1) AB 451 BN=FKY(2) AB 452 FNUG=FKY(3) AB 453 EGD=FKY(4) AB 454 GGD=FKY(5) AB 455 SA=FKY(6) AB 456 SG=FKY(7) AB 457 IF(BN.EQ.0D0)BN=8D0 AB 458 IF(FNUG.EQ.0D0)FNUG=20D0 AB 459 NG=FNUG/2 AB 460 XFR=0.5D0 AB 461 IF(NZ)303,302,303 AB 462 302 NRD=1 AB 463 READ(5,5330)(TGG(K),K=1,16) AB 464 WRITE(6,6330)(TGG(K),K=1,16) AB 465 TG0=1D0 AB 466 IF(KG.EQ.-1)KG=1 AB 467 303 GO TO 200 AB 468 C AB 469 C INPUT FISSION COEFFICIENTS AB 470 210 NF=IKY AB 471 NF2=2*NF AB 472 DO 317 K=1,32 AB 473 TFF(K)=0D0 AB 474 317 FNF(K)=1D0 AB 475 READ(5,5330)( TFF(K),FNF(K) ,K=1,NF2) AB 476 5330 FORMAT(16F5.3) AB 477 WRITE(6,6330)( TFF(K),FNF(K) ,K=1,NF2) AB 478 6330 FORMAT(10X,16F5.3) AB 479 DO 318 K=1,NF2 AB 480 318 IF(FNF(K).EQ.0D0)FNF(K)=1D0 AB 481 GO TO 200 AB 482 C AB 483 C INPUT LEVELS AB 484 211 NLEVEL=IKY AB 485 C NLEVEL IS THE NO. OF LEVELS. AB 486 NZT=IDINT(FKY(1)) AB 487 ECONT=FKY(2) AB 488 ESTEP=FKY(3) AB 489 TAU=FKY(4) AB 490 E0T=FKY(5) AB 491 SGT=FKY(6) AB 492 MXLVL=50 AB 493 C MXLVL IS MAX. NO. OF LEVELS = 50. AB 494 IF(NZT)415,415,416 AB 495 416 NCONT=-1 AB 496 C NCONT=-1 FOR CONTINUUM,=0 FOR NO CONTINUUM. AB 497 IF(FKY(7).GT.0D0)NCONT=1 AB 498 415 NXLVL=NLEVEL-MXLVL AB 499 C NXLVL TESTS FOR EXCEEDING 50-LEVEL LIMIT, IF EXCEEDED AB 500 C NLEVEL SET TO 50 AB 501 IF(NXLVL)411,411,412 AB 502 412 WRITE(6,6060)MXLVL AB 503 6060 FORMAT(1H0,' DISCRETE TARGET LEVELS LIMITED TO',I3) AB 504 NLEVEL=MXLVL AB 505 411 CONTINUE AB 506 C DEFAULT ESTEP FOR CONTINUUM IS 0.2 MEV. AB 507 IF(ESTEP.EQ.0D0)ESTEP=0.2D0 AB 508 IF(NLEVEL.LE.0)GO TO 200 AB 509 DO 310 I=1,NLEVEL AB 510 READ(5,5050)EX(I),FI(I),IPI(I),KGP(I),GW(I) AB 511 5050 FORMAT(F9.4,F4.1,I2,I5,F5.2) AB 512 IF(IPI(I).EQ.0)IPI(I)=+1 AB 513 IF(GW(I).EQ.0.0D0)GW(I)=1.0D0 AB 514 WRITE(6,6050)EX(I),FI(I),IPI(I),KGP(I),GW(I) AB 515 6050 FORMAT(10X,F9.4,F4.1,I2,I5,F5.2) AB 516 FFI=2D0*FI(I) AB 517 ID(I)=IDINT(FFI) AB 518 310 CONTINUE AB 519 IF(NXLVL.LT.1)GO TO 200 AB 520 DO 311 I=1,NXLVL AB 521 311 READ(5,5051)B AB 522 5051 FORMAT(F9.4) AB 523 GO TO 200 AB 524 C AB 525 C INPUT SCAN AB 526 C CAN NOT BOTH SEARCH AND SCAN IN THE SAME PROBLEM. AB 527 212 IF(KSCH.NE.0)GO TO 200 AB 528 C KSC=0 INITIALLY, SET=1 FOR SCAN AB 529 KSC=1 AB 530 IF(IKY.GT.0)GO TO 114 AB 531 DO 112 I=1,7 AB 532 IF(FKY(I).LE.0D0)GO TO 113 AB 533 C KS IS THE NUMBER OF ENERGIES TO BE SCANNED AB 534 KS=KS+1 AB 535 Z(KS)=FKY(I) AB 536 112 CONTINUE AB 537 GO TO 113 AB 538 114 DO 115 I=1,50 AB 539 KS=KS+1 AB 540 Z(KS)=FKY(1)+DFLOAT(I)*FKY(2)-FKY(2) AB 541 IF((Z(KS)+FKY(2)).GT.FKY(3))GO TO 113 AB 542 115 CONTINUE AB 543 113 GO TO 200 AB 544 C AB 545 C INPUT SEARCH AB 546 213 IF(KSC.GT.0)GO TO 200 AB 547 IF(IKY)262,269,269 AB 548 262 IF(KS.GT.0)GO TO 200 AB 549 ISTR=1 AB 550 ES=FKY(1) AB 551 IF(ES.EQ.0D0)ES=1D-6 AB 552 S0EXP=FKY(2) AB 553 RPEXP=FKY(4) AB 554 IC=3 AB 555 S1EXP=FKY(6) AB 556 KSCH=-3 AB 557 GWS0=FKY(3) AB 558 GWRP=FKY(5) AB 559 GWS1=FKY(7) AB 560 9876 FORMAT(16I1,F12.6) AB 561 READ(5,9876)(KP(JJX),JJX=1,16),XTOL AB 562 IF(XTOL.GT.0.)TOL=XTOL AB 563 KMAG=5 AB 564 268 WRITE(6,6100)TT(12),IKY,(FKY(I),I=1,7) AB 565 GO TO 200 AB 566 269 IF(KSCH.EQ.0)KSCH=1 AB 567 C KSCH=1 FOR SEARCH ON TOTAL XSEC OR DIFFERENTIAL XSEC. AB 568 ISTR=0 AB 569 KS=KS+1 AB 570 IQ=IQ+1 AB 571 NQ(IQ)=0 AB 572 C IF NO TOTAL-CROSS-SECTION FITTING GO TO 221 AB 573 IF(FKY(2))221,221,222 AB 574 222 NQ(IQ)=1 AB 575 IC=IC+1 AB 576 C DEFAULT TOTAL XSEC WT. = 1.0 AB 577 IF(FKY(3).EQ.0D0)FKY(3)=1D0 AB 578 221 IF(FKY(4).NE.0D0)IPRINT=IDINT(FKY(4)) AB 579 IF(FKY(5).GT.0D0)TOL=FKY(5) AB 580 C DECODE PARAMETER SELECTION FOR FITTING AB 581 FKY(6)=FKY(6)*1D-6+1D-11 AB 582 NTO=NQ(IQ) AB 583 IQ=IQ+1 AB 584 NQ(IQ)=IKY AB 585 NOB=IKY AB 586 IQ=IQ+1 AB 587 FQ=0D0 AB 588 DO 230 I=1,10 AB 589 FKY(6)=(FKY(6)-FQ)*1D1 AB 590 KQ(I)=IDINT(FKY(6)) AB 591 230 FQ=DFLOAT(KQ(I)) AB 592 FKY(7)=FKY(7)*1D-6+1D-11 AB 593 FQ=0D0 AB 594 DO 231 I=1,10 AB 595 FKY(7)=(FKY(7)-FQ)*1D1 AB 596 II=I+10 AB 597 KQ(II)=IDINT(FKY(7)) AB 598 231 FQ=DFLOAT(KQ(II)) AB 599 KQS=0 AB 600 DO 235 I=1,16 AB 601 235 KQS=KQS+KQ(I) AB 602 C IF NO FIT PARAMETER GO TO 240, KMAG = 0 USES STATISTICAL WEIGHTS. AB 603 C IF KMAG=5 ERROR IN PERCENTAGE IS READ IN. AB 604 IF(KQS)240,240,242 AB 605 242 DO 244 I=1,16 AB 606 244 KP(I)=KQ(I) AB 607 KMAG=KQ(20) AB 608 240 CONTINUE AB 609 WRITE(6,6110)TT(12),IKY,(FKY(I),I=1,5),(KQ(I),I=1,20) AB 610 6110 FORMAT(10X,A7,I3,5F10.4,20I1) AB 611 IZLAST=IZ AB 612 C INSERT NEW DATA INTO ZBLOCK AB 613 NOC=NOB+1+NTO AB 614 IZ=IZ+NOC AB 615 C IIZ AND IIQ FOR INDEXING ON ERRORS AB 616 IIZ=IZ AB 617 IIQ=IQ AB 618 IF(NTO)180,180,181 AB 619 181 IZ=IZ+1 AB 620 IIZ=IZ AB 621 Z(IZ)=FKY(2) AB 622 180 CONTINUE AB 623 IF(NOB.LT.1)GO TO 35 AB 624 DO 30 J=1,NOB AB 625 IQ=IQ+1 AB 626 NQ(IQ)=0 AB 627 C READ INTO Z(IZ) THE ANGLES AND 7 DIFFERENTIAL XSECS (SGSCT) AB 628 READ(5,5220)A(J), SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 629 XSGSCT(5),SGSCT(6),SGSCT(7) AB 630 5220 FORMAT(8F10.4) AB 631 WRITE(6,6220)A(J), SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 632 XSGSCT(5),SGSCT(6),SGSCT(7) AB 633 6220 FORMAT(10X,8F10.4) AB 634 DO 251 K=1,7 AB 635 L=8-K AB 636 IF(SGSCT(L))251,251,250 AB 637 250 NQ(IQ)=L AB 638 GO TO 252 AB 639 251 CONTINUE AB 640 252 L=NQ(IQ) AB 641 IF(L.LE.0)GO TO 253 AB 642 DO 238 K=1,L AB 643 IQ=IQ+1 AB 644 NQ(IQ)=0 AB 645 IF(SGSCT(K))238,238,236 AB 646 236 NQ(IQ)=1 AB 647 IZ=IZ+1 AB 648 Z(IZ)=SGSCT(K) AB 649 IC=IC+1 AB 650 238 CONTINUE AB 651 253 CONTINUE AB 652 30 CONTINUE AB 653 C READ IN PERCENTAGE ERRORS. AB 654 IF(KMAG.NE.5)GO TO 35 AB 655 DO 530 J=1,NOB AB 656 IIQ=IIQ+1 AB 657 READ(5,5220)BB, SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 658 XSGSCT(5),SGSCT(6),SGSCT(7) AB 659 WRITE(6,6220)BB, SGSCT(1),SGSCT(2),SGSCT(3),SGSCT(4), AB 660 XSGSCT(5),SGSCT(6),SGSCT(7) AB 661 LL=NQ(IIQ) AB 662 IF(LL.LE.0)GO TO 5253 AB 663 DO 5238 K=1,LL AB 664 IIQ=IIQ+1 AB 665 IF(SGSCT(K))5238,5238,5236 AB 666 5236 IIZ=IIZ+1 AB 667 ZZ(IIZ)=SGSCT(K) AB 668 5238 CONTINUE AB 669 5253 CONTINUE AB 670 530 CONTINUE AB 671 35 CONTINUE AB 672 C PUSH OLD DATA FORWARD IN IN ZBLOCK AB 673 ILONG=IZLAST-NOCTOT AB 674 IF(ILONG.LT.1)GO TO 194 AB 675 DO 187 I=1,ILONG AB 676 J=IZLAST+1-I AB 677 JJ=J+NOC AB 678 Z(JJ)=Z(J) AB 679 ZZ(JJ)=ZZ(J) AB 680 187 CONTINUE AB 681 C INSERT NEW ENERGY, TOTAL WEIGHT, ANGLES INTO ZBLOCK AB 682 194 I=NOCTOT+1 AB 683 Z(I)=FKY(1) AB 684 IF(NTO)188,188,189 AB 685 189 I=I+1 AB 686 Z(I)=FKY(3) AB 687 188 IF(NOB)190,190,191 AB 688 191 DO 192 J=1,NOB AB 689 I=I+1 AB 690 192 Z(I)=A(J) AB 691 190 CONTINUE AB 692 NOCTOT=NOCTOT+NOC AB 693 GO TO 200 AB 694 C AB 695 C INPUT COMPUTE AB 696 214 LMAX=IKY AB 697 C LMAX IS LIMIT ON L, DEFUALT=0 FOR INTERNAL DETERMINATION AB 698 C E=ENERGY, ANO=TARGET MASS,ANU=PROJECTILE MASS(DEFAULT=NEUT) AB 699 C FNU FOR CORRECTION, DEFAULT PAM CALCULATION,= NEGATIVE FOR AB 700 C SIMPLE H-F CALCULATION(I.E., NO WFC) AB 701 C DANG IS ANGULAR STEPS, DEFAULT=15 DEG. AB 702 C MATCHING RADIUS, DEFAULT=15 FM AB 703 C PTS=INTEGRATION MESH, DEFAULT=301 AB 704 E=FKY(1) AB 705 ANO=FKY(2) AB 706 ANU=FKY(3) AB 707 FNU=FKY(4) AB 708 DANG=FKY(5) AB 709 C1=FKY(6) AB 710 PTS=FKY(7) AB 711 C FORCE DEFAULT VALUES FOR TEST CALCULATIONS AB 712 IF(E.EQ.0D0)E=0.8D0 AB 713 IF(ANO.EQ.0D0)ANO=55.9349D0 AB 714 IF(ANU.EQ.0D0)ANU=1.008665D0 AB 715 IF(DANG.EQ.0D0)DANG=15D0 AB 716 IF(C1.EQ.0D0)C1=15D0 AB 717 IF(KS.GT.0)GO TO 220 AB 718 KS=1 AB 719 C E GOES TO Z(1) AB 720 Z(1)=E AB 721 220 CONTINUE AB 722 IF(VRE.NE.0D0)GO TO 217 AB 723 VRE=46.0 AB 724 R1=1.317 AB 725 A1=0.62 AB 726 217 IF(VSR.GT.0D0)GO TO 218 AB 727 KSO=1 AB 728 VSR=7.0 AB 729 RR1=1.317 AB 730 AA1=0.62 AB 731 218 IF(VIM.GT.0D0)GO TO 216 AB 732 KIM=4 AB 733 VIM=14.0 AB 734 R2=1.447 AB 735 A2=0.25 AB 736 216 CONTINUE AB 737 GO TO 316 AB 738 3 READ(5,INPUT) AB 739 316 CONTINUE AB 740 IF(IQ.LE.NQB)GO TO 160 AB 741 C CHECK TO INSURE THAT SEARCH HAS NOT EXCEEDED STORAGE AB 742 IQ=NQB-IQ AB 743 WRITE(6,6300)NQB,IQ AB 744 6300 FORMAT(1H0/' FOR THE SEARCH OPTION THE NUMBER OF ENERGIES * ((NO. AB 745 XOF LEVELS + 1) * NO. OF ANGLES + 3) IS LIMITED TO',I6,'.'/' THIS NAB 746 XUMBER IS EXCEEDED IN THIS INPUT BY',I6) AB 747 STOP AB 748 160 CONTINUE AB 749 IF(KSCH.EQ.0)NOCTOT=KS AB 750 C IF NO CONTINUUM CONTRIBUTIONS AB 751 IF(NLEVEL.EQ.0)NLEVEL=1 AB 752 C SETS ECONT TO EX OF LAST LEVEL AB 753 IF(ECONT.EQ.0D0)ECONT=EX(NLEVEL) AB 754 J1=1 AB 755 J2=J1+NOCTOT AB 756 IF(PTS)50,50,51 AB 757 C SETS INTEGRATION MESH KPT TO DEFAULT 301 OR INPUT VALUE AB 758 50 KPT=301 AB 759 GO TO 52 AB 760 51 KPT=INT(PTS) AB 761 52 CONTINUE AB 762 FF1=FI(1) AB 763 C FF1=GRND. STATE SPIN AB 764 C NGP=KGP=GROUP NUMBER, IF=0 GO TO DEFAULT VALUES. AB 765 R(1)=ANU/ANO AB 766 NGP=KGP(1) AB 767 IF(NGP)76,75,76 AB 768 75 DO 78 I=1,NLEVEL AB 769 78 KGP(I)=I AB 770 76 CONTINUE AB 771 WRITE(6,6001)ANO,ANU,C1,KPT AB 772 6001 FORMAT(1H0///' MASS NUMBERS(TARGET/PROJECTILE) =',F10.6,'/',F9.6/ AB 773 X' ============'// AB 774 X ' OPTICAL MODEL PARAMETERS :',10X,'ASYMPTOPIA=',F8.4,' FM',I15, AB 775 X' POINTS'/' ========================'//' TYPE',7X,'DEPTH',6X, AB 776 X'(E)',6X,'(E*E)',6X,'RADIUS',5X,'DIFF.',3X,'VIVOL',7X,'C2', AB 777 X4X,'VOLINT'/) AB 778 TTEMP=((DACOS(-1D0))*FIN(5))/(FIN(4)*(ANO**0.33333)) AB 779 REALVL=((4*(DACOS(-1D0))*(FIN(4)**3))/3)*(1+TTEMP**2) AB 780 REALVL=FIN(1)*REALVL AB 781 RWW=FIN(9)*(ANO**0.33333) AB 782 TTEMW=(((DACOS(-1D0))*FIN(10))/RWW)**2 AB 783 AGVAL=16*(DACOS(-1D0))*(RWW**2)*FIN(6)*FIN(10)/ANO AB 784 AGVAL=AGVAL*(1+0.333333*TTEMW) AB 785 C END OF VOLUME-INTEGRAL GENERATION AB 786 IF(KIM.NE.4)AGVAL=0D0 AB 787 C SETS R AND A FOR S-O EQUAL TO THAT OF V-R IF THAT OPTION IS USED. AB 788 RS=FIN(15) AB 789 AS=FIN(16) AB 790 IF(RS.EQ.0D0)RS=R1 AB 791 IF(AS.EQ.0D0)AS=A1 AB 792 C PRINTS INITIAL WELL PARAMETERS AB 793 WRITE(6,6101)(FIN(I),I=1,5),REALVL AB 794 WRITE(6,6102)KIM,(FIN(I),I=6,12),AGVAL AB 795 WRITE(6,6103)KSO,(FIN(I),I=13,14),RS,AS AB 796 WRITE(6,6104)SURF0,SURF1,SURF2 AB 797 6101 FORMAT(' REAL 1',5F10.4,20X,1F10.4) AB 798 6102 FORMAT(' IMAG',I5,8F10.4) AB 799 6103 FORMAT(' S.O.',I5,2F10.4,10X,2F10.4) AB 800 6104 FORMAT(' DISP',5X,3F10.4) AB 801 IF((KG.EQ.0).AND.(NCONT.EQ.0))GO TO 328 AB 802 IF(NZ.EQ.0)NZ=NZT AB 803 IF(NZ)312,312,314 AB 804 312 NDEF=1 AB 805 NZ=-NZ AB 806 GO TO 326 AB 807 314 NDEF=0 AB 808 326 AND=DINT(ANO) AB 809 IF(ANO-AND-0.5D0)320,322,322 AB 810 320 NA=AND+1D0 AB 811 GO TO 324 AB 812 322 NA=AND+2D0 AB 813 324 NN=NA-NZ AB 814 NZN=NZ*NN AB 815 AZ=DFLOAT(NZN) AB 816 328 CONTINUE AB 817 IF(KSCH.EQ.0)GO TO 130 AB 818 KIN=0 AB 819 DO 100 I=1,16 AB 820 IF(KP(I).LE.0)GO TO 100 AB 821 KIN=KIN+1 AB 822 VIN(KIN)=FIN(I) AB 823 100 CONTINUE AB 824 IF(KIN.EQ.0)GO TO 131 AB 825 WRITE(6,6003)KIN AB 826 6003 FORMAT(1H0/25X,' SEARCH FOR',I3,' PARAMETERS') AB 827 IF(KMAG-1)101,103,103 AB 828 101 WRITE(6,6005) AB 829 GO TO 104 AB 830 103 WRITE(6,6006) AB 831 104 CONTINUE AB 832 6005 FORMAT(1H+,13X,' CHI-SQUARE') AB 833 6006 FORMAT(1H+,' NORMALIZED LEAST SQUARE') AB 834 L=0 AB 835 N=NOCTOT AB 836 IQ=0 AB 837 IF(KSCH.GT.0)GO TO 330 AB 838 C CHANGES FOR PRINTOUT AND *1D-4 IN STR FN SEARCH AB 839 WRITE(6,6080)ES,S0EXP,GWS0 AB 840 6080 FORMAT(1H0,' AT LAB ENERGY =',F12.8/' S-WAVE STRENGTH FN. ='AB 841 X,F8.4,'D-4 WEIGHT =',F10.4) AB 842 S0EXP=S0EXP*(1D-4) AB 843 WRITE(6,6081)RPEXP,GWRP AB 844 6081 FORMAT(' R - PRIME =',F8.4,' FM WEIGHT =', AB 845 XF10.4) AB 846 WRITE(6,6082)S1EXP,GWS1 AB 847 6082 FORMAT(' P-WAVE STRENGTH FN. =',F8.4,'D-4 WEIGHT =', AB 848 XF10.4) AB 849 S1EXP=S1EXP*(1D-4) AB 850 330 continue AB 851 DO 140 K=1,KS AB 852 IQ=IQ+1 AB 853 L=L+1 AB 854 ECM=Z(L)/(1+R(1)) AB 855 IF(ISTR.EQ.0)WRITE(6,6090)Z(L),ECM AB 856 6090 FORMAT(1H0, ' AT LAB/CM ENERGY =',F10.6,'/',F9.6,' MEV') AB 857 IF(NQ(IQ))139,139,141 AB 858 141 L=L+1 AB 859 N=N+1 AB 860 WRITE(6,6095)Z(N),Z(L) AB 861 6095 FORMAT(1H0,' TOTAL CROSS SECTION DATA',F12.6,' WEIGHT=', AB 862 XF10.4) AB 863 139 CONTINUE AB 864 IQ=IQ+1 AB 865 NOB=NQ(IQ) AB 866 IF(NOB.GT.0)WRITE(6,6097) AB 867 6097 FORMAT(1H0,' SCATTERING DATA'//4X,'ANGLE',5X,'CROSS SECTION DATAB 868 XA FOR SUCCESSIVE LEVEL GROUPS'/) AB 869 IQ=IQ+1 AB 870 NLEVL=1 AB 871 IF(NLEVEL.LT.2)GO TO 3007 AB 872 DO 3010 I=2,NLEVEL AB 873 IF(EX(I).GE.ECM)GO TO 3010 AB 874 R(I)=R(1)*DSQRT(ECM/(ECM-EX(I))) AB 875 IF(R(I).LT.1D0)NLEVL=I AB 876 3010 CONTINUE AB 877 3007 CONTINUE AB 878 IF(NGP)3013,3014,3018 AB 879 3013 NQ(IQ)=1 AB 880 GO TO 3017 AB 881 3014 NQ(IQ)=NLEVL AB 882 GO TO 3017 AB 883 3018 DO 3015 I=1,NLEVL AB 884 J=NLEVL-I+1 AB 885 IF(KGP(J))3015,3015,3016 AB 886 3015 CONTINUE AB 887 3016 NQ(IQ)=IABS(KGP(J)) AB 888 3017 CONTINUE AB 889 IF(NOB.LT.1)GO TO 140 AB 890 DO 142 J=1,NOB AB 891 IQ=IQ+1 AB 892 L=L+1 AB 893 NOM=NQ(IQ) AB 894 MXLVL=0 AB 895 DO 144 I=1,NOM AB 896 IQ=IQ+1 AB 897 SGSCT(I)=0D0 AB 898 IF(NQ(IQ))144,144,143 AB 899 143 N=N+1 AB 900 MXLVL=I AB 901 SGSCT(I)=Z(N) AB 902 144 CONTINUE AB 903 IF(MXLVL.LE.0)GO TO 142 AB 904 WRITE(6,6004)Z(L),(SGSCT(I),I=1,MXLVL) AB 905 6004 FORMAT(1H ,F8.2,7F10.5) AB 906 142 CONTINUE AB 907 140 CONTINUE AB 908 LWA=(KIN+1)*IC+5*KIN AB 909 J3=J2+IC AB 910 J4=J3+IC AB 911 J5=J4+LWA+4+8*KPT AB 912 IF(J5.LE.NZB)GO TO 170 AB 913 J5=NZB-J5 AB 914 WRITE(6,6200)J5 AB 915 6200 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA BY',I6,' REAL*8AB 916 X LOCATIONS.') AB 917 STOP AB 918 170 CONTINUE AB 919 NIT=0 AB 920 KETA=0 AB 921 IF(IPRINT)175,176,175 AB 922 175 IPRINT=1 AB 923 KETA=-1 AB 924 WRITE(6,6010) AB 925 6010 FORMAT(1H1,'GENERATED OPTICAL MODEL PARAMETERS IN SEARCH :',62X, AB 926 X'STATISTIC'//) AB 927 176 IXDUM=IC AB 928 CALL LMDIF1(FCN,IXDUM,KIN,VIN,Z(J3),TOL,INFO,IWA,Z(J4),LWA) AB 929 IC=IXDUM AB 930 WRITE(6,6500)NIT AB 931 6500 FORMAT(1H0,' SEARCH TERMINATED AFTER',I5,' CALLS') AB 932 GO TO (501,501,501,504,505,506,506),INFO AB 933 WRITE(6,6550) AB 934 GO TO 510 AB 935 501 WRITE(6,6551)INFO AB 936 GO TO 510 AB 937 504 WRITE(6,6554) AB 938 GO TO 510 AB 939 505 WRITE(6,6555) AB 940 GO TO 510 AB 941 506 WRITE(6,6556)INFO AB 942 510 CONTINUE AB 943 6550 FORMAT(1H+,37X,'DUE TO IMPROPER INPUT PARAMETERS (INFO=0)') AB 944 6551 FORMAT(1H+,37X,'UPON CONVERGENCE (INFO=',I1,')') AB 945 6554 FORMAT(1H+,36X,'. PARAMETER VECTOR ORTHOGONAL TO JACOBIAN COLUMNS.AB 946 X') AB 947 6555 FORMAT(1H+,36X,'. LIMIT OF ALLOWED CALLS.') AB 948 6556 FORMAT(1H+,36X,'. TOL IS TOO SMALL (INFO=',I1,')') AB 949 KIN=0 AB 950 DO 150 I=1,16 AB 951 IF(KP(I).LE.0)GO TO 150 AB 952 KIN=KIN+1 AB 953 FIN(I)=VIN(KIN) AB 954 150 CONTINUE AB 955 131 KETA=0 AB 956 130 CONTINUE AB 957 J5=J2+4+8*KPT AB 958 KIN=0 AB 959 CALL FCN(0,0,C,D,IFLAG) AB 960 GO TO 1 AB 961 999 STOP AB 962 END AB 963 C **********************************************************************AB 964 SUBROUTINE FCN(MI,NI,FOP,U,IFLAG) AB 965 IMPLICIT REAL*8(A-H,O-Z) AB 966 INTEGER*2 NQ AB 967 COMMON AB 968 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32),RPEXP,AB 969 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, AB 970 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,ES,GWS0,GWRP,GWS1, AB 971 XS0EXP,S1EXP,ID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0, AB 972 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,ISTR AB 973 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB AB 974 COMMON /COMN/FIN(16),X(20),W(20),KP(16) AB 975 COMMON/ZBLOCK/Z(24000) AB 976 COMMON/ZZBLOC/ZZ(10000) AB 977 COMMON/QBLOCK/NQ(7600) AB 978 COMMON/ASUR/SURF0,SURF1,SURF2 AB 979 DIMENSION TPP(20),TMP(20),FOP(1),U(1),AIN(16),MM(50),KD(50,100), AB 980 XLLMX(50) AB 981 KSTOP=0 AB 982 IP=1 AB 983 IZ=0 AB 984 IM=-1 AB 985 NIT=NIT+1 AB 986 NO=0 AB 987 DO 400 I=1,16 AB 988 IF(KIN.LE.0)GO TO 410 AB 989 IF(KP(I))410,410,420 AB 990 420 NO=NO+1 AB 991 GO TO(430,431,431,430,430,430,431,431),I AB 992 430 AIN(I)=DABS(FOP(NO)) AB 993 GO TO 400 AB 994 431 AIN(I)=FOP(NO) AB 995 GO TO 400 AB 996 410 AIN(I)=FIN(I) AB 997 400 CONTINUE AB 998 IF(KETA.LT.0)WRITE(6,6100)(FOP(I),I=1,NO) AB 999 6100 FORMAT(5D12.4) AB 1000 490 CONTINUE AB 1001 KISCH=KIN AB 1002 IF(KSCH.NE.0)KISCH=KISCH+1 AB 1003 C KISCH=1 : SEARCH TERMINATED AB 1004 IF(KISCH.NE.1)GO TO 495 AB 1005 WRITE(6,6001) AB 1006 6001 FORMAT(1H1,' FINAL OPTICAL MODEL PARAMETERS :'/' ================AB 1007 X================' //' TYPE',7X,'DEPTH',6X, AB 1008 X'(E)',6X,'(E*E)',6X,'RADIUS',5X,'DIFF.',3X,'VIVOL',7X,'C2', AB 1009 X4X,'VOLINT'/) AB 1010 TTEMP=((DACOS(-1D0))*AIN(5))/(AIN(4)*(ANO**0.33333)) AB 1011 REALVL=((4*(DACOS(-1D0))*(AIN(4)**3))/3)*(1+TTEMP**2) AB 1012 REALVL=AIN(1)*REALVL AB 1013 RWW=AIN(9)*(ANO**0.33333) AB 1014 TTEMW=(((DACOS(-1D0))*AIN(10))/RWW)**2 AB 1015 AGVAL=16*(DACOS(-1D0))*(RWW**2)*AIN(6)*AIN(10)/ANO AB 1016 AGVAL=AGVAL*(1+0.333333*TTEMW) AB 1017 IF(KIM.NE.4)AGVAL=0D0 AB 1018 RS=AIN(15) AB 1019 AS=AIN(16) AB 1020 IF(RS.EQ.0D0)RS=AIN(4) AB 1021 IF(AS.EQ.0D0)AS=AIN(5) AB 1022 WRITE(6,6101)(AIN(I),I=1,5),REALVL AB 1023 WRITE(6,6102)KIM,(AIN(I),I=6,12),AGVAL AB 1024 WRITE(6,6103)KSO,(AIN(I),I=13,14),RS,AS AB 1025 6101 FORMAT(' REAL 1',5F10.4,20X,1F10.4) AB 1026 6102 FORMAT(' IMAG',I5,8F10.4) AB 1027 6103 FORMAT(' S.O.',I5,2F10.4,10X,2F10.4//) AB 1028 495 CONTINUE AB 1029 NJ2=J2-1 AB 1030 NJ3=0 AB 1031 CHISQ=0D0 AB 1032 NC=0 AB 1033 IF(NCONT.EQ.0)GO TO 3096 AB 1034 IF(TAU.GT.0D0)GO TO 3120 AB 1035 NNT=NN-1 AB 1036 NAT=NA-1 AB 1037 AAT=DFLOAT(NAT) AB 1038 CALL PRSL(NZ,NNT,PRT,SCT) AB 1039 UXT=2.5D0+150D0/AAT AB 1040 EXT=UXT+PRT AB 1041 SAT=(0.00917D0*SCT+0.142D0-0.022D0*NDEF)*AAT AB 1042 E0T=DSQRT(SAT*UXT) AB 1043 TAU=DSQRT(SAT/UXT)-1.5D0/UXT AB 1044 ATAU=DABS(TAU) AB 1045 IF(ATAU-1D-50)3097,3097,3098 AB 1046 3097 NCONT =0 AB 1047 GO TO 3096 AB 1048 3098 TAU=1D0/TAU AB 1049 SGSQT=0.1776D0*E0T*AAT**0.6667D0 AB 1050 SGT=DSQRT(SGSQT/2D0) AB 1051 E0T=DEXP(2D0*E0T)/(16.97056D0*UXT*SGT*DSQRT(E0T)) AB 1052 E0T=EXT-TAU*DLOG(TAU*E0T) AB 1053 3120 SGSQT=2D0*SGT*SGT AB 1054 RHO=(ECONT-E0T)/TAU AB 1055 RHO=DEXP(RHO)/TAU AB 1056 3096 CONTINUE AB 1057 NCNT=NCONT AB 1058 UX=1 AB 1059 IF(KG)3077,3076,3077 AB 1060 3077 IF(NRD.EQ.1)GO TO 3075 AB 1061 IF(EGD)3330,3332,3334 AB 1062 3332 EGD=163D0*DSQRT(AZ)/(NA**1.3333) AB 1063 GO TO 3334 AB 1064 3330 IF(TG0.EQ.0D0)GO TO 3332 AB 1065 KGD=0 AB 1066 GO TO 3335 AB 1067 3334 KGD=1 AB 1068 IF(GGD.LE.0D0)GGD=5D0 AB 1069 3335 CALL PRSL(NZ,NN,PR,SC) AB 1070 KOPG=0 AB 1071 IF(TG0.LT.0)KOPG=1 AB 1072 AA=DFLOAT(NA) AB 1073 H=5.0571D0*AA**0.33333 AB 1074 UX=2.5D0+150D0/AA AB 1075 EXX=UX+PR AB 1076 SSA=SA AB 1077 IF(SSA.GT.0)GO TO 3331 AB 1078 SA=(0.00917D0*SC+0.142D0-0.022D0*NDEF)*AA AB 1079 3331 CONTINUE AB 1080 SGSQ=SG*SG*2D0 AB 1081 IF(SG.EQ.0D0)SGSQ=0.1776D0*DSQRT(SA*UX)*AA**0.66667D0 AB 1082 SIGMA=SGSQ/2D0 AB 1083 SIGMA=DSQRT(SIGMA) AB 1084 ATG0=DABS(TG0) AB 1085 IF(KISCH.GT.1)GO TO 3076 AB 1086 WRITE(6,6311)NA,NZ,NN,BN,FNUG,SIGMA AB 1087 IF(NDEF.EQ.1)WRITE(6,6312) AB 1088 IF(TG0.EQ.0D0)GO TO 3336 AB 1089 WRITE(6,6313)ATG0 AB 1090 3336 CONTINUE AB 1091 IF(KGD.EQ.0)WRITE(6,6314) AB 1092 IF(KGD.EQ.1)WRITE(6,6315)EGD,GGD,XFR AB 1093 IF(KG.GE.0)GO TO 3076 AB 1094 IF(KOPG.LE.0)WRITE(6,6321) AB 1095 IF(KOPG.GT.0)WRITE(6,6322) AB 1096 GO TO 3076 AB 1097 3075 WRITE(6,6316)(TGG(K),K=1,16) AB 1098 3076 CONTINUE AB 1099 6311 FORMAT(1H0/' RADIATIVE CAPTURE INTO COMPOUND NUCLEUS'/ AB 1100 X' =======================================' AB 1101 X //' A=',I3,AB 1102 X' Z=',I3,' N=',I3,5X,F9.3,' MEV NEUTRON BINDING',5X,F6.2,' RADIAB 1103 XATIVE D. OF F.',5X,'SIGMA=',F6.3) AB 1104 6312 FORMAT(1H+,90X,'DEFORMED') AB 1105 6313 FORMAT(1H0,' NORMALIZED TO SLOW S-WAVE NEUTRON GAMMA WIDTHS/SPACIAB 1106 XNGS =',E12.4) AB 1107 6314 FORMAT(1H0,' E1 STRONG COUPLING MODEL') AB 1108 6315 FORMAT(1H0,' E1 GIANT RESONANCE AT ',F7.2,' MEV WIDTH=',F7.2, AB 1109 X' MEV',5X,'EXCHANGE FRACTION=',F4.2) AB 1110 6316 FORMAT(1H0,' GAMMA TRANSMISSION FACTORS(COMPOUND ANG. MOM.) WERE AB 1111 XREAD IN AS'//(8F10.6)) AB 1112 6321 FORMAT(1H0,' BLACK NUCLEUS SECOND CHANCE NEUTRON CHANNELS') AB 1113 6322 FORMAT(1H0,' OPTICAL MODEL SECOND CHANCE NEUTRON CHANNELS') AB 1114 IQ=0 AB 1115 IF(KSCH)140,141,141 AB 1116 140 KSH=KSCH AB 1117 IF(KISCH.EQ.1)WRITE(6,6400)ES AB 1118 6400 FORMAT(1H0,20X,'AT',D12.4,' MEV',8X,'L',5X,'J',6X,'GAMMASQ/D',5X, AB 1119 X'R-INFINITY',6X,'STR.FN.',8X,'R-PRIME') AB 1120 CALL ABACUS(1,ES,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,1,1,J5,J6,J7,KSH) AB 1121 IF(KSH.EQ.-10)GO TO 142 AB 1122 IF(KISCH.EQ.1)GO TO 141 AB 1123 NJ3=1 AB 1124 U(NJ3)=(Z(J5)-S0EXP)*100./(GWS0*S0EXP) AB 1125 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1126 NJ5=J5+1 AB 1127 NJ3=2 AB 1128 U(NJ3)=(Z(NJ5)-RPEXP)*100./(GWRP*RPEXP) AB 1129 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1130 NJ5=NJ5+1 AB 1131 NJ3=3 AB 1132 U(NJ3)=(Z(NJ5)-S1EXP)*100./(GWS1*S1EXP) AB 1133 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1134 141 CONTINUE AB 1135 IF(ISTR.NE.0)GO TO 501 AB 1136 DO 500 KK=1,KS AB 1137 IQ=IQ+1 AB 1138 NTO=NQ(IQ) AB 1139 IQ=IQ+1 AB 1140 NOA=NQ(IQ) AB 1141 IQ=IQ+1 AB 1142 NCONT=NCNT AB 1143 NC=NC+1 AB 1144 ECM=Z(NC)/(1D0+R(1)) AB 1145 FLMB=DSQRT(Z(NC)*ANU)/(1D0+R(1)) AB 1146 FLMB=0.457208D0/FLMB AB 1147 IF((ECONT+ESTEP).GE.ECM)NCONT=0 AB 1148 FFNU=FNU AB 1149 IF(NCONT.NE.0)FFNU=-1D0 AB 1150 NLEVL=1 AB 1151 IF(NLEVEL.LT.2)GO TO 3007 AB 1152 DO 3010 I=2,NLEVEL AB 1153 IF(EX(I).GE.ECM)GO TO 3010 AB 1154 R(I)=R(1)*DSQRT(ECM/(ECM-EX(I))) AB 1155 IF(R(I).LT.1D0)NLEVL=I AB 1156 3010 CONTINUE AB 1157 3007 CONTINUE AB 1158 IF(KISCH.GT.1)GO TO 3094 AB 1159 IF(KSC.GT.0)WRITE(6,6300) AB 1160 6300 FORMAT(1H1) AB 1161 IF(KSCH.NE.0)WRITE(6,6303) AB 1162 6303 FORMAT(1H0//) AB 1163 WRITE(6,6301)KK,Z(NC),ECM,FLMB AB 1164 6301 FORMAT(1H0,'NO.',I2,' ENERGY(LABORATORY/C.M.) =',F10.6,'/',F9.6 AB 1165 X,' MEV',10X,'LAMBDA-BAR =',F9.5,' SQRT-BARN'/' ============') AB 1166 IF(ECM.LT.1D-3)WRITE(6,6331)Z(NC),ECM AB 1167 6331 FORMAT(1H+,32X,D10.3,'/',D10.3) AB 1168 IF(FFNU)3089,3091,3092 AB 1169 3089 WRITE(6,6309) AB 1170 6309 FORMAT(1H0,'NO WIDTH FLUCTUATION CORRECTION') AB 1171 GO TO 3093 AB 1172 3091 WRITE(6,6310) AB 1173 WRITE(6,6319) AB 1174 GO TO 3093 AB 1175 3092 WRITE(6,6310) AB 1176 WRITE(6,6318)FFNU AB 1177 6319 FORMAT(1H+,53X,'ARE COMPUTED INTERNALLY.') AB 1178 6318 FORMAT(1H+,53X,'= ',F5.2) AB 1179 6310 FORMAT(1H0,'NEUTRON CHANNEL WIDTH FLUCTUATION DEGREES OF FREEDOM')AB 1180 3093 CONTINUE AB 1181 WRITE(6,6404) AB 1182 6404 FORMAT(1H0/15X,'TARGET LEVELS'/15X,'============='// AB 1183 X ' LEVEL GROUP ENERGY SPIN PARITY WEIGHT'/) AB 1184 WRITE(6,6302)( I,KGP(I),EX(I),FI(I),IPI(I),GW(I) ,I=1,NLEVL) AB 1185 6302 FORMAT(2I6,F10.4,F7.1,I6,F12.2) AB 1186 IF(NCONT.NE.0)WRITE(6,6308) ECONT,TAU,E0T,SGT,ECONT,RHO AB 1187 6308 FORMAT(1H0/' TARGET LEVEL CONTINUUM STARTS AT',F6.2,' MEV'//' AB 1188 XLEVEL DENSITY PARAMETERS: TEMP. =',F7.3,' MEV',5X,'E0 =',F8.3, AB 1189 X' MEV',5X,'SIGMA =',F8.3//' AT',F7.2,' MEV, COMPUTED TOTAL LEVELAB 1190 X DENSITY =',F8.2,'/MEV') AB 1191 IF(NCONT.GT.0)WRITE(6,6307) AB 1192 IF(NCONT.LT.0)WRITE(6,6306) AB 1193 6306 FORMAT(1H0,' OPTICAL MODEL CONTINUUM CHANNELS') AB 1194 6307 FORMAT(1H0,' BLACK NUCLEUS CONTINUUM CHANNELS') AB 1195 3094 CONTINUE AB 1196 FLMBR=FLMB *FLMB AB 1197 FNUHF=FFNU/2D0 AB 1198 LLMXMX=0 AB 1199 JJ7=0 AB 1200 DO 10 I=1,NLEVL AB 1201 EN=ECM-EX(I) AB 1202 LMXC=LMAX AB 1203 CALL ABACUS(I,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KETA,LMXC,J5,J6,J7AB 1204 X,JJ7) AB 1205 IF(JJ7.EQ.-10)GO TO 142 AB 1206 LLMX(I)=LMXC+1 AB 1207 IF(LLMX(I).GT.LLMXMX)LLMXMX=LLMX(I) AB 1208 10 CONTINUE AB 1209 LLMAX=LLMX(1) AB 1210 LMX=LLMAX-1 AB 1211 J8=JJ7 AB 1212 DO 18 I=1,NLEVL AB 1213 NJ8=J8+I-1 AB 1214 18 Z(NJ8)=0D0 AB 1215 FFF=FF1+0.5 AB 1216 NFF=IDINT(FFF) AB 1217 NJMIN=MAX0(1,NFF-LMX) AB 1218 NJMAX=NFF+LMX AB 1219 IT=MOD(ID(1),2) AB 1220 F0=DFLOAT(IT+1)/2D0 AB 1221 FJMIN=DFLOAT(NJMIN)-F0 AB 1222 FJMAX=DFLOAT(NJMAX)+F0 AB 1223 IF(KIN.LE.0)WRITE(6,6020)LMX,FJMIN,FJMAX AB 1224 6020 FORMAT(1H0,' MAXIMUM NEUTRON L VALUE,(RANGE OF TOTAL J VALUES) =',AB 1225 XI3,', (',F5.1,',',F5.1,')') AB 1226 J9=J8+NLEVL AB 1227 J10=J9+NLEVL AB 1228 J11=J10+2*LLMXMX AB 1229 J12=J11+2*LLMXMX AB 1230 KN=J12-1 AB 1231 DO 50 I=1,NLEVL AB 1232 DO 50 K=1,LLMAX AB 1233 KN=KN+1 AB 1234 50 Z(KN)=0D0 AB 1235 J13=KN+1 AB 1236 IDSUM=0 AB 1237 DO 49 I=1,NLEVL AB 1238 49 IDSUM=IDSUM+ID(I)+1 AB 1239 J14=J13+IDSUM AB 1240 J15=J14+IDSUM AB 1241 J16=J15+IDSUM AB 1242 J17=J16+IDSUM AB 1243 IF(J17.LE.NZB)GO TO 46 AB 1244 J17=NZB-J17 AB 1245 WRITE(6,6250)J17 AB 1246 6250 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA AND DISCRETE NEAB 1247 XUTRON CHANNELS BY',I6,' REAL*8 LOCATIONS.') AB 1248 STOP AB 1249 46 CONTINUE AB 1250 IF((KG.EQ.0).OR.(NRD.EQ.1))GO TO 91 AB 1251 TX=SA/UX AB 1252 TX=DSQRT(TX)-3D0/(2D0*UX) AB 1253 TX=1D0/TX AB 1254 AUX=SA*UX AB 1255 E0=DSQRT(AUX) AB 1256 E02=2D0*E0 AB 1257 E0=DEXP(E02)/(12D0*DSQRT(E0*SGSQ)*UX) AB 1258 E0=TX*E0 AB 1259 E0=EXX-TX*DLOG(E0) AB 1260 IF(TG0)84,82,84 AB 1261 84 ROJ=0D0 AB 1262 CALL GAMMAS(BN,0D0,E0,EXX,TX,SA,PR,H,KGD,EGD,GGD,TEMP) AB 1263 N1=ID(1)-1 AB 1264 N1=IABS(N1) AB 1265 N2=ID(1)+1 AB 1266 DO 80 I=N1,N2,2 AB 1267 N3=I-2 AB 1268 N3=IABS(N3) AB 1269 N4=I+2 AB 1270 DO 80 J=N3,N4,2 AB 1271 DEX=-(J+1)*(J+1)/(SGSQ*4D0) AB 1272 80 ROJ=ROJ+DEXP(DEX)*(J+1)/SGSQ AB 1273 CTG=ATG0/(TEMP*ROJ) AB 1274 GO TO 86 AB 1275 82 CTG=3.3D-06*NN*NZ*GGD*(1D0+0.8D0*XFR)/NA AB 1276 86 CONTINUE AB 1277 IF(KG)71,91,72 AB 1278 71 CALL GAMCAP(H,AIN,TG,TGB,J17,J18,J19,J20,KOPG) AB 1279 GO TO 75 AB 1280 72 CALL GAMMAS(BN,ECM,E0,EXX,TX,SA,PR,H,KGD,EGD,GGD,TG) AB 1281 75 CONTINUE AB 1282 TG1=TG*CTG AB 1283 IF(KG.LT.0)GO TO 92 AB 1284 91 J20=J17 AB 1285 92 IF(NCONT.EQ.0)GO TO 12 AB 1286 LMXC=IDINT(0.22D0*DSQRT(ECM-ECONT)*C1)+2 AB 1287 LLMAXC=LMXC+1 AB 1288 NCSPMX=NJMAX+LMXC-IT+1 AB 1289 LLMXC=2*LMXC+1 AB 1290 LLMXCP=LLMXC+1 AB 1291 J21=J20+LLMXC AB 1292 NTCON=LLMXCP*NCSPMX AB 1293 J22=J21+NTCON-1 AB 1294 IF(J22.LE.NZB)GO TO 26 AB 1295 J22=NZB-J22 AB 1296 WRITE(6,6260)J22 AB 1297 6260 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY CONTINUOUS NEUTRON CHANNELSAB 1298 X AND ALL OTHER REQUIREMENTS BY',I6,' REAL*8 LOCATIONS.') AB 1299 STOP AB 1300 26 CONTINUE AB 1301 DO 20 K=1,NTCON AB 1302 J=J21+K-1 AB 1303 20 Z(J)=0D0 AB 1304 ESTP=ESTEP AB 1305 ECN=ECONT AB 1306 ITW=-1 AB 1307 IF(NCONT.LT.0)ITW=0 AB 1308 14 IF(ECM-ECN)12,12,11 AB 1309 11 IF(ECM-ECN-ESTEP)13,17,17 AB 1310 13 ESTP=ECM-ECN AB 1311 17 CEX=ECN+ESTP/2D0 AB 1312 EN=ECM-CEX AB 1313 DO 19 K=1,LLMXC AB 1314 J=J20+K-1 AB 1315 19 Z(J)=0D0 AB 1316 LM=0D0 AB 1317 CALL ABACUS(ITW,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,IZ,LM,J5,JA,J20,AB 1318 XJB) AB 1319 LLM=2*LM+1 AB 1320 LLM=MIN0(LLM,LLMXC) AB 1321 DO 15 K=1,NCSPMX AB 1322 KB=IT+2*(K-1) AB 1323 FK=DFLOAT(KB+1) AB 1324 DO 15 J=1,LLM AB 1325 NJ20=J20+J-1 AB 1326 NJ21=J21+(K-1)*LLMXCP+J-1 AB 1327 Z(NJ21)=Z(NJ21)+ESTP*FK*Z(NJ20)*DEXP((CEX-E0T)/TAU-0.25D0*FK*FK/ AB 1328 XSGSQT)/(TAU*SGSQT) AB 1329 15 CONTINUE AB 1330 ECN=ECN+ESTEP AB 1331 GO TO 14 AB 1332 12 CONTINUE AB 1333 SGST=0D0 AB 1334 SGCT=0D0 AB 1335 SGGM=0D0 AB 1336 SGCP=0D0 AB 1337 SGFI=0D0 AB 1338 SGLP=0D0 AB 1339 SGCR=0D0 AB 1340 JJJ=0 AB 1341 IF((FNUHF.EQ.0.0).AND.(KETA.GT.0))WRITE(6,6040) AB 1342 6040 FORMAT(1H0,'TRANSMISSION COEFFS. T AND WIDTH FLUCTUATION DEGREES AB 1343 XOF FREEDOM NU FOR TOTAL ANG. MOM. J AND PARITIES (+) AND (-)'//' AB 1344 X2*J LEVEL CHANNEL',5X,'T(+)',11X,'NU(+)',10X,'T(-)',11X,'NU(-)'/AB 1345 X) AB 1346 C TOTAL ANGULAR MOMENTUM J JD=2*J AB 1347 DO 103 NJ=NJMIN,NJMAX AB 1348 JD=2*NJ-IT-1 AB 1349 JJJ=JJJ+1 AB 1350 JJM=2*JJJ AB 1351 JJP=JJM-1 AB 1352 G=(JD+1)/(4D0*FF1+2D0) AB 1353 TPS=0D0 AB 1354 TMS=0D0 AB 1355 DO 150 J=1,20 AB 1356 TPP(J)=1D0 AB 1357 TMP(J)=1D0 AB 1358 150 CONTINUE AB 1359 SGS=0D0 AB 1360 SGC=0D0 AB 1361 NJ7=J7 AB 1362 NJ130=J13-1 AB 1363 NJ140=J14-1 AB 1364 NJ150=J15-1 AB 1365 NJ160=J16-1 AB 1366 DO 200 I=1,NLEVL AB 1367 NKI=2*LLMX(I)-1 AB 1368 MM(I)=0 AB 1369 N=1 AB 1370 JID=JD-ID(I) AB 1371 NKMIN=(1+IABS(JID))/2 AB 1372 NKMAX=(1+JD+ID(I))/2 AB 1373 NKMAX=MIN0(NKMAX,LLMAX) AB 1374 IF(NKMAX-NKMIN)210,220,220 AB 1375 210 IF(I-1)103,103,215 AB 1376 C SELECTION OF PROJECTILE ORBITAL AND TOTAL ANGULAR MOMENTA AB 1377 220 DO 300 NK=NKMIN,NKMAX AB 1378 NKMOD=MOD(NK,2) AB 1379 JPLS=2*NK-NKMOD AB 1380 JMNS=2*NK+NKMOD-1 AB 1381 NJ71=NJ7+JPLS-1 AB 1382 NJ72=NJ7+JMNS-1 AB 1383 ZNJ71=0D0 AB 1384 ZNJ72=0D0 AB 1385 IF(JPLS.LE.NKI)ZNJ71=Z(NJ71) AB 1386 IF(JMNS.LE.NKI)ZNJ72=Z(NJ72) AB 1387 KD(I,N)=2*NK-1 AB 1388 IF(I-1)230,230,240 AB 1389 230 CONTINUE AB 1390 NJ51=J5+JPLS-1 AB 1391 NJ61=J6+JPLS-1 AB 1392 NJ52=J5+JMNS-1 AB 1393 NJ62=J6+JMNS-1 AB 1394 ZNJ51=0D0 AB 1395 ZNJ52=0D0 AB 1396 ZNJ61=0D0 AB 1397 ZNJ62=0D0 AB 1398 IF(JPLS.GT.NKI)GO TO 231 AB 1399 ZNJ51=Z(NJ51)*Z(NJ51) AB 1400 ZNJ61=Z(NJ61)*Z(NJ61) AB 1401 231 IF(JMNS.GT.NKI)GO TO 232 AB 1402 ZNJ52=Z(NJ52)*Z(NJ52) AB 1403 ZNJ62=Z(NJ62)*Z(NJ62) AB 1404 232 CONTINUE AB 1405 SGS=SGS+4D0*(ZNJ51+ZNJ61+ZNJ52+ZNJ62) AB 1406 SGC=SGC+ZNJ71+ZNJ72 AB 1407 240 CONTINUE AB 1408 NJ130=NJ130+1 AB 1409 NJ140=NJ140+1 AB 1410 NJ150=NJ150+1 AB 1411 NJ160=NJ160+1 AB 1412 IF(IPI(I))320,310,310 AB 1413 310 Z(NJ130)=ZNJ71 AB 1414 Z(NJ140)=ZNJ72 AB 1415 GO TO 330 AB 1416 320 Z(NJ130)=ZNJ72 AB 1417 Z(NJ140)=ZNJ71 AB 1418 330 TPS=TPS+Z(NJ130) AB 1419 TMS=TMS+Z(NJ140) AB 1420 Z(NJ150)=FNUHF AB 1421 Z(NJ160)=FNUHF AB 1422 300 N=N+1 AB 1423 MM(I)=N-1 AB 1424 215 NJ7=NJ7+NKI AB 1425 200 CONTINUE AB 1426 IF(KG)61,60,61 AB 1427 61 IF(NRD.EQ.1)GO TO 59 AB 1428 NJ18=J18+NJ-NJMIN AB 1429 NJ19=J19+NJ-NJMIN AB 1430 ROJ=0D0 AB 1431 N1=JD-2 AB 1432 N1=IABS(N1) AB 1433 N2=JD+2 AB 1434 DO 65 J=N1,N2,2 AB 1435 DEX=-(J+1)*(J+1)/(SGSQ*4D0) AB 1436 65 ROJ=ROJ+DEXP(DEX)*(J+1)/SGSQ AB 1437 TG=6.2832*TG1*ROJ AB 1438 IF(KG.GT.0)GO TO 63 AB 1439 TGB1=6.2832*TGB*ROJ AB 1440 TCAP=Z(NJ18)+TGB1 AB 1441 TCAM=Z(NJ19)+TGB1 AB 1442 TCAP=TCAP*CTG AB 1443 TCAM=TCAM*CTG AB 1444 GO TO 63 AB 1445 59 TG=TGG(JJJ) AB 1446 63 TPS=TPS+TG AB 1447 TMS=TMS+TG AB 1448 60 CONTINUE AB 1449 IF(NF)66,66,67 AB 1450 67 TFP=TFF(JJP) AB 1451 TFM=TFF(JJM) AB 1452 FNP=FNF(JJP)/2 AB 1453 FNM=FNF(JJM)/2 AB 1454 TPS=TPS+TFP AB 1455 TMS=TMS+TFM AB 1456 66 CONTINUE AB 1457 IF(NCONT.EQ.0)GO TO 120 AB 1458 TCO=0D0 AB 1459 DO 122 K=1,NCSPMX AB 1460 NJ21=J21+(K-1)*LLMXCP AB 1461 KB=IT+2*(K-1) AB 1462 KID=JD-KB AB 1463 NKMIN=(1+IABS(KID))/2 AB 1464 NKMAX=(1+JD+KB)/2 AB 1465 NKMAX=MIN0(NKMAX,LLMAXC) AB 1466 IF(NKMAX.LT.NKMIN)GO TO 122 AB 1467 DO 123 NK=NKMIN,NKMAX AB 1468 JPLS=2*NK AB 1469 JMNS=JPLS-1 AB 1470 MJ21=NJ21+JPLS-1 AB 1471 KJ21=NJ21+JMNS-1 AB 1472 TCO=TCO+(Z(MJ21)+Z(KJ21)) AB 1473 123 CONTINUE AB 1474 122 CONTINUE AB 1475 TCO=TCO*0.5 AB 1476 TPS=TPS+TCO AB 1477 TMS=TMS+TCO AB 1478 120 CONTINUE AB 1479 SGST=SGST+G*SGS AB 1480 SGCT=SGCT+G*SGC AB 1481 IF(TPS.LE.1D-50)TPS=1D-50 AB 1482 TPS=1D0/TPS AB 1483 IF(TMS.LE.1D-50)TMS=1D-50 AB 1484 TMS=1D0/TMS AB 1485 IF(FNUHF)851,852,853 AB 1486 852 CALL FLUCT(JD,KETA,J13,J14,J15,J16,NLEVL,MM,TPS,TMS) AB 1487 853 DO 850 J=1,20 AB 1488 NJ130=J13-1 AB 1489 NJ140=J14-1 AB 1490 NJ150=J15-1 AB 1491 NJ160=J16-1 AB 1492 DO 800 K=1,NLEVL AB 1493 MMI=MM(K) AB 1494 IF(MMI)800,800,805 AB 1495 805 DO 799 I=1,MMI AB 1496 NJ130=NJ130+1 AB 1497 NJ140=NJ140+1 AB 1498 NJ150=NJ150+1 AB 1499 NJ160=NJ160+1 AB 1500 TPP(J)=TPP(J)*(1D0+X(J)*Z(NJ130)*TPS/Z(NJ150))**Z(NJ150) AB 1501 TMP(J)=TMP(J)*(1D0+X(J)*Z(NJ140)*TMS/Z(NJ160))**Z(NJ160) AB 1502 799 CONTINUE AB 1503 800 CONTINUE AB 1504 FFP=1D0 AB 1505 FFM=1D0 AB 1506 IF(KG)802,801,802 AB 1507 802 FP=1D0+X(J)*TG*TPS/NG AB 1508 FM=1D0+X(J)*TG*TMS/NG AB 1509 DO 810 II=1,NG AB 1510 FFP=FFP*FP AB 1511 810 FFM=FFM*FM AB 1512 801 TPP(J)=FFP*TPP(J) AB 1513 TMP(J)=FFM*TMP(J) AB 1514 IF(NF)850,850,840 AB 1515 840 IF(TFP.GT.0D0)TPP(J)=TPP(J)*(1D0+X(J)*TFP*TPS/FNP)**FNP AB 1516 IF(TFM.GT.0D0)TMP(J)=TMP(J)*(1D0+X(J)*TFM*TMS/FNM)**FNM AB 1517 850 CONTINUE AB 1518 851 CONTINUE AB 1519 C PROJECTILE TOTAL ANG. MOM. K1D=2*J(1), K2D=2*J(2) AB 1520 MM1=MM(1) AB 1521 KJ130=J13-1 AB 1522 KJ140=J14-1 AB 1523 KJ150=J15-1 AB 1524 KJ160=J16-1 AB 1525 DO 102 K1=1,MM1 AB 1526 KJ130=KJ130+1 AB 1527 KJ140=KJ140+1 AB 1528 KJ150=KJ150+1 AB 1529 KJ160=KJ160+1 AB 1530 K1D=KD(1,K1) AB 1531 IF(KG.EQ.0)GO TO 906 AB 1532 IF(FNUHF.LT.0D0)GO TO 907 AB 1533 GP=0D0 AB 1534 GM=0D0 AB 1535 DO 905 J=1,20 AB 1536 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1537 X*(1D0+X(J)*TG*TPS/NG)) AB 1538 905 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1539 X*(1D0+X(J)*TG*TMS/NG)) AB 1540 GO TO 908 AB 1541 907 GP=1D0 AB 1542 GM=1D0 AB 1543 908 CONTINUE AB 1544 TEP=Z(KJ130)*GP*TPS+Z(KJ140)*GM*TMS AB 1545 SGGM=SGGM+TEP*TG*G AB 1546 IF(KG.LT.0)SGCP=SGCP+Z(KJ130)*GP*TPS*TCAP*G+Z(KJ140)*GM*TMS*TCAM*GAB 1547 906 CONTINUE AB 1548 IF(NF.LE.0)GO TO 916 AB 1549 IF(FNUHF.LT.0D0)GO TO 917 AB 1550 GP=0D0 AB 1551 GM=0D0 AB 1552 DO 915 J=1,20 AB 1553 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1554 X*(1D0+X(J)*TFP*TPS/FNP)) AB 1555 915 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1556 X*(1D0+X(J)*TFM*TMS/FNM)) AB 1557 GO TO 918 AB 1558 917 GP=1D0 AB 1559 GM=1D0 AB 1560 918 TEP=Z(KJ130)*TFP*GP*TPS+Z(KJ140)*TFM*GM*TMS AB 1561 SGFI=SGFI+TEP*G AB 1562 916 CONTINUE AB 1563 IF(NCONT.NE.0)SGLP=SGLP+TCO*G*(Z(KJ130)*TPS+Z(KJ140)*TMS) AB 1564 NJ12=J12 AB 1565 NJ130=J13-1 AB 1566 NJ140=J14-1 AB 1567 NJ150=J15-1 AB 1568 NJ160=J16-1 AB 1569 DO 102 I=1,NLEVL AB 1570 NJ8=J8+I-1 AB 1571 MMI=MM(I) AB 1572 IF(MMI)102,102,904 AB 1573 904 DO 101 K2=1,MMI AB 1574 NJ130=NJ130+1 AB 1575 NJ140=NJ140+1 AB 1576 NJ150=NJ150+1 AB 1577 NJ160=NJ160+1 AB 1578 K2D=KD(I,K2) AB 1579 GP=1D0 AB 1580 GM=1D0 AB 1581 IF(FNUHF.LT.0D0)GO TO 910 AB 1582 GP=0D0 AB 1583 GM=0D0 AB 1584 DO 900 J=1,20 AB 1585 GP=GP+W(J)/(TPP(J)*(1D0+X(J)*Z(KJ130)*TPS/Z(KJ150)) AB 1586 X*(1D0+X(J)*Z(NJ130)*TPS/Z(NJ150))) AB 1587 GM=GM+W(J)/(TMP(J)*(1D0+X(J)*Z(KJ140)*TMS/Z(KJ160)) AB 1588 X*(1D0+X(J)*Z(NJ140)*TMS/Z(NJ160))) AB 1589 900 CONTINUE AB 1590 IF(I.NE.1)GO TO 910 AB 1591 IF(NJ130.EQ.KJ130)GP=GP*(1D0+Z(KJ150))/Z(KJ150) AB 1592 IF(NJ140.EQ.KJ140)GM=GM*(1D0+Z(KJ160))/Z(KJ160) AB 1593 C COMPUND ELASTIC IS DOUBLED WHEN CONTINUUM LEVELS ARE SPECIFIED. AB 1594 C SGCR IS RESULTING COMPOUND EXCESS. ALL COMPOUND CROSS XSECS AB 1595 C REDUCED PROPORTIONALLY TO OFFSET SGCR. AB 1596 910 TEPP=Z(KJ130)*Z(NJ130)*GP*TPS*G AB 1597 TEPM=Z(KJ140)*Z(NJ140)*GM*TMS*G AB 1598 IF(NCONT.EQ.0)GO TO 930 AB 1599 IF(NJ130.NE.KJ130)GO TO 931 AB 1600 SGCR=SGCR+TEPP AB 1601 TEPP=2D0*TEPP AB 1602 931 CONTINUE AB 1603 IF(NJ140.NE.KJ140)GO TO 930 AB 1604 SGCR=SGCR+TEPM AB 1605 TEPM=2D0*TEPM AB 1606 930 CONTINUE AB 1607 TEP=TEPP+TEPM AB 1608 TEMP=(K1D+1)*(K2D+1)*(JD+1)*(JD+1)*TEP/G AB 1609 Z(NJ8)=Z(NJ8)+TEP AB 1610 IF(KISCH)110,110,111 AB 1611 110 IF(DANG.LT.0D0)GO TO 101 AB 1612 GO TO 112 AB 1613 111 IF(NOA.EQ.0)GO TO 101 AB 1614 112 CONTINUE AB 1615 MJ12=NJ12-1 AB 1616 DO 100 NLL=1,LLMAX AB 1617 MJ12=MJ12+1 AB 1618 LLD=4*(NLL-1) AB 1619 TEM=TEMP*(LLD+1) AB 1620 W1=THRJ(K1D,K1D,LLD,IP,IM,IZ)*SIXJ(K1D,K1D,LLD,JD,JD,ID(1)) AB 1621 W1=W1*THRJ(K2D,K2D,LLD,IP,IM,IZ)*SIXJ(K2D,K2D,LLD,JD,JD,ID(I)) AB 1622 W1=W1*TEM AB 1623 Z(MJ12)=Z(MJ12)-W1 AB 1624 IF(ID(1).EQ.0)GO TO 100 AB 1625 IF(I.GT.1)GO TO 100 AB 1626 IF(K2.EQ.K1)GO TO 100 AB 1627 W2=THRJ(K2D,K1D,LLD,IP,IM,IZ)*SIXJ(K2D,K1D,LLD,JD,JD,ID(1)) AB 1628 W2=W2*W2*TEM AB 1629 Z(MJ12)=Z(MJ12)-W2 AB 1630 100 CONTINUE AB 1631 101 CONTINUE AB 1632 NJ12=NJ12+LLMAX AB 1633 102 CONTINUE AB 1634 103 CONTINUE AB 1635 SGST=3.141592D0*FLMBR*SGST AB 1636 SGCT=3.141592D0*FLMBR*SGCT AB 1637 C CORRED IS REDUCTION DUE TO SGCR AB 1638 CORRED=1D0 AB 1639 IF(NCONT.EQ.0)GO TO 530 AB 1640 SGCR=3.141592D0*FLMBR*SGCR AB 1641 CORRED=SGCT/(SGCR+SGCT) AB 1642 530 CONTINUE AB 1643 SGTT=SGST+SGCT AB 1644 COEFF=3.141592D0*FLMBR*CORRED AB 1645 IF(KG.NE.0)SGGM=SGGM*COEFF AB 1646 IF(KG.LT.0)SGCP=SGCP*COEFF AB 1647 IF(NF.GT.0)SGFI=SGFI*COEFF AB 1648 IF(NCONT.NE.0)SGLP=SGLP*COEFF AB 1649 J80=J8+NLEVL-1 AB 1650 SGSM=SGGM+SGFI+SGLP AB 1651 DO 510 I=J8,J80 AB 1652 Z(I)=Z(I)*COEFF AB 1653 510 SGSM=SGSM+Z(I) AB 1654 SGET=SGST+Z(J8) AB 1655 IF(KIN)34,34,35 AB 1656 34 NNL=MIN0(NLEVL,10) AB 1657 J81=J8+NNL-1 AB 1658 IF(SGTT-999.9999D0)37,37,38 AB 1659 37 WRITE(6,6006)SGTT,SGCT,SGST,SGET,(Z(I),I=J8,J81) AB 1660 GO TO 39 AB 1661 38 WRITE(6,6007)SGTT,SGCT,SGST,SGET,(Z(I),I=J8,J81) AB 1662 39 CONTINUE AB 1663 J82=J8+10 AB 1664 J83=J8+NLEVL-1 AB 1665 IF(NLEVL.GT.10)WRITE(6,6009)(Z(I),I=J82,J83) AB 1666 6009 FORMAT(1H ,22X,10F9.5) AB 1667 IF(NCONT.NE.0)WRITE(6,6011)SGLP AB 1668 6011 FORMAT(1H ,' CONTINUUM LEVELS =',F9.5) AB 1669 IF(KG.NE.0)WRITE(6,6008)SGGM AB 1670 IF(KG.LT.0)WRITE(6,6010)SGCP AB 1671 IF(NF.GT.0)WRITE(6,6012)SGFI AB 1672 WRITE(6,6013)SGSM AB 1673 6006 FORMAT(1H0/' INTEGRATED CROSS SECTIONS IN BARNS'/ AB 1674 X' ==================================' //16X,'TOTAL ='AB 1675 X, F9.5/11X,'ABSORPTION =', F9.5/8X,'SHAPE ELASTIC =', F9.5/8X,'TOTAB 1676 XAL ELASTIC =', F9.5/' COMPOUND EXCITATIONS =',10F9.5) AB 1677 6007 FORMAT(1H0/' INTEGRATED CROSS SECTIONS IN BARNS'/ AB 1678 X' ==================================' //16X,'TOTAL ='AB 1679 X,D12.5/11X,'ABSORPTION =',D12.5/8X,'SHAPE ELASTIC =',D12.5/8X,'TOTAB 1680 XAL ELASTIC =',D12.5/' COMPOUND EXCITATIONS =',10F9.5) AB 1681 6008 FORMAT(1H ,' N-GAMMA =',F9.5) AB 1682 6010 FORMAT(1H ,' RADIATIVE CAPTURE =',F9.5) AB 1683 6012 FORMAT(1H ,' FISSION =',F9.5) AB 1684 6013 FORMAT(1H ,' TOTAL COMPOUND =',F9.5) AB 1685 36 CONTINUE AB 1686 IF((KSCH.NE.0).AND.(NTO.GT.0))NC=NC+1 AB 1687 GO TO 520 AB 1688 35 IF(NTO)520,520,31 AB 1689 31 NJ2=NJ2+1 AB 1690 NJ3=NJ3+1 AB 1691 NC=NC+1 AB 1692 C ERROR WEIGHTING ON CROSS SECTION AB 1693 IF(KMAG.NE.5)GO TO 5900 AB 1694 U(NJ3)=((SGTT-Z(NJ2))*100*Z(NC))/Z(NJ2) AB 1695 GO TO 5901 AB 1696 5900 U(NJ3)=(SGTT-Z(NJ2))*DSQRT(Z(NC)/Z(NJ2)) AB 1697 5901 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1698 520 FF=FLMBR/(8*(ID(1)+1)) AB 1699 NJ12=J12 AB 1700 DO 700 I=1,NLEVL AB 1701 NSGN=+1 AB 1702 IC=ID(I)-ID(1) AB 1703 IF(MOD(IC,4).EQ.0)NSGN=-1 AB 1704 DO 600 NLL=1,LLMAX AB 1705 MJ12=NJ12+NLL-1 AB 1706 Z(MJ12)=FF*Z(MJ12)*NSGN AB 1707 600 CONTINUE AB 1708 NJ12=NJ12+LLMAX AB 1709 700 CONTINUE AB 1710 C ANGULAR DISTRIBUTION Y=LAB ANGLE Z=COS(C.M. ANGLE) AB 1711 IF(KISCH)130,130,131 AB 1712 130 IF(DANG.LT.0D0)GO TO 2000 AB 1713 GO TO 132 AB 1714 131 IF(NOA.EQ.0)GO TO 2000 AB 1715 132 CONTINUE AB 1716 IF(KIN)625,625,630 AB 1717 625 WRITE(6,6050) AB 1718 6050 FORMAT(1H0/' LABORATORY CROSS SECTION IN BARNS PER STERADIAN'/ AB 1719 X ' ==============================================='/) AB 1720 WRITE(6,6052) AB 1721 6052 FORMAT(1H ,' ANGLE S.E. C.E. LEVEL GROUP CROSS SECTIAB 1722 XONS'/) AB 1723 IF(KSCH.NE.0)GO TO 630 AB 1724 NANG=1+180D0/DANG AB 1725 GO TO 635 AB 1726 630 NANG=NOA AB 1727 635 FRANG=DATAN(1D0)/45D0 AB 1728 DO 1000 M=1,NANG AB 1729 IQ=IQ+1 AB 1730 IF(KSCH)650,640,650 AB 1731 640 Y=(M-1)*DANG AB 1732 GO TO 660 AB 1733 650 NC=NC+1 AB 1734 Y=Z(NC) AB 1735 660 CONTINUE AB 1736 NJ12=J12 AB 1737 DO 1020 I=1,NLEVL AB 1738 NJ9=J9+I-1 AB 1739 RR=R(I) AB 1740 CALL CMC(Y,RR,FRANG,F,LMX,I,J10,J11) AB 1741 IF(I.GT.1)GO TO 1017 AB 1742 AR=Z(J5) AB 1743 AI=Z(J6) AB 1744 BR=0D0 AB 1745 BI=0D0 AB 1746 L=0 AB 1747 DO 1050 L=1,LMX AB 1748 K=L+1 AB 1749 NJ10=J10+L AB 1750 NJ11=J11+L AB 1751 NJ51=J5+2*L-1 AB 1752 NJ52=NJ51+1 AB 1753 NJ61=J6+2*L-1 AB 1754 NJ62=NJ61+1 AB 1755 AR=AR+Z(NJ10)*((L+1)*Z(NJ52)+L*Z(NJ51)) AB 1756 AI=AI+Z(NJ10)*((L+1)*Z(NJ62)+L*Z(NJ61)) AB 1757 BR=BR+Z(NJ11)*(Z(NJ52)-Z(NJ51)) AB 1758 BI=BI+Z(NJ11)*(Z(NJ62)-Z(NJ61)) AB 1759 1050 CONTINUE AB 1760 SGSE=FLMBR*(AR*AR+AI*AI+BR*BR+BI*BI)*F AB 1761 1017 CONTINUE AB 1762 Z(NJ9)=0D0 AB 1763 DO 1030 N=1,LLMAX AB 1764 MJ12=NJ12+N-1 AB 1765 NJ10=J10-1+2*N-1 AB 1766 Z(NJ9)=Z(NJ9)+Z(NJ10)*Z(MJ12) AB 1767 1030 CONTINUE AB 1768 Z(NJ9)=Z(NJ9)*F*CORRED AB 1769 NJ12=NJ12+LLMAX AB 1770 1020 CONTINUE AB 1771 SIG3=Z(J9) AB 1772 Z(J9)=Z(J9)+SGSE AB 1773 IF(KGP(1).LT.0)Z(J9)=SGSE AB 1774 I=J9-1 AB 1775 ILVL=0 AB 1776 DO 51 K=1,NLEVL AB 1777 NJ9=J9+K-1 AB 1778 IF(KGP(K))51,51,52 AB 1779 52 J=K-1 AB 1780 KGPM=KGP(J) AB 1781 IF(K.EQ.1)KGPM=0 AB 1782 IF(KGP(K)-KGPM)53,53,54 AB 1783 53 Z(I)=Z(I)+Z(NJ9) AB 1784 GO TO 51 AB 1785 54 I=I+1 AB 1786 Z(I)=Z(NJ9) AB 1787 ILVL=ILVL+1 AB 1788 GW(ILVL)=GW(K) AB 1789 51 CONTINUE AB 1790 IF(KIN)40,40,41 AB 1791 40 NL=MIN0(ILVL,9) AB 1792 J90=J9+NL-1 AB 1793 WRITE(6,6200)Y,SGSE,SIG3,(Z(I),I=J9,J90) AB 1794 6200 FORMAT(1H ,F8.2,11F10.5) AB 1795 IF(ILVL.LE.9)GO TO 47 AB 1796 J91=J9+9 AB 1797 J92=J9+ILVL-1 AB 1798 IF(ILVL.GT.9) WRITE(6,6220)(Z(I),I=J91,J92) AB 1799 6220 FORMAT(39X,8F10.5) AB 1800 47 CONTINUE AB 1801 43 CONTINUE AB 1802 41 NOM=NQ(IQ) AB 1803 IF(KIN)44,44,48 AB 1804 44 IQ=IQ+NOM AB 1805 GO TO 1000 AB 1806 48 DO 42 I=1,NOM AB 1807 IQ=IQ+1 AB 1808 NJ9=J9+I-1 AB 1809 IF(NQ(IQ))42,42,45 AB 1810 45 NJ2=NJ2+1 AB 1811 NJ3=NJ3+1 AB 1812 C ZZ(NJ2)IS THE ERROR IN PERCENT FOR POINT Z(NJ2) AB 1813 IF(KMAG.NE.5)GO TO 24 AB 1814 U(NJ3)=((Z(NJ9)-Z(NJ2))*GW(I)*100)/(ZZ(NJ2)*Z(NJ2)) AB 1815 GO TO 5903 AB 1816 24 U(NJ3)=(Z(NJ9)-Z(NJ2))*DSQRT(GW(I)/Z(NJ2)) AB 1817 5903 CHISQ=CHISQ+U(NJ3)*U(NJ3) AB 1818 42 CONTINUE AB 1819 1000 CONTINUE AB 1820 2000 CONTINUE AB 1821 NCONT=NCNT AB 1822 500 CONTINUE AB 1823 501 CONTINUE AB 1824 IF(KETA.LT.0)WRITE(6,6110)CHISQ AB 1825 6110 FORMAT(100X,F17.6) AB 1826 IF(KSTOP.EQ.1)GO TO 3000 AB 1827 SA=SSA AB 1828 RETURN AB 1829 142 IF(KISCH.LE.1)GO TO 144 AB 1830 DO 145 IU=2,MI AB 1831 145 U(IU)=1D10 AB 1832 RETURN AB 1833 144 WRITE(6,6500) AB 1834 6500 FORMAT(1H0,' VIMAG NONPOSITIVE - EXECUTION TERMINATES.') AB 1835 3000 STOP AB 1836 END AB 1837 C **********************************************************************AB 1838 SUBROUTINE ABACUS(N,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KETA,LMAX,J5AB 1839 X,J6,J7,JJ7) AB 1840 IMPLICIT REAL*8 (A-H,O-Z) AB 1841 COMPLEX*16 DEX,RTL AB 1842 COMMON/ASUR/SURF0,SURF1,SURF2 AB 1843 COMMON/ZBLOCK/Z(24000) AB 1844 DIMENSION FJ(21),FN(21),AIN(1) AB 1845 C S0,RPRP AND S1 INITIALIZED FOR SEARCH ON STR-FN. AB 1846 S0=0D0 AB 1847 RPRP=0D0 AB 1848 S1=0D0 AB 1849 KR=J5-4-8*KPT AB 1850 KI=KR+KPT AB 1851 KS=KI+KPT AB 1852 KX=KS+KPT AB 1853 KREP=KX+KPT-1 AB 1854 KIMP=KREP+KPT+1 AB 1855 KREM=KIMP+KPT+1 AB 1856 KIMM=KREM+KPT+1 AB 1857 IF(LMAX.EQ.0)LMAX=IDINT(0.22D0*DSQRT(EN)*C1)+3 AB 1858 NOC=2*LMAX+1 AB 1859 IF(N-1)5,6,7 AB 1860 6 J6=J5+NOC AB 1861 J7=J6+NOC AB 1862 IF(JJ7.GE.0)JJ7=J7 AB 1863 NJ5=J5 AB 1864 NJ6=J6 AB 1865 7 NJ7=JJ7 AB 1866 GO TO 8 AB 1867 5 NJ7=J7 AB 1868 JJ7=J7 AB 1869 8 CONTINUE AB 1870 KPM=KPT-1 AB 1871 KPHF=KPM/2 AB 1872 A1=AIN(5) AB 1873 A2=AIN(10) AB 1874 C2=AIN(12) AB 1875 RQ1=AIN(15) AB 1876 AQ1=AIN(16) AB 1877 IF(RQ1.EQ.0D0)RQ1=AIN(4) AB 1878 IF(AQ1.EQ.0D0)AQ1=AIN(5) AB 1879 OT=1D0/3D0 AB 1880 CRA=ANO**OT AB 1881 P1=AIN(4)*CRA AB 1882 P2=AIN(9)*CRA AB 1883 PP1=RQ1*CRA AB 1884 ARED=ANO/(ANO+ANU) AB 1885 IF(KIM.EQ.1) C2=1. AB 1886 DELTAR=C1/KPM AB 1887 VREM=1.D60 AB 1888 VIMM=1.D60 AB 1889 KIM2=MOD(KIM,2) AB 1890 ENA=DABS(EN) AB 1891 CAPK=0.218719D0*DSQRT(ANU*ARED*ENA) AB 1892 C VALUE OF SURFF CALCULATED FROM INPUT QUADRATIC DISP VALUES AB 1893 SURFF=SURF0+EN*(SURF1+SURF2*EN) AB 1894 VREAL=AIN(1)+EN*(AIN(2)+AIN(3)*EN) AB 1895 IF(DABS(VREAL).LT.1D-5)VREAL=1D-5 AB 1896 IF(N.LT.0)GO TO 350 AB 1897 VIMAG=AIN(6)+EN*(AIN(7)+AIN(8)*EN) AB 1898 IF(VIMAG.GE.1D-5)GO TO 13 AB 1899 JJ7=-10 AB 1900 RETURN AB 1901 13 CONTINUE AB 1902 IF(AIN(11).EQ.0.0)GO TO 26 AB 1903 VIV=AIN(11)+EN*(AIN(7)+AIN(8)*EN) AB 1904 VIMAG=VIV+VIMAG AB 1905 C2=VIV/VIMAG AB 1906 26 IF(VREAL.EQ.VREM) GO TO 40 AB 1907 VREM=VREAL AB 1908 R=0. AB 1909 DO 30 I=1,KPT AB 1910 JR=KR+I-1 AB 1911 EX=(R-P1)/A1 AB 1912 IF(EX.LT.64D0)GO TO 28 AB 1913 Z(JR)=0D0 AB 1914 GO TO 30 AB 1915 28 IF(EX.GT.-64D0)GO TO 29 AB 1916 Z(JR)=-VREAL AB 1917 GO TO 30 AB 1918 29 Z(JR)=-VREAL/(DEXP(EX)+1D0) AB 1919 30 R=R+DELTAR AB 1920 R=0D0 AB 1921 GO TO(39,35,37),KSO AB 1922 DO 32 I=2,KPT AB 1923 JS=KS+I-1 AB 1924 32 Z(JS)=0D0 AB 1925 GO TO 40 AB 1926 39 ZS=2.D0/AQ1 AB 1927 DO 34 I=2,KPT AB 1928 JS=KS+I-1 AB 1929 R=R+DELTAR AB 1930 EX=(R-PP1)/AQ1 AB 1931 IF(EX.LT.32D0.AND.EX.GT.-32D0) GO TO 33 AB 1932 Z(JS)=0D0 AB 1933 GO TO 34 AB 1934 33 VSRM=1D0/(DEXP(EX)+1D0) AB 1935 Z(JS)=VSRM*(1D0-VSRM)*ZS/R AB 1936 34 CONTINUE AB 1937 GO TO 40 AB 1938 35 DO 36 I=2,KPT AB 1939 JR=KR+I-1 AB 1940 JS=KS+I-1 AB 1941 36 Z(JS)=-Z(JR)/VREAL AB 1942 GO TO 40 AB 1943 37 ZS=2.D0/A1 AB 1944 DO 38 I=2,KPT AB 1945 JR=KR+I-1 AB 1946 JS=KS+I-1 AB 1947 R=R+DELTAR AB 1948 ZR=-Z(JR)/VREAL AB 1949 38 Z(JS)=(ZR-ZR*ZR)*ZS/R AB 1950 40 CONTINUE AB 1951 IF(VIMAG.EQ.VIMM) GO TO 55 AB 1952 VIMM=VIMAG AB 1953 DO 41 I=1,KPT AB 1954 JI=KI+I-1 AB 1955 41 Z(JI)=0D0 AB 1956 IF(KIM.EQ.0) GO TO 55 AB 1957 R=0. AB 1958 KQ=0 AB 1959 IF(A2.LE.0.) GO TO 42 AB 1960 IF(A2.NE.A1.OR.P2.NE.P1) KQ=1 AB 1961 42 IF(KIM2.EQ.0) GO TO 48 AB 1962 ZS=C2*VIMAG AB 1963 IF(KQ.EQ.0) GO TO 45 AB 1964 DO 44 I=1,KPT AB 1965 JI=KI+I-1 AB 1966 EX=(R-P2)/A2 AB 1967 IF(EX.GE.64D0) GO TO 44 AB 1968 IF(EX.GT.-64D0) GO TO 43 AB 1969 Z(JI)=-ZS AB 1970 GO TO 44 AB 1971 43 Z(JI)=-ZS/(DEXP(EX)+1D0) AB 1972 44 R=R+DELTAR AB 1973 GO TO 47 AB 1974 45 ZS=ZS/VREAL AB 1975 DO 46 I=1,KPT AB 1976 JR=KR+I-1 AB 1977 JI=KI+I-1 AB 1978 46 Z(JI)=ZS*Z(JR) AB 1979 47 IF(KIM.EQ.1) GO TO 55 AB 1980 48 ZS=C2*VIMAG-VIMAG AB 1981 IF(KIM.GT.3) GO TO 50 AB 1982 R=0. AB 1983 DO 49 I=1,KPT AB 1984 JI=KI+I-1 AB 1985 EX=(R-P2)/A2 AB 1986 EX=EX*EX AB 1987 IF(EX.LT.100.) Z(JI)=Z(JI)+ZS*DEXP(-EX) AB 1988 C SURFACE CONTRIBUTION BEING ADDED TO VREAL AB 1989 JR=KR+I-1 AB 1990 IF(EX.LT.100.) Z(JR)=Z(JR)+SURFF*ZS*DEXP(-EX) AB 1991 49 R=R+DELTAR AB 1992 GO TO 55 AB 1993 50 IF(KQ.EQ.1) GO TO 52 AB 1994 ZS=-4.*ZS AB 1995 DO 51 I=1,KPT AB 1996 JR=KR+I-1 AB 1997 JI=KI+I-1 AB 1998 ZR=Z(JR)/VREAL AB 1999 C SURFACE CONTRIBUTION BEING ADDED TO REAL POTENTIAL AB 2000 Z(JR)=Z(JR)+(ZR*ZR+ZR)*ZS*SURFF AB 2001 51 Z(JI)=(ZR*ZR+ZR)*ZS+Z(JI) AB 2002 GO TO 55 AB 2003 52 R=0. AB 2004 ZS=4.*ZS AB 2005 DO 53 I=1,KPT AB 2006 JI=KI+I-1 AB 2007 EX=(R-P2)/A2 AB 2008 IF(EX.GE.64D0.OR.EX.LE.-64D0) GO TO 53 AB 2009 EX=DEXP(EX) AB 2010 Z(JI)=Z(JI)+ZS*EX/((EX+1D0)*(EX+1D0)) AB 2011 JR=KR+I-1 AB 2012 Z(JR)=Z(JR)+SURFF*ZS*EX/((EX+1D0)*(EX+1D0)) AB 2013 53 R=R+DELTAR AB 2014 55 CAPX=CAPK*C1 AB 2015 DELTAX=CAPK*DELTAR AB 2016 D0=DELTAX*DELTAX AB 2017 DO 57 I=1,KPM AB 2018 JX=KX+I-1 AB 2019 Z(JX)=D0*I*I AB 2020 57 Z(JX)=1D0/Z(JX) AB 2021 D1=D0/ENA AB 2022 D2=2.-D0 AB 2023 LS=0 AB 2024 FJ(1)=DSIN(CAPX)/CAPX AB 2025 FN(1)=-DCOS(CAPX)/CAPX AB 2026 FJ(2)=FJ(1)/CAPX+FN(1) AB 2027 FN(2)=FN(1)/CAPX-FJ(1) AB 2028 IF(LMAX.LE.1)GO TO 220 AB 2029 LLIM=LMAX+1 AB 2030 DO 200 LL=3,LLIM AB 2031 FJ(LL)=(LL+LL-3)*FJ(LL-1)/CAPX-FJ(LL-2) AB 2032 FN(LL)=(LL+LL-3)*FN(LL-1)/CAPX-FN(LL-2) AB 2033 FTEST=DABS(FJ(LL))+DABS(FN(LL)) AB 2034 IF(FTEST.GT.1D30)GO TO 210 AB 2035 200 CONTINUE AB 2036 GO TO 220 AB 2037 210 LMAX=LL AB 2038 220 CONTINUE AB 2039 IF(JJ7.LT.0)GO TO 355 AB 2040 IF((KIN.NE.0).OR.(KETA.LE.0))GO TO 360 AB 2041 IF(KETA.GE.N)WRITE(6,6010)N,EN,CAPK AB 2042 6010 FORMAT(1H0/10X,'O. M. OUTPUT FOR LEVEL',I3,8X,'CHANNEL ENERGY=', AB 2043 XF9.4,' MEV',8X,' WAVE NUMBER=',F10.6//' L J',16X,'ETA', AB 2044 X22X,'T',6X,'GAMMASQ/D',5X,'R-INFINITY',6X,'STR.FN.',8X,'R-PRIME'/)AB 2045 IF(N.NE.1)GO TO 360 AB 2046 355 RTEIN=1.D6*EN AB 2047 RTEIN=1D0/DSQRT(RTEIN) AB 2048 350 CONTINUE AB 2049 RO=CAPK*P1 AB 2050 ROSQ=RO*RO AB 2051 IF(N.GE.0)GO TO 360 AB 2052 RI=RO*DSQRT(1D0+VREAL/ENA) AB 2053 RX=1D0/(2D0*RO) AB 2054 360 CONTINUE AB 2055 DO 100 L=LS,LMAX AB 2056 IF(N.LT.0)GO TO 300 AB 2057 FL=L AB 2058 LL1=L+1 AB 2059 FL0=LL1 AB 2060 D3=FL*FL0*D0 AB 2061 GSUBL=-CAPX*FN(LL1) AB 2062 DUM7=GSUBL**2 AB 2063 FSUBL= CAPX*FJ(LL1) AB 2064 DUM8=FSUBL**2 AB 2065 DUM6=GSUBL*FSUBL AB 2066 DUM78=DUM7+DUM8 AB 2067 DUM4 =DUM7-DUM8 AB 2068 SSUBL=CAPX/DUM78 AB 2069 IF(L.GT.0) GO TO 63 AB 2070 GLP=-FSUBL AB 2071 FLP= GSUBL AB 2072 GO TO 64 AB 2073 63 GLP=-CAPX*FN(L)+FL*FN(LL1) AB 2074 FLP= CAPX*FJ(L)-FL*FJ(LL1) AB 2075 64 DELSL=(FSUBL*FLP+GSUBL*GLP)*SSUBL AB 2076 Z(KREP)=0D0 AB 2077 Z(KIMP)=0D0 AB 2078 JRE=KREP+1 AB 2079 JIM=KIMP+1 AB 2080 Z(JRE)=1D-8 AB 2081 Z(JIM)=1D-8 AB 2082 IF(L.EQ.0) GO TO 80 AB 2083 S2=AIN(13)*D1 AB 2084 S2I=AIN(14)*D1 AB 2085 SO=-FL*S2 AB 2086 SOI=-FL*S2I AB 2087 S2=FL0*S2 AB 2088 S2I=FL0*S2I AB 2089 Z(KREM)=0D0 AB 2090 Z(KIMM)=0D0 AB 2091 JREM=KREM+1 AB 2092 JIMM=KIMM+1 AB 2093 Z(JREM)=1D-8 AB 2094 Z(JIMM)=1D-8 AB 2095 DO 78 I=1,KPM AB 2096 MX=KX+I-1 AB 2097 IR=KR+I AB 2098 II=KI+I AB 2099 IS=KS+I AB 2100 IRE=KREP+I AB 2101 IIM=KIMP+I AB 2102 IREM=KREM+I AB 2103 IIMM=KIMM+I AB 2104 MRE=IRE-1 AB 2105 MIM=IIM-1 AB 2106 MREM=IREM-1 AB 2107 MIMM=IIMM-1 AB 2108 NRE=IRE+1 AB 2109 NIM=IIM+1 AB 2110 NREM=IREM+1 AB 2111 NIMM=IIMM+1 AB 2112 DR =D2+D3*Z(MX)+D1*Z(IR) AB 2113 DR1=DR+SO*Z(IS) AB 2114 DI =D1*Z(II) AB 2115 DI1=DI+SOI*Z(IS) AB 2116 DR2=DR+S2*Z(IS) AB 2117 DI2=DI+S2I*Z(IS) AB 2118 Z(NREM)=DR2*Z(IREM)-DI2*Z(IIMM)-Z(MREM) AB 2119 Z(NIMM)=DR2*Z(IIMM)+DI2*Z(IREM)-Z(MIMM) AB 2120 Z(NRE )=DR1*Z(IRE )-DI1*Z(IIM )-Z(MRE ) AB 2121 Z(NIM )=DR1*Z(IIM )+DI1*Z(IRE )-Z(MIM ) AB 2122 IF(DABS(Z(MRE)).LE.1.D24) GO TO 78 AB 2123 Z(IRE )=1D-30*Z(IRE) AB 2124 Z(NRE )=1D-30*Z(NRE) AB 2125 Z(IIM )=1D-30*Z(IIM) AB 2126 Z(NIM )=1D-30*Z(NIM) AB 2127 Z(IREM)=1D-30*Z(IREM) AB 2128 Z(NREM)=1D-30*Z(NREM) AB 2129 Z(IIMM)=1D-30*Z(IIMM) AB 2130 Z(NIMM)=1D-30*Z(NIMM) AB 2131 78 CONTINUE AB 2132 J=2 AB 2133 NREM=KREM+KPT AB 2134 IREM=NREM-1 AB 2135 MREM=IREM-1 AB 2136 NIMM=KIMM+KPT AB 2137 IIMM=NIMM-1 AB 2138 MIMM=IIMM-1 AB 2139 DRE=Z(NREM)-Z(MREM) AB 2140 DIM=Z(NIMM)-Z(MIMM) AB 2141 DEN=(Z(IREM)*Z(IREM)+Z(IIMM)*Z(IIMM))/KPHF AB 2142 FLR=(Z(IREM)*DRE+Z(IIMM)*DIM)/DEN AB 2143 FLI=(Z(IREM)*DIM-Z(IIMM)*DRE)/DEN AB 2144 GO TO 89 AB 2145 80 DO 86 I=1,KPM AB 2146 MX=KX+I-1 AB 2147 IR=KR+I AB 2148 II=KI+I AB 2149 IS=KS+I AB 2150 IRE=KREP+I AB 2151 IIM=KIMP+I AB 2152 MRE=IRE-1 AB 2153 MIM=IIM-1 AB 2154 NRE=IRE+1 AB 2155 NIM=IIM+1 AB 2156 DR1=D2+D3*Z(MX)+D1*Z(IR) AB 2157 DI1=D1*Z(II) AB 2158 Z(NRE)=DR1*Z(IRE)-DI1*Z(IIM)-Z(MRE) AB 2159 Z(NIM)=DR1*Z(IIM)+DI1*Z(IRE)-Z(MIM) AB 2160 IF(DABS(Z(MRE)).LE.1.D24) GO TO 86 AB 2161 Z(IRE )=1D-30*Z(IRE) AB 2162 Z(NRE )=1D-30*Z(NRE) AB 2163 Z(IIM )=1D-30*Z(IIM) AB 2164 Z(NIM )=1D-30*Z(NIM) AB 2165 86 CONTINUE AB 2166 88 J=1 AB 2167 IF(N.LT.0)GO TO 370 AB 2168 NRE=KREP+KPT AB 2169 IRE=NRE-1 AB 2170 MRE=IRE-1 AB 2171 NIM=KIMP+KPT AB 2172 IIM=NIM-1 AB 2173 MIM=IIM-1 AB 2174 DRE=Z(NRE)-Z(MRE) AB 2175 DIM=Z(NIM)-Z(MIM) AB 2176 DEN=(Z(IRE)*Z(IRE)+Z(IIM)*Z(IIM))/KPHF AB 2177 FLR=(Z(IRE)*DRE+Z(IIM)*DIM)/DEN AB 2178 FLI=(Z(IRE)*DIM-Z(IIM)*DRE)/DEN AB 2179 89 DUM1=FLR-DELSL AB 2180 DUM2=DUM1**2 AB 2181 DUM1=SSUBL*DUM1 AB 2182 DUM5=(FLI+SSUBL)*(FLI-SSUBL)+DUM2 AB 2183 DEN=((FLI-SSUBL)**2+DUM2)*DUM78 AB 2184 ETARE=(DUM4*DUM5+4.*DUM1*DUM6)/DEN AB 2185 ETAIM=2.*(DUM1*DUM4-DUM5*DUM6)/DEN AB 2186 ETIMSQ=ETAIM*ETAIM AB 2187 TL =1.0-ETARE*ETARE-ETIMSQ AB 2188 GO TO 400 AB 2189 300 CONTINUE AB 2190 J=2 AB 2191 P=1D0 AB 2192 S=0D0 AB 2193 IF(L.EQ.0)GO TO 310 AB 2194 RR=1D0 AB 2195 DO 320 M=1,L AB 2196 M1=M+L AB 2197 M2=2*M AB 2198 M3=L-M AB 2199 RR=RR*RX*RX AB 2200 C OVERFLOWS FROM NFAC CORRECTED. NFAC REPLACED BY FFAC,N AB 2201 FNF=FFAC(M1)*FFAC(M2)/(FFAC(M3)*FFAC(M)*FFAC(M)) AB 2202 P=P+FNF*RR AB 2203 S=S-FNF*M2*RR*RX AB 2204 320 CONTINUE AB 2205 GO TO 315 AB 2206 310 J=1 AB 2207 315 CONTINUE AB 2208 P=RO/P AB 2209 S=P*S AB 2210 TL=4D0*RI*P/(S*S+(P+RI)*(P+RI)) AB 2211 ETIMSQ=1D0 AB 2212 370 CONTINUE AB 2213 400 CONTINUE AB 2214 JJ=3+2*(L-J) AB 2215 IF(JJ7.LT.0)GO TO 385 AB 2216 IF((KIN.NE.0).OR.(KETA.LE.0))GO TO 91 AB 2217 IF(KETA.GE.N)WRITE(6,6000)L,JJ,ETARE,ETAIM,TL AB 2218 6000 FORMAT(1H ,2I5,'/2',F16.6,F12.6,F16.6) AB 2219 385 IF(N.NE.1)GO TO 384 AB 2220 SFF=1-TL AB 2221 RPR=-DATAN2(ETAIM,ETARE)/(2D0*CAPK) AB 2222 IF(L-1)380,382,384 AB 2223 380 SS=0D0 AB 2224 PP=RO AB 2225 XI=2D0*RO AB 2226 SFF=-RTEIN*DLOG(SFF)/6.28318D0 AB 2227 C S0 AND RPRP CALCULATED. NEEDED IN STR-FN. FIT AB 2228 S0=SFF AB 2229 RPRP=RPR AB 2230 GO TO 383 AB 2231 382 SS=ROSQ/(1D0+ROSQ) AB 2232 PP=SS*RO AB 2233 XI=RO-DATAN(RO) AB 2234 SFF=-RTEIN*DLOG(SFF)*(1D0+ROSQ)/(J*9.42478D0*ROSQ) AB 2235 C S1 CALCULATED. NEEDED IN STR-FN. FIT AB 2236 S1=S1+SFF AB 2237 RPR=RPR*(1D0+ROSQ)/(10D6*EN) AB 2238 383 DEX=DCMPLX(0D0,XI) AB 2239 DEX=CDEXP(DEX)*DCMPLX(ETARE,ETAIM) AB 2240 RTL=(DEX-(1D0,0D0))/(DCMPLX(SS,PP)*DEX-DCMPLX(SS,-PP)) AB 2241 RINF=DREAL(RTL) AB 2242 STRF=DIMAG(RTL)/3.14159 AB 2243 IF(KIN.NE.0)GO TO 384 AB 2244 IF(JJ7)96,96,97 AB 2245 96 WRITE(6,6001)L,JJ AB 2246 6001 FORMAT(1H0,39X,I8,I5,'/2') AB 2247 97 WRITE(6,6002)STRF,RINF,SFF,RPR AB 2248 6002 FORMAT(1H+,53X,2F15.4,2D14.4) AB 2249 384 IF(JJ7.LT.0)GO TO 95 AB 2250 IF((TL.LT.-1D-6).OR.(TL.GT.1D0))WRITE(6,6030)N,L,JJ,TL,ETARE, AB 2251 XETAIM AB 2252 6030 FORMAT(1H0,' C A U T I O N : FOR LEVEL NO.',I3,5X,'L =',I3,5X,'J =AB 2253 X',I3,'/2',5X,'T =',D14.6,5X,'ETA = (',D14.6,',',D14.6,')') AB 2254 91 IF(N.NE.1)GO TO 90 AB 2255 Z(NJ5)=ETAIM/2D0 AB 2256 Z(NJ6)=(1D0-ETARE)/2D0 AB 2257 NJ5=NJ5+1 AB 2258 NJ6=NJ6+1 AB 2259 90 Z(NJ7)=TL AB 2260 IF(TL.LT.1D-30)Z(NJ7)=0D0 AB 2261 NJ7=NJ7+1 AB 2262 95 IF(J.EQ.2) GO TO 88 AB 2263 IF(JJ7.LT.0)GO TO 100 AB 2264 IF(L.EQ.LMAX)GO TO 99 AB 2265 IF((TL.LT.1D-5).AND.(ETIMSQ.LT.1D-10))GO TO 102 AB 2266 GO TO 100 AB 2267 99 IF((TL.GT.1D-3).AND.(N.GT.0))WRITE(6,6040)N,TL,LMAX AB 2268 6040 FORMAT(1H0,' C A U T I O N : FOR LEVEL',I3,' T =',F10.6,' FOR AB 2269 XINTERNALLY COMPUTED LMAX =',I3/) AB 2270 100 CONTINUE AB 2271 GO TO 900 AB 2272 102 NOC=2*L+1 AB 2273 IF(N.NE.1)GO TO 701 AB 2274 LDF=2*(LMAX-L) AB 2275 J6=J5+NOC AB 2276 J6M=J6+NOC-1 AB 2277 DO 700 J=J6,J6M AB 2278 K=J+LDF AB 2279 700 Z(J)=Z(K) AB 2280 J7=J6M+1 AB 2281 JJ7=J7 AB 2282 J7M=J7+NOC-1 AB 2283 DO 600 J=J7,J7M AB 2284 K=J+2*LDF AB 2285 600 Z(J)=Z(K) AB 2286 701 LMAX=L AB 2287 900 JJ7=JJ7+NOC AB 2288 IF(JJ7.GT.2)GO TO 990 AB 2289 Z(J5)=S0 AB 2290 NJ5=J5+1 AB 2291 Z(NJ5)=RPRP AB 2292 NJ5=NJ5+1 AB 2293 Z(NJ5)=S1 AB 2294 990 RETURN AB 2295 END AB 2296 C **********************************************************************AB 2297 SUBROUTINE CMC(Y,R,FRANG,F,LMX,I,J10,J11) AB 2298 IMPLICIT REAL*8(A-H,O-Z) AB 2299 COMMON/ZBLOCK/Z(24000) AB 2300 IF(Y.EQ.0D0)GO TO 711 AB 2301 IF(Y.EQ.180D0)GO TO 712 AB 2302 IF(Y-90D0)705,710,715 AB 2303 705 S=1D0 AB 2304 GO TO 730 AB 2305 715 S=-1D0 AB 2306 730 Q=FRANG*Y AB 2307 Q=DTAN(Q) AB 2308 Q=Q*Q AB 2309 C=1D0+(1D0-R*R)*Q AB 2310 C=DSQRT(C) AB 2311 Q=(S*C-R*Q)/(1D0+Q) AB 2312 GO TO 720 AB 2313 710 Q=-R AB 2314 GO TO 720 AB 2315 711 Q=1D0 AB 2316 GO TO 720 AB 2317 712 Q=-1D0 AB 2318 720 F=1D0+R*R+2D0*R*Q AB 2319 F=F*DSQRT(F)/(1D0+R*Q) AB 2320 Z(J10)=1D0 AB 2321 J101=J10+1 AB 2322 Z(J101)=Q AB 2323 V=1D0-Q*Q AB 2324 V=DSQRT(V) AB 2325 IF(I.GT.1)GO TO 10 AB 2326 Z(J11)=0D0 AB 2327 J111=J11+1 AB 2328 Z(J111)=V AB 2329 10 NUMT=2*LMX+1 AB 2330 IF(NUMT.LT.3)GO TO 1011 AB 2331 DO 1010 J=3,NUMT AB 2332 NJ10=J10+J-1 AB 2333 K=J-1 AB 2334 NJ101=NJ10-1 AB 2335 L=J-2 AB 2336 NJ102=NJ10-2 AB 2337 Z(NJ10)=((2*K-1)*Q*Z(NJ101)-L*Z(NJ102))/K AB 2338 IF (I.GT.1)GO TO 1010 AB 2339 NJ11=J11+J-1 AB 2340 NJ111=NJ11-1 AB 2341 NJ112=NJ11-2 AB 2342 Z(NJ11)=((2*K-1)*Q*Z(NJ111)-K*Z(NJ112))/L AB 2343 1010 CONTINUE AB 2344 1011 RETURN AB 2345 END AB 2346 C **********************************************************************AB 2347 FUNCTION FFAC(N) AB 2348 C NFAC MADE INTO DOUBLE PRECISION FFAC AB 2349 IMPLICIT REAL*8(A-H,O-Z) AB 2350 FFAC=1D0 AB 2351 IF(N)2,2,3 AB 2352 3 DO 10 I=1,N AB 2353 10 FFAC=FFAC*I AB 2354 2 RETURN AB 2355 END AB 2356 C **********************************************************************AB 2357 SUBROUTINE FLUCT(JD,KETA,J13,J14,J15,J16,NLEVL,MM,TPS,TMS) AB 2358 IMPLICIT REAL*8(A-H,O-Z) AB 2359 AB 2360 DIMENSION MM(1) AB 2361 COMMON/ZBLOCK/Z(24000) AB 2362 NJ130=J13-1 AB 2363 NJ140=J14-1 AB 2364 NJ150=J15-1 AB 2365 NJ160=J16-1 AB 2366 DO 350 I=1,NLEVL AB 2367 IF(MM(I).LT.1)GO TO 350 AB 2368 MMI=MM(I) AB 2369 DO 360 N=1,MMI AB 2370 NJ130=NJ130+1 AB 2371 NJ140=NJ140+1 AB 2372 NJ150=NJ150+1 AB 2373 NJ160=NJ160+1 AB 2374 Z(NJ150)=0D0 AB 2375 IF(TPS.LT.0.04D0)GO TO 370 AB 2376 Z(NJ150)=Z(NJ130)**1.212D0-0.78D0 AB 2377 TST=DABS(Z(NJ150)) AB 2378 IF(TST.LT.10D-10)GO TO 370 AB 2379 IF(TPS.LT.10D10)Z(NJ150)=Z(NJ150)/DEXP(0.228D0/TPS) AB 2380 370 Z(NJ150)=Z(NJ150)+1.78D0 AB 2381 Z(NJ160)=0D0 AB 2382 IF(TMS.LT.0.04D0)GO TO 380 AB 2383 Z(NJ160)=Z(NJ140)**1.212D0-0.78D0 AB 2384 TST=DABS(Z(NJ160)) AB 2385 IF(TST.LT.10D-10)GO TO 380 AB 2386 IF(TMS.LT.10D10)Z(NJ160)=Z(NJ160)/DEXP(0.228D0/TMS) AB 2387 380 Z(NJ160)=Z(NJ160)+1.78D0 AB 2388 IF(KETA.GE.I)WRITE(6,6030)JD,I,N,Z(NJ130),Z(NJ150),Z(NJ140), AB 2389 XZ(NJ160) AB 2390 6030 FORMAT(1H ,2I5,I7,4F15.6) AB 2391 Z(NJ150)=Z(NJ150)/2D0 AB 2392 Z(NJ160)=Z(NJ160)/2D0 AB 2393 360 CONTINUE AB 2394 350 CONTINUE AB 2395 RETURN AB 2396 END AB 2397 C **********************************************************************AB 2398 SUBROUTINE GAMCAP(B,AIN,TG,TGB,J17,J18,J19,J20,KOPG) AB 2399 C RAYNAL VERSION. AB 2400 IMPLICIT INTEGER*4(I-N) AB 2401 IMPLICIT REAL*8(A-H,O-Z) AB 2402 COMMON AB 2403 XEX(50),FI(50),GW(50),ANO,ANU,R(50),SGSCT(7),TGG(16),TFF(32),RPEXP,AB 2404 XFNF(32),DANG,C1,FF1,BN,ECM,E0,EXX,TX,SA,PR,EGD,GGD,CTG,SGSQ,TG0, AB 2405 XSGT,XFR,ECONT,TAU,E0T,ESTEP,AZ,SG,FNUG,FNU,ES,GWS0,GWRP,GWS1, AB 2406 XS0EXP,S1EXP,ID(50),IPI(50),NLEVEL,NLEVL,IT,LMAX,NJMIN,NJMAX,NT0, AB 2407 XNTI,KIM,KSO,KETA,KPT,KIN,KMAG,NIT,KGD,NZ,KG,NG,NF,NN,ISTR AB 2408 X,NA,NRD,NCONT,KGP(50),KS,KSCH,KSC,NDEF,IC,J2,J3,J5,NZB,NQB AB 2409 COMMON/ZBLOCK/Z(24000) AB 2410 DIMENSION AIN(1),LLMX(50) AB 2411 KTA=0 AB 2412 NINT=0 AB 2413 J18=0 AB 2414 TGU=0D0 AB 2415 TGB=0D0 AB 2416 ELIM=BN+ECM AB 2417 ELO=0D0 AB 2418 IF(0.05D0.GE.ECM)EHI=ELO+ECM AB 2419 IF(0.05D0.GE.ECM)GO TO 41 AB 2420 40 EHI=ELO+0.05D0 AB 2421 41 IF(EHI.GE.ELIM)EHI=ELIM AB 2422 EPS=(EHI+ELO)/2D0 AB 2423 ESQ=EPS*EPS AB 2424 TINT=(EHI-ELO)*EPS*ESQ AB 2425 EEE=-EGD*EGD+ESQ AB 2426 IF(KGD.EQ.1)TINT=TINT*EPS/(ESQ*GGD*GGD+EEE*EEE) AB 2427 EXC=BN+ECM-EPS AB 2428 IF(EXC-EXX)42,42,46 AB 2429 42 EBYT=(EXC-E0)/TX AB 2430 TINT=TINT*DEXP(EBYT)/TX AB 2431 GO TO 44 AB 2432 46 EBYT=DSQRT(SA*(EXC-PR)) AB 2433 DEN=B*EBYT*(EXC-PR) AB 2434 TINT=TINT*DEXP(2D0*EBYT)/DEN AB 2435 44 CONTINUE AB 2436 IF(EPS-ECM)30,32,32 AB 2437 30 TGU=TGU+TINT AB 2438 EEI=ECM-EPS AB 2439 NINT=NINT+1 AB 2440 CALL GAMMAS(BN,EEI,E0,EXX,TX,SA,PR,B,KGD,EGD,GGD,TMP) AB 2441 TMP=TMP*CTG AB 2442 JK7=J17 AB 2443 DO 82 I=1,NLEVL AB 2444 IF(EEI.LT.EX(I))GO TO 82 AB 2445 LMX=LMAX AB 2446 EN=EEI-EX(I) AB 2447 K=-1 AB 2448 IF(KOPG.GT.0)K=0 AB 2449 CALL ABACUS(K,EN,AIN,C1,ANO,ANU,KIM,KIN,KPT,KSO,KTA,LMX,J5,JA,JK7,AB 2450 XJJ17) AB 2451 LLMX(I)=LMX+1 AB 2452 LLMX(I+NLEVL)=JK7 AB 2453 J18=MAX0(J18,JJ17) AB 2454 JK7=JJ17 AB 2455 82 CONTINUE AB 2456 IF (NINT.GT.1) GO TO 91 AB 2457 J19=J18+NJMAX-NJMIN+1 AB 2458 J20=J19+NJMAX-NJMIN+1 AB 2459 IF(J20.LE.NZB)GO TO 90 AB 2460 J20=NZB-J20 AB 2461 WRITE(6,6000)J20 AB 2462 6000 FORMAT(1H0/' STORAGE LIMIT EXCEEDED BY SEARCH DATA, DISCRETE NEUTRAB 2463 XON AND GAMMA CHANNELS BY',I6,' REAL*8 LOCATIONS.') AB 2464 STOP AB 2465 90 CONTINUE AB 2466 DO 10 J=J18,J20-1 AB 2467 10 Z(J)=0D0 AB 2468 91 DO 84 NJ=NJMIN,NJMAX AB 2469 NJ18=J18+NJ-NJMIN AB 2470 NJ19=J19+NJ-NJMIN AB 2471 JD=2*NJ-IT-1 AB 2472 N1=JD-2 AB 2473 N1=IABS(N1) AB 2474 N2=JD+2 AB 2475 RPS=0D0 AB 2476 RMS=0D0 AB 2477 DO 65 J=N1,N2,2 AB 2478 DEX=-(J+1)*(J+1)/(SGSQ*4D0) AB 2479 RO=0D0 AB 2480 M1=J-2 AB 2481 M1=IABS(M1) AB 2482 M2=J+2 AB 2483 DO 66 K=M1,M2,2 AB 2484 DEY=-(K+1)*(K+1)/(SGSQ*4D0) AB 2485 66 RO=RO+DEXP(DEY)*(K+1) AB 2486 RO=6.2836*RO/SGSQ AB 2487 ROJ=6.2836*(J+1)*DEXP(DEX)/SGSQ AB 2488 TPS=0D0 AB 2489 TMS=0D0 AB 2490 DO 200 I=1,NLEVL AB 2491 IF(EEI.LT.EX(I))GO TO 200 AB 2492 NJ17=LLMX(I+NLEVEL) AB 2493 JID=JD-ID(I) AB 2494 NKMIN=(1+IABS(JID))/2 AB 2495 NKMAX=(1+JD+ID(I))/2 AB 2496 NKMAX=MIN0(NKMAX,LLMX(I)) AB 2497 IF(NKMAX-NKMIN)200,220,220 AB 2498 220 DO 300 NK=NKMIN,NKMAX AB 2499 NKMOD=MOD(NK,2) AB 2500 JPLS=2*NK-NKMOD AB 2501 JMNS=2*NK+NKMOD-1 AB 2502 NJ171=NJ17+JPLS-1 AB 2503 NJ172=NJ17+JMNS-1 AB 2504 IF(IPI(I)+IPI(1))310,320,310 AB 2505 310 TPS=TPS+Z(NJ171) AB 2506 TMS=TMS+Z(NJ172) AB 2507 GO TO 300 AB 2508 320 TPS=TPS+Z(NJ172) AB 2509 TMS=TMS+Z(NJ171) AB 2510 300 CONTINUE AB 2511 200 CONTINUE AB 2512 TIP=TMP*RO AB 2513 TPS=TPS+TIP AB 2514 TMS=TMS+TIP AB 2515 TPS=TMP/TPS AB 2516 TMS=TMP/TMS AB 2517 RJ=RO*ROJ AB 2518 RPS=RPS+RJ*TMS AB 2519 RMS=RMS+RJ*TPS AB 2520 65 CONTINUE AB 2521 Z(NJ18)=Z(NJ18)+TINT*RPS AB 2522 Z(NJ19)=Z(NJ19)+TINT*RMS AB 2523 84 CONTINUE AB 2524 GO TO 34 AB 2525 32 TGB=TGB+TINT AB 2526 34 CONTINUE AB 2527 IF(EHI.EQ.ELIM)GO TO 50 AB 2528 ELO=EHI AB 2529 GO TO 40 AB 2530 50 TG=TGU+TGB AB 2531 RETURN AB 2532 END AB 2533 C **********************************************************************AB 2534 SUBROUTINE GAMMAS(BN,ECM,E0,EX,TX,SA,PR,B,KGD,EGD,GGD,TG) AB 2535 IMPLICIT REAL*8(A-H,O-Z) AB 2536 TG=0D0 AB 2537 ELIM=BN+ECM AB 2538 ELO=0D0 AB 2539 40 EHI=ELO+0.05D0 AB 2540 IF(EHI.GE.ELIM)EHI=ELIM AB 2541 EPS=(EHI+ELO)/2D0 AB 2542 ESQ=EPS*EPS AB 2543 TINT=(EHI-ELO)*EPS*ESQ AB 2544 EEE=-EGD*EGD+ESQ AB 2545 IF(KGD.EQ.1)TINT=TINT*EPS/(ESQ*GGD*GGD+EEE*EEE) AB 2546 EXC=BN+ECM-EPS AB 2547 IF(EXC-EX)42,42,46 AB 2548 42 EBYT=(EXC-E0)/TX AB 2549 TINT=TINT*DEXP(EBYT)/TX AB 2550 GO TO 44 AB 2551 46 EBYT=DSQRT(SA*(EXC-PR)) AB 2552 DEN=B*EBYT*(EXC-PR) AB 2553 TINT=TINT*DEXP(2D0*EBYT)/DEN AB 2554 44 CONTINUE AB 2555 TG=TG+TINT AB 2556 IF(EHI.EQ.ELIM)GO TO 50 AB 2557 ELO=EHI AB 2558 GO TO 40 AB 2559 50 RETURN AB 2560 END AB 2561 C **********************************************************************AB 2562 SUBROUTINE PRSL(NZ,NN,PR,SC) AB 2563 IMPLICIT REAL*8(A-H,O-Z) AB 2564 DIMENSION JZ(44),JN(70),KZ(88),KN(140) AB 2565 DATA JZ/246,209,162,162,183,173,135,154,120,106,136,143,117,124, AB 2566 2120,128,128,135,136,119,114,112,158,117,118,122,97,92,62,68,64,72,AB 2567 375,71,87,83,89,79,89,78,69,61,72,77/ AB 2568 DATA JN/267,180,167,186,204,164,144,154,130,127,129,141,150,150, AB 2569 2143,188,147,157,146,93,72,112,129,94,124,125,114,132,115,124,143, AB 2570 3109,120,104,70,85,76,92,99,110,92,73,70,87,61,69,55,40,73,58,86, AB 2571 4113,84,79,82,71,41,38,67,61,78,67,67,79,60,57,49,43,50,39/ AB 2572 DATA KZ/291,417,572,780,897,970,1010,1070,1138,1207,1255,1324,1393AB 2573 2,1471,1553,1637,1736,1852,1844,1819,1768,1709,1665,1666,1659,1635,AB 2574 31618,1641,1660,1654,1642,1684,1722,1742,1752,1782,1819,1858,1911, AB 2575 41983,1914,1835,1740,1654,1568,1475,1371,1287,1218,1161,1109,1078, AB 2576 51053,1041,1021,985,936,897,856,813,768,733,711,716,705,681,656,695AB 2577 6,752,803,841,886,771,638,547,478,437,417,412,429,461,504,548,596, AB 2578 7640,687,720,774/ AB 2579 DATA KN/680,753,755,721,744,807,894,981,1060,1139,1254,1368,1434, AB 2580 21419,1383,1350,1300,1213,1260,1326,1413,1492,1560,1638,1708,1755, AB 2581 31798,1833,1856,1871,1865,1855,1852,1834,1801,1738,1656,1562,1438, AB 2582 41288,1324,1371,1440,1516,1589,1643,1697,1759,1808,1872,1922,1951, AB 2583 51973,1991,2006,2016,2009,1983,1941,1906,1866,1773,1703,1644,1600, AB 2584 61533,1449,1342,1228,1114,1010,909,1000,1064,1118,1170,1222,1271, AB 2585 71305,1299,1262,1211,1166,1121,1081,1038,1003,965,938,899,862,833, AB 2586 8810,782,756,733,715,683,669,655,653,649,639,582,526,453,383,308, AB 2587 9237,172,105,27,-69,-169,-258,-316,-172,-41,71,166,262,322,376,410,AB 2588 A446,483,509,518,517,510,505,504,503,499,498,511,527,539,537,530/ AB 2589 SC=0D0 AB 2590 PR=0D0 AB 2591 IF((NZ.LT.11).OR.(NN.LT.11))GO TO 10 AB 2592 IF((NZ.GT.98).OR.(NN.GT.150))GO TO 10 AB 2593 IN=NN-10 AB 2594 IZ=NZ-10 AB 2595 SC=(DFLOAT(KN(IN))-DFLOAT(KZ(IZ)))/100D0 AB 2596 NZHF=NZ/2 AB 2597 NNHF=NN/2 AB 2598 NZCK=2*NZHF AB 2599 NNCK=2*NNHF AB 2600 IZ=NZHF-5 AB 2601 IN=NNHF-5 AB 2602 IF(NZCK.EQ.NZ)PR=PR+DFLOAT(JZ(IZ))/100D0 AB 2603 IF(NNCK.EQ.NN)PR=PR+DFLOAT(JN(IN))/100D0 AB 2604 10 RETURN AB 2605 END AB 2606 C **********************************************************************AB 2607 BLOCK DATA AB 2608 IMPLICIT REAL*8(A-H,O-Z) AB 2609 COMMON /COMN/FIN(16),X(20),W(20),KP(16) AB 2610 DATA KP/1,2*0,3*1,2*0,2*1,6*0/, AB 2611 XFIN/50D0,2*0D0,1.2,0.6,14D0,2*0D0,1.3,0.5,2*0D0,7D0,0D0,1.2,0.6/ AB 2612 DATA X/0.07054,0.372127,0.916582,1.707307,2.749199,4.048925,5.6151AB 2613 X75,7.459017,9.594393,12.038803,14.814293,17.948896,21.478788,25.45AB 2614 X1703,29.932555,35.013434,40.833057,47.619994,55.810796,66.524417/ AB 2615 DATA W/0.168747,0.291254,0.266686,0.166002,.0748261,0.0249644,0.00AB 2616 X620255,0.00114496,0.000155742,0.154014D-4,0.108649D-5,0.533012D-7,AB 2617 X0.175798D-8,0.37255D-10,0.476753D-12,0.337284D-14,0.115501D-16,0.1AB 2618 X53952D-19,0.528644D-23,0.165646D-27/ AB 2619 END AB 2620 C **********************************************************************AB 2621 C THESE SUBROUTINES CONSTITUTE THE GENERALIZED NON-LINEAR FITTING AB 2622 C PACKAGE OF B. GARBOW, K. HILLSTROM AND J. MORE, ANL-AMD LIBRARY. AB 2623 C IT HAS BEEN SUCESSFULLY USED ON IBM, VAX AND PC MACHINES. THE AB 2624 C VERSION GIVEN HERE HAS BEEN EXTENSIVELY TESTED USING VAX/VMS FORTRAN, AB 2625 C LAHEY PC FORTRAN, AND MS PC FORTRAN. THE RESULTS ARE VERY REASONABLE AB 2626 C ALTHOUGH ANY NON-LINEAR FITTING MUST BE CARRIED OUT WITH JUDGEMENT. AB 2627 C AB 2628 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) AB 2629 INTEGER M,N,INFO,LWA AB 2630 INTEGER IWA(N) AB 2631 DOUBLE PRECISION TOL AB 2632 DOUBLE PRECISION X(N),FVEC(M),WA(LWA) AB 2633 EXTERNAL FCN AB 2634 C AB 2635 C SUBROUTINE LMDIF1 AB 2636 C AB 2637 C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF AB 2638 C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE AB 2639 C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE AB 2640 C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A AB 2641 C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS AB 2642 C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. AB 2643 C AB 2644 C THE SUBROUTINE STATEMENT IS AB 2645 C AB 2646 C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) AB 2647 C AB 2648 C WHERE AB 2649 C AB 2650 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH AB 2651 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED AB 2652 C IN AN EXTERNAL STATEMENT IN THE USER CALLING AB 2653 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. AB 2654 C AB 2655 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) AB 2656 C INTEGER M,N,IFLAG AB 2657 C DOUBLE PRECISION X(N),FVEC(M) AB 2658 C ---------- AB 2659 C CALCULATE THE FUNCTIONS AT X AND AB 2660 C RETURN THIS VECTOR IN FVEC. AB 2661 C ---------- AB 2662 C RETURN AB 2663 C END AB 2664 C AB 2665 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS AB 2666 C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. AB 2667 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. AB 2668 C AB 2669 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 2670 C OF FUNCTIONS. AB 2671 C AB 2672 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 2673 C OF VARIABLES. N MUST NOT EXCEED M. AB 2674 C AB 2675 C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN AB 2676 C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X AB 2677 C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. AB 2678 C AB 2679 C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS AB 2680 C THE FUNCTIONS EVALUATED AT THE OUTPUT X. AB 2681 C AB 2682 C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS AB 2683 C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE AB 2684 C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT AB 2685 C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT AB 2686 C MOST TOL. AB 2687 C AB 2688 C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS AB 2689 C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) AB 2690 C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, AB 2691 C INFO IS SET AS FOLLOWS. AB 2692 C AB 2693 C INFO = 0 IMPROPER INPUT PARAMETERS. AB 2694 C AB 2695 C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR AB 2696 C IN THE SUM OF SQUARES IS AT MOST TOL. AB 2697 C AB 2698 C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR AB 2699 C BETWEEN X AND THE SOLUTION IS AT MOST TOL. AB 2700 C AB 2701 C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. AB 2702 C AB 2703 C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE AB 2704 C JACOBIAN TO MACHINE PRECISION. AB 2705 C AB 2706 C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR AB 2707 C EXCEEDED 200*(N+1). AB 2708 C AB 2709 C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN AB 2710 C THE SUM OF SQUARES IS POSSIBLE. AB 2711 C AB 2712 C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN AB 2713 C THE APPROXIMATE SOLUTION X IS POSSIBLE. AB 2714 C AB 2715 C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. AB 2716 C AB 2717 C WA IS A WORK ARRAY OF LENGTH LWA. AB 2718 C AB 2719 C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN AB 2720 C M*N+5*N+M. AB 2721 C AB 2722 C SUBPROGRAMS CALLED AB 2723 C AB 2724 C USER-SUPPLIED ...... FCN AB 2725 C AB 2726 C MINPACK-SUPPLIED ... LMDIF AB 2727 C AB 2728 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 2729 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 2730 C AB 2731 C ********** AB 2732 INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT AB 2733 DOUBLE PRECISION EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO AB 2734 DATA FACTOR,ZERO /1.0D2,0.0D0/ AB 2735 INFO = 0 AB 2736 C AB 2737 C CHECK THE INPUT PARAMETERS FOR ERRORS. AB 2738 C AB 2739 IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO AB 2740 * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 AB 2741 C AB 2742 C CALL LMDIF. AB 2743 C AB 2744 MAXFEV = 200*(N + 1) AB 2745 FTOL = TOL AB 2746 XTOL = TOL AB 2747 GTOL = ZERO AB 2748 EPSFCN = ZERO AB 2749 MODE = 1 AB 2750 NPRINT = 0 AB 2751 MP5N = M + 5*N AB 2752 CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), AB 2753 * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, AB 2754 * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) AB 2755 IF (INFO .EQ. 8) INFO = 4 AB 2756 10 CONTINUE AB 2757 RETURN AB 2758 END AB 2759 C **********************************************************************AB 2760 DOUBLE PRECISION FUNCTION DPMPAR(I) AB 2761 INTEGER I AB 2762 C AB 2763 C FUNCTION DPMPAR AB 2764 C AB 2765 C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS AB 2766 C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY AB 2767 C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE AB 2768 C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED AB 2769 C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. AB 2770 C AB 2771 C THE FUNCTION STATEMENT IS AB 2772 C AB 2773 C DOUBLE PRECISION FUNCTION DPMPAR(I) AB 2774 C AB 2775 C WHERE AB 2776 C AB 2777 C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH AB 2778 C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS AB 2779 C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE AB 2780 C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE AB 2781 C AB 2782 C DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, AB 2783 C AB 2784 C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, AB 2785 C AB 2786 C DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. AB 2787 C AB 2788 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 2789 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 2790 C AB 2791 C ********** AB 2792 INTEGER MCHEPS(4) AB 2793 INTEGER MINMAG(4) AB 2794 INTEGER MAXMAG(4) AB 2795 DOUBLE PRECISION DMACH(3) AB 2796 EQUIVALENCE (DMACH(1),MCHEPS(1)) AB 2797 EQUIVALENCE (DMACH(2),MINMAG(1)) AB 2798 EQUIVALENCE (DMACH(3),MAXMAG(1)) AB 2799 C AB 2800 C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, AB 2801 C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, AB 2802 C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. AB 2803 C AB 2804 C DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 / AB 2805 C DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 / AB 2806 C DATA MAXMAG(1),MAXMAG(2) / Z7FFFFFFF, ZFFFFFFFF / AB 2807 C AB 2808 C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. AB 2809 C AB 2810 C DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / AB 2811 C DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / AB 2812 C DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / AB 2813 C AB 2814 C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. AB 2815 C AB 2816 C DATA MCHEPS(1) / 15614000000000000000B / AB 2817 C DATA MCHEPS(2) / 15010000000000000000B / AB 2818 C AB 2819 C DATA MINMAG(1) / 00604000000000000000B / AB 2820 C DATA MINMAG(2) / 00000000000000000000B / AB 2821 C AB 2822 C DATA MAXMAG(1) / 37767777777777777777B / AB 2823 C DATA MAXMAG(2) / 37167777777777777777B / AB 2824 C AB 2825 C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). AB 2826 C AB 2827 C DATA MCHEPS(1),MCHEPS(2) / "114400000000, "000000000000 / AB 2828 C DATA MINMAG(1),MINMAG(2) / "033400000000, "000000000000 / AB 2829 C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "344777777777 / AB 2830 C AB 2831 C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). AB 2832 C AB 2833 C DATA MCHEPS(1),MCHEPS(2) / "104400000000, "000000000000 / AB 2834 C DATA MINMAG(1),MINMAG(2) / "000400000000, "000000000000 / AB 2835 C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "377777777777 / AB 2836 C AB 2837 C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING 32-BIT AB 2838 C INTEGERS (EXPRESSED IN INTEGER AND OCTAL). USE FOR VAX AND PC. AB 2839 C AB 2840 C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / AB 2841 C DATA MINMAG(1),MINMAG(2) / 128, 0 / AB 2842 C DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / AB 2843 C AB 2844 C DATA MCHEPS(1),MCHEPS(2) / O04500000000, O00000000000 / AB 2845 C DATA MINMAG(1),MINMAG(2) / O00040000000, O00000000000 / AB 2846 C DATA MAXMAG(1),MAXMAG(2) / O17777777777, O37777777777 / AB 2847 C AB 2848 C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING AB 2849 C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). AB 2850 C AB 2851 C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / AB 2852 C DATA MCHEPS(3),MCHEPS(4) / 0, 0 / AB 2853 C AB 2854 C DATA MINMAG(1),MINMAG(2) / 128, 0 / AB 2855 C DATA MINMAG(3),MINMAG(4) / 0, 0 / AB 2856 C AB 2857 C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / AB 2858 C DATA MAXMAG(3),MAXMAG(4) / -1, -1 / AB 2859 C AB 2860 C DATA MCHEPS(1),MCHEPS(2) / O022400, O000000 / AB 2861 C DATA MCHEPS(3),MCHEPS(4) / O000000, O000000 / AB 2862 C AB 2863 C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / AB 2864 C DATA MINMAG(3),MINMAG(4) / O000000, O000000 / AB 2865 C AB 2866 C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / AB 2867 C DATA MAXMAG(3),MAXMAG(4) / O177777, O177777 / AB 2868 C AB 2869 C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. AB 2870 C AB 2871 C DATA MCHEPS(1) / O1451000000000000 / AB 2872 C DATA MCHEPS(2) / O0000000000000000 / AB 2873 C AB 2874 C DATA MINMAG(1) / O1771000000000000 / AB 2875 C DATA MINMAG(2) / O7770000000000000 / AB 2876 C AB 2877 C DATA MAXMAG(1) / O0777777777777777 / AB 2878 C DATA MAXMAG(2) / O7777777777777777 / AB 2879 C AB 2880 C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. AB 2881 C AB 2882 C DATA MCHEPS(1) / O1451000000000000 / AB 2883 C DATA MCHEPS(2) / O0000000000000000 / AB 2884 C AB 2885 C DATA MINMAG(1) / O1771000000000000 / AB 2886 C DATA MINMAG(2) / O0000000000000000 / AB 2887 C AB 2888 C DATA MAXMAG(1) / O0777777777777777 / AB 2889 C DATA MAXMAG(2) / O0007777777777777 / AB 2890 C AB 2891 C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. AB 2892 C AB 2893 C DATA MCHEPS(1) / ZCC6800000 / AB 2894 C DATA MCHEPS(2) / Z000000000 / AB 2895 C AB 2896 C DATA MINMAG(1) / ZC00800000 / AB 2897 C DATA MINMAG(2) / Z000000000 / AB 2898 C AB 2899 C DATA MAXMAG(1) / ZDFFFFFFFF / AB 2900 C DATA MAXMAG(2) / ZFFFFFFFFF / AB 2901 C AB 2902 C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. AB 2903 C AB 2904 C DATA MCHEPS(1),MCHEPS(2) / O170640000000, O000000000000 / AB 2905 C DATA MINMAG(1),MINMAG(2) / O000040000000, O000000000000 / AB 2906 C DATA MAXMAG(1),MAXMAG(2) / O377777777777, O777777777777 / AB 2907 C AB 2908 C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. AB 2909 C AB 2910 C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - AB 2911 C STATIC DMACH(3) AB 2912 C AB 2913 C DATA MINMAG/20K,3*0/,MAXMAG/77777K,3*177777K/ AB 2914 C DATA MCHEPS/32020K,3*0/ AB 2915 C AB 2916 C MACHINE CONSTANTS FOR THE HARRIS 220. AB 2917 C AB 2918 C DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000334 / AB 2919 C DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / AB 2920 C DATA MAXMAG(1),MAXMAG(2) / '37777777, '37777577 / AB 2921 C AB 2922 C MACHINE CONSTANTS FOR THE CRAY-1. AB 2923 C AB 2924 C DATA MCHEPS(1) / 0376424000000000000000B / AB 2925 C DATA MCHEPS(2) / 0000000000000000000000B / AB 2926 C AB 2927 C DATA MINMAG(1) / 0200034000000000000000B / AB 2928 C DATA MINMAG(2) / 0000000000000000000000B / AB 2929 C AB 2930 C DATA MAXMAG(1) / 0577777777777777777777B / AB 2931 C DATA MAXMAG(2) / 0000007777777777777776B / AB 2932 C AB 2933 C MACHINE CONSTANTS FOR THE PRIME 400. AB 2934 C AB 2935 C DATA MCHEPS(1),MCHEPS(2) / :10000000000, :00000000123 / AB 2936 C DATA MINMAG(1),MINMAG(2) / :10000000000, :00000100000 / AB 2937 C DATA MAXMAG(1),MAXMAG(2) / :17777777777, :37777677776 / AB 2938 C AB 2939 DMACH(1)=2.**(-53) AB 2940 DMACH(2)=1.D-38 AB 2941 DMACH(3)=1.D+38 AB 2942 DPMPAR = DMACH(I) AB 2943 RETURN AB 2944 END AB 2945 C **********************************************************************AB 2946 DOUBLE PRECISION FUNCTION ENORM(N,X) AB 2947 INTEGER N AB 2948 DOUBLE PRECISION X(N) AB 2949 C AB 2950 C FUNCTION ENORM AB 2951 C AB 2952 C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE AB 2953 C EUCLIDEAN NORM OF X. AB 2954 C AB 2955 C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF AB 2956 C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE AB 2957 C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS AB 2958 C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS AB 2959 C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED AB 2960 C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. AB 2961 C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS AB 2962 C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN AB 2963 C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT AB 2964 C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS AB 2965 C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. AB 2966 C AB 2967 C THE FUNCTION STATEMENT IS AB 2968 C AB 2969 C DOUBLE PRECISION FUNCTION ENORM(N,X) AB 2970 C AB 2971 C WHERE AB 2972 C AB 2973 C N IS A POSITIVE INTEGER INPUT VARIABLE. AB 2974 C AB 2975 C X IS AN INPUT ARRAY OF LENGTH N. AB 2976 C AB 2977 C SUBPROGRAMS CALLED AB 2978 C AB 2979 C FORTRAN-SUPPLIED ... DABS,DSQRT AB 2980 C AB 2981 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 2982 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 2983 C AB 2984 C ********** AB 2985 INTEGER I AB 2986 DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS, AB 2987 * X1MAX,X3MAX,ZERO AB 2988 DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ AB 2989 S1 = ZERO AB 2990 S2 = ZERO AB 2991 S3 = ZERO AB 2992 X1MAX = ZERO AB 2993 X3MAX = ZERO AB 2994 FLOATN = N AB 2995 AGIANT = RGIANT/FLOATN AB 2996 DO 90 I = 1, N AB 2997 XABS = DABS(X(I)) AB 2998 IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 AB 2999 IF (XABS .LE. RDWARF) GO TO 30 AB 3000 C AB 3001 C SUM FOR LARGE COMPONENTS. AB 3002 C AB 3003 IF (XABS .LE. X1MAX) GO TO 10 AB 3004 S1 = ONE + S1*(X1MAX/XABS)**2 AB 3005 X1MAX = XABS AB 3006 GO TO 20 AB 3007 10 CONTINUE AB 3008 S1 = S1 + (XABS/X1MAX)**2 AB 3009 20 CONTINUE AB 3010 GO TO 60 AB 3011 30 CONTINUE AB 3012 C AB 3013 C SUM FOR SMALL COMPONENTS. AB 3014 C AB 3015 IF (XABS .LE. X3MAX) GO TO 40 AB 3016 S3 = ONE + S3*(X3MAX/XABS)**2 AB 3017 X3MAX = XABS AB 3018 GO TO 50 AB 3019 40 CONTINUE AB 3020 IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 AB 3021 50 CONTINUE AB 3022 60 CONTINUE AB 3023 GO TO 80 AB 3024 70 CONTINUE AB 3025 C AB 3026 C SUM FOR INTERMEDIATE COMPONENTS. AB 3027 C AB 3028 S2 = S2 + XABS**2 AB 3029 80 CONTINUE AB 3030 90 CONTINUE AB 3031 C AB 3032 C CALCULATION OF NORM. AB 3033 C AB 3034 IF (S1 .EQ. ZERO) GO TO 100 AB 3035 ENORM = X1MAX*DSQRT(S1+(S2/X1MAX)/X1MAX) AB 3036 GO TO 130 AB 3037 100 CONTINUE AB 3038 IF (S2 .EQ. ZERO) GO TO 110 AB 3039 IF (S2 .GE. X3MAX) AB 3040 * ENORM = DSQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) AB 3041 IF (S2 .LT. X3MAX) AB 3042 * ENORM = DSQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) AB 3043 GO TO 120 AB 3044 110 CONTINUE AB 3045 ENORM = X3MAX*DSQRT(S3) AB 3046 120 CONTINUE AB 3047 130 CONTINUE AB 3048 RETURN AB 3049 C AB 3050 C LAST CARD OF FUNCTION ENORM. AB 3051 C AB 3052 END AB 3053 SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) AB 3054 INTEGER M,N,LDFJAC,IFLAG AB 3055 DOUBLE PRECISION EPSFCN AB 3056 DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) AB 3057 C ********** AB 3058 C AB 3059 C SUBROUTINE FDJAC2 AB 3060 C AB 3061 C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION AB 3062 C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED AB 3063 C PROBLEM OF M FUNCTIONS IN N VARIABLES. AB 3064 C AB 3065 C THE SUBROUTINE STATEMENT IS AB 3066 C AB 3067 C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) AB 3068 C AB 3069 C WHERE AB 3070 C AB 3071 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH AB 3072 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED AB 3073 C IN AN EXTERNAL STATEMENT IN THE USER CALLING AB 3074 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. AB 3075 C AB 3076 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) AB 3077 C INTEGER M,N,IFLAG AB 3078 C DOUBLE PRECISION X(N),FVEC(M) AB 3079 C ---------- AB 3080 C CALCULATE THE FUNCTIONS AT X AND AB 3081 C RETURN THIS VECTOR IN FVEC. AB 3082 C ---------- AB 3083 C RETURN AB 3084 C END AB 3085 C AB 3086 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS AB 3087 C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. AB 3088 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. AB 3089 C AB 3090 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3091 C OF FUNCTIONS. AB 3092 C AB 3093 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3094 C OF VARIABLES. N MUST NOT EXCEED M. AB 3095 C AB 3096 C X IS AN INPUT ARRAY OF LENGTH N. AB 3097 C AB 3098 C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE AB 3099 C FUNCTIONS EVALUATED AT X. AB 3100 C AB 3101 C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE AB 3102 C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. AB 3103 C AB 3104 C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M AB 3105 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. AB 3106 C AB 3107 C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE AB 3108 C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. AB 3109 C AB 3110 C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE AB 3111 C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS AB 3112 C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE AB 3113 C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS AB 3114 C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE AB 3115 C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE AB 3116 C PRECISION. AB 3117 C AB 3118 C WA IS A WORK ARRAY OF LENGTH M. AB 3119 C AB 3120 C SUBPROGRAMS CALLED AB 3121 C AB 3122 C USER-SUPPLIED ...... FCN AB 3123 C AB 3124 C MINPACK-SUPPLIED ... DPMPAR AB 3125 C MINPACK-SUPPLIED ... DPMPAR AB 3126 C AB 3127 C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT AB 3128 C AB 3129 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 3130 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 3131 C AB 3132 C ********** AB 3133 INTEGER I,J AB 3134 DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO AB 3135 DOUBLE PRECISION DPMPAR AB 3136 DATA ZERO /0.0D0/ AB 3137 C AB 3138 C EPSMCH IS THE MACHINE PRECISION. AB 3139 C AB 3140 EPSMCH = DPMPAR(1) AB 3141 C AB 3142 EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) AB 3143 DO 20 J = 1, N AB 3144 TEMP = X(J) AB 3145 H = EPS*DABS(TEMP) AB 3146 IF (H .EQ. ZERO) H = EPS AB 3147 X(J) = TEMP + H AB 3148 CALL FCN(M,N,X,WA,IFLAG) AB 3149 IF (IFLAG .LT. 0) GO TO 30 AB 3150 X(J) = TEMP AB 3151 DO 10 I = 1, M AB 3152 FJAC(I,J) = (WA(I) - FVEC(I))/H AB 3153 10 CONTINUE AB 3154 20 CONTINUE AB 3155 30 CONTINUE AB 3156 RETURN AB 3157 C AB 3158 C LAST CARD OF SUBROUTINE FDJAC2. AB 3159 C AB 3160 END AB 3161 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, AB 3162 * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, AB 3163 * IPVT,QTF,WA1,WA2,WA3,WA4) AB 3164 INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC AB 3165 INTEGER IPVT(N) AB 3166 DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR AB 3167 DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), AB 3168 * WA1(N),WA2(N),WA3(N),WA4(M) AB 3169 EXTERNAL FCN AB 3170 C ********** AB 3171 C AB 3172 C SUBROUTINE LMDIF AB 3173 C AB 3174 C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF AB 3175 C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF AB 3176 C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A AB 3177 C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS AB 3178 C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. AB 3179 C AB 3180 C THE SUBROUTINE STATEMENT IS AB 3181 C AB 3182 C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, AB 3183 C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, AB 3184 C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) AB 3185 C AB 3186 C WHERE AB 3187 C AB 3188 C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH AB 3189 C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED AB 3190 C IN AN EXTERNAL STATEMENT IN THE USER CALLING AB 3191 C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. AB 3192 C AB 3193 C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) AB 3194 C INTEGER M,N,IFLAG AB 3195 C DOUBLE PRECISION X(N),FVEC(M) AB 3196 C ---------- AB 3197 C CALCULATE THE FUNCTIONS AT X AND AB 3198 C RETURN THIS VECTOR IN FVEC. AB 3199 C ---------- AB 3200 C RETURN AB 3201 C END AB 3202 C AB 3203 C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS AB 3204 C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. AB 3205 C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. AB 3206 C AB 3207 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3208 C OF FUNCTIONS. AB 3209 C AB 3210 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3211 C OF VARIABLES. N MUST NOT EXCEED M. AB 3212 C AB 3213 C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN AB 3214 C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X AB 3215 C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. AB 3216 C AB 3217 C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS AB 3218 C THE FUNCTIONS EVALUATED AT THE OUTPUT X. AB 3219 C AB 3220 C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION AB 3221 C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE AB 3222 C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. AB 3223 C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED AB 3224 C IN THE SUM OF SQUARES. AB 3225 C AB 3226 C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION AB 3227 C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE AB 3228 C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE AB 3229 C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. AB 3230 C AB 3231 C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION AB 3232 C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND AB 3233 C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE AB 3234 C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY AB 3235 C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS AB 3236 C OF THE JACOBIAN. AB 3237 C AB 3238 C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION AB 3239 C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST AB 3240 C MAXFEV BY THE END OF AN ITERATION. AB 3241 C AB 3242 C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE AB 3243 C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS AB 3244 C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE AB 3245 C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS AB 3246 C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE AB 3247 C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE AB 3248 C PRECISION. AB 3249 C AB 3250 C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE AB 3251 C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG AB 3252 C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS AB 3253 C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. AB 3254 C AB 3255 C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE AB 3256 C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, AB 3257 C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER AB 3258 C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. AB 3259 C AB 3260 C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE AB 3261 C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF AB 3262 C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE AB 3263 C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE AB 3264 C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. AB 3265 C AB 3266 C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED AB 3267 C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, AB 3268 C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST AB 3269 C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND AB 3270 C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE AB 3271 C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS AB 3272 C OF FCN WITH IFLAG = 0 ARE MADE. AB 3273 C AB 3274 C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS AB 3275 C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) AB 3276 C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, AB 3277 C INFO IS SET AS FOLLOWS. AB 3278 C AB 3279 C INFO = 0 IMPROPER INPUT PARAMETERS. AB 3280 C AB 3281 C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS AB 3282 C IN THE SUM OF SQUARES ARE AT MOST FTOL. AB 3283 C AB 3284 C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES AB 3285 C IS AT MOST XTOL. AB 3286 C AB 3287 C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. AB 3288 C AB 3289 C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY AB 3290 C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN AB 3291 C ABSOLUTE VALUE. AB 3292 C AB 3293 C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR AB 3294 C EXCEEDED MAXFEV. AB 3295 C AB 3296 C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN AB 3297 C THE SUM OF SQUARES IS POSSIBLE. AB 3298 C AB 3299 C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN AB 3300 C THE APPROXIMATE SOLUTION X IS POSSIBLE. AB 3301 C AB 3302 C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE AB 3303 C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. AB 3304 C AB 3305 C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF AB 3306 C CALLS TO FCN. AB 3307 C AB 3308 C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX AB 3309 C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH AB 3310 C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT AB 3311 C AB 3312 C T T T AB 3313 C P *(JAC *JAC)*P = R *R, AB 3314 C AB 3315 C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL AB 3316 C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) AB 3317 C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL AB 3318 C PART OF FJAC CONTAINS INFORMATION GENERATED DURING AB 3319 C THE COMPUTATION OF R. AB 3320 C AB 3321 C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M AB 3322 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. AB 3323 C AB 3324 C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT AB 3325 C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, AB 3326 C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS AB 3327 C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR AB 3328 C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. AB 3329 C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. AB 3330 C AB 3331 C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS AB 3332 C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. AB 3333 C AB 3334 C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. AB 3335 C AB 3336 C WA4 IS A WORK ARRAY OF LENGTH M. AB 3337 C AB 3338 C SUBPROGRAMS CALLED AB 3339 C AB 3340 C USER-SUPPLIED ...... FCN AB 3341 C AB 3342 C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC AB 3343 C AB 3344 C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD AB 3345 C AB 3346 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 3347 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 3348 C AB 3349 C ********** AB 3350 INTEGER I,IFLAG,ITER,J,L AB 3351 DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, AB 3352 * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, AB 3353 * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO AB 3354 DOUBLE PRECISION DPMPAR,ENORM AB 3355 DATA ONE,P1,P5,P25,P75,P0001,ZERO AB 3356 * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ AB 3357 C AB 3358 C EPSMCH IS THE MACHINE PRECISION. AB 3359 C AB 3360 EPSMCH = DPMPAR(1) AB 3361 C AB 3362 INFO = 0 AB 3363 IFLAG = 0 AB 3364 NFEV = 0 AB 3365 C AB 3366 C CHECK THE INPUT PARAMETERS FOR ERRORS. AB 3367 C AB 3368 IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M AB 3369 * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO AB 3370 * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 AB 3371 IF (MODE .NE. 2) GO TO 20 AB 3372 DO 10 J = 1, N AB 3373 IF (DIAG(J) .LE. ZERO) GO TO 300 AB 3374 10 CONTINUE AB 3375 20 CONTINUE AB 3376 C AB 3377 C EVALUATE THE FUNCTION AT THE STARTING POINT AB 3378 C AND CALCULATE ITS NORM. AB 3379 C AB 3380 IFLAG = 1 AB 3381 CALL FCN(M,N,X,FVEC,IFLAG) AB 3382 NFEV = 1 AB 3383 IF (IFLAG .LT. 0) GO TO 300 AB 3384 FNORM = ENORM(M,FVEC) AB 3385 C AB 3386 C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. AB 3387 C AB 3388 PAR = ZERO AB 3389 ITER = 1 AB 3390 C AB 3391 C BEGINNING OF THE OUTER LOOP. AB 3392 C AB 3393 30 CONTINUE AB 3394 C AB 3395 C CALCULATE THE JACOBIAN MATRIX. AB 3396 C AB 3397 IFLAG = 2 AB 3398 CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) AB 3399 NFEV = NFEV + N AB 3400 IF (IFLAG .LT. 0) GO TO 300 AB 3401 C AB 3402 C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. AB 3403 C AB 3404 IF (NPRINT .LE. 0) GO TO 40 AB 3405 IFLAG = 0 AB 3406 IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) AB 3407 IF (IFLAG .LT. 0) GO TO 300 AB 3408 40 CONTINUE AB 3409 C AB 3410 C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. AB 3411 C AB 3412 CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) AB 3413 C AB 3414 C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING AB 3415 C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. AB 3416 C AB 3417 IF (ITER .NE. 1) GO TO 80 AB 3418 IF (MODE .EQ. 2) GO TO 60 AB 3419 DO 50 J = 1, N AB 3420 DIAG(J) = WA2(J) AB 3421 IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE AB 3422 50 CONTINUE AB 3423 60 CONTINUE AB 3424 C AB 3425 C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X AB 3426 C AND INITIALIZE THE STEP BOUND DELTA. AB 3427 C AB 3428 DO 70 J = 1, N AB 3429 WA3(J) = DIAG(J)*X(J) AB 3430 70 CONTINUE AB 3431 XNORM = ENORM(N,WA3) AB 3432 DELTA = FACTOR*XNORM AB 3433 IF (DELTA .EQ. ZERO) DELTA = FACTOR AB 3434 80 CONTINUE AB 3435 C AB 3436 C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN AB 3437 C QTF. AB 3438 C AB 3439 DO 90 I = 1, M AB 3440 WA4(I) = FVEC(I) AB 3441 90 CONTINUE AB 3442 DO 130 J = 1, N AB 3443 IF (FJAC(J,J) .EQ. ZERO) GO TO 120 AB 3444 SUM = ZERO AB 3445 DO 100 I = J, M AB 3446 SUM = SUM + FJAC(I,J)*WA4(I) AB 3447 100 CONTINUE AB 3448 TEMP = -SUM/FJAC(J,J) AB 3449 DO 110 I = J, M AB 3450 WA4(I) = WA4(I) + FJAC(I,J)*TEMP AB 3451 110 CONTINUE AB 3452 120 CONTINUE AB 3453 FJAC(J,J) = WA1(J) AB 3454 QTF(J) = WA4(J) AB 3455 130 CONTINUE AB 3456 C AB 3457 C COMPUTE THE NORM OF THE SCALED GRADIENT. AB 3458 C AB 3459 GNORM = ZERO AB 3460 IF (FNORM .EQ. ZERO) GO TO 170 AB 3461 DO 160 J = 1, N AB 3462 L = IPVT(J) AB 3463 IF (WA2(L) .EQ. ZERO) GO TO 150 AB 3464 SUM = ZERO AB 3465 DO 140 I = 1, J AB 3466 SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) AB 3467 140 CONTINUE AB 3468 GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) AB 3469 150 CONTINUE AB 3470 160 CONTINUE AB 3471 170 CONTINUE AB 3472 C AB 3473 C TEST FOR CONVERGENCE OF THE GRADIENT NORM. AB 3474 C AB 3475 IF (GNORM .LE. GTOL) INFO = 4 AB 3476 IF (INFO .NE. 0) GO TO 300 AB 3477 C AB 3478 C RESCALE IF NECESSARY. AB 3479 C AB 3480 IF (MODE .EQ. 2) GO TO 190 AB 3481 DO 180 J = 1, N AB 3482 DIAG(J) = DMAX1(DIAG(J),WA2(J)) AB 3483 180 CONTINUE AB 3484 190 CONTINUE AB 3485 C AB 3486 C BEGINNING OF THE INNER LOOP. AB 3487 C AB 3488 200 CONTINUE AB 3489 C AB 3490 C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. AB 3491 C AB 3492 CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, AB 3493 * WA3,WA4) AB 3494 C AB 3495 C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. AB 3496 C AB 3497 DO 210 J = 1, N AB 3498 WA1(J) = -WA1(J) AB 3499 WA2(J) = X(J) + WA1(J) AB 3500 WA3(J) = DIAG(J)*WA1(J) AB 3501 210 CONTINUE AB 3502 PNORM = ENORM(N,WA3) AB 3503 C AB 3504 C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. AB 3505 C AB 3506 IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) AB 3507 C AB 3508 C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. AB 3509 C AB 3510 IFLAG = 1 AB 3511 CALL FCN(M,N,WA2,WA4,IFLAG) AB 3512 NFEV = NFEV + 1 AB 3513 IF (IFLAG .LT. 0) GO TO 300 AB 3514 FNORM1 = ENORM(M,WA4) AB 3515 C AB 3516 C COMPUTE THE SCALED ACTUAL REDUCTION. AB 3517 C AB 3518 ACTRED = -ONE AB 3519 IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 AB 3520 C AB 3521 C COMPUTE THE SCALED PREDICTED REDUCTION AND AB 3522 C THE SCALED DIRECTIONAL DERIVATIVE. AB 3523 C AB 3524 DO 230 J = 1, N AB 3525 WA3(J) = ZERO AB 3526 L = IPVT(J) AB 3527 TEMP = WA1(L) AB 3528 DO 220 I = 1, J AB 3529 WA3(I) = WA3(I) + FJAC(I,J)*TEMP AB 3530 220 CONTINUE AB 3531 230 CONTINUE AB 3532 TEMP1 = ENORM(N,WA3)/FNORM AB 3533 TEMP2 = (DSQRT(PAR)*PNORM)/FNORM AB 3534 PRERED = TEMP1**2 + TEMP2**2/P5 AB 3535 DIRDER = -(TEMP1**2 + TEMP2**2) AB 3536 C AB 3537 C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED AB 3538 C REDUCTION. AB 3539 C AB 3540 RATIO = ZERO AB 3541 IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED AB 3542 C AB 3543 C UPDATE THE STEP BOUND. AB 3544 C AB 3545 IF (RATIO .GT. P25) GO TO 240 AB 3546 IF (ACTRED .GE. ZERO) TEMP = P5 AB 3547 IF (ACTRED .LT. ZERO) AB 3548 * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) AB 3549 IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 AB 3550 DELTA = TEMP*DMIN1(DELTA,PNORM/P1) AB 3551 PAR = PAR/TEMP AB 3552 GO TO 260 AB 3553 240 CONTINUE AB 3554 IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 AB 3555 DELTA = PNORM/P5 AB 3556 PAR = P5*PAR AB 3557 250 CONTINUE AB 3558 260 CONTINUE AB 3559 C AB 3560 C TEST FOR SUCCESSFUL ITERATION. AB 3561 C AB 3562 IF (RATIO .LT. P0001) GO TO 290 AB 3563 C AB 3564 C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. AB 3565 C AB 3566 DO 270 J = 1, N AB 3567 X(J) = WA2(J) AB 3568 WA2(J) = DIAG(J)*X(J) AB 3569 270 CONTINUE AB 3570 DO 280 I = 1, M AB 3571 FVEC(I) = WA4(I) AB 3572 280 CONTINUE AB 3573 XNORM = ENORM(N,WA2) AB 3574 FNORM = FNORM1 AB 3575 ITER = ITER + 1 AB 3576 290 CONTINUE AB 3577 C AB 3578 C TESTS FOR CONVERGENCE. AB 3579 C AB 3580 IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL AB 3581 * .AND. P5*RATIO .LE. ONE) INFO = 1 AB 3582 IF (DELTA .LE. XTOL*XNORM) INFO = 2 AB 3583 IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL AB 3584 * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 AB 3585 IF (INFO .NE. 0) GO TO 300 AB 3586 C AB 3587 C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. AB 3588 C AB 3589 IF (NFEV .GE. MAXFEV) INFO = 5 AB 3590 IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH AB 3591 * .AND. P5*RATIO .LE. ONE) INFO = 6 AB 3592 IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 AB 3593 IF (GNORM .LE. EPSMCH) INFO = 8 AB 3594 IF (INFO .NE. 0) GO TO 300 AB 3595 C AB 3596 C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. AB 3597 C AB 3598 IF (RATIO .LT. P0001) GO TO 200 AB 3599 C AB 3600 C END OF THE OUTER LOOP. AB 3601 C AB 3602 GO TO 30 AB 3603 300 CONTINUE AB 3604 C AB 3605 C TERMINATION, EITHER NORMAL OR USER IMPOSED. AB 3606 C AB 3607 IF (IFLAG .LT. 0) INFO = IFLAG AB 3608 IFLAG = 0 AB 3609 IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) AB 3610 RETURN AB 3611 END AB 3612 C **********************************************************************AB 3613 SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, AB 3614 * WA2) AB 3615 INTEGER N,LDR AB 3616 INTEGER IPVT(N) AB 3617 DOUBLE PRECISION DELTA,PAR AB 3618 DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N), AB 3619 * WA2(N) AB 3620 C AB 3621 C SUBROUTINE LMPAR AB 3622 C AB 3623 C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL AB 3624 C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, AB 3625 C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER AB 3626 C PAR SUCH THAT IF X SOLVES THE SYSTEM AB 3627 C AB 3628 C A*X = B , SQRT(PAR)*D*X = 0 , AB 3629 C AB 3630 C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN AB 3631 C NORM OF D*X, THEN EITHER PAR IS ZERO AND AB 3632 C AB 3633 C (DXNORM-DELTA) .LE. 0.1*DELTA , AB 3634 C AB 3635 C OR PAR IS POSITIVE AND AB 3636 C AB 3637 C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . AB 3638 C AB 3639 C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM AB 3640 C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE AB 3641 C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF AB 3642 C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL AB 3643 C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL AB 3644 C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS AB 3645 C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, AB 3646 C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT AB 3647 C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT AB 3648 C AB 3649 C T T T AB 3650 C P *(A *A + PAR*D*D)*P = S *S . AB 3651 C AB 3652 C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. AB 3653 C AB 3654 C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE AB 3655 C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS AB 3656 C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST AB 3657 C VALUE OBTAINED SO FAR. AB 3658 C AB 3659 C THE SUBROUTINE STATEMENT IS AB 3660 C AB 3661 C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, AB 3662 C WA1,WA2) AB 3663 C AB 3664 C WHERE AB 3665 C AB 3666 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. AB 3667 C AB 3668 C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE AB 3669 C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. AB 3670 C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE AB 3671 C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE AB 3672 C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. AB 3673 C AB 3674 C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N AB 3675 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. AB 3676 C AB 3677 C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE AB 3678 C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P AB 3679 C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. AB 3680 C AB 3681 C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE AB 3682 C DIAGONAL ELEMENTS OF THE MATRIX D. AB 3683 C AB 3684 C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST AB 3685 C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. AB 3686 C AB 3687 C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER AB 3688 C BOUND ON THE EUCLIDEAN NORM OF D*X. AB 3689 C AB 3690 C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN AB 3691 C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. AB 3692 C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. AB 3693 C AB 3694 C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST AB 3695 C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, AB 3696 C FOR THE OUTPUT PAR. AB 3697 C AB 3698 C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE AB 3699 C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. AB 3700 C AB 3701 C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. AB 3702 C AB 3703 C SUBPROGRAMS CALLED AB 3704 C AB 3705 C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV AB 3706 C AB 3707 C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT AB 3708 C AB 3709 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 3710 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 3711 C AB 3712 C ********** AB 3713 INTEGER I,ITER,J,JM1,JP1,K,L,NSING AB 3714 DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, AB 3715 * SUM,TEMP,ZERO AB 3716 DOUBLE PRECISION DPMPAR,ENORM AB 3717 DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ AB 3718 C AB 3719 C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. AB 3720 C AB 3721 DWARF = DPMPAR(2) AB 3722 C AB 3723 C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE AB 3724 C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. AB 3725 C AB 3726 NSING = N AB 3727 DO 10 J = 1, N AB 3728 WA1(J) = QTB(J) AB 3729 IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 AB 3730 IF (NSING .LT. N) WA1(J) = ZERO AB 3731 10 CONTINUE AB 3732 IF (NSING .LT. 1) GO TO 50 AB 3733 DO 40 K = 1, NSING AB 3734 J = NSING - K + 1 AB 3735 WA1(J) = WA1(J)/R(J,J) AB 3736 TEMP = WA1(J) AB 3737 JM1 = J - 1 AB 3738 IF (JM1 .LT. 1) GO TO 30 AB 3739 DO 20 I = 1, JM1 AB 3740 WA1(I) = WA1(I) - R(I,J)*TEMP AB 3741 20 CONTINUE AB 3742 30 CONTINUE AB 3743 40 CONTINUE AB 3744 50 CONTINUE AB 3745 DO 60 J = 1, N AB 3746 L = IPVT(J) AB 3747 X(L) = WA1(J) AB 3748 60 CONTINUE AB 3749 C AB 3750 C INITIALIZE THE ITERATION COUNTER. AB 3751 C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST AB 3752 C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. AB 3753 C AB 3754 ITER = 0 AB 3755 DO 70 J = 1, N AB 3756 WA2(J) = DIAG(J)*X(J) AB 3757 70 CONTINUE AB 3758 DXNORM = ENORM(N,WA2) AB 3759 FP = DXNORM - DELTA AB 3760 IF (FP .LE. P1*DELTA) GO TO 220 AB 3761 C AB 3762 C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON AB 3763 C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF AB 3764 C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. AB 3765 C AB 3766 PARL = ZERO AB 3767 IF (NSING .LT. N) GO TO 120 AB 3768 DO 80 J = 1, N AB 3769 L = IPVT(J) AB 3770 WA1(J) = DIAG(L)*(WA2(L)/DXNORM) AB 3771 80 CONTINUE AB 3772 DO 110 J = 1, N AB 3773 SUM = ZERO AB 3774 JM1 = J - 1 AB 3775 IF (JM1 .LT. 1) GO TO 100 AB 3776 DO 90 I = 1, JM1 AB 3777 SUM = SUM + R(I,J)*WA1(I) AB 3778 90 CONTINUE AB 3779 100 CONTINUE AB 3780 WA1(J) = (WA1(J) - SUM)/R(J,J) AB 3781 110 CONTINUE AB 3782 TEMP = ENORM(N,WA1) AB 3783 PARL = ((FP/DELTA)/TEMP)/TEMP AB 3784 120 CONTINUE AB 3785 C AB 3786 C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. AB 3787 C AB 3788 DO 140 J = 1, N AB 3789 SUM = ZERO AB 3790 DO 130 I = 1, J AB 3791 SUM = SUM + R(I,J)*QTB(I) AB 3792 130 CONTINUE AB 3793 L = IPVT(J) AB 3794 WA1(J) = SUM/DIAG(L) AB 3795 140 CONTINUE AB 3796 GNORM = ENORM(N,WA1) AB 3797 PARU = GNORM/DELTA AB 3798 IF (PARU .EQ. ZERO) PARU = DWARF/DMIN1(DELTA,P1) AB 3799 C AB 3800 C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), AB 3801 C SET PAR TO THE CLOSER ENDPOINT. AB 3802 C AB 3803 PAR = DMAX1(PAR,PARL) AB 3804 PAR = DMIN1(PAR,PARU) AB 3805 IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM AB 3806 C AB 3807 C BEGINNING OF AN ITERATION. AB 3808 C AB 3809 150 CONTINUE AB 3810 ITER = ITER + 1 AB 3811 C AB 3812 C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. AB 3813 C AB 3814 IF (PAR .EQ. ZERO) PAR = DMAX1(DWARF,P001*PARU) AB 3815 TEMP = DSQRT(PAR) AB 3816 DO 160 J = 1, N AB 3817 WA1(J) = TEMP*DIAG(J) AB 3818 160 CONTINUE AB 3819 CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) AB 3820 DO 170 J = 1, N AB 3821 WA2(J) = DIAG(J)*X(J) AB 3822 170 CONTINUE AB 3823 DXNORM = ENORM(N,WA2) AB 3824 TEMP = FP AB 3825 FP = DXNORM - DELTA AB 3826 C AB 3827 C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE AB 3828 C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL AB 3829 C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. AB 3830 C AB 3831 IF (DABS(FP) .LE. P1*DELTA AB 3832 * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP AB 3833 * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 AB 3834 C AB 3835 C COMPUTE THE NEWTON CORRECTION. AB 3836 C AB 3837 DO 180 J = 1, N AB 3838 L = IPVT(J) AB 3839 WA1(J) = DIAG(L)*(WA2(L)/DXNORM) AB 3840 180 CONTINUE AB 3841 DO 210 J = 1, N AB 3842 WA1(J) = WA1(J)/SDIAG(J) AB 3843 TEMP = WA1(J) AB 3844 JP1 = J + 1 AB 3845 IF (N .LT. JP1) GO TO 200 AB 3846 DO 190 I = JP1, N AB 3847 WA1(I) = WA1(I) - R(I,J)*TEMP AB 3848 190 CONTINUE AB 3849 200 CONTINUE AB 3850 210 CONTINUE AB 3851 TEMP = ENORM(N,WA1) AB 3852 PARC = ((FP/DELTA)/TEMP)/TEMP AB 3853 C AB 3854 C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. AB 3855 C AB 3856 IF (FP .GT. ZERO) PARL = DMAX1(PARL,PAR) AB 3857 IF (FP .LT. ZERO) PARU = DMIN1(PARU,PAR) AB 3858 C AB 3859 C COMPUTE AN IMPROVED ESTIMATE FOR PAR. AB 3860 C AB 3861 PAR = DMAX1(PARL,PAR+PARC) AB 3862 C AB 3863 C END OF AN ITERATION. AB 3864 C AB 3865 GO TO 150 AB 3866 220 CONTINUE AB 3867 C AB 3868 C TERMINATION. AB 3869 C AB 3870 IF (ITER .EQ. 0) PAR = ZERO AB 3871 RETURN AB 3872 END AB 3873 C **********************************************************************AB 3874 SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) AB 3875 INTEGER M,N,LDA,LIPVT AB 3876 INTEGER IPVT(LIPVT) AB 3877 LOGICAL PIVOT AB 3878 DOUBLE PRECISION A(LDA,N),RDIAG(N),ACNORM(N),WA(N) AB 3879 C AB 3880 C SUBROUTINE QRFAC AB 3881 C AB 3882 C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN AB 3883 C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE AB 3884 C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL AB 3885 C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL AB 3886 C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, AB 3887 C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR AB 3888 C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM AB 3889 C AB 3890 C T AB 3891 C I - (1/U(K))*U*U AB 3892 C AB 3893 C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF AB 3894 C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST AB 3895 C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. AB 3896 C AB 3897 C THE SUBROUTINE STATEMENT IS AB 3898 C AB 3899 C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) AB 3900 C AB 3901 C WHERE AB 3902 C AB 3903 C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3904 C OF ROWS OF A. AB 3905 C AB 3906 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER AB 3907 C OF COLUMNS OF A. AB 3908 C AB 3909 C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR AB 3910 C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT AB 3911 C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT AB 3912 C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL AB 3913 C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL AB 3914 C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). AB 3915 C AB 3916 C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M AB 3917 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. AB 3918 C AB 3919 C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, AB 3920 C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, AB 3921 C THEN NO COLUMN PIVOTING IS DONE. AB 3922 C AB 3923 C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT AB 3924 C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. AB 3925 C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. AB 3926 C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. AB 3927 C AB 3928 C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, AB 3929 C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN AB 3930 C LIPVT MUST BE AT LEAST N. AB 3931 C AB 3932 C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE AB 3933 C DIAGONAL ELEMENTS OF R. AB 3934 C AB 3935 C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE AB 3936 C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. AB 3937 C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE AB 3938 C WITH RDIAG. AB 3939 C AB 3940 C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA AB 3941 C CAN COINCIDE WITH RDIAG. AB 3942 C AB 3943 C SUBPROGRAMS CALLED AB 3944 C AB 3945 C MINPACK-SUPPLIED ... DPMPAR,ENORM AB 3946 C AB 3947 C FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0 AB 3948 C AB 3949 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 3950 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 3951 C AB 3952 C ********** AB 3953 INTEGER I,J,JP1,K,KMAX,MINMN AB 3954 DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO AB 3955 DOUBLE PRECISION DPMPAR,ENORM AB 3956 DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ AB 3957 C AB 3958 C EPSMCH IS THE MACHINE PRECISION. AB 3959 C AB 3960 EPSMCH = DPMPAR(1) AB 3961 C AB 3962 C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. AB 3963 C AB 3964 DO 10 J = 1, N AB 3965 ACNORM(J) = ENORM(M,A(1,J)) AB 3966 RDIAG(J) = ACNORM(J) AB 3967 WA(J) = RDIAG(J) AB 3968 IF (PIVOT) IPVT(J) = J AB 3969 10 CONTINUE AB 3970 C AB 3971 C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. AB 3972 C AB 3973 MINMN = MIN0(M,N) AB 3974 DO 110 J = 1, MINMN AB 3975 IF (.NOT.PIVOT) GO TO 40 AB 3976 C AB 3977 C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. AB 3978 C AB 3979 KMAX = J AB 3980 DO 20 K = J, N AB 3981 IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K AB 3982 20 CONTINUE AB 3983 IF (KMAX .EQ. J) GO TO 40 AB 3984 DO 30 I = 1, M AB 3985 TEMP = A(I,J) AB 3986 A(I,J) = A(I,KMAX) AB 3987 A(I,KMAX) = TEMP AB 3988 30 CONTINUE AB 3989 RDIAG(KMAX) = RDIAG(J) AB 3990 WA(KMAX) = WA(J) AB 3991 K = IPVT(J) AB 3992 IPVT(J) = IPVT(KMAX) AB 3993 IPVT(KMAX) = K AB 3994 40 CONTINUE AB 3995 C AB 3996 C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE AB 3997 C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. AB 3998 C AB 3999 AJNORM = ENORM(M-J+1,A(J,J)) AB 4000 IF (AJNORM .EQ. ZERO) GO TO 100 AB 4001 IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM AB 4002 DO 50 I = J, M AB 4003 A(I,J) = A(I,J)/AJNORM AB 4004 50 CONTINUE AB 4005 A(J,J) = A(J,J) + ONE AB 4006 C AB 4007 C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS AB 4008 C AND UPDATE THE NORMS. AB 4009 C AB 4010 JP1 = J + 1 AB 4011 IF (N .LT. JP1) GO TO 100 AB 4012 DO 90 K = JP1, N AB 4013 SUM = ZERO AB 4014 DO 60 I = J, M AB 4015 SUM = SUM + A(I,J)*A(I,K) AB 4016 60 CONTINUE AB 4017 TEMP = SUM/A(J,J) AB 4018 DO 70 I = J, M AB 4019 A(I,K) = A(I,K) - TEMP*A(I,J) AB 4020 70 CONTINUE AB 4021 IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 AB 4022 TEMP = A(J,K)/RDIAG(K) AB 4023 RDIAG(K) = RDIAG(K)*DSQRT(DMAX1(ZERO,ONE-TEMP**2)) AB 4024 IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 AB 4025 RDIAG(K) = ENORM(M-J,A(JP1,K)) AB 4026 WA(K) = RDIAG(K) AB 4027 80 CONTINUE AB 4028 90 CONTINUE AB 4029 100 CONTINUE AB 4030 RDIAG(J) = -AJNORM AB 4031 110 CONTINUE AB 4032 RETURN AB 4033 END AB 4034 C **********************************************************************AB 4035 SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) AB 4036 INTEGER N,LDR AB 4037 INTEGER IPVT(N) AB 4038 DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) AB 4039 C AB 4040 C SUBROUTINE QRSOLV AB 4041 C AB 4042 C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, AB 4043 C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH AB 4044 C SOLVES THE SYSTEM AB 4045 C AB 4046 C A*X = B , D*X = 0 , AB 4047 C AB 4048 C IN THE LEAST SQUARES SENSE. AB 4049 C AB 4050 C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM AB 4051 C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE AB 4052 C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF AB 4053 C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL AB 4054 C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL AB 4055 C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS AB 4056 C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, AB 4057 C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM AB 4058 C A*X = B, D*X = 0, IS THEN EQUIVALENT TO AB 4059 C AB 4060 C T T AB 4061 C R*Z = Q *B , P *D*P*Z = 0 , AB 4062 C AB 4063 C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, AB 4064 C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV AB 4065 C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT AB 4066 C AB 4067 C T T T AB 4068 C P *(A *A + D*D)*P = S *S . AB 4069 C AB 4070 C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. AB 4071 C AB 4072 C THE SUBROUTINE STATEMENT IS AB 4073 C AB 4074 C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) AB 4075 C AB 4076 C WHERE AB 4077 C AB 4078 C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. AB 4079 C AB 4080 C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE AB 4081 C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. AB 4082 C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE AB 4083 C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE AB 4084 C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. AB 4085 C AB 4086 C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N AB 4087 C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. AB 4088 C AB 4089 C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE AB 4090 C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P AB 4091 C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. AB 4092 C AB 4093 C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE AB 4094 C DIAGONAL ELEMENTS OF THE MATRIX D. AB 4095 C AB 4096 C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST AB 4097 C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. AB 4098 C AB 4099 C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST AB 4100 C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. AB 4101 C AB 4102 C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE AB 4103 C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. AB 4104 C AB 4105 C WA IS A WORK ARRAY OF LENGTH N. AB 4106 C AB 4107 C SUBPROGRAMS CALLED AB 4108 C AB 4109 C FORTRAN-SUPPLIED ... DABS,DSQRT AB 4110 C AB 4111 C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. AB 4112 C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE AB 4113 C AB 4114 C ********** AB 4115 INTEGER I,J,JP1,K,KP1,L,NSING AB 4116 DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO AB 4117 DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ AB 4118 C AB 4119 C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. AB 4120 C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. AB 4121 C AB 4122 DO 20 J = 1, N AB 4123 DO 10 I = J, N AB 4124 R(I,J) = R(J,I) AB 4125 10 CONTINUE AB 4126 X(J) = R(J,J) AB 4127 WA(J) = QTB(J) AB 4128 20 CONTINUE AB 4129 C AB 4130 C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. AB 4131 C AB 4132 DO 100 J = 1, N AB 4133 C AB 4134 C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE AB 4135 C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. AB 4136 C AB 4137 L = IPVT(J) AB 4138 IF (DIAG(L) .EQ. ZERO) GO TO 90 AB 4139 DO 30 K = J, N AB 4140 SDIAG(K) = ZERO AB 4141 30 CONTINUE AB 4142 SDIAG(J) = DIAG(L) AB 4143 C AB 4144 C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D AB 4145 C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B AB 4146 C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. AB 4147 C AB 4148 QTBPJ = ZERO AB 4149 DO 80 K = J, N AB 4150 C AB 4151 C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE AB 4152 C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. AB 4153 C AB 4154 IF (SDIAG(K) .EQ. ZERO) GO TO 70 AB 4155 IF (DABS(R(K,K)) .GE. DABS(SDIAG(K))) GO TO 40 AB 4156 COTAN = R(K,K)/SDIAG(K) AB 4157 SIN = P5/DSQRT(P25+P25*COTAN**2) AB 4158 COS = SIN*COTAN AB 4159 GO TO 50 AB 4160 40 CONTINUE AB 4161 TAN = SDIAG(K)/R(K,K) AB 4162 COS = P5/DSQRT(P25+P25*TAN**2) AB 4163 SIN = COS*TAN AB 4164 50 CONTINUE AB 4165 C AB 4166 C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND AB 4167 C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). AB 4168 C AB 4169 R(K,K) = COS*R(K,K) + SIN*SDIAG(K) AB 4170 TEMP = COS*WA(K) + SIN*QTBPJ AB 4171 QTBPJ = -SIN*WA(K) + COS*QTBPJ AB 4172 WA(K) = TEMP AB 4173 C AB 4174 C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. AB 4175 C AB 4176 KP1 = K + 1 AB 4177 IF (N .LT. KP1) GO TO 70 AB 4178 DO 60 I = KP1, N AB 4179 TEMP = COS*R(I,K) + SIN*SDIAG(I) AB 4180 SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) AB 4181 R(I,K) = TEMP AB 4182 60 CONTINUE AB 4183 70 CONTINUE AB 4184 80 CONTINUE AB 4185 90 CONTINUE AB 4186 C AB 4187 C STORE THE DIAGONAL ELEMENT OF S AND RESTORE AB 4188 C THE CORRESPONDING DIAGONAL ELEMENT OF R. AB 4189 C AB 4190 SDIAG(J) = R(J,J) AB 4191 R(J,J) = X(J) AB 4192 100 CONTINUE AB 4193 C AB 4194 C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS AB 4195 C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. AB 4196 C AB 4197 NSING = N AB 4198 DO 110 J = 1, N AB 4199 IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 AB 4200 IF (NSING .LT. N) WA(J) = ZERO AB 4201 110 CONTINUE AB 4202 IF (NSING .LT. 1) GO TO 150 AB 4203 DO 140 K = 1, NSING AB 4204 J = NSING - K + 1 AB 4205 SUM = ZERO AB 4206 JP1 = J + 1 AB 4207 IF (NSING .LT. JP1) GO TO 130 AB 4208 DO 120 I = JP1, NSING AB 4209 SUM = SUM + R(I,J)*WA(I) AB 4210 120 CONTINUE AB 4211 130 CONTINUE AB 4212 WA(J) = (WA(J) - SUM)/SDIAG(J) AB 4213 140 CONTINUE AB 4214 150 CONTINUE AB 4215 C AB 4216 C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. AB 4217 C AB 4218 DO 160 J = 1, N AB 4219 L = IPVT(J) AB 4220 X(L) = WA(J) AB 4221 160 CONTINUE AB 4222 RETURN AB 4223 END AB 4224 C END OF FITTING PACKAGE AB 4225 C **********************************************************************AB 4226 FUNCTION CLEBSH (A, B, X, Y, CIN, ZIN) AB 4227 C AB 4228 C A VAX/VMS PACKAGE SUITABLE FOR A PC RUNNING LAHEY FORTRAN. ALSO AB 4229 C SEEMS TO WORK WITH MS-FORTRAN. ADAPTED FROM THE ANL-PHY SOFTWARE AB 4230 C PACKAGE OF S. PIEPER BY R. OSBORN AND G. GOODMAN, ANL, AND TESTED AB 4231 C BY R. LAWSON AND A. SMITH, ANL. WHEN USING ON THE PC WITH LAHEY AB 4232 C FORTRAN USE THE VAX SWITCH IN COMPILATION. AB 4233 C AB 4234 C COMPUTES CLEBSCH-GORDAN AND 3-J COEFICENTS. AB 4235 C AB 4236 C THIS ROUTINE COMPUTES THE CLEBSH GORDAN OR 3-J COEFICENT FOR AB 4237 C A GIVEN SET OF J'S AND M'S. THE INPUT CONSISTS OF 6 INTEGERS AB 4238 C THAT ARE TWICE THE VALUES OF THE J'S AND M'S. IN THIS MANNER AB 4239 C HALF-INTEGER ANGULAR MOMENTA CAN BE ACCOMMODATED. AB 4240 C AB 4241 C A FACTORIZATION OF THE RACAH SUM SUGGESTED BY J. G. WILLS, AB 4242 C COMPUTER PHYSICS COMM. 2, 381 (1971) IS USED. THE REQUIRED AB 4243 C FACTORIALS THAT MULTIPLY THE SUM ARE FOUND IN ONE OF 3 WAYS: AB 4244 C FOR J1+J2+J3 < 96, A TABLE OF SQRT(FACTORIAL) IS USED; AB 4245 C FOR 95 < J1+J2+J3 < 1000, A TABLE OF LOG(FACTORIAL) IS USED; AB 4246 C FOR 1000 <= J1+J2+J3, THE LOG GAMMA FUNCTION IS USED. AB 4247 C AB 4248 C THESE CHOICES REPRESENT REASONABLE TRADE OFFS BETWEEN SIZE AND AB 4249 C SPEED CONSIDERATIONS. BY RECOMPILING THE BLOCK DATA PROGRAMS AB 4250 C FOR THE /FACTRL/ OR /LOGFAC/ COMMON BLOCKS, ONE CAN CHANGE AB 4251 C THE ABOVE BOUNDRIES TO EITHER REDUCE CORE (IF ONE IS NOT AB 4252 C INTERESTED IN LARGE J'S) OR INCREASE THE SPEED FOR LARGE J'S. AB 4253 C AB 4254 C THE MAGNITUDE OF THE J'S AND M'S THAT CAN BE ACCOMMODATED BY AB 4255 C THIS ROUTINE IS DETERMINED BY CANCELLATIONS IN THE AB 4256 C RACAH SUM. IF ALL THREE J'S GET LARGE, SEVERE CANCELLATION AB 4257 C SETS IN FOR EACH J OF THE ORDER OF 75, WHILE OVERFLOWS BEGIN AB 4258 C TO OCCUR FOR THE J'S OF THE ORDER OF 150. HOWEVER IF ONE OF AB 4259 C THE J'S IS HELD SMALL, THE PRECISION REMAINS GOOD FOR VERY AB 4260 C LARGE VALUES OF THE OTHER TWO J'S AND THERE ARE NO OVERFLOW AB 4261 C PROBLEMS (THE LARGEST VALUES TRIED WERE 2000). AB 4262 C AB 4263 C A SPECIAL CASE IS USED FOR M1 = M2 = M3 = 0. ALL THREE J'S AB 4264 C MAY THEN BE VERY LARGE. AB 4265 C AB 4266 C PRECISIONS WERE DETERMINED BY COMPARING THE RESULTS TO A AB 4267 C QUADRUPOLE PRECISION CLEBSCH GORDAN ROUTINE. IT IS NOT AB 4268 C SIGNIFICANT THAT J3 WAS HELD SMALL; ANY OF THE J'S MAY BE KEPT AB 4269 C SMALL WITH THE SAME TIMING AND RELATIVE ERROR RESULTS. AB 4270 C AB 4271 C THE LONG EXECUTION TIMES FOR THE J1, J2 > 500 ENTRIES ARE AB 4272 C DUE TO THE USE OF THE LOG GAMMA FUNCTION. THEY MAY BE REDUCED AB 4273 C BY INCREASING THE SIZE OF THE /LOGFAC/ TABLE. AB 4274 C AB 4275 C THERE ARE THREE ENTRIES: AB 4276 C AB 4277 C CLEBSH (2*J1, 2*J2, 2*M1, 2*M2, 2*J3, 2*M3) RETURNS A AB 4278 C DOUBLE PRECISION CLEBSCH-GORDAN COEFICENT. AB 4279 C THREEJ (2*J1, 2*J2, 2*J3, 2*M1, 2*M2, 2*M3) RETURNS A AB 4280 C DOUBLE PRECISION 3-J SYMBOL (M3 = -(M1+M2)). AB 4281 C COFCG (2*J1, 2*J2, 2*M1, 2*M2, 2*J3, 2*M3) RETURNS A AB 4282 C SINGLE PRECISION CLEBSCH-GORDAN COEFICENT. AB 4283 C AB 4284 C IN ALL CASES THE TRIANGLE INEQUALITIES, THE REQUIREMENTS THAT AB 4285 C EACH (J, M) SATISFY |M| <= J, AND THE REQUIREMENT THAT AB 4286 C M1+M2 = M3 (FOR 3-J M1+M2+M3 = 0) ARE CHECKED. IF THEY ARE AB 4287 C VIOLATED, 0 IS RETURNED. HOWEVER NO CHECK IS MADE TO VERIFY AB 4288 C THAT EACH (J, M) PAIR IS EITHER 1/2 INTEGER OR INTEGER NOR AB 4289 C THAT J1+J2+J3 IS INTEGER. THE USER MUST INSURE THAT AB 4290 C 2*J+2*M IS EVEN AND THAT 2*J1+2*J2+2*J3 IS EVEN. AB 4291 C IF THIS IS NOT SO, MEANINGLESS RESULTS WILL BE RETURNED. AB 4292 C AB 4293 C CORE REQUIREMENTS (BASE 10): AB 4294 C AB 4295 C CLEBSH 4088 BYTES AB 4296 C /FACTRL/ 798 MAY BE REDUCED AB 4297 C /LOGFAC/ 8028 MAY BE REDUCED OR INCREASED AB 4298 C DLGAMA 1008 (NOT KNOWN FOR VAX/VMS VERSION) AB 4299 C TOTAL 13,922 AB 4300 C AB 4301 C ALSO "DSQRT", "DLOG", "DEXP" AND THE FORTRAN I/O PACKAGE ARE USED AB 4302 C SINCE THESE ARE LIKELY TO BE USED BY OTHER PARTS OF YOUR AB 4303 C PROGRAM, THEY ARE NOT INCLUDED IN THE ABOVE (THE FORTRAN I/O AB 4304 C PACKAGE IS USED BY DLOG, DEXP, AND DSQRT). THE /FACTRL/ AB 4305 C AND /LOGFAC/ COMMON BLOCKS AND THE "DLGAMA" FUNCTION WILL BE AB 4306 C SHARED WITH "SIXJ" AND "RACAH" SHOULD YOU ALSO USE THEM. AB 4307 C AB 4308 C IN THE VAX/VMS VERSION, THE NAG ROUTINE S14ABF IS USED WITHIN AB 4309 C THE DUMMY ROUTINE DLGAMA. THIS MAY BE EASILY CHANGED TO USE AB 4310 C ANOTHER LIBRARY ROUTINE. IF TRANSFERING THIS PROGRAM TO AB 4311 C ANOTHER SITE, IT IS IMPORTANT TO CHECK THAT S14ABF IS THE AB 4312 C DOUBLE PRECISION VERSION (RATHER THAN S14ABE) IN THE LOCAL AB 4313 C NAG LIBRARY. THE SOURCE OF DLGAMA IS AT THE END OF THIS FILE. AB 4314 C AB 4315 IMPLICIT INTEGER*4 (A-C, I-Z), REAL*8 (D-H) AB 4316 REAL*8 SUM,ANSWER AB 4317 REAL*8 CLEBSH, THREEJ, THRJ AB 4318 REAL*8 DLGAMA AB 4319 COMMON /FACTRL/ MAXFAC, ISPACE, FACTBL(97) AB 4320 REAL*8 LF AB 4321 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) AB 4322 C FOLLOWING ARE THE VAX FORTRAN FUNCTIONS THAT ARE USED. AB 4323 C BTEST CHECKS TO SEE IF A BIT IS ON. AB 4324 C BTEST(I,0) CHECKS FOR I BEING ODD, BTEST(I,1) CHECKS FOR I/2 AB 4325 C BEING ODD. AB 4326 C ISHFT(I,-1) SHIFTS THE BITS IN I ONE TO THE RIGHT = /2 AB 4327 LOGICAL DBLSW, THRESW, BTEST AB 4328 REAL*4 COFCG AB 4329 C FOLLOWING ARRAYS ARE DEFINED TO ALLOW USE OF LOOPS TO SHORTEN AB 4330 C CODE. AB 4331 DIMENSION DRAY(9) AB 4332 EQUIVALENCE (DRAY(1), DA1), (DRAY(2), DA2), (DRAY(3), DA3), AB 4333 1 (DRAY(4), DY1), (DRAY(5), DX2), (DRAY(6), DY2), (DRAY(7), DX1), AB 4334 2 (DRAY(8), DZ1), (DRAY(9), DZ2) AB 4335 C FOLLOWING DUMMY EXTERNAL CAUSES THE FACTORIAL TABLES TO BE DEFINEDAB 4336 EXTERNAL FACDUM, LOGDUM AB 4337 C CLEBSH IS THE ANL-AMD COMPATIBLE ENTRY POINT AB 4338 THRESW = .FALSE. AB 4339 DBLSW = .TRUE. AB 4340 GO TO 10 AB 4341 C COFCG IS SINGLE PRECISION ENTRY AB 4342 ENTRY COFCG (A, B, X, Y, CIN, ZIN) AB 4343 THRESW = .FALSE. AB 4344 DBLSW = .FALSE. AB 4345 10 Z = ZIN AB 4346 20 C = CIN AB 4347 IF (Z .EQ. X+Y) GO TO 120 AB 4348 110 CLEBSH=0.0 AB 4349 RETURN AB 4350 C X1 = J1 + M1 ; ETC. AB 4351 C THE FOLLOWING ISHFT FUNCTIONS EFFECT A DIVIDE BY 2 AB 4352 C TO GET FROM THE 2*J STUFF TO J STUFF SINCE THE 3 AB 4353 C (J+M)'S MUST BE INTEGERS. AB 4354 120 X1 = ISHFT(A+X, -1) AB 4355 Y1 = ISHFT(B+Y, -1) AB 4356 Z1 = ISHFT(C+Z, -1) AB 4357 AB 4358 C THE ISHFT INSTRUCTION IS A LOGICAL SHIFT. THUS IT CONVERTS AB 4359 C A NEGATIVE NUMBER INTO A LARGE POSITIVE NUMBER WHICH WILL LOUSE AB 4360 C UP THE TRIANGLE CONDITION CHECKS. HERE WE CHECK TO SEE IF ANY OF AB 4361 C THE THREE NUMBERS HAD SIGN BITS THAT WERE SHIFTED INTO THE FIRST AB 4362 C POSITION. IF SO THEN THE CORRESPONDING M WAS GREATER THAN J SO AB 4363 C WE JUST RETURN 0. ALL OF THIS IS TO AVOID DIVIDES BY 2 WHICH ARE AB 4364 C VERY SLOW ON THE IBM/195. AB 4365 C T30 IS THE LOCATION OF THE SHIFTED SIGN BIT AND IS 30 FOR THE AB 4366 C VAX FORTRAN USED HERE AB 4367 T30 = 30 AB 4368 IF (BTEST(X1,T30).OR.BTEST(Y1,T30).OR.BTEST(Z1,T30)) GO TO 110 AB 4369 C X2 = J1 - M1 ; ETC AB 4370 X2 = X1 - X AB 4371 Y2 = Y1 - Y AB 4372 Z2 = Z1 - Z AB 4373 C R = J1+J2+J3 + 1 AB 4374 R = X1 + Y1 + Z2 + 1 AB 4375 C A(I) = J1+J2+J3 - 2J(I) ; A1 = -J1 + J2 + J3 , ETC. AB 4376 A1 = R-1 - A AB 4377 A2 = R-1 - B AB 4378 A3 = R-1 - C AB 4379 C B1 = J3 - J1 - M2 ; B2 = J3 - J2 + M1 AB 4380 B1 = A1 - Y1 AB 4381 B2 = A2 - X2 AB 4382 C WE WILL NEED THESE FLOATING POINT NUMBERS AT VARIOUS PLACES AB 4383 DA1 = A1 AB 4384 DA2 = A2 AB 4385 DA3 = A3 AB 4386 DY1 = Y1 AB 4387 DX2 = X2 AB 4388 DB1 = DA1 - DY1 AB 4389 DB2 = DA2 - DX2 AB 4390 SUM = 1 AB 4391 NMIN = MAX0 (0, -B1, -B2) AB 4392 NMAX = MIN0 (A3, X2, Y1) AB 4393 C THIS ONE CHECK MAKES SURE OF THE FOLLOWING AB 4394 C 1) ALL 3 TRIANGLE RULES AB 4395 C 2) |M| <= J FOR ALL 3 CASES AB 4396 C 3) J >= 0 FOR ALL 3 CASES AB 4397 IF (NMAX - NMIN) 110, 300, 200 AB 4398 C IS IT THE ALL M = 0 CASE AB 4399 200 IF (IABS(X)+IABS(Y) .EQ. 0) GO TO 500 AB 4400 C PREPARE TO DO THE SUM AB 4401 DX = NMAX AB 4402 E1 = -DX AB 4403 E2 = -DB1-DX AB 4404 E3 = -DB2 - DX AB 4405 E4 = DA3 - (DX-1) AB 4406 E5 = DX2 - (DX-1) AB 4407 E6 = DY1 - (DX-1) AB 4408 F1 = E1*E2*E3 AB 4409 F4 = E4*E5*E6 AB 4410 NMAXM2 = NMAX - 2 AB 4411 SUM = 1 + F4/F1 AB 4412 IF (NMAXM2 .LT. NMIN) GO TO 300 AB 4413 G1 = (E1+1)*(E2+1)*(E3+1) - F1 AB 4414 G4 = (E4+1)*(E5+1)*(E6+1) - F4 AB 4415 H1 = (E1+2)*(E2+2)*(E3+2) - G1 - G1 - F1 AB 4416 H4 = (E4+2)*(E5+2)*(E6+2) - G4 - G4 - F4 AB 4417 C COMPUTE THE SUM IN THE RACAH FORMULA AB 4418 DO 259 N = NMIN, NMAXM2 AB 4419 F1 = F1 + G1 AB 4420 F4 = F4 + G4 AB 4421 G1 = G1 + H1 AB 4422 G4 = G4 + H4 AB 4423 H1 = H1 + 6 AB 4424 H4 = H4 + 6 AB 4425 SUM = 1 + SUM*(F4/F1) AB 4426 259 CONTINUE AB 4427 C NOW WE NEED THE FACTORIALS OUTSIDE THE SUM AB 4428 300 IF (R .LE. MAXFAC) GO TO 400 AB 4429 C SOME OF THE FACTORIALS WILL BE TOO LARGE TO USE THE TABLE. AB 4430 C WE USE ONE OF TWO METHODS* AB 4431 C 1) FOR MODERATELY SIZED J'S WE USE A TABLE OF AB 4432 C LOG FACTORIALS. AB 4433 C 2) FOR TRUELY LARGE J'S WE USED THE LOG GAMMA FUNCTION AB 4434 C TO GET THE LOGS OF THE FACTORIALS. AB 4435 IF (R .GT. MAXLF) GO TO 350 AB 4436 C THIS IS THE MODERATELY LARGE REGION - USE TABLE AB 4437 E = LF(1+A3) - LF(1+NMIN) - LF(1+A3-NMIN) AB 4438 1 + LF(1+A1) - LF(1+B1+NMIN) - LF(1+Y1-NMIN) AB 4439 2 + LF(1+A2) - LF(1+B2+NMIN) - LF(1+X2-NMIN) AB 4440 E2 = .5*(-LF(1+A1) - LF(1+A2) - LF(1+A3) + LF(1+X1) + LF(1+X2) AB 4441 1 + LF(1+Y1) + LF(1+Y2) + LF(1+Z1) + LF(1+Z2) - LF(1+R) AB 4442 2 + LF(2+C) - LF(1+C) ) AB 4443 IF (DABS(E) .GT. 40) GO TO 330 AB 4444 C SUM*E**2 MUST BE AN INTEGER. AB 4445 C SINCE E IS NOT VERY LARGE IS IS LIKELY TO BE MEANINGFUL TO AB 4446 C ATTEMPT TO FORCE THE INTEGER RESULT. AB 4447 SUM = ANINT(SUM*DEXP(E)) AB 4448 ANSWER = DEXP(E2)*SUM AB 4449 GO TO 450 AB 4450 C HERE E IS LARGE AND AN ATTEMPT TO INTERGERIZE SUM*EXP(E) AB 4451 C WOULD NOT BE SIGNIFICANT ON A 16 PLACE MACHINE. INSTEAD WE AB 4452 C SPREAD THE E FACTOR AMOUNGST THE OTHER STUFF IN AN ATTEMPT TO AB 4453 C AVOID OVERFLOWS. AB 4454 330 E = E + E2 AB 4455 ANSWER = DEXP(E)*SUM AB 4456 GO TO 450 AB 4457 C FOR LARGE VALUES OF J, WE USE THE LOG GAMMA FUNTION TO DIRECTLY AB 4458 C FIND THE LOG OF THE COMPLETE MESS OF OUTSIDE FACTORIALS. AB 4459 C HERE WE AVOID INTEGER TO DOUBLE CONVERSIONS AB 4460 350 DX1 = DA2 + DA3 - DX2 AB 4461 DC = C AB 4462 DN = NMIN AB 4463 DZ1 = DX1 + DY1 - DA3 AB 4464 DY2 = DA1 + DA3 - DY1 AB 4465 DZ2 = DC - DZ1 AB 4466 E = DLOG(DC+1) - DLGAMA(2+DX1+DY1+DZ2) AB 4467 DO 369 I = 1, 9 AB 4468 E = E + DLGAMA(1+DRAY(I)) AB 4469 369 CONTINUE AB 4470 E = .5*E AB 4471 DA1 = DB1 + (DN+1) AB 4472 DA2 = DB2 + (DN+1) AB 4473 DA3 = DA3 - (DN-1) AB 4474 DY1 = DY1 - (DN-1) AB 4475 DX2 = DX2 - (DN-1) AB 4476 DY2 = (DN+1) AB 4477 DO 379 I = 1, 6 AB 4478 E = E - DLGAMA(DRAY(I)) AB 4479 379 CONTINUE AB 4480 ANSWER = DEXP(E) * SUM AB 4481 GO TO 450 AB 4482 C WE CAN USE THE FACTORIAL TABLES AND NOT WORRY AB 4483 400 F1 = FACTBL(1+A1) AB 4484 F2 = FACTBL(1+A2) AB 4485 F3 = FACTBL(1+A3) AB 4486 C HERE WE FORCE THE SUM OF PRODUCTS OF 3 BINOMIAL AB 4487 C COEFFICENTS TO BE AN INTEGER AB 4488 E = (F3/(FACTBL(1+NMIN)*FACTBL(1+A3-NMIN))) AB 4489 1 * (F2/(FACTBL(1+X2-NMIN)*FACTBL(1+B2+NMIN))) AB 4490 2 * (F1/(FACTBL(1+Y1-NMIN)*FACTBL(1+B1+NMIN))) AB 4491 SUM = ANINT(E*SUM*E) AB 4492 C FOR THE FOLLOWING NOTE THAT R = J1+J2+J3 + 1 AB 4493 ANSWER = SUM * (FACTBL(1+X1)*FACTBL(1+X2)/(F3*F2)) AB 4494 1 * (FACTBL(1+Y1)*FACTBL(1+Y2)/F1) AB 4495 2 * (FACTBL(2+C)/FACTBL(1+C)) AB 4496 3 * (FACTBL(1+Z1)*FACTBL(1+Z2)/FACTBL(1+R)) AB 4497 450 IF (BTEST(NMIN,0)) ANSWER = -ANSWER AB 4498 GO TO 800 AB 4499 C USE SPECIAL CASE FOR M1 = M2 = M3 = 0 SINCE RACAH IS AB 4500 C NOT TRIVIAL FOR THAT CASE AB 4501 C RESULT IS 0 IF J1+J2+J3 IS ODD AB 4502 500 IF (.NOT.BTEST(R,0)) GO TO 110 AB 4503 JSUM = R-1 AB 4504 IF (R .GT. MAXFAC) GO TO 550 AB 4505 C USE THE FACTORIAL TABLES AB 4506 ANSWER = ((FACTBL(1+A1)*FACTBL(1+A2))/FACTBL(1+R)) AB 4507 1 * ((FACTBL(2+C)*FACTBL(1+A3))/FACTBL(1+C)) AB 4508 2 * (FACTBL(1+JSUM/2)/ AB 4509 3 (FACTBL(1+A1/2)*FACTBL(1+A2/2)*FACTBL(1+A3/2)) )**2 AB 4510 GO TO 570 AB 4511 C USE LOG(FACTORIAL) AB 4512 C IN THE FOLLOWING WE USE ISHFT( ,-1) TO MAKE A /2. AB 4513 550 IF (R .GT. MAXLF) GO TO 560 AB 4514 E = .5 * (LF(1+A1) + LF(1+A2) + LF(1+A3) AB 4515 1 + LF(2+C) - LF(1+C) - LF(1+R) ) AB 4516 2 - LF(1+ISHFT(A1,-1)) - LF(1+ISHFT(A2,-1)) - LF(1+ISHFT(A3,-1)) AB 4517 3 + LF(1+ISHFT(JSUM,-1)) AB 4518 GO TO 565 AB 4519 560 DJSUM = DA1 + DA2 + DA3 AB 4520 E = DLOG(DFLOAT(C+1)) - DLGAMA(DJSUM+2) AB 4521 E2 = -DLGAMA(.5*DJSUM+1) AB 4522 DO 564 I = 1, 3 AB 4523 E = E + DLGAMA(1+DRAY(I)) AB 4524 E2 = E2 + DLGAMA(1 + .5*DRAY(I)) AB 4525 564 CONTINUE AB 4526 E = .5*E - E2 AB 4527 565 ANSWER = DEXP(E) AB 4528 C GET PHASE AB 4529 570 IF (BTEST(A3,1)) ANSWER = -ANSWER AB 4530 C DETERMINE THE REQUESTED OUTPUT MODE AB 4531 C WAS A 3-J REQUESTED AB 4532 800 IF (THRESW) GO TO 950 AB 4533 810 IF (DBLSW) GO TO 850 AB 4534 C ROUND THE ANSWER TO SINGLE PRECISION AB 4535 COFCG = REAL(ANSWER) AB 4536 RETURN AB 4537 C DOUBLE PRECISION ENTRY USED AB 4538 850 CLEBSH = ANSWER AB 4539 RETURN AB 4540 C AB 4541 C THIS IS AVAILABLE ONLY IN DOUBLE PRECISION AB 4542 ENTRY THRJ(A,B,CIN,X,Y,ZIN) AB 4543 ENTRY THREEJ (A, B, CIN, X, Y, ZIN) AB 4544 Z = -ZIN AB 4545 THRESW = .TRUE. AB 4546 DBLSW = .TRUE. AB 4547 GO TO 20 AB 4548 C NOW PUT IN THE 3-J FACTOR AB 4549 950 TEMP = A2-Z2 AB 4550 IF (BTEST(TEMP,0)) ANSWER = -ANSWER AB 4551 IF (C .GT. MAXFAC-1) GO TO 970 AB 4552 ANSWER = ANSWER * (FACTBL(1+C)/FACTBL(2+C)) AB 4553 GO TO 810 AB 4554 970 ANSWER = ANSWER / DSQRT(C+1.D0) AB 4555 GO TO 810 AB 4556 END AB 4557 C AB 4558 FUNCTION SIXJ (A, B, C, X, Y, Z) AB 4559 C AB 4560 C COMPUTES 6-J AND RACAH COEFFICIENTS. AB 4561 C AB 4562 C THIS ROUTINE COMPUTES THE 6-J OR RACAH COEFFICIENT FOR AB 4563 C A GIVEN SET OF J'S. THE INPUT CONSISTS OF 6 INTEGERS THAT AB 4564 C ARE TWICE THE VALUES OF THE J'S. IN THIS MANNER AB 4565 C HALF-INTEGER ANGULAR MOMENTA CAN BE ACCOMODATED. AB 4566 C FOR THE FOLLOWING DISCUSSION CONSIDERS THE 6-J COEFFICENT: AB 4567 C ( J1 J2 J3 ) AB 4568 C ( J4 J5 J6 ) AB 4569 C A FACTORIZATION OF THE RACAH SUM SUGGESTED BY J. G. WILLS, AB 4570 C COMPUTER PHYSICS COMM. 2, 381 (1971) IS USED. THE REQUIRED AB 4571 C FACTORIALS THAT MULTIPLY THE SUM ARE FOUND IN ONE OF 3 WAYS: AB 4572 C FOR J1+J2+J4+J5 < 96, A TABLE OF SQRT(FACTORIAL) IS USE AB 4573 C FOR 95 < J1+J2+J4+J5 < 1000, A TABLE OF LOG(FACTORIAL) IS USED; AB 4574 C FOR 1000 <= J1+J2+J4+J5, LOG GAMMA IS USED. AB 4575 C THESE CHOICES REPRESENT REASONABLE TRADE OFFS BETWEEN SIZE AND AB 4576 C SPEED CONSIDERATIONS. BY RECOMPILING THE BLOCK DATA PROGRAMS AB 4577 C FOR THE /FACTRL/ OR /LOGFAC/ COMMON BLOCKS, ONE CAN CHANGE AB 4578 C THE ABOVE BOUNDRIES TO EITHER REDUCE CORE (IF ONE IS NOT AB 4579 C INTERESTED IN LARGE J'S) OR INCREASE THE SPEED FOR LARGE J'S. AB 4580 C AB 4581 C THE MAGNITUDE OF THE J'S AND M'S THAT CAN BE ACCOMODATED BY AB 4582 C THIS ROUTINE IS DETERMINED BY CANCELLATIONS IN THE AB 4583 C RACAH SUM. IF ALL SIX J'S GET LARGE, SEVERE CANCELLATION SETS AB 4584 C IN FOR EACH J OF THE ORDER OF 100. HOWEVER IF THREE OF THE J'S AB 4585 C ARE HELD SMALL, THE PRECISION REMAINS GOOD FOR VERY LARGE AB 4586 C VALUES OF THE OTHER THREE J'S AND THERE ARE NO OVERFLOW PROBLEMS AB 4587 C (THE LARGEST VALUES TRIED WERE 500). AB 4588 C AB 4589 C NO EVALUATION OF 6-J COEFICENTS THAT WERE TRIVIALLY AB 4590 C ZERO WERE INCLUDED IN THE ABOVE RESULTS. THE LONG EXECUTION AB 4591 C TIMES IN THE LAST LINE OF THE TABLE ARE DUE TO THE USE OF THE AB 4592 C LOG GAMMA FUNCTION. THEY MAY BE MADE COMPARABLE TO THE TIMES IN AB 4593 C THE PREVIOUS LINE BY INCREASING THE SIZE OF THE /LOGFAC/ AB 4594 C TABLE. AB 4595 C AB 4596 C THERE ARE THREE ENTRIES: AB 4597 C AB 4598 C SIXJ (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6) RETURNS THE AB 4599 C DOUBLE PRECISION 6-J COEFICENT. AB 4600 C ( J1 J2 J3 ) AB 4601 C ( J4 J5 J6 ) AB 4602 C RACAH (2*J1, 2*J2, 2*J5, 2*J4, 2*J3, 2*J6) RETURNS THE AB 4603 C DOUBLE PRECISION RACAH SYMBOL AB 4604 C W (J1, J2, J5, J4; J3, J6) AB 4605 C COF6J (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6) RETURNS A AB 4606 C PROPERLY ROUNDED SINGLE PRECISION 6-J COEFICENT. AB 4607 C IN ALL CASES THE TRIANGLE INEQUALITIES ARE CHECKED. IF THEY ARE AB 4608 C VIOLATED, 0 IS RETURNED. HOWEVER NO CHECK IS MADE TO VERIFY AB 4609 C THAT J1+J2+J3, J4+J2+J6, J1+J5+J6, AND J4+J5+J3 ARE AB 4610 C INTEGERS. THE USER MUST INSURE THAT 2*J1 + 2*J2 + 2*J3, ETC, AB 4611 C ARE EVEN. IF THIS IS NOT SO MEANINGLESS RESULTS WILL BE RETURNED AB 4612 C AB 4613 C CORE REQUIREMENTS (BASE 10): AB 4614 C SIXJ 4000 BYTES AB 4615 C /FACTRL/ 798 MAY BE MADE SMALLER AB 4616 C /LOGFAC/ 8028 MAY BE MADE SMALLER OR LARGER AB 4617 C DLGAMA 1008 AB 4618 C TOTAL 13,834 AB 4619 C AB 4620 C IN ADDITION "DEXP" AND THE FORTRAN I/O PACKAGE WILL BE USED. AB 4621 C SINCE THESE ARE LIKELY TO BE USED BY OTHER PARTS OF YOUR AB 4622 C PROGRAM, THEY ARE NOT INCLUDED IN THE ABOVE (THE FORTRAN I/O AB 4623 C PACKAGE IS CALLED ONLY BY DEXP). THE /FACTRL/ AB 4624 C AND /LOGFAC/ COMMON BLOCKS AND THE "DLGAMA" FUNCTION WILL BE AB 4625 C SHARED WITH "CLEBSH" AND "THREEJ" SHOULD YOU ALSO USE THEM. AB 4626 C AB 4627 IMPLICIT INTEGER*4 (A-C, I-Z), REAL*8 (D-H) AB 4628 REAL*8 SUM, ANSWER, SIXJ, RACAH, DLGAMA AB 4629 REAL*4 COF6J AB 4630 LOGICAL DBLSW, RACHSW, BTEST AB 4631 COMMON /FACTRL/ MAXFAC, ISPACE, FACTBL(97) AB 4632 REAL*8 LF AB 4633 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) AB 4634 C THE FOLLOWING FAKE EXTERNALS DRAG IN THE REQUIRED BLOCK DATAS AB 4635 C FOR THE ABOVE COMMON BLOCKS AB 4636 EXTERNAL FACDUM, LOGDUM AB 4637 CCCC COMMON /NUMBLK/ NUMIT, IBIG, INOTSO, ILF, E, SUM AB 4638 C WE USE THE FOLLOWING VAX FORTRAN FUNCTIONS: AB 4639 C BTEST - TESTS TO SEE IF A BIT IS ON. BTEST(I, 0) IS TRUE AB 4640 C IF I IS ODD. AB 4641 C ISHFT(N,-1) SHIFTS THE BITS IN N ONE TO THE RIGHT = /2 AB 4642 DIMENSION DRAY(8) AB 4643 EQUIVALENCE (DA1, DRAY(1)), (DA2, DRAY(2)), AB 4644 1 (DA3, DRAY(3)), (DA4, DRAY(4)), AB 4645 2 (DC, DRAY(5)), (DZ, DRAY(7)) AB 4646 C SIXJ IS THE DOUBLE PRECISON ENTRY POINT AB 4647 DBLSW = .TRUE. AB 4648 RACHSW = .FALSE. AB 4649 GO TO 100 AB 4650 C COF6J IS THE SINGLE PRECISION ENTRY POINT AB 4651 ENTRY COF6J (A, B, C, X, Y, Z) AB 4652 DBLSW = .FALSE. AB 4653 RACHSW = .FALSE. AB 4654 GO TO 100 AB 4655 C RACAH ENTRY IS DOUBLE PRECISION AB 4656 ENTRY RACAH (A, B, Y, X, C, Z) AB 4657 RACHSW = .TRUE. AB 4658 DBLSW = .TRUE. AB 4659 100 SUM=1 AB 4660 CCCC NUMIT = 0 AB 4661 A2 = ISHFT(X+Y-C, -1) AB 4662 A3 = ISHFT(A+Y-Z, -1) AB 4663 A4 = ISHFT(B+X-Z, -1) AB 4664 A1 = ISHFT(A+B-C, -1) AB 4665 C THE ISHFT IS A LOGICAL SHIFT AND HENCE CONVERTS NEGATIVE AB 4666 C QUANTITIES INTO VERY LARGE POSITIVE QUANTITIES. IF ANY OF AB 4667 C THE AI'S ARE NEGATIVE, THEN THE CORRESPONDING TRIANGLE AB 4668 C IS VIOLATED. WE TEST FOR THAT CASE HERE. AB 4669 IF (BTEST(A1,30) .OR. BTEST(A2,30) .OR. AB 4670 1 BTEST(A3,30) .OR. BTEST(A4,30)) GO TO 900 AB 4671 C B1 = J3 +J6 - J1 - J4 AB 4672 C B2 = J3 + J6 - J2 - J5 AB 4673 C R = J1 + J2 + J4 + J5 + 1 AB 4674 B1 = Y - A2 - A3 AB 4675 B2 = A3 - A1 + Z - Y AB 4676 R = A1 + A2 + C + 1 AB 4677 NMAX = MIN0 (A1, A2, A3, A4) AB 4678 NMIN = MAX0 (0, -B1, -B2) AB 4679 C NUMIT = NMAX - NMIN + 1 AB 4680 C CONVERT VARIOUS INTEGERS TO DOUBLE PRECISON FOR NOW AND AB 4681 C POSSIBLY LATER. AB 4682 DA1 = A1 AB 4683 DA2 = A2 AB 4684 DA3 = A3 AB 4685 DA4 = A4 AB 4686 DY = Y AB 4687 DZ = Z AB 4688 DC = C AB 4689 DB1 = DY - DA2 - DA3 AB 4690 DB2 = DA3 - DA1 + DZ - DY AB 4691 DR = DA1 + DA2 + DC + 1 AB 4692 DN = NMIN AB 4693 DX = NMAX AB 4694 C THIS ONE TEST CHECKS ALL 12 INEQUALITIES IMPLIED BY THE AB 4695 C 4 TRIANGLE CONDITIONS. AB 4696 IF (NMAX - NMIN) 900, 300, 200 AB 4697 200 D1 = DA1 - (DX-1) AB 4698 D2 = DA2 - (DX-1) AB 4699 D3 = DA3 - (DX-1) AB 4700 D4 = DA4 - (DX-1) AB 4701 D5 = -DX AB 4702 D6 = -DB1 - DX AB 4703 D7 = -DB2 - DX AB 4704 D8 = DR - (DX-1) AB 4705 E1 = D1*D2*D3*D4 AB 4706 E5 = D5*D6*D7*D8 AB 4707 NMAXM2 = NMAX-2 AB 4708 SUM = 1 + E1/E5 AB 4709 IF (NMAXM2 .LT. NMIN) GO TO 300 AB 4710 F1 = (D1+1)*(D2+1)*(D3+1)*(D4+1) - E1 AB 4711 F5 = (D5+1)*(D6+1)*(D7+1)*(D8+1) - E5 AB 4712 G1 = (D1+2)*(D2+2)*(D3+2)*(D4+2) - F1 - F1 - E1 AB 4713 G5 = (D5+2)*(D6+2)*(D7+2)*(D8+2) - F5 - F5 - E5 AB 4714 H1 = (D1+3)*(D2+3)*(D3+3)*(D4+3) - 3*(G1+F1) - E1 AB 4715 H5 = (D5+3)*(D6+3)*(D7+3)*(D8+3) - 3*(G5+F5) - E5 AB 4716 C COMPUTE THE SUM IN THE RACAH FORMULA AB 4717 DO 259 N = NMIN, NMAXM2 AB 4718 E1 = E1 + F1 AB 4719 E5 = E5 + F5 AB 4720 F1 = F1 + G1 AB 4721 F5 = F5 + G5 AB 4722 G1 = G1 + H1 AB 4723 G5 = G5 + H5 AB 4724 H1 = H1 + 24 AB 4725 H5 = H5 + 24 AB 4726 SUM = 1 + SUM*(E1/E5) AB 4727 259 CONTINUE AB 4728 C NOW WE NEED THE OUTSIDE FACTORIALS AB 4729 C WE USE ONE OF 3 METHODS DEPENDING ON THE SIZE OF J1+J2+J4+J5 AB 4730 C 1) A TABLE OF SQRT(FACTORIALS) AB 4731 C 2) A TABLE OF LN(FACTORIALS) AB 4732 C 3) LN(GAMMA) FUNCTION AB 4733 300 IF (R .GT. MAXFAC) GO TO 400 AB 4734 C FIRST THE STUFF WE FACTORED OUT OF THE SUM AB 4735 E = FACTBL(1+R-NMIN) / (FACTBL(1+NMIN) AB 4736 1 * FACTBL(1+B1+NMIN) * FACTBL(1+B2+NMIN) * FACTBL(1+A1-NMIN) AB 4737 2 * FACTBL(1+A2-NMIN) * FACTBL(1+A3-NMIN) * FACTBL(1+A4-NMIN) ) AB 4738 C SUM IS AN INTEGER NOW AB 4739 SUM = ANINT(E*SUM*E) AB 4740 C AND NOW THE OUTSIDE FACTORS AB 4741 DENOM = (FACTBL(2+A1+C)/(FACTBL(1+A1)*FACTBL(1+A4+B1) AB 4742 1 *FACTBL(1+A3+B2))) AB 4743 2 * (FACTBL(2+A2+C)/(FACTBL(1+A2)*FACTBL(1+A3+B1) AB 4744 3 *FACTBL(1+A4+B2))) AB 4745 4 * (FACTBL(2+A3+Z)/(FACTBL(1+A3)*FACTBL(1+A2+B1) AB 4746 5 *FACTBL(1+A1+B2))) AB 4747 6 * (FACTBL(2+A4+Z)/(FACTBL(1+A4)*FACTBL(1+A1+B1) AB 4748 7 *FACTBL(1+A2+B2))) AB 4749 ANSWER = SUM/(DENOM) AB 4750 GO TO 600 AB 4751 C TRY FOR LOG FACTORIAL TABLE AB 4752 400 IF (R .GT. MAXLF) GO TO 500 AB 4753 C IBIG = IBIG + 1 AB 4754 C ILF = ILF + 1 AB 4755 E = LF(1+R-NMIN) - LF(1+NMIN) AB 4756 1 - LF(1+B1+NMIN) - LF(1+B2+NMIN) - LF(1+A1-NMIN) AB 4757 2 - LF(1+A2-NMIN) - LF(1+A3-NMIN) - LF(1+A4-NMIN) AB 4758 E2 = .5 * ( LF(1+A1) + LF(1+A4+B1) + LF(1+A3+B2) AB 4759 1 - LF(2+A1+C) AB 4760 2 + LF(1+A2) + LF(1+A3+B1) + LF(1+A4+B2) - LF(2+A2+C) AB 4761 3 + LF(1+A3) + LF(1+A2+B1) + LF(1+A1+B2) - LF(2+A3+Z) AB 4762 4 + LF(1+A4) + LF(1+A1+B1) + LF(1+A2+B2) - LF(2+A4+Z) ) AB 4763 C AT THIS POINT IT WOULD BE POSSIBLE TO TRY TO INTERGERIZE AB 4764 C SUM*EXP(E). HOWEVER, TESTS SHOW THAT IN PRACTICE THIS WOULD AB 4765 C BE USEFUL (RESULT < 10**18) LESS THAN 1% OF THE TIME SO AB 4766 C WE DON'T BOTHER WITH IT. AB 4767 450 ANSWER = DEXP(E+E2) * SUM AB 4768 GO TO 600 AB 4769 C HERE THE J'S ARE VERY LARGE - WE USE LN(GAMMA) AB 4770 500 DRAY(6) = DC AB 4771 DRAY(8) = DZ AB 4772 E2 = 0 AB 4773 E = DLGAMA(1-DN+DR) - DLGAMA(1+DN) AB 4774 1 - DLGAMA(1+DN+DB1) - DLGAMA(1+DN+DB2) AB 4775 DO 549 I = 1, 4 AB 4776 E2 = E2 + DLGAMA(1+DRAY(I)) + DLGAMA(1+DB1+DRAY(I)) AB 4777 1 + DLGAMA(1+DB2+DRAY(I)) - DLGAMA(2+DRAY(I)+DRAY(4+I)) AB 4778 E = E - DLGAMA(1-DN+DRAY(I)) AB 4779 549 CONTINUE AB 4780 E = E + .5*E2 AB 4781 C IBIG = IBIG + 1 AB 4782 ANSWER = DEXP(E) * SUM AB 4783 C NOW GET THE SIGN CORRECT AB 4784 600 TEMP = NMIN + R AB 4785 IF (.NOT. BTEST(TEMP, 0)) ANSWER = -ANSWER AB 4786 C CALCULATION OF THE 6-J COMPLETED; WAS RACAH REQUESTED AB 4787 700 IF (.NOT. RACHSW) GO TO 800 AB 4788 C YES, CONVERT THE SIGN AB 4789 IF (.NOT. BTEST(R, 0)) ANSWER = -ANSWER AB 4790 C WHAT PRECISION WAS REQUESTED FOR THE RESULT AB 4791 800 IF (DBLSW) GO TO 850 AB 4792 C ROUND THE ANSWER TO SINGLE PRECISION AB 4793 COF6J = REAL(ANSWER) AB 4794 RETURN AB 4795 C DOUBLE PRECISION ENTRY POINT WAS USED AB 4796 850 SIXJ = ANSWER AB 4797 RETURN AB 4798 C THE TRIANGLE RULES ARE NOT SATISFIED AB 4799 900 COF6J = 0 AB 4800 IF (DBLSW) SIXJ = 0 AB 4801 RETURN AB 4802 END AB 4803 FUNCTION WIG9J ( J1, J2, J3, J4, J5, J6, J7, AB 4804 1 J8, J9 ) AB 4805 C AB 4806 C COMPUTES 9-J COEFICENTS. AB 4807 C AB 4808 C THIS ROUTNE COMPUTES THE WIGNER 9-J COEFICENT AB 4809 C AB 4810 C ( J1 J2 J3 ) AB 4811 C ( J4 J5 J6 ) AB 4812 C ( J7 J8 J9 ) AB 4813 C AB 4814 C THE INPUT CONSISTS OF 9 INTEGERS THAT ARE TWICE THE CORRESPONDING AB 4815 C J'S. IN THIS MANNER HALF-INTEGER ANGULAR MOMENTA CAN BE AB 4816 C ACCOMODATED. AB 4817 C AB 4818 C THE STANDARD METHOD (COMPUTING A SUM OF PRODUCTS OF THREE 6-J'S) AB 4819 C IS USED. ALL OF THE FACTORIALS COMMON TO ALL TERMS IN THE SUM ARE AB 4820 C FACTORED OUT AND EVALUATED ONLY ONCE. SIMILARLY ALL THE INTEGER TO AB 4821 C REAL CONVERSIONS AND OTHER SETUP REQUIRED FOR TH 6-J CALCULATIONS AB 4822 C ARE CARRIED OUT ONLY ONCE. TO EVALUATE THE 6-J'S A FACTORIZATION O AB 4823 C THE RACAH SUM SUGGESTED BY J. G. WILLS, COMPUTER PHYSICS COMM. 2, 38AB 4824 C (1971) IS USED. THE LOGARITHMS OF THE REQUIRED FACTORIALS ARE FOUNDAB 4825 C EITHER FROM A TABLE OF LOG(FACTORIAL) OR BY USING THE LOG GAMMA AB 4826 C FUNCTION. IN THE PRESENT IMPLIMENTATION, THE TABLE CONTAINS THE AB 4827 C FIRST 1001 FACTORIALS. THIS SIZE MAY BE REDUCED (TO SAVE CORE) OR AB 4828 C INCREASED (TO SAVE TIME FOR VERY LARGE J'S) BY RECOMPILING THE AB 4829 C /LOGFAC/ COMMON BLOCK. AB 4830 C AB 4831 C THE MAGNITUDE OF THE J'S THAT CAN BE ACCOMODATED BY THIS ROUTINE AB 4832 C IS DETERMINED BY CANCELLATIONS IN THE RACAH AND 9-J SUMS. FAIRLY AB 4833 C SEVERE CANCELLATIONS OCCUR WHEN ALL NINE J'S ARE OF THE ORDER OF 50.AB 4834 C COMPLETE LOSS OF SIGNIFICANCE AND EXTENSIVE NUMERIC OVERFLOWS OCCUR AB 4835 C WHEN ALL THE J'S ARE 75. HOWEVER, IF FIVE OF THE J'S REMAIN SMALL AB 4836 C WHILE THE OTHER FOUR GET LARGE, THE THE LARGE J'S MAY GET VERY LARGEAB 4837 C AB 4838 C THE NUMBER OF TERMS IN THE 9-J SUM IS AB 4839 C N = MIN ( J1+J9 , J2+J6 , J4+J8 ) - AB 4840 C MAX ( |J1-J9| , |J2-J6| , |J4-J8| ) + 1 AB 4841 C NO ATTEMPT IS MADE TO MINIMIZE N BY INTERCHANGING ROWS OR COLUMNS. AB 4842 C IT MAY BE ADVANTAGEOUS TO THE USER TO ARRANGE THE J'S SUCH THAT N AB 4843 C IS MINIMIZED (AT LEAST APPROXIMATELY). IN PARTICULAR IT SHOULD BE AB 4844 C NOTICED THAT J3, J5, AND J7 ARE NOT USED IN DETERMINING N SO AB 4845 C THAT A ZERO VALUE OF ONE OF THESE IS "WASTED". AB 4846 C AB 4847 C ERRORS WERE DETERMINED BY COMPARASON WITH QUADRUPOLE PRECISION AB 4848 C 9-J VALUES. NONE OF THE 9-J'S EVALUATED WERE TRIVIALLY ZERO. AB 4849 C AB 4850 C USAGE: AB 4851 C AB 4852 C WIG9J (2*J1, 2*J2, 2*J3, 2*J4, 2*J5, 2*J6, 2*J7, 2*J8, 2*J9) AB 4853 C AB 4854 C RETURNS THE DOUBLE PRECISION 9-J COEFICENT. THE TRIANGLE RULES AB 4855 C ARE CHECKED AND 0 IS RETURNED IF THEY ARE VIOLATED. HOWEVER NO AB 4856 C CHECK IS MADE FOR INVALID COMBINATIONS OF HALF-INTEGER AND AB 4857 C INTEGER J'S. THE USER MUST INSURE THAT TWICE THE SUM OF THE J'S AB 4858 C IN EACH ROW AND COLUMN IS EVEN. IF THIS IS NOT SO, MEANINGLESS AB 4859 C RESULTS WILL BE RETURNED. AB 4860 C AB 4861 C CORE REQUIREMENTS (BASE 10): AB 4862 C AB 4863 C WIG9J 4878 AB 4864 C /LOGFAC/ 8028 (MAY BE REDUCED OR INCREASED) AB 4865 C DLGAMA 1008 AB 4866 C TOTAL 13914 AB 4867 C AB 4868 C IN ADDITION "DEXP" AND THE FORTRAN I/O PACKAGE ARE REQUIRED. AB 4869 C THESE ARE NOT INCLUDED IN THE ABOVE SINCE YOU ARE LIKELY TO USE AB 4870 C THEM ANYWAY. /LOGFAC/ WILL BE SHARED WITH THE CLEBSCH AND AB 4871 C 6-J ROUTINES SHOULD YOU USE THEM. AB 4872 C AB 4873 IMPLICIT INTEGER*4 (A-C, I-R, T-Z), REAL*8 (D-H, S) AB 4874 REAL*8 WIG9J, DLGAMA AB 4875 REAL*8 LF AB 4876 COMMON /LOGFAC/ MAXLF, ISPLF, LF(1001) AB 4877 C THE FOLLOWING FAKE EXTERNALS DRAG IN THE REQUIRED BLOCK DATAS AB 4878 C FOR THE ABOVE COMMON BLOCK AB 4879 EXTERNAL LOGDUM AB 4880 C COMMON /NUMBLK/ NUMIT, NUM6J, BIGOUT, BIGIN, SUMLOG, SUMOUT AB 4881 C WE USE THE FOLLOWING VAX FORTRAN FUNCTIONS: AB 4882 C BTEST - TESTS TO SEE IF A BIT IS ON. BTEST(I, 0) IS TRUE AB 4883 C IF I IS ODD. AB 4884 C ISHFT(N,-1) SHIFTS THE BITS IN N ONE TO THE RIGHT = /2 AB 4885 LOGICAL BTEST AB 4886 REAL*8 ZERONE(2) / 0.D0, 1.D0 / AB 4887 DIMENSION J1S(5), J2S(5), J3S(5) AB 4888 DIMENSION AS(4, 3), BS(2, 3), DAS(4, 3), DBS(2, 3), AB 4889 1 MX2S(3), MN2S(3), MN1S(3), RS(3), DRS(3), AB 4890 2 DMN1S(3), DMN2S(3), DMX2S(3), IDS(2, 3) AB 4891 DIMENSION SUMS(3) AB 4892 C FOLLOWING IS FACTORIAL(N-1) AB 4893 DLF(N) = DLGAMA(DFLOAT(N)) AB 4894 C NUMIT = 0 AB 4895 C NUM6J = 0 AB 4896 C BIGOUT = 0 AB 4897 C BIGIN = 0 AB 4898 C PICK UP THE J'S IN THE APPROPRIATE ORDER AB 4899 C NOTE THAT THE JIS ARRAYS REALLY CONTAIN 2*J AB 4900 J1S(1) = J1 AB 4901 J1S(2) = J6 AB 4902 J1S(3) = J8 AB 4903 J2S(1) = J2 AB 4904 J2S(2) = J4 AB 4905 J2S(3) = J9 AB 4906 J3S(1) = J3 AB 4907 J3S(2) = J5 AB 4908 J3S(3) = J7 AB 4909 C EXPAND THE ARRAYS TO ALLOW CYCLIC INDICES AB 4910 C AFTER THIS IS DONE THE 3 6-J'S ARE AB 4911 C ( J1S(I) J2S(I) J3S(I) ) AB 4912 C ( J1S(I+1) J2S(I+2) X ) AB 4913 C FOR I = 1, 2, 3. AB 4914 DO 59 I = 1, 2 AB 4915 J1S(I+3) = J1S(I) AB 4916 J2S(I+3) = J2S(I) AB 4917 J3S(I+3) = J3S(I) AB 4918 59 CONTINUE AB 4919 C DETERMINE THE RANGE OF 2*X AB 4920 XSTART = IABS(J2S(1) - J1S(2)) AB 4921 XEND = J2S(1) + J1S(2) AB 4922 XSUM = XEND AB 4923 DO 129 I = 2, 3 AB 4924 XSTART = MAX0 ( XSTART, IABS(J2S(I)-J1S(I+1)) ) AB 4925 XPIECE = J2S(I) + J1S(I+1) AB 4926 XEND = MIN0 ( XEND, XPIECE) AB 4927 XSUM = XSUM + XPIECE AB 4928 129 CONTINUE AB 4929 IF (XEND .LT. XSTART) GO TO 900 AB 4930 XSUM = XSUM - XEND AB 4931 C EXTRACT 1/2 INTEGER PART OF X AND CONVERT 2*X TO INTPART(X) AB 4932 XHALF = 0 AB 4933 IF ( BTEST(XSTART, 0) ) XHALF = 1 AB 4934 XSTART = ISHFT(XSTART, -1) AB 4935 XEND = ISHFT(XEND, -1) AB 4936 XSUM = ISHFT(XSUM, -1) AB 4937 DXHALF = ZERONE(XHALF+1) AB 4938 DX = XSTART - 1 AB 4939 XSUM = XSUM + 1 AB 4940 C NUMIT = XEND - XSTART + 1 AB 4941 C SETUP THE J1+J2-J3, ETC AB 4942 DO 159 I = 1, 3 AB 4943 C THE AS, FOR EACH 6-J THEY ARE AB 4944 C A1 = J1+J2-J3 AB 4945 C A2 = J4+J5-J3 AB 4946 C A3 = J1+J5-J6 AB 4947 C A4 = J4+J2-J6 AB 4948 C IN A3 AND A4 THE J6 = X IS LEFT OUT. AB 4949 AS(1,I) = ISHFT (J1S(I)+J2S(I)-J3S(I), -1) AB 4950 AS(2,I) = ISHFT (J1S(I+1)+J2S(I+2)-J3S(I), -1) AB 4951 AS(3,I) = ISHFT (J1S(I)+J2S(I+2), -1) AB 4952 AS(4,I) = ISHFT (J2S(I)+J1S(I+1), -1) AB 4953 C NOW MAKE SURE NONE OF THEM ARE NEGATIVE WHICH WOULD INDICATE AB 4954 C A VIOLATION OF THE TRIANGLE RULES. AB 4955 IF (BTEST(AS(1,I),30) .OR. BTEST(AS(2,I),30)) GO TO 900 AB 4956 C MAKE SURE NO SUPER LARGE INTEGERS SNEAK THROUGH AB 4957 C AS(3,I) = IBCLR(AS(3,I),30) AB 4958 C AS(4,I) = IBCLR(AS(4,I),30) AB 4959 C THE BS, FOR EACH 6-J THEY ARE AB 4960 C B1 = J3 + J6 - J1 - J4 AB 4961 C B2 = J3 + J6 - J2 - J5 AB 4962 C THE J6 = X IS LEFT OUT AB 4963 BS(1,I) = J2S(I+2) - AS(2,I) - AS(3,I) AB 4964 BS(2,I) = J1S(I) - AS(1,I) - AS(3,I) AB 4965 159 CONTINUE AB 4966 C SETUP THE QUANTITIES FOR EACH OF THE 3 6-J SUMS. AB 4967 C THESE INCLUDE THE STARTING MIN AND MAX VALUES, ETC. AB 4968 DO 299 I = 1, 3 AB 4969 MN1S(I) = MIN0(AS(1,I), AS(2,I)) AB 4970 MN2S(I) = MIN0(AS(3,I), AS(4,I)) AB 4971 MX2S(I) = -MIN0(BS(1,I), BS(2,I)) AB 4972 RS(I) = 1 + XHALF + AS(3,I) + AS(4,I) AB 4973 DO 239 J = 1, 4 AB 4974 DAS(J,I) = AS(J,I) AB 4975 239 CONTINUE AB 4976 DBS(1,I) = BS(1,I) AB 4977 DBS(2,I) = BS(2,I) AB 4978 DRS(I) = 1 + DXHALF + DAS(3,I) + DAS(4,I) AB 4979 DMN1S(I) = MN1S(I) AB 4980 DMN2S(I) = MN2S(I) AB 4981 DMX2S(I) = MX2S(I) AB 4982 C THESE ARE INDICES FOR THE 4 FACTORIALTS THAT DEPEND ON X AB 4983 IDS(1,I) = AS(2,I) + BS(2,I) AB 4984 IDS(2,I) = AS(1,I) + BS(1,I) AB 4985 299 CONTINUE AB 4986 C FIND THE LOG OF THE OUTSIDE FACTORS NOW AB 4987 C IT WILL BE USED IN EACH TERM OF THE 9-J SUM TO AVOID UNDER/OVER AB 4988 C FLOW PROBLEMS. AB 4989 C THESE ARE ALL THE TRIANGLE FACTORIALS THAT COMPLTELY FACTOR OUT AB 4990 C OF THE SUM AB 4991 SUMOUT = 0 AB 4992 C XSUM IS >= ANY OF THE REQUIRED FACTORIAL ARGUMENTS AB 4993 IF (XSUM .GT. MAXLF) GO TO 350 AB 4994 C WE CAN USE THE LOG(FACTORIAL) TABLE AB 4995 DO 339 I = 1, 3 AB 4996 DO 339 J = 1, 2 AB 4997 SUMOUT = SUMOUT + AB 4998 1 LF(1+AS(J,I)) - LF(2+J3S(I)+AS(J,I)) AB 4999 2 + LF(1-AS(J,I)+J1S(I-1+J)) AB 5000 3 + LF(1-AS(J,I)+J2S(I-2+2*J)) AB 5001 339 CONTINUE AB 5002 GO TO 400 AB 5003 C WE MUST USE LOG GAMMA AB 5004 350 DO 359 I = 1, 3 AB 5005 DO 359 J = 1, 2 AB 5006 SUMOUT = SUMOUT + AB 5007 1 DLGAMA(1+DAS(J,I)) - DLF(2+J3S(I)+AS(J,I)) AB 5008 2 + DLF(1-AS(J,I)+J1S(I-1+J)) AB 5009 3 + DLF(1-AS(J,I)+J2S(I-2+2*J)) AB 5010 359 CONTINUE AB 5011 C BIGOUT = 1 AB 5012 400 SUMOUT = .5*SUMOUT AB 5013 C WE ARE NOW READY TO DO THE 9-J LOOP AB 5014 WIG9J = 0 AB 5015 DO 799 X = XSTART, XEND AB 5016 DX = DX + 1 AB 5017 C DO THE PARTS OF EACH 6-J THAT DEPEND ON X AB 5018 SUMLOG = SUMOUT AB 5019 ISIGN = 0 AB 5020 DO 759 I = 1, 3 AB 5021 C GET THE COEFFICENTS FOR THIS 6-J AB 5022 MX2 = MX2S(I) - X AB 5023 MN2 = MN2S(I) - X AB 5024 NMAX = MN1S(I) AB 5025 DNMAX = DMN1S(I) AB 5026 DNMIN = 0 AB 5027 NMIN = 0 AB 5028 C GET THE RANGE OF THE 6-J SUM AB 5029 IF (MN2 .GE. NMAX) GO TO 520 AB 5030 NMAX = MN2 AB 5031 DNMAX = DMN2S(I) - DX AB 5032 520 IF (MX2 .LE. 0) GO TO 540 AB 5033 NMIN = MX2 AB 5034 DNMIN = DMX2S(I) - DX AB 5035 540 SUM = 1 AB 5036 ISIGN = ISIGN + NMIN AB 5037 C THIS ONE TEST CHECKS ALL 12 INEQUALITIES IMPLIED BY THE AB 5038 C 4 TRIANGLE CONDITIONS.FOR THE GIVEN 6-J. AB 5039 IF (NMAX - NMIN) 900, 700, 600 AB 5040 600 D1 = DAS(1,I) - (DNMAX-1) AB 5041 D2 = DAS(2,I) - (DNMAX-1) AB 5042 D8 = DRS(I) - (DNMAX-1) AB 5043 D3 = DAS(3,I) - (DNMAX-1+DX) AB 5044 D4 = DAS(4,I) - (DNMAX-1+DX) AB 5045 D5 = -DNMAX AB 5046 D6 = -DBS(1,I) - (DX + DNMAX) AB 5047 D7 = -DBS(2,I) - (DX + DNMAX) AB 5048 E1 = D1*D2*D3*D4 AB 5049 E5 = D5*D6*D7*D8 AB 5050 NMAXM2 = NMAX-2 AB 5051 SUM = 1 + E1/E5 AB 5052 IF (NMAXM2 .LT. NMIN) GO TO 700 AB 5053 F1 = (D1+1)*(D2+1)*(D3+1)*(D4+1) - E1 AB 5054 F5 = (D5+1)*(D6+1)*(D7+1)*(D8+1) - E5 AB 5055 G1 = (D1+2)*(D2+2)*(D3+2)*(D4+2) - F1 - F1 - E1 AB 5056 G5 = (D5+2)*(D6+2)*(D7+2)*(D8+2) - F5 - F5 - E5 AB 5057 H1 = (D1+3)*(D2+3)*(D3+3)*(D4+3) - 3*(G1+F1) - E1 AB 5058 H5 = (D5+3)*(D6+3)*(D7+3)*(D8+3) - 3*(G5+F5) - E5 AB 5059 C COMPUTE THE SUM IN THE RACAH FORMULA AB 5060 DO 659 N = NMIN, NMAXM2 AB 5061 E1 = E1 + F1 AB 5062 E5 = E5 + F5 AB 5063 F1 = F1 + G1 AB 5064 F5 = F5 + G5 AB 5065 G1 = G1 + H1 AB 5066 G5 = G5 + H5 AB 5067 H1 = H1 + 24 AB 5068 H5 = H5 + 24 AB 5069 SUM = 1 + SUM*(E1/E5) AB 5070 659 CONTINUE AB 5071 700 SUMS(I) = SUM AB 5072 C NUM6J = NUM6J + NMAX - NMIN + 1 AB 5073 C HERE ARE THE PARTS OF THE FACTORIALS FOR NMIN AND ALSO THOSE AB 5074 C FACTORIALS THAT DEPEND ON X AB 5075 IF (RS(I) .GT. MAXLF) GO TO 730 AB 5076 C WE CAN USE THE LOG FACTORIAL TABLE AB 5077 SUMLOG = SUMLOG + AB 5078 1 LF(1-X+AS(4,I)) + LF(1+X+IDS(1,I)) AB 5079 2 + LF(1+X+IDS(2,I)) - LF(2+XHALF+X+AS(4,I)) AB 5080 3 + LF(1-NMIN+RS(I)) - LF(1+NMIN) AB 5081 4 - LF(1+NMIN+X+BS(1,I)) - LF(1+NMIN+X+BS(2,I)) AB 5082 5 - LF(1-NMIN+AS(1,I)) - LF(1-NMIN+AS(2,I)) AB 5083 6 - LF(1-NMIN-X+AS(3,I)) - LF(1-NMIN-X+AS(4,I)) AB 5084 GO TO 759 AB 5085 C WE MUST USE LOG GAMMA AB 5086 730 SUMLOG = SUMLOG + AB 5087 1 DLGAMA(1-DX+DAS(4,I)) + DLGAMA(1+DX+DAS(2,I)+DBS(2,I)) AB 5088 1 + DLGAMA(1+DX+DAS(1,I)+DBS(1,I)) AB 5089 2 - DLGAMA(2+DXHALF+DX+DAS(4,I)) AB 5090 3 + DLGAMA(1-DNMIN+DRS(I)) - DLGAMA(1+DNMIN) AB 5091 4 - DLGAMA(1+DNMIN+DX+DBS(1,I)) AB 5092 4 - DLGAMA(1+DNMIN+DX+DBS(2,I)) AB 5093 5 - DLGAMA(1-DNMIN+DAS(1,I)) - DLGAMA(1-DNMIN+DAS(2,I)) AB 5094 6 - DLGAMA(1-DNMIN-DX+DAS(3,I)) AB 5095 7 - DLGAMA(1-DNMIN-DX+DAS(4,I)) AB 5096 C BIGIN = 1 AB 5097 759 CONTINUE AB 5098 C NOW MULTIPLY THE 3 6-J PARTS TOGETHER AND SUM AB 5099 SUMP = SUMS(1) * SUMS(2) * DEXP(SUMLOG) * SUMS(3) AB 5100 1 * (1+DXHALF+(DX+DX)) AB 5101 IF (BTEST(ISIGN, 0)) SUMP = -SUMP AB 5102 WIG9J = WIG9J + SUMP AB 5103 799 CONTINUE AB 5104 RETURN AB 5105 C THE TRIANGLE RULES ARE NOT SATISFIED AB 5106 900 WIG9J = 0 AB 5107 RETURN AB 5108 END AB 5109 BLOCKDATA FACDUM AB 5110 C AB 5111 C BLOCK DATA TO DEFINE THE SQRT(FACTORIAL) TABLE AB 5112 C THE TABLE IS USED BY THE CLEBSH, THREEJ, SIXJ AND RACAH AB 5113 C ROUTINES. AB 5114 C AB 5115 C IT MAY BE INCLUDED IN YOUR LOAD MODULE FOR OTHER PURPOSES AB 5116 C BY PLACING A DUMMY EXTERNAL CARD OF THE FORM AB 5117 C EXTERNAL FACDUM AB 5118 C IN YOUR SOURCE. AB 5119 C AB 5120 C THE FORM OF THE TABLE IS AB 5121 C AB 5122 C COMMON / FACTRL / MAX, ISPACE, TABLE AB 5123 C AB 5124 C MAX IS THE MAXIMUM NUMBER WHOSE SQRT(FACTORIAL) IS AB 5125 C IN TABLE. TABLE HAS MAX+1 ELEMENTS. AB 5126 C IN THE PRESENT VERSION: AB 5127 C MAX = 96 (DETERMINED BY EXPONENT RANGE) AB 5128 C ISPACE IS NOT USED. AB 5129 C TABLE IS THE TABLE. THE FIRST ELEMENT CORRESPONDS TO 0. AB 5130 C AB 5131 INTEGER*4 MAXFAC, SP1 AB 5132 REAL*8 FACTBL AB 5133 COMMON /FACTRL/ MAXFAC, SP1, FACTBL(97) AB 5134 DATA MAXFAC /96/ AB 5135 C THESE ARE THE SQUARE ROOTS OF FACTORIALS. AB 5136 C THEY ARE STORED UP TO THE EXPONENT RANGE OF THE MACHINE. AB 5137 DATA FACTBL( 1) / 0.1000000000000000D+01 / AB 5138 DATA FACTBL( 2) / 0.1000000000000000D+01 / AB 5139 DATA FACTBL( 3) / 0.1414213562373095D+01 / AB 5140 DATA FACTBL( 4) / 0.2449489742783178D+01 / AB 5141 DATA FACTBL( 5) / 0.4898979485566356D+01 / AB 5142 DATA FACTBL( 6) / 0.1095445115010332D+02 / AB 5143 DATA FACTBL( 7) / 0.2683281572999748D+02 / AB 5144 DATA FACTBL( 8) / 0.7099295739719539D+02 / AB 5145 DATA FACTBL( 9) / 0.2007984063681781D+03 / AB 5146 DATA FACTBL(10) / 0.6023952191045344D+03 / AB 5147 DATA FACTBL(11) / 0.1904940943966505D+04 / AB 5148 DATA FACTBL(12) / 0.6317974358922328D+04 / AB 5149 DATA FACTBL(13) / 0.2188610518114176D+05 / AB 5150 DATA FACTBL(14) / 0.7891147445080469D+05 / AB 5151 DATA FACTBL(15) / 0.2952597012800765D+06 / AB 5152 DATA FACTBL(16) / 0.1143535905863913D+07 / AB 5153 DATA FACTBL(17) / 0.4574143623455652D+07 / AB 5154 DATA FACTBL(18) / 0.1885967730625315D+08 / AB 5155 DATA FACTBL(19) / 0.8001483428544984D+08 / AB 5156 DATA FACTBL(20) / 0.3487765766344294D+09 / AB 5157 DATA FACTBL(21) / 0.1559776268628498D+10 / AB 5158 DATA FACTBL(22) / 0.7147792818185865D+10 / AB 5159 DATA FACTBL(23) / 0.3352612008237171D+11 / AB 5160 DATA FACTBL(24) / 0.1607856235454059D+12 / AB 5161 DATA FACTBL(25) / 0.7876854713229383D+12 / AB 5162 DATA FACTBL(26) / 0.3938427356614691D+13 / AB 5163 DATA FACTBL(27) / 0.2008211794424596D+14 / AB 5164 DATA FACTBL(28) / 0.1043497458090740D+15 / AB 5165 DATA FACTBL(29) / 0.5521669535672285D+15 / AB 5166 DATA FACTBL(30) / 0.2973510046012911D+16 / AB 5167 DATA FACTBL(31) / 0.1628658527169496D+17 / AB 5168 DATA FACTBL(32) / 0.9067986906793549D+17 / AB 5169 DATA FACTBL(33) / 0.5129628026803635D+18 / AB 5170 DATA FACTBL(34) / 0.2946746955341073D+19 / AB 5171 DATA FACTBL(35) / 0.1718233974287565D+20 / AB 5172 DATA FACTBL(36) / 0.1016520927791757D+21 / AB 5173 DATA FACTBL(37) / 0.6099125566750542D+21 / AB 5174 DATA FACTBL(38) / 0.3709953246501409D+22 / AB 5175 DATA FACTBL(39) / 0.2286968774309350D+23 / AB 5176 DATA FACTBL(40) / 0.1428211541796153D+24 / AB 5177 DATA FACTBL(41) / 0.9032802905233224D+24 / AB 5178 DATA FACTBL(42) / 0.5783815921445271D+25 / AB 5179 DATA FACTBL(43) / 0.3748341123420972D+26 / AB 5180 DATA FACTBL(44) / 0.2457951648494613D+27 / AB 5181 DATA FACTBL(45) / 0.1630420674178431D+28 / AB 5182 DATA FACTBL(46) / 0.1093719437815202D+29 / AB 5183 DATA FACTBL(47) / 0.7417966136220958D+29 / AB 5184 DATA FACTBL(48) / 0.5085501366740237D+30 / AB 5185 DATA FACTBL(49) / 0.3523338699662023D+31 / AB 5186 DATA FACTBL(50) / 0.2466337089763416D+32 / AB 5187 DATA FACTBL(51) / 0.1743963680863606D+33 / AB 5188 DATA FACTBL(52) / 0.1245439180886559D+34 / AB 5189 DATA FACTBL(53) / 0.8980989654316716D+34 / AB 5190 DATA FACTBL(54) / 0.6538259159791714D+35 / AB 5191 DATA FACTBL(55) / 0.4804619624270389D+36 / AB 5192 DATA FACTBL(56) / 0.3563201278858420D+37 / AB 5193 DATA FACTBL(57) / 0.2666455677120592D+38 / AB 5194 DATA FACTBL(58) / 0.2013129889124823D+39 / AB 5195 DATA FACTBL(59) / 0.1533154046820762D+40 / AB 5196 DATA FACTBL(60) / 0.1177637968756484D+41 / AB 5197 DATA FACTBL(61) / 0.9121944481710788D+41 / AB 5198 DATA FACTBL(62) / 0.7124466393192018D+42 / AB 5199 DATA FACTBL(63) / 0.5609810447812647D+43 / AB 5200 DATA FACTBL(64) / 0.4452649004137245D+44 / AB 5201 DATA FACTBL(65) / 0.3562119203309796D+45 / AB 5202 DATA FACTBL(66) / 0.2871872314724746D+46 / AB 5203 DATA FACTBL(67) / 0.2333120097803461D+47 / AB 5204 DATA FACTBL(68) / 0.1909741105966688D+48 / AB 5205 DATA FACTBL(69) / 0.1574812859496909D+49 / AB 5206 DATA FACTBL(70) / 0.1308137807832727D+50 / AB 5207 DATA FACTBL(71) / 0.1094466613011557D+51 / AB 5208 DATA FACTBL(72) / 0.9222139602976428D+51 / AB 5209 DATA FACTBL(73) / 0.7825244940376377D+52 / AB 5210 DATA FACTBL(74) / 0.6685892207860282D+53 / AB 5211 DATA FACTBL(75) / 0.5751421947239992D+54 / AB 5212 DATA FACTBL(76) / 0.4980877514193197D+55 / AB 5213 DATA FACTBL(77) / 0.4342228346904444D+56 / AB 5214 DATA FACTBL(78) / 0.3810289910601106D+57 / AB 5215 DATA FACTBL(79) / 0.3365156932181068D+58 / AB 5216 DATA FACTBL(80) / 0.2991016905800262D+59 / AB 5217 DATA FACTBL(81) / 0.2675246849288189D+60 / AB 5218 DATA FACTBL(82) / 0.2407722164359370D+61 / AB 5219 DATA FACTBL(83) / 0.2180285150390389D+62 / AB 5220 DATA FACTBL(84) / 0.1986334304622628D+63 / AB 5221 DATA FACTBL(85) / 0.1820505461284133D+64 / AB 5222 DATA FACTBL(86) / 0.1678423103505356D+65 / AB 5223 DATA FACTBL(87) / 0.1556505553593457D+66 / AB 5224 DATA FACTBL(88) / 0.1451811729660402D+67 / AB 5225 DATA FACTBL(89) / 0.1361920123419132D+68 / AB 5226 DATA FACTBL(90) / 0.1284832874770429D+69 / AB 5227 DATA FACTBL(91) / 0.1218899489080934D+70 / AB 5228 DATA FACTBL(92) / 0.1162756005221389D+71 / AB 5229 DATA FACTBL(93) / 0.1115276380752381D+72 / AB 5230 DATA FACTBL(94) / 0.1075533591796017D+73 / AB 5231 DATA FACTBL(95) / 0.1042768505784838D+74 / AB 5232 DATA FACTBL(96) / 0.1016365017512855D+75 / AB 5233 DATA FACTBL(97) / 0.9958302741285533D+75 / AB 5234 END AB 5235 BLOCKDATA LOGDUM AB 5236 C AB 5237 C BLOCK DATA TO DEFINE THE LOG(FACTORIAL) TABLE. AB 5238 C AB 5239 C THIS TABLE IS USED BY THE CLEBSH, THREEJ, SIXJ AND RACAH AB 5240 C ROUTINES. AB 5241 C AB 5242 C IT MAY BE INCLUDED IN YOUR LOAD MODULE FOR OTHER PURPOSES AB 5243 C BY PLACING A DUMMY EXTERNAL CARD OF THE FORM AB 5244 C EXTERNAL LOGDUM AB 5245 C IN YOUR SOURCE. AB 5246 C AB 5247 C THE FORM OF THE TABLE IS AB 5248 C AB 5249 C COMMON / LOGFAC / MAX, ISPACE, TABLE AB 5250 C AB 5251 C MAX IS THE MAXIMUM NUMBER WHOSE LOG(FACTORIAL) IS AB 5252 C IN TABLE. TABLE HAS MAX+1 ELEMENTS. AB 5253 C IN THE PRESENT VERSION: AB 5254 C MAX = 1000 AB 5255 C ISPACE IS NOT USED. AB 5256 C TABLE IS THE TABLE. THE FIRST ELEMENT CORRESPONDS TO 0. AB 5257 INTEGER*4 MAXLF, SP2 AB 5258 REAL*8 LF AB 5259 COMMON /LOGFAC/ MAXLF, SP2, LF(1001) AB 5260 DATA MAXLF /1000/ AB 5261 DATA LF( 1) / 0.0 / AB 5262 DATA LF( 2) / 0.0 / AB 5263 DATA LF( 3) / 0.6931471805599453D+00 / AB 5264 DATA LF( 4) / 0.1791759469228055D+01 / AB 5265 DATA LF( 5) / 0.3178053830347946D+01 / AB 5266 DATA LF( 6) / 0.4787491742782046D+01 / AB 5267 DATA LF( 7) / 0.6579251212010101D+01 / AB 5268 DATA LF( 8) / 0.8525161361065414D+01 / AB 5269 DATA LF( 9) / 0.1060460290274525D+02 / AB 5270 DATA LF( 10) / 0.1280182748008147D+02 / AB 5271 DATA LF( 11) / 0.1510441257307552D+02 / AB 5272 DATA LF( 12) / 0.1750230784587389D+02 / AB 5273 DATA LF( 13) / 0.1998721449566188D+02 / AB 5274 DATA LF( 14) / 0.2255216385312342D+02 / AB 5275 DATA LF( 15) / 0.2519122118273868D+02 / AB 5276 DATA LF( 16) / 0.2789927138384089D+02 / AB 5277 DATA LF( 17) / 0.3067186010608067D+02 / AB 5278 DATA LF( 18) / 0.3350507345013689D+02 / AB 5279 DATA LF( 19) / 0.3639544520803305D+02 / AB 5280 DATA LF( 20) / 0.3933988418719949D+02 / AB 5281 DATA LF( 21) / 0.4233561646075349D+02 / AB 5282 DATA LF( 22) / 0.4538013889847691D+02 / AB 5283 DATA LF( 23) / 0.4847118135183522D+02 / AB 5284 DATA LF( 24) / 0.5160667556776437D+02 / AB 5285 DATA LF( 25) / 0.5478472939811232D+02 / AB 5286 DATA LF( 26) / 0.5800360522298052D+02 / AB 5287 DATA LF( 27) / 0.6126170176100200D+02 / AB 5288 DATA LF( 28) / 0.6455753862700633D+02 / AB 5289 DATA LF( 29) / 0.6788974313718154D+02 / AB 5290 DATA LF( 30) / 0.7125703896716801D+02 / AB 5291 DATA LF( 31) / 0.7465823634883017D+02 / AB 5292 DATA LF( 32) / 0.7809222355331531D+02 / AB 5293 DATA LF( 33) / 0.8155795945611504D+02 / AB 5294 DATA LF( 34) / 0.8505446701758152D+02 / AB 5295 DATA LF( 35) / 0.8858082754219768D+02 / AB 5296 DATA LF( 36) / 0.9213617560368709D+02 / AB 5297 DATA LF( 37) / 0.9571969454214320D+02 / AB 5298 DATA LF( 38) / 0.9933061245478743D+02 / AB 5299 DATA LF( 39) / 0.1029681986145138D+03 / AB 5300 DATA LF( 40) / 0.1066317602606435D+03 / AB 5301 DATA LF( 41) / 0.1103206397147574D+03 / AB 5302 DATA LF( 42) / 0.1140342117814617D+03 / AB 5303 DATA LF( 43) / 0.1177718813997451D+03 / AB 5304 DATA LF( 44) / 0.1215330815154386D+03 / AB 5305 DATA LF( 45) / 0.1253172711493569D+03 / AB 5306 DATA LF( 46) / 0.1291239336391272D+03 / AB 5307 DATA LF( 47) / 0.1329525750356163D+03 / AB 5308 DATA LF( 48) / 0.1368027226373264D+03 / AB 5309 DATA LF( 49) / 0.1406739236482343D+03 / AB 5310 DATA LF( 50) / 0.1445657439463449D+03 / AB 5311 DATA LF( 51) / 0.1484777669517730D+03 / AB 5312 DATA LF( 52) / 0.1524095925844974D+03 / AB 5313 DATA LF( 53) / 0.1563608363030788D+03 / AB 5314 DATA LF( 54) / 0.1603311282166309D+03 / AB 5315 DATA LF( 55) / 0.1643201122631952D+03 / AB 5316 DATA LF( 56) / 0.1683274454484277D+03 / AB 5317 DATA LF( 57) / 0.1723527971391628D+03 / AB 5318 DATA LF( 58) / 0.1763958484069974D+03 / AB 5319 DATA LF( 59) / 0.1804562914175438D+03 / AB 5320 DATA LF( 60) / 0.1845338288614495D+03 / AB 5321 DATA LF( 61) / 0.1886281734236716D+03 / AB 5322 DATA LF( 62) / 0.1927390472878449D+03 / AB 5323 DATA LF( 63) / 0.1968661816728900D+03 / AB 5324 DATA LF( 64) / 0.2010093163992815D+03 / AB 5325 DATA LF( 65) / 0.2051681994826412D+03 / AB 5326 DATA LF( 66) / 0.2093425867525368D+03 / AB 5327 DATA LF( 67) / 0.2135322414945633D+03 / AB 5328 DATA LF( 68) / 0.2177369341139542D+03 / AB 5329 DATA LF( 69) / 0.2219564418191303D+03 / AB 5330 DATA LF( 70) / 0.2261905483237276D+03 / AB 5331 DATA LF( 71) / 0.2304390435657770D+03 / AB 5332 DATA LF( 72) / 0.2347017234428183D+03 / AB 5333 DATA LF( 73) / 0.2389783895618343D+03 / AB 5334 DATA LF( 74) / 0.2432688490029827D+03 / AB 5335 DATA LF( 75) / 0.2475729140961869D+03 / AB 5336 DATA LF( 76) / 0.2518904022097232D+03 / AB 5337 DATA LF( 77) / 0.2562211355500095D+03 / AB 5338 DATA LF( 78) / 0.2605649409718632D+03 / AB 5339 DATA LF( 79) / 0.2649216497985528D+03 / AB 5340 DATA LF( 80) / 0.2692910976510198D+03 / AB 5341 DATA LF( 81) / 0.2736731242856937D+03 / AB 5342 DATA LF( 82) / 0.2780675734403661D+03 / AB 5343 DATA LF( 83) / 0.2824742926876304D+03 / AB 5344 DATA LF( 84) / 0.2868931332954270D+03 / AB 5345 DATA LF( 85) / 0.2913239500942703D+03 / AB 5346 DATA LF( 86) / 0.2957666013507607D+03 / AB 5347 DATA LF( 87) / 0.3002209486470142D+03 / AB 5348 DATA LF( 88) / 0.3046868567656687D+03 / AB 5349 DATA LF( 89) / 0.3091641935801469D+03 / AB 5350 DATA LF( 90) / 0.3136528299498790D+03 / AB 5351 DATA LF( 91) / 0.3181526396202093D+03 / AB 5352 DATA LF( 92) / 0.3226634991267262D+03 / AB 5353 DATA LF( 93) / 0.3271852877037752D+03 / AB 5354 DATA LF( 94) / 0.3317178871969285D+03 / AB 5355 DATA LF( 95) / 0.3362611819791985D+03 / AB 5356 DATA LF( 96) / 0.3408150588707990D+03 / AB 5357 DATA LF( 97) / 0.3453794070622669D+03 / AB 5358 DATA LF( 98) / 0.3499541180407703D+03 / AB 5359 DATA LF( 99) / 0.3545390855194408D+03 / AB 5360 DATA LF( 100) / 0.3591342053695754D+03 / AB 5361 DATA LF( 101) / 0.3637393755555635D+03 / AB 5362 DATA LF( 102) / 0.3683544960724047D+03 / AB 5363 DATA LF( 103) / 0.3729794688856890D+03 / AB 5364 DATA LF( 104) / 0.3776141978739187D+03 / AB 5365 DATA LF( 105) / 0.3822585887730600D+03 / AB 5366 DATA LF( 106) / 0.3869125491232176D+03 / AB 5367 DATA LF( 107) / 0.3915759882173296D+03 / AB 5368 DATA LF( 108) / 0.3962488170517915D+03 / AB 5369 DATA LF( 109) / 0.4009309482789158D+03 / AB 5370 DATA LF( 110) / 0.4056222961611449D+03 / AB 5371 DATA LF( 111) / 0.4103227765269373D+03 / AB 5372 DATA LF( 112) / 0.4150323067282496D+03 / AB 5373 DATA LF( 113) / 0.4197508055995447D+03 / AB 5374 DATA LF( 114) / 0.4244781934182571D+03 / AB 5375 DATA LF( 115) / 0.4292143918666516D+03 / AB 5376 DATA LF( 116) / 0.4339593239950148D+03 / AB 5377 DATA LF( 117) / 0.4387129141861212D+03 / AB 5378 DATA LF( 118) / 0.4434750881209189D+03 / AB 5379 DATA LF( 119) / 0.4482457727453846D+03 / AB 5380 DATA LF( 120) / 0.4530248962384961D+03 / AB 5381 DATA LF( 121) / 0.4578123879812782D+03 / AB 5382 DATA LF( 122) / 0.4626081785268749D+03 / AB 5383 DATA LF( 123) / 0.4674121995716082D+03 / AB 5384 DATA LF( 124) / 0.4722243839269806D+03 / AB 5385 DATA LF( 125) / 0.4770446654925856D+03 / AB 5386 DATA LF( 126) / 0.4818729792298880D+03 / AB 5387 DATA LF( 127) / 0.4867092611368394D+03 / AB 5388 DATA LF( 128) / 0.4915534482232980D+03 / AB 5389 DATA LF( 129) / 0.4964054784872176D+03 / AB 5390 DATA LF( 130) / 0.5012652908915793D+03 / AB 5391 DATA LF( 131) / 0.5061328253420349D+03 / AB 5392 DATA LF( 132) / 0.5110080226652360D+03 / AB 5393 DATA LF( 133) / 0.5158908245878224D+03 / AB 5394 DATA LF( 134) / 0.5207811737160442D+03 / AB 5395 DATA LF( 135) / 0.5256790135159951D+03 / AB 5396 DATA LF( 136) / 0.5305842882944335D+03 / AB 5397 DATA LF( 137) / 0.5354969431801695D+03 / AB 5398 DATA LF( 138) / 0.5404169241059977D+03 / AB 5399 DATA LF( 139) / 0.5453441777911549D+03 / AB 5400 DATA LF( 140) / 0.5502786517242856D+03 / AB 5401 DATA LF( 141) / 0.5552202941468948D+03 / AB 5402 DATA LF( 142) / 0.5601690540372730D+03 / AB 5403 DATA LF( 143) / 0.5651248810948743D+03 / AB 5404 DATA LF( 144) / 0.5700877257251342D+03 / AB 5405 DATA LF( 145) / 0.5750575390247102D+03 / AB 5406 DATA LF( 146) / 0.5800342727671308D+03 / AB 5407 DATA LF( 147) / 0.5850178793888391D+03 / AB 5408 DATA LF( 148) / 0.5900083119756179D+03 / AB 5409 DATA LF( 149) / 0.5950055242493819D+03 / AB 5410 DATA LF( 150) / 0.6000094705553274D+03 / AB 5411 DATA LF( 151) / 0.6050201058494237D+03 / AB 5412 DATA LF( 152) / 0.6100373856862386D+03 / AB 5413 DATA LF( 153) / 0.6150612662070849D+03 / AB 5414 DATA LF( 154) / 0.6200917041284773D+03 / AB 5415 DATA LF( 155) / 0.6251286567308910D+03 / AB 5416 DATA LF( 156) / 0.6301720818478102D+03 / AB 5417 DATA LF( 157) / 0.6352219378550597D+03 / AB 5418 DATA LF( 158) / 0.6402781836604080D+03 / AB 5419 DATA LF( 159) / 0.6453407786934350D+03 / AB 5420 DATA LF( 160) / 0.6504096828956552D+03 / AB 5421 DATA LF( 161) / 0.6554848567108891D+03 / AB 5422 DATA LF( 162) / 0.6605662610758735D+03 / AB 5423 DATA LF( 163) / 0.6656538574111059D+03 / AB 5424 DATA LF( 164) / 0.6707476076119127D+03 / AB 5425 DATA LF( 165) / 0.6758474740397369D+03 / AB 5426 DATA LF( 166) / 0.6809534195136375D+03 / AB 5427 DATA LF( 167) / 0.6860654073019940D+03 / AB 5428 DATA LF( 168) / 0.6911834011144107D+03 / AB 5429 DATA LF( 169) / 0.6963073650938140D+03 / AB 5430 DATA LF( 170) / 0.7014372638087371D+03 / AB 5431 DATA LF( 171) / 0.7065730622457874D+03 / AB 5432 DATA LF( 172) / 0.7117147258022900D+03 / AB 5433 DATA LF( 173) / 0.7168622202791034D+03 / AB 5434 DATA LF( 174) / 0.7220155118736012D+03 / AB 5435 DATA LF( 175) / 0.7271745671728158D+03 / AB 5436 DATA LF( 176) / 0.7323393531467393D+03 / AB 5437 DATA LF( 177) / 0.7375098371417774D+03 / AB 5438 DATA LF( 178) / 0.7426859868743513D+03 / AB 5439 DATA LF( 179) / 0.7478677704246434D+03 / AB 5440 DATA LF( 180) / 0.7530551562304841D+03 / AB 5441 DATA LF( 181) / 0.7582481130813743D+03 / AB 5442 DATA LF( 182) / 0.7634466101126401D+03 / AB 5443 DATA LF( 183) / 0.7686506167997169D+03 / AB 5444 DATA LF( 184) / 0.7738601029525583D+03 / AB 5445 DATA LF( 185) / 0.7790750387101673D+03 / AB 5446 DATA LF( 186) / 0.7842953945352457D+03 / AB 5447 DATA LF( 187) / 0.7895211412089589D+03 / AB 5448 DATA LF( 188) / 0.7947522498258135D+03 / AB 5449 DATA LF( 189) / 0.7999886917886434D+03 / AB 5450 DATA LF( 190) / 0.8052304388037031D+03 / AB 5451 DATA LF( 191) / 0.8104774628758635D+03 / AB 5452 DATA LF( 192) / 0.8157297363039102D+03 / AB 5453 DATA LF( 193) / 0.8209872316759379D+03 / AB 5454 DATA LF( 194) / 0.8262499218648428D+03 / AB 5455 DATA LF( 195) / 0.8315177800239061D+03 / AB 5456 DATA LF( 196) / 0.8367907795824699D+03 / AB 5457 DATA LF( 197) / 0.8420688942417004D+03 / AB 5458 DATA LF( 198) / 0.8473520979704384D+03 / AB 5459 DATA LF( 199) / 0.8526403650011329D+03 / AB 5460 DATA LF( 200) / 0.8579336698258575D+03 / AB 5461 DATA LF( 201) / 0.8632319871924055D+03 / AB 5462 DATA LF( 202) / 0.8685352921004646D+03 / AB 5463 DATA LF( 203) / 0.8738435597978657D+03 / AB 5464 DATA LF( 204) / 0.8791567657769075D+03 / AB 5465 DATA LF( 205) / 0.8844748857707518D+03 / AB 5466 DATA LF( 206) / 0.8897978957498902D+03 / AB 5467 DATA LF( 207) / 0.8951257719186797D+03 / AB 5468 DATA LF( 208) / 0.9004584907119451D+03 / AB 5469 DATA LF( 209) / 0.9057960287916464D+03 / AB 5470 DATA LF( 210) / 0.9111383630436113D+03 / AB 5471 DATA LF( 211) / 0.9164854705743287D+03 / AB 5472 DATA LF( 212) / 0.9218373287078048D+03 / AB 5473 DATA LF( 213) / 0.9271939149824768D+03 / AB 5474 DATA LF( 214) / 0.9325552071481862D+03 / AB 5475 DATA LF( 215) / 0.9379211831632081D+03 / AB 5476 DATA LF( 216) / 0.9432918211913357D+03 / AB 5477 DATA LF( 217) / 0.9486670995990199D+03 / AB 5478 DATA LF( 218) / 0.9540469969525603D+03 / AB 5479 DATA LF( 219) / 0.9594314920153494D+03 / AB 5480 DATA LF( 220) / 0.9648205637451659D+03 / AB 5481 DATA LF( 221) / 0.9702141912915183D+03 / AB 5482 DATA LF( 222) / 0.9756123539930360D+03 / AB 5483 DATA LF( 223) / 0.9810150313749083D+03 / AB 5484 DATA LF( 224) / 0.9864222031463685D+03 / AB 5485 DATA LF( 225) / 0.9918338491982235D+03 / AB 5486 DATA LF( 226) / 0.9972499496004279D+03 / AB 5487 DATA LF( 227) / 0.1002670484599700D+04 / AB 5488 DATA LF( 228) / 0.1008095434617182D+04 / AB 5489 DATA LF( 229) / 0.1013524780246136D+04 / AB 5490 DATA LF( 230) / 0.1018958502249690D+04 / AB 5491 DATA LF( 231) / 0.1024396581558613D+04 / AB 5492 DATA LF( 232) / 0.1029838999269135D+04 / AB 5493 DATA LF( 233) / 0.1035285736640802D+04 / AB 5494 DATA LF( 234) / 0.1040736775094367D+04 / AB 5495 DATA LF( 235) / 0.1046192096209725D+04 / AB 5496 DATA LF( 236) / 0.1051651681723869D+04 / AB 5497 DATA LF( 237) / 0.1057115513528895D+04 / AB 5498 DATA LF( 238) / 0.1062583573670030D+04 / AB 5499 DATA LF( 239) / 0.1068055844343701D+04 / AB 5500 DATA LF( 240) / 0.1073532307895633D+04 / AB 5501 DATA LF( 241) / 0.1079012946818975D+04 / AB 5502 DATA LF( 242) / 0.1084497743752466D+04 / AB 5503 DATA LF( 243) / 0.1089986681478622D+04 / AB 5504 DATA LF( 244) / 0.1095479742921963D+04 / AB 5505 DATA LF( 245) / 0.1100976911147256D+04 / AB 5506 DATA LF( 246) / 0.1106478169357801D+04 / AB 5507 DATA LF( 247) / 0.1111983500893733D+04 / AB 5508 DATA LF( 248) / 0.1117492889230361D+04 / AB 5509 DATA LF( 249) / 0.1123006317976526D+04 / AB 5510 DATA LF( 250) / 0.1128523770872991D+04 / AB 5511 DATA LF( 251) / 0.1134045231790853D+04 / AB 5512 DATA LF( 252) / 0.1139570684729985D+04 / AB 5513 DATA LF( 253) / 0.1145100113817496D+04 / AB 5514 DATA LF( 254) / 0.1150633503306224D+04 / AB 5515 DATA LF( 255) / 0.1156170837573242D+04 / AB 5516 DATA LF( 256) / 0.1161712101118401D+04 / AB 5517 DATA LF( 257) / 0.1167257278562880D+04 / AB 5518 DATA LF( 258) / 0.1172806354647775D+04 / AB 5519 DATA LF( 259) / 0.1178359314232697D+04 / AB 5520 DATA LF( 260) / 0.1183916142294397D+04 / AB 5521 DATA LF( 261) / 0.1189476823925412D+04 / AB 5522 DATA LF( 262) / 0.1195041344332735D+04 / AB 5523 DATA LF( 263) / 0.1200609688836496D+04 / AB 5524 DATA LF( 264) / 0.1206181842868674D+04 / AB 5525 DATA LF( 265) / 0.1211757791971820D+04 / AB 5526 DATA LF( 266) / 0.1217337521797806D+04 / AB 5527 DATA LF( 267) / 0.1222921018106588D+04 / AB 5528 DATA LF( 268) / 0.1228508266764988D+04 / AB 5529 DATA LF( 269) / 0.1234099253745499D+04 / AB 5530 DATA LF( 270) / 0.1239693965125101D+04 / AB 5531 DATA LF( 271) / 0.1245292387084099D+04 / AB 5532 DATA LF( 272) / 0.1250894505904979D+04 / AB 5533 DATA LF( 273) / 0.1256500307971275D+04 / AB 5534 DATA LF( 274) / 0.1262109779766460D+04 / AB 5535 DATA LF( 275) / 0.1267722907872848D+04 / AB 5536 DATA LF( 276) / 0.1273339678970515D+04 / AB 5537 DATA LF( 277) / 0.1278960079836232D+04 / AB 5538 DATA LF( 278) / 0.1284584097342419D+04 / AB 5539 DATA LF( 279) / 0.1290211718456110D+04 / AB 5540 DATA LF( 280) / 0.1295842930237931D+04 / AB 5541 DATA LF( 281) / 0.1301477719841100D+04 / AB 5542 DATA LF( 282) / 0.1307116074510434D+04 / AB 5543 DATA LF( 283) / 0.1312757981581372D+04 / AB 5544 DATA LF( 284) / 0.1318403428479015D+04 / AB 5545 DATA LF( 285) / 0.1324052402717177D+04 / AB 5546 DATA LF( 286) / 0.1329704891897445D+04 / AB 5547 DATA LF( 287) / 0.1335360883708265D+04 / AB 5548 DATA LF( 288) / 0.1341020365924025D+04 / AB 5549 DATA LF( 289) / 0.1346683326404161D+04 / AB 5550 DATA LF( 290) / 0.1352349753092273D+04 / AB 5551 DATA LF( 291) / 0.1358019634015254D+04 / AB 5552 DATA LF( 292) / 0.1363692957282425D+04 / AB 5553 DATA LF( 293) / 0.1369369711084693D+04 / AB 5554 DATA LF( 294) / 0.1375049883693710D+04 / AB 5555 DATA LF( 295) / 0.1380733463461049D+04 / AB 5556 DATA LF( 296) / 0.1386420438817389D+04 / AB 5557 DATA LF( 297) / 0.1392110798271713D+04 / AB 5558 DATA LF( 298) / 0.1397804530410516D+04 / AB 5559 DATA LF( 299) / 0.1403501623897021D+04 / AB 5560 DATA LF( 300) / 0.1409202067470412D+04 / AB 5561 DATA LF( 301) / 0.1414905849945068D+04 / AB 5562 DATA LF( 302) / 0.1420612960209817D+04 / AB 5563 DATA LF( 303) / 0.1426323387227192D+04 / AB 5564 DATA LF( 304) / 0.1432037120032701D+04 / AB 5565 DATA LF( 305) / 0.1437754147734107D+04 / AB 5566 DATA LF( 306) / 0.1443474459510715D+04 / AB 5567 DATA LF( 307) / 0.1449198044612667D+04 / AB 5568 DATA LF( 308) / 0.1454924892360254D+04 / AB 5569 DATA LF( 309) / 0.1460654992143228D+04 / AB 5570 DATA LF( 310) / 0.1466388333420126D+04 / AB 5571 DATA LF( 311) / 0.1472124905717605D+04 / AB 5572 DATA LF( 312) / 0.1477864698629784D+04 / AB 5573 DATA LF( 313) / 0.1483607701817594D+04 / AB 5574 DATA LF( 314) / 0.1489353905008134D+04 / AB 5575 DATA LF( 315) / 0.1495103297994042D+04 / AB 5576 DATA LF( 316) / 0.1500855870632868D+04 / AB 5577 DATA LF( 317) / 0.1506611612846454D+04 / AB 5578 DATA LF( 318) / 0.1512370514620332D+04 / AB 5579 DATA LF( 319) / 0.1518132566003112D+04 / AB 5580 DATA LF( 320) / 0.1523897757105897D+04 / AB 5581 DATA LF( 321) / 0.1529666078101691D+04 / AB 5582 DATA LF( 322) / 0.1535437519224821D+04 / AB 5583 DATA LF( 323) / 0.1541212070770365D+04 / AB 5584 DATA LF( 324) / 0.1546989723093588D+04 / AB 5585 DATA LF( 325) / 0.1552770466609380D+04 / AB 5586 DATA LF( 326) / 0.1558554291791710D+04 / AB 5587 DATA LF( 327) / 0.1564341189173076D+04 / AB 5588 DATA LF( 328) / 0.1570131149343974D+04 / AB 5589 DATA LF( 329) / 0.1575924162952358D+04 / AB 5590 DATA LF( 330) / 0.1581720220703123D+04 / AB 5591 DATA LF( 331) / 0.1587519313357584D+04 / AB 5592 DATA LF( 332) / 0.1593321431732961D+04 / AB 5593 DATA LF( 333) / 0.1599126566701877D+04 / AB 5594 DATA LF( 334) / 0.1604934709191858D+04 / AB 5595 DATA LF( 335) / 0.1610745850184834D+04 / AB 5596 DATA LF( 336) / 0.1616559980716659D+04 / AB 5597 DATA LF( 337) / 0.1622377091876623D+04 / AB 5598 DATA LF( 338) / 0.1628197174806975D+04 / AB 5599 DATA LF( 339) / 0.1634020220702458D+04 / AB 5600 DATA LF( 340) / 0.1639846220809839D+04 / AB 5601 DATA LF( 341) / 0.1645675166427449D+04 / AB 5602 DATA LF( 342) / 0.1651507048904732D+04 / AB 5603 DATA LF( 343) / 0.1657341859641795D+04 / AB 5604 DATA LF( 344) / 0.1663179590088961D+04 / AB 5605 DATA LF( 345) / 0.1669020231746334D+04 / AB 5606 DATA LF( 346) / 0.1674863776163366D+04 / AB 5607 DATA LF( 347) / 0.1680710214938423D+04 / AB 5608 DATA LF( 348) / 0.1686559539718370D+04 / AB 5609 DATA LF( 349) / 0.1692411742198145D+04 / AB 5610 DATA LF( 350) / 0.1698266814120347D+04 / AB 5611 DATA LF( 351) / 0.1704124747274830D+04 / AB 5612 DATA LF( 352) / 0.1709985533498296D+04 / AB 5613 DATA LF( 353) / 0.1715849164673894D+04 / AB 5614 DATA LF( 354) / 0.1721715632730828D+04 / AB 5615 DATA LF( 355) / 0.1727584929643962D+04 / AB 5616 DATA LF( 356) / 0.1733457047433437D+04 / AB 5617 DATA LF( 357) / 0.1739331978164289D+04 / AB 5618 DATA LF( 358) / 0.1745209713946069D+04 / AB 5619 DATA LF( 359) / 0.1751090246932469D+04 / AB 5620 DATA LF( 360) / 0.1756973569320958D+04 / AB 5621 DATA LF( 361) / 0.1762859673352408D+04 / AB 5622 DATA LF( 362) / 0.1768748551310741D+04 / AB 5623 DATA LF( 363) / 0.1774640195522566D+04 / AB 5624 DATA LF( 364) / 0.1780534598356831D+04 / AB 5625 DATA LF( 365) / 0.1786431752224468D+04 / AB 5626 DATA LF( 366) / 0.1792331649578050D+04 / AB 5627 DATA LF( 367) / 0.1798234282911452D+04 / AB 5628 DATA LF( 368) / 0.1804139644759506D+04 / AB 5629 DATA LF( 369) / 0.1810047727697675D+04 / AB 5630 DATA LF( 370) / 0.1815958524341716D+04 / AB 5631 DATA LF( 371) / 0.1821872027347354D+04 / AB 5632 DATA LF( 372) / 0.1827788229409962D+04 / AB 5633 DATA LF( 373) / 0.1833707123264235D+04 / AB 5634 DATA LF( 374) / 0.1839628701683879D+04 / AB 5635 DATA LF( 375) / 0.1845552957481293D+04 / AB 5636 DATA LF( 376) / 0.1851479883507263D+04 / AB 5637 DATA LF( 377) / 0.1857409472650653D+04 / AB 5638 DATA LF( 378) / 0.1863341717838101D+04 / AB 5639 DATA LF( 379) / 0.1869276612033721D+04 / AB 5640 DATA LF( 380) / 0.1875214148238803D+04 / AB 5641 DATA LF( 381) / 0.1881154319491524D+04 / AB 5642 DATA LF( 382) / 0.1887097118866651D+04 / AB 5643 DATA LF( 383) / 0.1893042539475257D+04 / AB 5644 DATA LF( 384) / 0.1898990574464438D+04 / AB 5645 DATA LF( 385) / 0.1904941217017026D+04 / AB 5646 DATA LF( 386) / 0.1910894460351313D+04 / AB 5647 DATA LF( 387) / 0.1916850297720778D+04 / AB 5648 DATA LF( 388) / 0.1922808722413808D+04 / AB 5649 DATA LF( 389) / 0.1928769727753431D+04 / AB 5650 DATA LF( 390) / 0.1934733307097050D+04 / AB 5651 DATA LF( 391) / 0.1940699453836173D+04 / AB 5652 DATA LF( 392) / 0.1946668161396159D+04 / AB 5653 DATA LF( 393) / 0.1952639423235949D+04 / AB 5654 DATA LF( 394) / 0.1958613232847818D+04 / AB 5655 DATA LF( 395) / 0.1964589583757116D+04 / AB 5656 DATA LF( 396) / 0.1970568469522017D+04 / AB 5657 DATA LF( 397) / 0.1976549883733272D+04 / AB 5658 DATA LF( 398) / 0.1982533820013959D+04 / AB 5659 DATA LF( 399) / 0.1988520272019244D+04 / AB 5660 DATA LF( 400) / 0.1994509233436133D+04 / AB 5661 DATA LF( 401) / 0.2000500697983241D+04 / AB 5662 DATA LF( 402) / 0.2006494659410548D+04 / AB 5663 DATA LF( 403) / 0.2012491111499167D+04 / AB 5664 DATA LF( 404) / 0.2018490048061114D+04 / AB 5665 DATA LF( 405) / 0.2024491462939075D+04 / AB 5666 DATA LF( 406) / 0.2030495350006181D+04 / AB 5667 DATA LF( 407) / 0.2036501703165783D+04 / AB 5668 DATA LF( 408) / 0.2042510516351226D+04 / AB 5669 DATA LF( 409) / 0.2048521783525630D+04 / AB 5670 DATA LF( 410) / 0.2054535498681673D+04 / AB 5671 DATA LF( 411) / 0.2060551655841371D+04 / AB 5672 DATA LF( 412) / 0.2066570249055867D+04 / AB 5673 DATA LF( 413) / 0.2072591272405217D+04 / AB 5674 DATA LF( 414) / 0.2078614719998178D+04 / AB 5675 DATA LF( 415) / 0.2084640585972003D+04 / AB 5676 DATA LF( 416) / 0.2090668864492234D+04 / AB 5677 DATA LF( 417) / 0.2096699549752495D+04 / AB 5678 DATA LF( 418) / 0.2102732635974294D+04 / AB 5679 DATA LF( 419) / 0.2108768117406819D+04 / AB 5680 DATA LF( 420) / 0.2114805988326741D+04 / AB 5681 DATA LF( 421) / 0.2120846243038018D+04 / AB 5682 DATA LF( 422) / 0.2126888875871701D+04 / AB 5683 DATA LF( 423) / 0.2132933881185737D+04 / AB 5684 DATA LF( 424) / 0.2138981253364783D+04 / AB 5685 DATA LF( 425) / 0.2145030986820015D+04 / AB 5686 DATA LF( 426) / 0.2151083075988939D+04 / AB 5687 DATA LF( 427) / 0.2157137515335209D+04 / AB 5688 DATA LF( 428) / 0.2163194299348437D+04 / AB 5689 DATA LF( 429) / 0.2169253422544019D+04 / AB 5690 DATA LF( 430) / 0.2175314879462947D+04 / AB 5691 DATA LF( 431) / 0.2181378664671635D+04 / AB 5692 DATA LF( 432) / 0.2187444772761738D+04 / AB 5693 DATA LF( 433) / 0.2193513198349982D+04 / AB 5694 DATA LF( 434) / 0.2199583936077985D+04 / AB 5695 DATA LF( 435) / 0.2205656980612085D+04 / AB 5696 DATA LF( 436) / 0.2211732326643174D+04 / AB 5697 DATA LF( 437) / 0.2217809968886523D+04 / AB 5698 DATA LF( 438) / 0.2223889902081619D+04 / AB 5699 DATA LF( 439) / 0.2229972120991995D+04 / AB 5700 DATA LF( 440) / 0.2236056620405070D+04 / AB 5701 DATA LF( 441) / 0.2242143395131983D+04 / AB 5702 DATA LF( 442) / 0.2248232440007429D+04 / AB 5703 DATA LF( 443) / 0.2254323749889507D+04 / AB 5704 DATA LF( 444) / 0.2260417319659552D+04 / AB 5705 DATA LF( 445) / 0.2266513144221985D+04 / AB 5706 DATA LF( 446) / 0.2272611218504151D+04 / AB 5707 DATA LF( 447) / 0.2278711537456171D+04 / AB 5708 DATA LF( 448) / 0.2284814096050784D+04 / AB 5709 DATA LF( 449) / 0.2290918889283199D+04 / AB 5710 DATA LF( 450) / 0.2297025912170942D+04 / AB 5711 DATA LF( 451) / 0.2303135159753706D+04 / AB 5712 DATA LF( 452) / 0.2309246627093209D+04 / AB 5713 DATA LF( 453) / 0.2315360309273041D+04 / AB 5714 DATA LF( 454) / 0.2321476201398524D+04 / AB 5715 DATA LF( 455) / 0.2327594298596565D+04 / AB 5716 DATA LF( 456) / 0.2333714596015516D+04 / AB 5717 DATA LF( 457) / 0.2339837088825031D+04 / AB 5718 DATA LF( 458) / 0.2345961772215925D+04 / AB 5719 DATA LF( 459) / 0.2352088641400039D+04 / AB 5720 DATA LF( 460) / 0.2358217691610100D+04 / AB 5721 DATA LF( 461) / 0.2364348918099583D+04 / AB 5722 DATA LF( 462) / 0.2370482316142579D+04 / AB 5723 DATA LF( 463) / 0.2376617881033661D+04 / AB 5724 DATA LF( 464) / 0.2382755608087747D+04 / AB 5725 DATA LF( 465) / 0.2388895492639974D+04 / AB 5726 DATA LF( 466) / 0.2395037530045561D+04 / AB 5727 DATA LF( 467) / 0.2401181715679687D+04 / AB 5728 DATA LF( 468) / 0.2407328044937356D+04 / AB 5729 DATA LF( 469) / 0.2413476513233273D+04 / AB 5730 DATA LF( 470) / 0.2419627116001719D+04 / AB 5731 DATA LF( 471) / 0.2425779848696424D+04 / AB 5732 DATA LF( 472) / 0.2431934706790440D+04 / AB 5733 DATA LF( 473) / 0.2438091685776025D+04 / AB 5734 DATA LF( 474) / 0.2444250781164517D+04 / AB 5735 DATA LF( 475) / 0.2450411988486213D+04 / AB 5736 DATA LF( 476) / 0.2456575303290247D+04 / AB 5737 DATA LF( 477) / 0.2462740721144479D+04 / AB 5738 DATA LF( 478) / 0.2468908237635367D+04 / AB 5739 DATA LF( 479) / 0.2475077848367858D+04 / AB 5740 DATA LF( 480) / 0.2481249548965269D+04 / AB 5741 DATA LF( 481) / 0.2487423335069171D+04 / AB 5742 DATA LF( 482) / 0.2493599202339277D+04 / AB 5743 DATA LF( 483) / 0.2499777146453328D+04 / AB 5744 DATA LF( 484) / 0.2505957163106980D+04 / AB 5745 DATA LF( 485) / 0.2512139248013697D+04 / AB 5746 DATA LF( 486) / 0.2518323396904634D+04 / AB 5747 DATA LF( 487) / 0.2524509605528535D+04 / AB 5748 DATA LF( 488) / 0.2530697869651617D+04 / AB 5749 DATA LF( 489) / 0.2536888185057470D+04 / AB 5750 DATA LF( 490) / 0.2543080547546945D+04 / AB 5751 DATA LF( 491) / 0.2549274952938050D+04 / AB 5752 DATA LF( 492) / 0.2555471397065845D+04 / AB 5753 DATA LF( 493) / 0.2561669875782337D+04 / AB 5754 DATA LF( 494) / 0.2567870384956380D+04 / AB 5755 DATA LF( 495) / 0.2574072920473567D+04 / AB 5756 DATA LF( 496) / 0.2580277478236136D+04 / AB 5757 DATA LF( 497) / 0.2586484054162861D+04 / AB 5758 DATA LF( 498) / 0.2592692644188958D+04 / AB 5759 DATA LF( 499) / 0.2598903244265982D+04 / AB 5760 DATA LF( 500) / 0.2605115850361734D+04 / AB 5761 DATA LF( 501) / 0.2611330458460156D+04 / AB 5762 DATA LF( 502) / 0.2617547064561241D+04 / AB 5763 DATA LF( 503) / 0.2623765664680933D+04 / AB 5764 DATA LF( 504) / 0.2629986254851032D+04 / AB 5765 DATA LF( 505) / 0.2636208831119104D+04 / AB 5766 DATA LF( 506) / 0.2642433389548379D+04 / AB 5767 DATA LF( 507) / 0.2648659926217667D+04 / AB 5768 DATA LF( 508) / 0.2654888437221258D+04 / AB 5769 DATA LF( 509) / 0.2661118918668836D+04 / AB 5770 DATA LF( 510) / 0.2667351366685387D+04 / AB 5771 DATA LF( 511) / 0.2673585777411105D+04 / AB 5772 DATA LF( 512) / 0.2679822147001309D+04 / AB 5773 DATA LF( 513) / 0.2686060471626348D+04 / AB 5774 DATA LF( 514) / 0.2692300747471519D+04 / AB 5775 DATA LF( 515) / 0.2698542970736974D+04 / AB 5776 DATA LF( 516) / 0.2704787137637638D+04 / AB 5777 DATA LF( 517) / 0.2711033244403120D+04 / AB 5778 DATA LF( 518) / 0.2717281287277628D+04 / AB 5779 DATA LF( 519) / 0.2723531262519888D+04 / AB 5780 DATA LF( 520) / 0.2729783166403053D+04 / AB 5781 DATA LF( 521) / 0.2736036995214629D+04 / AB 5782 DATA LF( 522) / 0.2742292745256382D+04 / AB 5783 DATA LF( 523) / 0.2748550412844265D+04 / AB 5784 DATA LF( 524) / 0.2754809994308330D+04 / AB 5785 DATA LF( 525) / 0.2761071485992651D+04 / AB 5786 DATA LF( 526) / 0.2767334884255242D+04 / AB 5787 DATA LF( 527) / 0.2773600185467980D+04 / AB 5788 DATA LF( 528) / 0.2779867386016522D+04 / AB 5789 DATA LF( 529) / 0.2786136482300228D+04 / AB 5790 DATA LF( 530) / 0.2792407470732086D+04 / AB 5791 DATA LF( 531) / 0.2798680347738632D+04 / AB 5792 DATA LF( 532) / 0.2804955109759874D+04 / AB 5793 DATA LF( 533) / 0.2811231753249216D+04 / AB 5794 DATA LF( 534) / 0.2817510274673382D+04 / AB 5795 DATA LF( 535) / 0.2823790670512342D+04 / AB 5796 DATA LF( 536) / 0.2830072937259238D+04 / AB 5797 DATA LF( 537) / 0.2836357071420309D+04 / AB 5798 DATA LF( 538) / 0.2842643069514818D+04 / AB 5799 DATA LF( 539) / 0.2848930928074979D+04 / AB 5800 DATA LF( 540) / 0.2855220643645888D+04 / AB 5801 DATA LF( 541) / 0.2861512212785447D+04 / AB 5802 DATA LF( 542) / 0.2867805632064293D+04 / AB 5803 DATA LF( 543) / 0.2874100898065733D+04 / AB 5804 DATA LF( 544) / 0.2880398007385667D+04 / AB 5805 DATA LF( 545) / 0.2886696956632523D+04 / AB 5806 DATA LF( 546) / 0.2892997742427186D+04 / AB 5807 DATA LF( 547) / 0.2899300361402931D+04 / AB 5808 DATA LF( 548) / 0.2905604810205353D+04 / AB 5809 DATA LF( 549) / 0.2911911085492301D+04 / AB 5810 DATA LF( 550) / 0.2918219183933810D+04 / AB 5811 DATA LF( 551) / 0.2924529102212037D+04 / AB 5812 DATA LF( 552) / 0.2930840837021190D+04 / AB 5813 DATA LF( 553) / 0.2937154385067467D+04 / AB 5814 DATA LF( 554) / 0.2943469743068989D+04 / AB 5815 DATA LF( 555) / 0.2949786907755737D+04 / AB 5816 DATA LF( 556) / 0.2956105875869483D+04 / AB 5817 DATA LF( 557) / 0.2962426644163733D+04 / AB 5818 DATA LF( 558) / 0.2968749209403661D+04 / AB 5819 DATA LF( 559) / 0.2975073568366042D+04 / AB 5820 DATA LF( 560) / 0.2981399717839197D+04 / AB 5821 DATA LF( 561) / 0.2987727654622926D+04 / AB 5822 DATA LF( 562) / 0.2994057375528449D+04 / AB 5823 DATA LF( 563) / 0.3000388877378343D+04 / AB 5824 DATA LF( 564) / 0.3006722157006483D+04 / AB 5825 DATA LF( 565) / 0.3013057211257981D+04 / AB 5826 DATA LF( 566) / 0.3019394036989127D+04 / AB 5827 DATA LF( 567) / 0.3025732631067330D+04 / AB 5828 DATA LF( 568) / 0.3032072990371058D+04 / AB 5829 DATA LF( 569) / 0.3038415111789779D+04 / AB 5830 DATA LF( 570) / 0.3044758992223905D+04 / AB 5831 DATA LF( 571) / 0.3051104628584734D+04 / AB 5832 DATA LF( 572) / 0.3057452017794390D+04 / AB 5833 DATA LF( 573) / 0.3063801156785770D+04 / AB 5834 DATA LF( 574) / 0.3070152042502485D+04 / AB 5835 DATA LF( 575) / 0.3076504671898804D+04 / AB 5836 DATA LF( 576) / 0.3082859041939601D+04 / AB 5837 DATA LF( 577) / 0.3089215149600297D+04 / AB 5838 DATA LF( 578) / 0.3095572991866805D+04 / AB 5839 DATA LF( 579) / 0.3101932565735478D+04 / AB 5840 DATA LF( 580) / 0.3108293868213051D+04 / AB 5841 DATA LF( 581) / 0.3114656896316591D+04 / AB 5842 DATA LF( 582) / 0.3121021647073443D+04 / AB 5843 DATA LF( 583) / 0.3127388117521175D+04 / AB 5844 DATA LF( 584) / 0.3133756304707525D+04 / AB 5845 DATA LF( 585) / 0.3140126205690353D+04 / AB 5846 DATA LF( 586) / 0.3146497817537585D+04 / AB 5847 DATA LF( 587) / 0.3152871137327162D+04 / AB 5848 DATA LF( 588) / 0.3159246162146990D+04 / AB 5849 DATA LF( 589) / 0.3165622889094889D+04 / AB 5850 DATA LF( 590) / 0.3172001315278541D+04 / AB 5851 DATA LF( 591) / 0.3178381437815440D+04 / AB 5852 DATA LF( 592) / 0.3184763253832846D+04 / AB 5853 DATA LF( 593) / 0.3191146760467730D+04 / AB 5854 DATA LF( 594) / 0.3197531954866728D+04 / AB 5855 DATA LF( 595) / 0.3203918834186091D+04 / AB 5856 DATA LF( 596) / 0.3210307395591636D+04 / AB 5857 DATA LF( 597) / 0.3216697636258702D+04 / AB 5858 DATA LF( 598) / 0.3223089553372094D+04 / AB 5859 DATA LF( 599) / 0.3229483144126045D+04 / AB 5860 DATA LF( 600) / 0.3235878405724160D+04 / AB 5861 DATA LF( 601) / 0.3242275335379377D+04 / AB 5862 DATA LF( 602) / 0.3248673930313912D+04 / AB 5863 DATA LF( 603) / 0.3255074187759221D+04 / AB 5864 DATA LF( 604) / 0.3261476104955948D+04 / AB 5865 DATA LF( 605) / 0.3267879679153883D+04 / AB 5866 DATA LF( 606) / 0.3274284907611913D+04 / AB 5867 DATA LF( 607) / 0.3280691787597983D+04 / AB 5868 DATA LF( 608) / 0.3287100316389042D+04 / AB 5869 DATA LF( 609) / 0.3293510491271008D+04 / AB 5870 DATA LF( 610) / 0.3299922309538718D+04 / AB 5871 DATA LF( 611) / 0.3306335768495886D+04 / AB 5872 DATA LF( 612) / 0.3312750865455057D+04 / AB 5873 DATA LF( 613) / 0.3319167597737570D+04 / AB 5874 DATA LF( 614) / 0.3325585962673506D+04 / AB 5875 DATA LF( 615) / 0.3332005957601653D+04 / AB 5876 DATA LF( 616) / 0.3338427579869460D+04 / AB 5877 DATA LF( 617) / 0.3344850826832993D+04 / AB 5878 DATA LF( 618) / 0.3351275695856898D+04 / AB 5879 DATA LF( 619) / 0.3357702184314356D+04 / AB 5880 DATA LF( 620) / 0.3364130289587041D+04 / AB 5881 DATA LF( 621) / 0.3370560009065080D+04 / AB 5882 DATA LF( 622) / 0.3376991340147013D+04 / AB 5883 DATA LF( 623) / 0.3383424280239752D+04 / AB 5884 DATA LF( 624) / 0.3389858826758540D+04 / AB 5885 DATA LF( 625) / 0.3396294977126909D+04 / AB 5886 DATA LF( 626) / 0.3402732728776646D+04 / AB 5887 DATA LF( 627) / 0.3409172079147746D+04 / AB 5888 DATA LF( 628) / 0.3415613025688379D+04 / AB 5889 DATA LF( 629) / 0.3422055565854847D+04 / AB 5890 DATA LF( 630) / 0.3428499697111547D+04 / AB 5891 DATA LF( 631) / 0.3434945416930933D+04 / AB 5892 DATA LF( 632) / 0.3441392722793474D+04 / AB 5893 DATA LF( 633) / 0.3447841612187621D+04 / AB 5894 DATA LF( 634) / 0.3454292082609765D+04 / AB 5895 DATA LF( 635) / 0.3460744131564202D+04 / AB 5896 DATA LF( 636) / 0.3467197756563095D+04 / AB 5897 DATA LF( 637) / 0.3473652955126435D+04 / AB 5898 DATA LF( 638) / 0.3480109724782007D+04 / AB 5899 DATA LF( 639) / 0.3486568063065352D+04 / AB 5900 DATA LF( 640) / 0.3493027967519730D+04 / AB 5901 DATA LF( 641) / 0.3499489435696083D+04 / AB 5902 DATA LF( 642) / 0.3505952465153004D+04 / AB 5903 DATA LF( 643) / 0.3512417053456694D+04 / AB 5904 DATA LF( 644) / 0.3518883198180932D+04 / AB 5905 DATA LF( 645) / 0.3525350896907036D+04 / AB 5906 DATA LF( 646) / 0.3531820147223832D+04 / AB 5907 DATA LF( 647) / 0.3538290946727614D+04 / AB 5908 DATA LF( 648) / 0.3544763293022115D+04 / AB 5909 DATA LF( 649) / 0.3551237183718468D+04 / AB 5910 DATA LF( 650) / 0.3557712616435172D+04 / AB 5911 DATA LF( 651) / 0.3564189588798061D+04 / AB 5912 DATA LF( 652) / 0.3570668098440270D+04 / AB 5913 DATA LF( 653) / 0.3577148143002197D+04 / AB 5914 DATA LF( 654) / 0.3583629720131473D+04 / AB 5915 DATA LF( 655) / 0.3590112827482930D+04 / AB 5916 DATA LF( 656) / 0.3596597462718566D+04 / AB 5917 DATA LF( 657) / 0.3603083623507510D+04 / AB 5918 DATA LF( 658) / 0.3609571307525994D+04 / AB 5919 DATA LF( 659) / 0.3616060512457320D+04 / AB 5920 DATA LF( 660) / 0.3622551235991822D+04 / AB 5921 DATA LF( 661) / 0.3629043475826842D+04 / AB 5922 DATA LF( 662) / 0.3635537229666694D+04 / AB 5923 DATA LF( 663) / 0.3642032495222631D+04 / AB 5924 DATA LF( 664) / 0.3648529270212817D+04 / AB 5925 DATA LF( 665) / 0.3655027552362294D+04 / AB 5926 DATA LF( 666) / 0.3661527339402949D+04 / AB 5927 DATA LF( 667) / 0.3668028629073490D+04 / AB 5928 DATA LF( 668) / 0.3674531419119405D+04 / AB 5929 DATA LF( 669) / 0.3681035707292942D+04 / AB 5930 DATA LF( 670) / 0.3687541491353070D+04 / AB 5931 DATA LF( 671) / 0.3694048769065455D+04 / AB 5932 DATA LF( 672) / 0.3700557538202427D+04 / AB 5933 DATA LF( 673) / 0.3707067796542950D+04 / AB 5934 DATA LF( 674) / 0.3713579541872595D+04 / AB 5935 DATA LF( 675) / 0.3720092771983507D+04 / AB 5936 DATA LF( 676) / 0.3726607484674380D+04 / AB 5937 DATA LF( 677) / 0.3733123677750423D+04 / AB 5938 DATA LF( 678) / 0.3739641349023335D+04 / AB 5939 DATA LF( 679) / 0.3746160496311275D+04 / AB 5940 DATA LF( 680) / 0.3752681117438834D+04 / AB 5941 DATA LF( 681) / 0.3759203210237004D+04 / AB 5942 DATA LF( 682) / 0.3765726772543154D+04 / AB 5943 DATA LF( 683) / 0.3772251802200997D+04 / AB 5944 DATA LF( 684) / 0.3778778297060568D+04 / AB 5945 DATA LF( 685) / 0.3785306254978190D+04 / AB 5946 DATA LF( 686) / 0.3791835673816453D+04 / AB 5947 DATA LF( 687) / 0.3798366551444179D+04 / AB 5948 DATA LF( 688) / 0.3804898885736401D+04 / AB 5949 DATA LF( 689) / 0.3811432674574334D+04 / AB 5950 DATA LF( 690) / 0.3817967915845348D+04 / AB 5951 DATA LF( 691) / 0.3824504607442939D+04 / AB 5952 DATA LF( 692) / 0.3831042747266707D+04 / AB 5953 DATA LF( 693) / 0.3837582333222325D+04 / AB 5954 DATA LF( 694) / 0.3844123363221514D+04 / AB 5955 DATA LF( 695) / 0.3850665835182021D+04 / AB 5956 DATA LF( 696) / 0.3857209747027586D+04 / AB 5957 DATA LF( 697) / 0.3863755096687920D+04 / AB 5958 DATA LF( 698) / 0.3870301882098681D+04 / AB 5959 DATA LF( 699) / 0.3876850101201443D+04 / AB 5960 DATA LF( 700) / 0.3883399751943677D+04 / AB 5961 DATA LF( 701) / 0.3889950832278721D+04 / AB 5962 DATA LF( 702) / 0.3896503340165755D+04 / AB 5963 DATA LF( 703) / 0.3903057273569781D+04 / AB 5964 DATA LF( 704) / 0.3909612630461592D+04 / AB 5965 DATA LF( 705) / 0.3916169408817750D+04 / AB 5966 DATA LF( 706) / 0.3922727606620562D+04 / AB 5967 DATA LF( 707) / 0.3929287221858055D+04 / AB 5968 DATA LF( 708) / 0.3935848252523952D+04 / AB 5969 DATA LF( 709) / 0.3942410696617645D+04 / AB 5970 DATA LF( 710) / 0.3948974552144178D+04 / AB 5971 DATA LF( 711) / 0.3955539817114213D+04 / AB 5972 DATA LF( 712) / 0.3962106489544016D+04 / AB 5973 DATA LF( 713) / 0.3968674567455428D+04 / AB 5974 DATA LF( 714) / 0.3975244048875843D+04 / AB 5975 DATA LF( 715) / 0.3981814931838182D+04 / AB 5976 DATA LF( 716) / 0.3988387214380876D+04 / AB 5977 DATA LF( 717) / 0.3994960894547837D+04 / AB 5978 DATA LF( 718) / 0.4001535970388436D+04 / AB 5979 DATA LF( 719) / 0.4008112439957485D+04 / AB 5980 DATA LF( 720) / 0.4014690301315206D+04 / AB 5981 DATA LF( 721) / 0.4021269552527216D+04 / AB 5982 DATA LF( 722) / 0.4027850191664501D+04 / AB 5983 DATA LF( 723) / 0.4034432216803393D+04 / AB 5984 DATA LF( 724) / 0.4041015626025552D+04 / AB 5985 DATA LF( 725) / 0.4047600417417938D+04 / AB 5986 DATA LF( 726) / 0.4054186589072793D+04 / AB 5987 DATA LF( 727) / 0.4060774139087617D+04 / AB 5988 DATA LF( 728) / 0.4067363065565151D+04 / AB 5989 DATA LF( 729) / 0.4073953366613348D+04 / AB 5990 DATA LF( 730) / 0.4080545040345356D+04 / AB 5991 DATA LF( 731) / 0.4087138084879499D+04 / AB 5992 DATA LF( 732) / 0.4093732498339249D+04 / AB 5993 DATA LF( 733) / 0.4100328278853210D+04 / AB 5994 DATA LF( 734) / 0.4106925424555096D+04 / AB 5995 DATA LF( 735) / 0.4113523933583711D+04 / AB 5996 DATA LF( 736) / 0.4120123804082924D+04 / AB 5997 DATA LF( 737) / 0.4126725034201652D+04 / AB 5998 DATA LF( 738) / 0.4133327622093842D+04 / AB 5999 DATA LF( 739) / 0.4139931565918442D+04 / AB 6000 DATA LF( 740) / 0.4146536863839391D+04 / AB 6001 DATA LF( 741) / 0.4153143514025589D+04 / AB 6002 DATA LF( 742) / 0.4159751514650885D+04 / AB 6003 DATA LF( 743) / 0.4166360863894052D+04 / AB 6004 DATA LF( 744) / 0.4172971559938770D+04 / AB 6005 DATA LF( 745) / 0.4179583600973603D+04 / AB 6006 DATA LF( 746) / 0.4186196985191983D+04 / AB 6007 DATA LF( 747) / 0.4192811710792186D+04 / AB 6008 DATA LF( 748) / 0.4199427775977319D+04 / AB 6009 DATA LF( 749) / 0.4206045178955294D+04 / AB 6010 DATA LF( 750) / 0.4212663917938811D+04 / AB 6011 DATA LF( 751) / 0.4219283991145341D+04 / AB 6012 DATA LF( 752) / 0.4225905396797106D+04 / AB 6013 DATA LF( 753) / 0.4232528133121055D+04 / AB 6014 DATA LF( 754) / 0.4239152198348856D+04 / AB 6015 DATA LF( 755) / 0.4245777590716863D+04 / AB 6016 DATA LF( 756) / 0.4252404308466113D+04 / AB 6017 DATA LF( 757) / 0.4259032349842292D+04 / AB 6018 DATA LF( 758) / 0.4265661713095729D+04 / AB 6019 DATA LF( 759) / 0.4272292396481372D+04 / AB 6020 DATA LF( 760) / 0.4278924398258768D+04 / AB 6021 DATA LF( 761) / 0.4285557716692048D+04 / AB 6022 DATA LF( 762) / 0.4292192350049910D+04 / AB 6023 DATA LF( 763) / 0.4298828296605596D+04 / AB 6024 DATA LF( 764) / 0.4305465554636880D+04 / AB 6025 DATA LF( 765) / 0.4312104122426047D+04 / AB 6026 DATA LF( 766) / 0.4318743998259873D+04 / AB 6027 DATA LF( 767) / 0.4325385180429614D+04 / AB 6028 DATA LF( 768) / 0.4332027667230981D+04 / AB 6029 DATA LF( 769) / 0.4338671456964129D+04 / AB 6030 DATA LF( 770) / 0.4345316547933635D+04 / AB 6031 DATA LF( 771) / 0.4351962938448482D+04 / AB 6032 DATA LF( 772) / 0.4358610626822046D+04 / AB 6033 DATA LF( 773) / 0.4365259611372070D+04 / AB 6034 DATA LF( 774) / 0.4371909890420658D+04 / AB 6035 DATA LF( 775) / 0.4378561462294248D+04 / AB 6036 DATA LF( 776) / 0.4385214325323601D+04 / AB 6037 DATA LF( 777) / 0.4391868477843785D+04 / AB 6038 DATA LF( 778) / 0.4398523918194152D+04 / AB 6039 DATA LF( 779) / 0.4405180644718330D+04 / AB 6040 DATA LF( 780) / 0.4411838655764201D+04 / AB 6041 DATA LF( 781) / 0.4418497949683885D+04 / AB 6042 DATA LF( 782) / 0.4425158524833724D+04 / AB 6043 DATA LF( 783) / 0.4431820379574269D+04 / AB 6044 DATA LF( 784) / 0.4438483512270261D+04 / AB 6045 DATA LF( 785) / 0.4445147921290611D+04 / AB 6046 DATA LF( 786) / 0.4451813605008393D+04 / AB 6047 DATA LF( 787) / 0.4458480561800822D+04 / AB 6048 DATA LF( 788) / 0.4465148790049240D+04 / AB 6049 DATA LF( 789) / 0.4471818288139098D+04 / AB 6050 DATA LF( 790) / 0.4478489054459944D+04 / AB 6051 DATA LF( 791) / 0.4485161087405405D+04 / AB 6052 DATA LF( 792) / 0.4491834385373172D+04 / AB 6053 DATA LF( 793) / 0.4498508946764987D+04 / AB 6054 DATA LF( 794) / 0.4505184769986622D+04 / AB 6055 DATA LF( 795) / 0.4511861853447869D+04 / AB 6056 DATA LF( 796) / 0.4518540195562523D+04 / AB 6057 DATA LF( 797) / 0.4525219794748367D+04 / AB 6058 DATA LF( 798) / 0.4531900649427158D+04 / AB 6059 DATA LF( 799) / 0.4538582758024608D+04 / AB 6060 DATA LF( 800) / 0.4545266118970374D+04 / AB 6061 DATA LF( 801) / 0.4551950730698041D+04 / AB 6062 DATA LF( 802) / 0.4558636591645110D+04 / AB 6063 DATA LF( 803) / 0.4565323700252977D+04 / AB 6064 DATA LF( 804) / 0.4572012054966924D+04 / AB 6065 DATA LF( 805) / 0.4578701654236103D+04 / AB 6066 DATA LF( 806) / 0.4585392496513521D+04 / AB 6067 DATA LF( 807) / 0.4592084580256028D+04 / AB 6068 DATA LF( 808) / 0.4598777903924298D+04 / AB 6069 DATA LF( 809) / 0.4605472465982819D+04 / AB 6070 DATA LF( 810) / 0.4612168264899877D+04 / AB 6071 DATA LF( 811) / 0.4618865299147544D+04 / AB 6072 DATA LF( 812) / 0.4625563567201659D+04 / AB 6073 DATA LF( 813) / 0.4632263067541820D+04 / AB 6074 DATA LF( 814) / 0.4638963798651368D+04 / AB 6075 DATA LF( 815) / 0.4645665759017371D+04 / AB 6076 DATA LF( 816) / 0.4652368947130612D+04 / AB 6077 DATA LF( 817) / 0.4659073361485576D+04 / AB 6078 DATA LF( 818) / 0.4665779000580436D+04 / AB 6079 DATA LF( 819) / 0.4672485862917039D+04 / AB 6080 DATA LF( 820) / 0.4679193947000892D+04 / AB 6081 DATA LF( 821) / 0.4685903251341150D+04 / AB 6082 DATA LF( 822) / 0.4692613774450602D+04 / AB 6083 DATA LF( 823) / 0.4699325514845658D+04 / AB 6084 DATA LF( 824) / 0.4706038471046336D+04 / AB 6085 DATA LF( 825) / 0.4712752641576245D+04 / AB 6086 DATA LF( 826) / 0.4719468024962580D+04 / AB 6087 DATA LF( 827) / 0.4726184619736101D+04 / AB 6088 DATA LF( 828) / 0.4732902424431125D+04 / AB 6089 DATA LF( 829) / 0.4739621437585510D+04 / AB 6090 DATA LF( 830) / 0.4746341657740645D+04 / AB 6091 DATA LF( 831) / 0.4753063083441436D+04 / AB 6092 DATA LF( 832) / 0.4759785713236291D+04 / AB 6093 DATA LF( 833) / 0.4766509545677112D+04 / AB 6094 DATA LF( 834) / 0.4773234579319279D+04 / AB 6095 DATA LF( 835) / 0.4779960812721638D+04 / AB 6096 DATA LF( 836) / 0.4786688244446489D+04 / AB 6097 DATA LF( 837) / 0.4793416873059574D+04 / AB 6098 DATA LF( 838) / 0.4800146697130063D+04 / AB 6099 DATA LF( 839) / 0.4806877715230545D+04 / AB 6100 DATA LF( 840) / 0.4813609925937012D+04 / AB 6101 DATA LF( 841) / 0.4820343327828849D+04 / AB 6102 DATA LF( 842) / 0.4827077919488823D+04 / AB 6103 DATA LF( 843) / 0.4833813699503065D+04 / AB 6104 DATA LF( 844) / 0.4840550666461067D+04 / AB 6105 DATA LF( 845) / 0.4847288818955662D+04 / AB 6106 DATA LF( 846) / 0.4854028155583020D+04 / AB 6107 DATA LF( 847) / 0.4860768674942627D+04 / AB 6108 DATA LF( 848) / 0.4867510375637278D+04 / AB 6109 DATA LF( 849) / 0.4874253256273070D+04 / AB 6110 DATA LF( 850) / 0.4880997315459382D+04 / AB 6111 DATA LF( 851) / 0.4887742551808866D+04 / AB 6112 DATA LF( 852) / 0.4894488963937440D+04 / AB 6113 DATA LF( 853) / 0.4901236550464268D+04 / AB 6114 DATA LF( 854) / 0.4907985310011760D+04 / AB 6115 DATA LF( 855) / 0.4914735241205549D+04 / AB 6116 DATA LF( 856) / 0.4921486342674486D+04 / AB 6117 DATA LF( 857) / 0.4928238613050627D+04 / AB 6118 DATA LF( 858) / 0.4934992050969225D+04 / AB 6119 DATA LF( 859) / 0.4941746655068713D+04 / AB 6120 DATA LF( 860) / 0.4948502423990697D+04 / AB 6121 DATA LF( 861) / 0.4955259356379945D+04 / AB 6122 DATA LF( 862) / 0.4962017450884373D+04 / AB 6123 DATA LF( 863) / 0.4968776706155037D+04 / AB 6124 DATA LF( 864) / 0.4975537120846119D+04 / AB 6125 DATA LF( 865) / 0.4982298693614924D+04 / AB 6126 DATA LF( 866) / 0.4989061423121856D+04 / AB 6127 DATA LF( 867) / 0.4995825308030418D+04 / AB 6128 DATA LF( 868) / 0.5002590347007199D+04 / AB 6129 DATA LF( 869) / 0.5009356538721859D+04 / AB 6130 DATA LF( 870) / 0.5016123881847125D+04 / AB 6131 DATA LF( 871) / 0.5022892375058773D+04 / AB 6132 DATA LF( 872) / 0.5029662017035625D+04 / AB 6133 DATA LF( 873) / 0.5036432806459535D+04 / AB 6134 DATA LF( 874) / 0.5043204742015374D+04 / AB 6135 DATA LF( 875) / 0.5049977822391030D+04 / AB 6136 DATA LF( 876) / 0.5056752046277387D+04 / AB 6137 DATA LF( 877) / 0.5063527412368324D+04 / AB 6138 DATA LF( 878) / 0.5070303919360696D+04 / AB 6139 DATA LF( 879) / 0.5077081565954330D+04 / AB 6140 DATA LF( 880) / 0.5083860350852016D+04 / AB 6141 DATA LF( 881) / 0.5090640272759489D+04 / AB 6142 DATA LF( 882) / 0.5097421330385425D+04 / AB 6143 DATA LF( 883) / 0.5104203522441431D+04 / AB 6144 DATA LF( 884) / 0.5110986847642035D+04 / AB 6145 DATA LF( 885) / 0.5117771304704673D+04 / AB 6146 DATA LF( 886) / 0.5124556892349681D+04 / AB 6147 DATA LF( 887) / 0.5131343609300286D+04 / AB 6148 DATA LF( 888) / 0.5138131454282596D+04 / AB 6149 DATA LF( 889) / 0.5144920426025587D+04 / AB 6150 DATA LF( 890) / 0.5151710523261101D+04 / AB 6151 DATA LF( 891) / 0.5158501744723828D+04 / AB 6152 DATA LF( 892) / 0.5165294089151299D+04 / AB 6153 DATA LF( 893) / 0.5172087555283879D+04 / AB 6154 DATA LF( 894) / 0.5178882141864755D+04 / AB 6155 DATA LF( 895) / 0.5185677847639929D+04 / AB 6156 DATA LF( 896) / 0.5192474671358204D+04 / AB 6157 DATA LF( 897) / 0.5199272611771178D+04 / AB 6158 DATA LF( 898) / 0.5206071667633237D+04 / AB 6159 DATA LF( 899) / 0.5212871837701539D+04 / AB 6160 DATA LF( 900) / 0.5219673120736011D+04 / AB 6161 DATA LF( 901) / 0.5226475515499335D+04 / AB 6162 DATA LF( 902) / 0.5233279020756943D+04 / AB 6163 DATA LF( 903) / 0.5240083635277007D+04 / AB 6164 DATA LF( 904) / 0.5246889357830423D+04 / AB 6165 DATA LF( 905) / 0.5253696187190815D+04 / AB 6166 DATA LF( 906) / 0.5260504122134515D+04 / AB 6167 DATA LF( 907) / 0.5267313161440558D+04 / AB 6168 DATA LF( 908) / 0.5274123303890673D+04 / AB 6169 DATA LF( 909) / 0.5280934548269275D+04 / AB 6170 DATA LF( 910) / 0.5287746893363452D+04 / AB 6171 DATA LF( 911) / 0.5294560337962963D+04 / AB 6172 DATA LF( 912) / 0.5301374880860223D+04 / AB 6173 DATA LF( 913) / 0.5308190520850298D+04 / AB 6174 DATA LF( 914) / 0.5315007256730893D+04 / AB 6175 DATA LF( 915) / 0.5321825087302346D+04 / AB 6176 DATA LF( 916) / 0.5328644011367622D+04 / AB 6177 DATA LF( 917) / 0.5335464027732296D+04 / AB 6178 DATA LF( 918) / 0.5342285135204553D+04 / AB 6179 DATA LF( 919) / 0.5349107332595173D+04 / AB 6180 DATA LF( 920) / 0.5355930618717529D+04 / AB 6181 DATA LF( 921) / 0.5362754992387572D+04 / AB 6182 DATA LF( 922) / 0.5369580452423827D+04 / AB 6183 DATA LF( 923) / 0.5376406997647384D+04 / AB 6184 DATA LF( 924) / 0.5383234626881886D+04 / AB 6185 DATA LF( 925) / 0.5390063338953529D+04 / AB 6186 DATA LF( 926) / 0.5396893132691041D+04 / AB 6187 DATA LF( 927) / 0.5403724006925687D+04 / AB 6188 DATA LF( 928) / 0.5410555960491253D+04 / AB 6189 DATA LF( 929) / 0.5417388992224039D+04 / AB 6190 DATA LF( 930) / 0.5424223100962853D+04 / AB 6191 DATA LF( 931) / 0.5431058285549000D+04 / AB 6192 DATA LF( 932) / 0.5437894544826278D+04 / AB 6193 DATA LF( 933) / 0.5444731877640963D+04 / AB 6194 DATA LF( 934) / 0.5451570282841810D+04 / AB 6195 DATA LF( 935) / 0.5458409759280039D+04 / AB 6196 DATA LF( 936) / 0.5465250305809328D+04 / AB 6197 DATA LF( 937) / 0.5472091921285805D+04 / AB 6198 DATA LF( 938) / 0.5478934604568044D+04 / AB 6199 DATA LF( 939) / 0.5485778354517050D+04 / AB 6200 DATA LF( 940) / 0.5492623169996258D+04 / AB 6201 DATA LF( 941) / 0.5499469049871523D+04 / AB 6202 DATA LF( 942) / 0.5506315993011108D+04 / AB 6203 DATA LF( 943) / 0.5513163998285684D+04 / AB 6204 DATA LF( 944) / 0.5520013064568318D+04 / AB 6205 DATA LF( 945) / 0.5526863190734462D+04 / AB 6206 DATA LF( 946) / 0.5533714375661957D+04 / AB 6207 DATA LF( 947) / 0.5540566618231009D+04 / AB 6208 DATA LF( 948) / 0.5547419917324195D+04 / AB 6209 DATA LF( 949) / 0.5554274271826450D+04 / AB 6210 DATA LF( 950) / 0.5561129680625059D+04 / AB 6211 DATA LF( 951) / 0.5567986142609654D+04 / AB 6212 DATA LF( 952) / 0.5574843656672199D+04 / AB 6213 DATA LF( 953) / 0.5581702221706991D+04 / AB 6214 DATA LF( 954) / 0.5588561836610646D+04 / AB 6215 DATA LF( 955) / 0.5595422500282093D+04 / AB 6216 DATA LF( 956) / 0.5602284211622574D+04 / AB 6217 DATA LF( 957) / 0.5609146969535625D+04 / AB 6218 DATA LF( 958) / 0.5616010772927079D+04 / AB 6219 DATA LF( 959) / 0.5622875620705049D+04 / AB 6220 DATA LF( 960) / 0.5629741511779933D+04 / AB 6221 DATA LF( 961) / 0.5636608445064395D+04 / AB 6222 DATA LF( 962) / 0.5643476419473365D+04 / AB 6223 DATA LF( 963) / 0.5650345433924031D+04 / AB 6224 DATA LF( 964) / 0.5657215487335829D+04 / AB 6225 DATA LF( 965) / 0.5664086578630439D+04 / AB 6226 DATA LF( 966) / 0.5670958706731778D+04 / AB 6227 DATA LF( 967) / 0.5677831870565991D+04 / AB 6228 DATA LF( 968) / 0.5684706069061444D+04 / AB 6229 DATA LF( 969) / 0.5691581301148721D+04 / AB 6230 DATA LF( 970) / 0.5698457565760611D+04 / AB 6231 DATA LF( 971) / 0.5705334861832109D+04 / AB 6232 DATA LF( 972) / 0.5712213188300400D+04 / AB 6233 DATA LF( 973) / 0.5719092544104860D+04 / AB 6234 DATA LF( 974) / 0.5725972928187047D+04 / AB 6235 DATA LF( 975) / 0.5732854339490689D+04 / AB 6236 DATA LF( 976) / 0.5739736776961687D+04 / AB 6237 DATA LF( 977) / 0.5746620239548100D+04 / AB 6238 DATA LF( 978) / 0.5753504726200143D+04 / AB 6239 DATA LF( 979) / 0.5760390235870178D+04 / AB 6240 DATA LF( 980) / 0.5767276767512708D+04 / AB 6241 DATA LF( 981) / 0.5774164320084373D+04 / AB 6242 DATA LF( 982) / 0.5781052892543938D+04 / AB 6243 DATA LF( 983) / 0.5787942483852293D+04 / AB 6244 DATA LF( 984) / 0.5794833092972440D+04 / AB 6245 DATA LF( 985) / 0.5801724718869492D+04 / AB 6246 DATA LF( 986) / 0.5808617360510664D+04 / AB 6247 DATA LF( 987) / 0.5815511016865267D+04 / AB 6248 DATA LF( 988) / 0.5822405686904700D+04 / AB 6249 DATA LF( 989) / 0.5829301369602448D+04 / AB 6250 DATA LF( 990) / 0.5836198063934071D+04 / AB 6251 DATA LF( 991) / 0.5843095768877200D+04 / AB 6252 DATA LF( 992) / 0.5849994483411529D+04 / AB 6253 DATA LF( 993) / 0.5856894206518815D+04 / AB 6254 DATA LF( 994) / 0.5863794937182860D+04 / AB 6255 DATA LF( 995) / 0.5870696674389516D+04 / AB 6256 DATA LF( 996) / 0.5877599417126675D+04 / AB 6257 DATA LF( 997) / 0.5884503164384259D+04 / AB 6258 DATA LF( 998) / 0.5891407915154221D+04 / AB 6259 DATA LF( 999) / 0.5898313668430533D+04 / AB 6260 DATA LF(1000) / 0.5905220423209181D+04 / AB 6261 DATA LF(1001) / 0.5912128178488163D+04 / AB 6262 END AB 6263 DOUBLE PRECISION FUNCTION DLGAMA(X) AB 6264 C AB 6265 C THIS ROUTINE CALCULATES THE LOG(GAMMA) FUNCTION FOR A REAL ARGUMENT AB 6266 C X. COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCES AB 6267 C 1 AND 2. THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE AB 6268 C LOG(GAMMA) TO AT LEAST 18 SIGNIFICANT DECIMAL DIGITS. THE AB 6269 C APPROXIMATION FOR X .GE. 12 IS FROM REFERENCE 3. APPROXIMATIONS AB 6270 C FOR X .LT. 12.0 ARE UNPUBLISHED. LOWER ORDER APPROXIMATIONS CAN AB 6271 C BE SUBSTITUTED ON MACHINES WITH LESS PRECISE ARITHMETIC. AB 6272 C AB 6273 C EXPLANATION OF MACHINE-DEPENDENT CONSTANTS AB 6274 C AB 6275 C XBIG - THE LARGEST ARGUMENT FOR WHICH LN(GAMMA(X)) IS REPRESENTABLE AB 6276 C IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION AB 6277 C LN(GAMMA(XBIG)) = XINF. AB 6278 C XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER. AB 6279 C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT AB 6280 C 1.0+EPS .GT. 1.0 AB 6281 C FRTBIG - ROUGH ESTIMATE OF THE FOURTH ROOT OF XBIG AB 6282 C AB 6283 C APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: AB 6284 C AB 6285 C IBM/370 UNIVAC/110X VAX 11/780 AB 6286 C (D.P.) (D.P.) (S.P.) (D.P.) (G.F.) AB 6287 C AB 6288 C XBIG 4.293D+73 1.280D+305 2.057E+36 2.057D+36 1.28D305 AB 6289 C XINF 7.230D+75 8.980D+307 1.701E+38 1.701D+38 8.98D307 AB 6290 C EPS 2.220D-16 1.735D-018 5.960E-08 1.388D-17 1.70D-15 AB 6291 C FRTBIG 2.500D+18 1.800D+076 1.100E+09 1.100D+09 1.80D+76 AB 6292 C AB 6293 C ERROR RETURNS AB 6294 C AB 6295 C THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR AB 6296 C WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED AB 6297 C TO BE FREE OF UNDERFLOW AND OVERFLOW. AB 6298 C AB 6299 C OTHER SUBPROGRAMS REQUIRED (SINGLE PRECISION VERSION) AB 6300 C AB 6301 C ALOG,EXP,FLOAT,IFIX,SIN AB 6302 C AB 6303 C OTHER SUBPROGRAMS REQUIRED (DOUBLE PRECISION VERSION) AB 6304 C AB 6305 C DBLE,DEXP,DLOG,DSIN,FLOAT,IFIX,SNGL AB 6306 C AB 6307 C REFERENCES: AB 6308 C AB 6309 C 1) W. J. CODY AND K. E. HILLSTROM, 'CHEBYSHEV APPROXIMATIONS FOR AB 6310 C THE NATURAL LOGARITHM OF THE GAMMA FUNCTION,' MATH. COMP. 21, AB 6311 C 1967, PP. 198-203. AB 6312 C AB 6313 C 2) K. E. HILLSTROM, ANL/AMD PROGRAM ANLC366S, DGAMMA/DLGAMA, MAY, AB 6314 C 1969. AB 6315 C AB 6316 C 3) HART, ET. AL., COMPUTER APPROXIMATIONS, WILEY AND SONS, NEW AB 6317 C YORK, 1968. AB 6318 C AB 6319 C AUTHOR: W. J. CODY AB 6320 C ARGONNE NATIONAL LABORATORY AB 6321 C AB 6322 C LATEST MODIFICATION: JULY 14, 1983 AB 6323 C AB 6324 INTEGER I AB 6325 DOUBLE PRECISION C,CORR,D1,D2,D4,EPS,FRTBIG,FOUR,HALF,ONE,PNT68, AB 6326 1 P1,P2,P4,Q1,Q2,Q4,RES,SQRTPI,THRHAL,TWELVE,TWO,X,XBIG,XDEN, AB 6327 2 XINF,XM1,XM2,XM4,XNUM,Y,YSQ,ZERO AB 6328 DIMENSION C(7),P1(8),P2(8),P4(8),Q1(8),Q2(8),Q4(8) AB 6329 C MATHEMATICAL CONSTANTS AB 6330 DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/ AB 6331 DATA FOUR,THRHAL,TWO,PNT68/4.0D0,1.5D0,2.0D0,0.6796875D0/ AB 6332 DATA SQRTPI/0.9189385332046727417803297D0/ AB 6333 C MACHINE DEPENDENT PARAMETERS AB 6334 C VAX G_FLOAT PARAMETERS AB 6335 DATA XBIG,XINF,EPS,FRTBIG/1.28D305,8.98D307,1.70D-16,1.80D+76/ AB 6336 C NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX AB 6337 C APPROXIMATION OVER (0.5,1.5). AB 6338 DATA D1/-5.772156649015328605195174D-1/ AB 6339 DATA P1/4.945235359296727046734888D0,2.018112620856775083915565D2,AB 6340 1 2.290838373831346393026739D3,1.131967205903380828685045D4,AB 6341 2 2.855724635671635335736389D4,3.848496228443793359990269D4,AB 6342 3 2.637748787624195437963534D4,7.225813979700288197698961D3/AB 6343 DATA Q1/6.748212550303777196073036D1,1.113332393857199323513008D3,AB 6344 1 7.738757056935398733233834D3,2.763987074403340708898585D4,AB 6345 2 5.499310206226157329794414D4,6.161122180066002127833352D4,AB 6346 3 3.635127591501940507276287D4,8.785536302431013170870835D3/AB 6347 C NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX AB 6348 C APPROXIMATION OVER (1.5,4.0). AB 6349 DATA D2/4.227843350984671393993777D-1/ AB 6350 DATA P2/4.974607845568932035012064D0,5.424138599891070494101986D2,AB 6351 1 1.550693864978364947665077D4,1.847932904445632425417223D5,AB 6352 2 1.088204769468828767498470D6,3.338152967987029735917223D6,AB 6353 3 5.106661678927352456275255D6,3.074109054850539556250927D6/AB 6354 DATA Q2/1.830328399370592604055942D2,7.765049321445005871323047D3,AB 6355 1 1.331903827966074194402448D5,1.136705821321969608938755D6,AB 6356 2 5.267964117437946917577538D6,1.346701454311101692290052D7,AB 6357 3 1.782736530353274213975932D7,9.533095591844353613395747D6/AB 6358 C NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX AB 6359 C APPROXIMATION OVER (4.0,12.0). AB 6360 DATA D4/1.791759469228055000094023D0/ AB 6361 DATA P4/1.474502166059939948905062D4,2.426813369486704502836312D6,AB 6362 1 1.214755574045093227939592D8,2.663432449630976949898078D9,AB 6363 2 2.940378956634553899906876D10,1.702665737765398868392998D11,AB 6364 3 4.926125793377430887588120D11,5.606251856223951465078242D11/AB 6365 DATA Q4/2.690530175870899333379843D3,6.393885654300092398984238D5,AB 6366 2 4.135599930241388052042842D7,1.120872109616147941376570D9,AB 6367 3 1.488613728678813811542398D10,1.016803586272438228077304D11,AB 6368 4 3.417476345507377132798597D11,4.463158187419713286462081D11/AB 6369 C COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). AB 6370 DATA C/-1.910444077728D-03,8.4171387781295D-04, AB 6371 1 -5.952379913043012D-04,7.93650793500350248D-04, AB 6372 2 -2.777777777777681622553D-03,8.333333333333333331554247D-02, AB 6373 3 5.7083835261D-03/ AB 6374 Y = X AB 6375 IF ((Y .LE. ZERO) .OR. (Y .GT. XBIG)) GO TO 700 AB 6376 IF (Y .GT. TWELVE) GO TO 400 AB 6377 IF (Y .GT. FOUR) GO TO 300 AB 6378 IF (Y .GT. THRHAL) GO TO 200 AB 6379 IF (Y .GE. PNT68) GO TO 100 AB 6380 CORR = -DLOG(Y) AB 6381 XM1 = Y AB 6382 IF (Y .GT. EPS) GO TO 120 AB 6383 RES = CORR AB 6384 GO TO 900 AB 6385 C 0.5 .LT. X .LE. 1.5 AB 6386 100 CORR = ZERO AB 6387 XM1 = (Y - HALF) - HALF AB 6388 120 XDEN = ONE AB 6389 XNUM = ZERO AB 6390 DO 140 I = 1, 8