00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include <eh_utils.h>
00014 #include <math.h>
00015 #include "f2c.h"
00016
00017 #define DSIGN(a,b) ( (b>0)?((a)>0?a:-(a)):((a)<=0?a:-(a)))
00018
00019
00020
00021 static integer c__4 = 4;
00022 static integer c__15 = 15;
00023 static integer c__16 = 16;
00024 static integer c__5 = 5;
00025 static integer c__14 = 14;
00026 static integer c__9 = 9;
00027 static integer c__1 = 1;
00028 static integer c__2 = 2;
00029 static doublereal c_b168 = .5;
00030 static doublereal c_b169 = 0.;
00031 static integer c__0 = 0;
00032
00033
00034
00035
00036
00037 int zbesh_(doublereal *zr, doublereal *zi, doublereal *fnu,
00038 integer *kode, integer *m, integer *n, doublereal *cyr, doublereal *
00039 cyi, integer *nz, integer *ierr)
00040 {
00041
00042
00043 static doublereal hpi = 1.57079632679489662;
00044
00045
00046 integer i__1, i__2;
00047 doublereal d__1, d__2;
00048
00049
00050 double sqrt(doublereal), log(doublereal), d_sign(doublereal *, doublereal
00051 *), cos(doublereal), sin(doublereal);
00052
00053
00054 static integer i__, k, k1, k2;
00055 static doublereal aa, bb, fn;
00056 static integer mm;
00057 static doublereal az;
00058 static integer ir, nn;
00059 static doublereal rl;
00060 static integer mr, nw;
00061 static doublereal dig, arg, aln, fmm, r1m5, ufl, sgn;
00062 static integer nuf, inu;
00063 static doublereal tol, sti, zni, zti, str, znr, alim, elim;
00064 extern doublereal zabs_(doublereal *, doublereal *);
00065 static doublereal atol, rhpi;
00066 static integer inuh;
00067 static doublereal fnul, rtol, ascle, csgni;
00068 extern int zacon_(doublereal *, doublereal *, doublereal
00069 *, integer *, integer *, integer *, doublereal *, doublereal *,
00070 integer *, doublereal *, doublereal *, doublereal *, doublereal *,
00071 doublereal *);
00072 static doublereal csgnr;
00073 extern int zbknu_(doublereal *, doublereal *, doublereal
00074 *, integer *, integer *, doublereal *, doublereal *, integer *,
00075 doublereal *, doublereal *, doublereal *), zbunk_(doublereal *,
00076 doublereal *, doublereal *, integer *, integer *, integer *,
00077 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
00078 doublereal *);
00079 extern doublereal d1mach_(integer *);
00080 extern int zuoik_(doublereal *, doublereal *, doublereal
00081 *, integer *, integer *, integer *, doublereal *, doublereal *,
00082 integer *, doublereal *, doublereal *, doublereal *);
00083 extern integer i1mach_(integer *);
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173
00174
00175
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
00191
00192
00193
00194
00195
00196
00197
00198
00199
00200
00201
00202
00203
00204
00205
00206
00207
00208
00209
00210
00211
00212
00213
00214
00215
00216
00217
00218
00219
00220
00221
00222
00223
00224
00225
00226
00227
00228
00229
00230
00231
00232
00233
00234
00235
00236
00237
00238
00239
00240
00241
00242
00243
00244
00245 --cyi;
00246 --cyr;
00247
00248
00249
00250
00251 *ierr = 0;
00252 *nz = 0;
00253 if (*zr == 0. && *zi == 0.) {
00254 *ierr = 1;
00255 }
00256 if (*fnu < 0.) {
00257 *ierr = 1;
00258 }
00259 if (*m < 1 || *m > 2) {
00260 *ierr = 1;
00261 }
00262 if (*kode < 1 || *kode > 2) {
00263 *ierr = 1;
00264 }
00265 if (*n < 1) {
00266 *ierr = 1;
00267 }
00268 if (*ierr != 0) {
00269 return 0;
00270 }
00271 nn = *n;
00272
00273
00274
00275
00276
00277
00278
00279
00280
00281
00282
00283
00284 d__1 = d1mach_(&c__4);
00285 tol = max(d__1,1e-18);
00286 k1 = i1mach_(&c__15);
00287 k2 = i1mach_(&c__16);
00288 r1m5 = d1mach_(&c__5);
00289
00290 i__1 = abs(k1), i__2 = abs(k2);
00291 k = min(i__1,i__2);
00292 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
00293 k1 = i1mach_(&c__14) - 1;
00294 aa = r1m5 * (doublereal) ((real) k1);
00295 dig = min(aa,18.);
00296 aa *= 2.303;
00297
00298 d__1 = -aa;
00299 alim = elim + max(d__1,-41.45);
00300 fnul = (dig - 3.) * 6. + 10.;
00301 rl = dig * 1.2 + 3.;
00302 fn = *fnu + (doublereal) ((real) (nn - 1));
00303 mm = 3 - *m - *m;
00304 fmm = (doublereal) ((real) mm);
00305 znr = fmm * *zi;
00306 zni = -fmm * *zr;
00307
00308
00309
00310 az = zabs_(zr, zi);
00311 aa = .5 / tol;
00312 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
00313 aa = min(aa,bb);
00314 if (az > aa) {
00315 goto L260;
00316 }
00317 if (fn > aa) {
00318 goto L260;
00319 }
00320 aa = sqrt(aa);
00321 if (az > aa) {
00322 *ierr = 3;
00323 }
00324 if (fn > aa) {
00325 *ierr = 3;
00326 }
00327
00328
00329
00330 ufl = d1mach_(&c__1) * 1e3;
00331 if (az < ufl) {
00332 goto L230;
00333 }
00334 if (*fnu > fnul) {
00335 goto L90;
00336 }
00337 if (fn <= 1.) {
00338 goto L70;
00339 }
00340 if (fn > 2.) {
00341 goto L60;
00342 }
00343 if (az > tol) {
00344 goto L70;
00345 }
00346 arg = az * .5;
00347 aln = -fn * log(arg);
00348 if (aln > elim) {
00349 goto L230;
00350 }
00351 goto L70;
00352 L60:
00353 zuoik_(&znr, &zni, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &
00354 elim, &alim);
00355 if (nuf < 0) {
00356 goto L230;
00357 }
00358 *nz += nuf;
00359 nn -= nuf;
00360
00361
00362
00363
00364 if (nn == 0) {
00365 goto L140;
00366 }
00367 L70:
00368 if ( (znr < 0.) || (znr == 0. && zni < 0. && *m == 2) ) {
00369 goto L80;
00370 }
00371
00372
00373
00374
00375 zbknu_(&znr, &zni, fnu, kode, &nn, &cyr[1], &cyi[1], nz, &tol, &elim, &
00376 alim);
00377 goto L110;
00378
00379
00380
00381 L80:
00382 mr = -mm;
00383 zacon_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul,
00384 &tol, &elim, &alim);
00385 if (nw < 0) {
00386 goto L240;
00387 }
00388 *nz = nw;
00389 goto L110;
00390 L90:
00391
00392
00393
00394 mr = 0;
00395 if (znr >= 0. && (znr != 0. || zni >= 0. || *m != 2)) {
00396 goto L100;
00397 }
00398 mr = -mm;
00399 if (znr != 0. || zni >= 0.) {
00400 goto L100;
00401 }
00402 znr = -znr;
00403 zni = -zni;
00404 L100:
00405 zbunk_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &
00406 elim, &alim);
00407 if (nw < 0) {
00408 goto L240;
00409 }
00410 *nz += nw;
00411 L110:
00412
00413
00414
00415
00416
00417 d__1 = -fmm;
00418 sgn = DSIGN(hpi, d__1);
00419
00420
00421
00422
00423 inu = (integer) ((real) (*fnu));
00424 inuh = inu / 2;
00425 ir = inu - (inuh << 1);
00426 arg = (*fnu - (doublereal) ((real) (inu - ir))) * sgn;
00427 rhpi = 1. / sgn;
00428
00429
00430 csgni = rhpi * cos(arg);
00431 csgnr = -rhpi * sin(arg);
00432 if (inuh % 2 == 0) {
00433 goto L120;
00434 }
00435
00436
00437 csgnr = -csgnr;
00438 csgni = -csgni;
00439 L120:
00440 zti = -fmm;
00441 rtol = 1. / tol;
00442 ascle = ufl * rtol;
00443 i__1 = nn;
00444 for (i__ = 1; i__ <= i__1; ++i__) {
00445
00446
00447
00448
00449
00450
00451 aa = cyr[i__];
00452 bb = cyi[i__];
00453 atol = 1.;
00454
00455 d__1 = abs(aa), d__2 = abs(bb);
00456 if (max(d__1,d__2) > ascle) {
00457 goto L135;
00458 }
00459 aa *= rtol;
00460 bb *= rtol;
00461 atol = tol;
00462 L135:
00463 str = aa * csgnr - bb * csgni;
00464 sti = aa * csgni + bb * csgnr;
00465 cyr[i__] = str * atol;
00466 cyi[i__] = sti * atol;
00467 str = -csgni * zti;
00468 csgni = csgnr * zti;
00469 csgnr = str;
00470
00471 }
00472 return 0;
00473 L140:
00474 if (znr < 0.) {
00475 goto L230;
00476 }
00477 return 0;
00478 L230:
00479 *nz = 0;
00480 *ierr = 2;
00481 return 0;
00482 L240:
00483 if (nw == -1) {
00484 goto L230;
00485 }
00486 *nz = 0;
00487 *ierr = 5;
00488 return 0;
00489 L260:
00490 *nz = 0;
00491 *ierr = 4;
00492 return 0;
00493 }
00494
00495 int zbesi_(doublereal *zr, doublereal *zi, doublereal *fnu,
00496 integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
00497 nz, integer *ierr)
00498 {
00499
00500
00501 static doublereal pi = 3.14159265358979324;
00502 static doublereal coner = 1.;
00503 static doublereal conei = 0.;
00504
00505
00506 integer i__1, i__2;
00507 doublereal d__1, d__2;
00508
00509
00510 double sqrt(doublereal), cos(doublereal), sin(doublereal);
00511
00512
00513 static integer i__, k, k1, k2;
00514 static doublereal aa, bb, fn, az;
00515 static integer nn;
00516 static doublereal rl, dig, arg, r1m5;
00517 static integer inu;
00518 static doublereal tol, sti, zni, str, znr, alim, elim;
00519 extern doublereal zabs_(doublereal *, doublereal *);
00520 static doublereal atol, fnul, rtol, ascle, csgni, csgnr;
00521 extern int zbinu_(doublereal *, doublereal *, doublereal
00522 *, integer *, integer *, doublereal *, doublereal *, integer *,
00523 doublereal *, doublereal *, doublereal *, doublereal *,
00524 doublereal *);
00525 extern doublereal d1mach_(integer *);
00526 extern integer i1mach_(integer *);
00527
00528
00529
00530
00531
00532
00533
00534
00535
00536
00537
00538
00539
00540
00541
00542
00543
00544
00545
00546
00547
00548
00549
00550
00551
00552
00553
00554
00555
00556
00557
00558
00559
00560
00561
00562
00563
00564
00565
00566
00567
00568
00569
00570
00571
00572
00573
00574
00575
00576
00577
00578
00579
00580
00581
00582
00583
00584
00585
00586
00587
00588
00589
00590
00591
00592
00593
00594
00595
00596
00597
00598
00599
00600
00601
00602
00603
00604
00605
00606
00607
00608
00609
00610
00611
00612
00613
00614
00615
00616
00617
00618
00619
00620
00621
00622
00623
00624
00625
00626
00627
00628
00629
00630
00631
00632
00633
00634
00635
00636
00637
00638
00639
00640
00641
00642
00643
00644
00645
00646
00647
00648
00649
00650
00651
00652
00653
00654
00655
00656
00657
00658
00659
00660
00661
00662
00663
00664
00665
00666
00667
00668
00669
00670
00671
00672
00673
00674
00675
00676
00677
00678
00679
00680
00681 --cyi;
00682 --cyr;
00683
00684
00685
00686
00687 *ierr = 0;
00688 *nz = 0;
00689 if (*fnu < 0.) {
00690 *ierr = 1;
00691 }
00692 if (*kode < 1 || *kode > 2) {
00693 *ierr = 1;
00694 }
00695 if (*n < 1) {
00696 *ierr = 1;
00697 }
00698 if (*ierr != 0) {
00699 return 0;
00700 }
00701
00702
00703
00704
00705
00706
00707
00708
00709
00710
00711
00712
00713 d__1 = d1mach_(&c__4);
00714 tol = max(d__1,1e-18);
00715 k1 = i1mach_(&c__15);
00716 k2 = i1mach_(&c__16);
00717 r1m5 = d1mach_(&c__5);
00718
00719 i__1 = abs(k1), i__2 = abs(k2);
00720 k = min(i__1,i__2);
00721 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
00722 k1 = i1mach_(&c__14) - 1;
00723 aa = r1m5 * (doublereal) ((real) k1);
00724 dig = min(aa,18.);
00725 aa *= 2.303;
00726
00727 d__1 = -aa;
00728 alim = elim + max(d__1,-41.45);
00729 rl = dig * 1.2 + 3.;
00730 fnul = (dig - 3.) * 6. + 10.;
00731
00732
00733
00734 az = zabs_(zr, zi);
00735 fn = *fnu + (doublereal) ((real) (*n - 1));
00736 aa = .5 / tol;
00737 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
00738 aa = min(aa,bb);
00739 if (az > aa) {
00740 goto L260;
00741 }
00742 if (fn > aa) {
00743 goto L260;
00744 }
00745 aa = sqrt(aa);
00746 if (az > aa) {
00747 *ierr = 3;
00748 }
00749 if (fn > aa) {
00750 *ierr = 3;
00751 }
00752 znr = *zr;
00753 zni = *zi;
00754 csgnr = coner;
00755 csgni = conei;
00756 if (*zr >= 0.) {
00757 goto L40;
00758 }
00759 znr = -(*zr);
00760 zni = -(*zi);
00761
00762
00763
00764
00765 inu = (integer) ((real) (*fnu));
00766 arg = (*fnu - (doublereal) ((real) inu)) * pi;
00767 if (*zi < 0.) {
00768 arg = -arg;
00769 }
00770 csgnr = cos(arg);
00771 csgni = sin(arg);
00772 if (inu % 2 == 0) {
00773 goto L40;
00774 }
00775 csgnr = -csgnr;
00776 csgni = -csgni;
00777 L40:
00778 zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
00779 elim, &alim);
00780 if (*nz < 0) {
00781 goto L120;
00782 }
00783 if (*zr >= 0.) {
00784 return 0;
00785 }
00786
00787
00788
00789 nn = *n - *nz;
00790 if (nn == 0) {
00791 return 0;
00792 }
00793 rtol = 1. / tol;
00794 ascle = d1mach_(&c__1) * rtol * 1e3;
00795 i__1 = nn;
00796 for (i__ = 1; i__ <= i__1; ++i__) {
00797
00798
00799
00800 aa = cyr[i__];
00801 bb = cyi[i__];
00802 atol = 1.;
00803
00804 d__1 = abs(aa), d__2 = abs(bb);
00805 if (max(d__1,d__2) > ascle) {
00806 goto L55;
00807 }
00808 aa *= rtol;
00809 bb *= rtol;
00810 atol = tol;
00811 L55:
00812 str = aa * csgnr - bb * csgni;
00813 sti = aa * csgni + bb * csgnr;
00814 cyr[i__] = str * atol;
00815 cyi[i__] = sti * atol;
00816 csgnr = -csgnr;
00817 csgni = -csgni;
00818
00819 }
00820 return 0;
00821 L120:
00822 if (*nz == -2) {
00823 goto L130;
00824 }
00825 *nz = 0;
00826 *ierr = 2;
00827 return 0;
00828 L130:
00829 *nz = 0;
00830 *ierr = 5;
00831 return 0;
00832 L260:
00833 *nz = 0;
00834 *ierr = 4;
00835 return 0;
00836 }
00837
00838 int zbesj_(doublereal *zr, doublereal *zi, doublereal *fnu,
00839 integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
00840 nz, integer *ierr)
00841 {
00842
00843
00844 static doublereal hpi = 1.57079632679489662;
00845
00846
00847 integer i__1, i__2;
00848 doublereal d__1, d__2;
00849
00850
00851 double sqrt(doublereal), cos(doublereal), sin(doublereal);
00852
00853
00854 static integer i__, k, k1, k2;
00855 static doublereal aa, bb, fn;
00856 static integer nl;
00857 static doublereal az;
00858 static integer ir;
00859 static doublereal rl, dig, cii, arg, r1m5;
00860 static integer inu;
00861 static doublereal tol, sti, zni, str, znr, alim, elim;
00862 extern doublereal zabs_(doublereal *, doublereal *);
00863 static doublereal atol;
00864 static integer inuh;
00865 static doublereal fnul, rtol, ascle, csgni, csgnr;
00866 extern int zbinu_(doublereal *, doublereal *, doublereal
00867 *, integer *, integer *, doublereal *, doublereal *, integer *,
00868 doublereal *, doublereal *, doublereal *, doublereal *,
00869 doublereal *);
00870 extern doublereal d1mach_(integer *);
00871 extern integer i1mach_(integer *);
00872
00873
00874
00875
00876
00877
00878
00879
00880
00881
00882
00883
00884
00885
00886
00887
00888
00889
00890
00891
00892
00893
00894
00895
00896
00897
00898
00899
00900
00901
00902
00903
00904
00905
00906
00907
00908
00909
00910
00911
00912
00913
00914
00915
00916
00917
00918
00919
00920
00921
00922
00923
00924
00925
00926
00927
00928
00929
00930
00931
00932
00933
00934
00935
00936
00937
00938
00939
00940
00941
00942
00943
00944
00945
00946
00947
00948
00949
00950
00951
00952
00953
00954
00955
00956
00957
00958
00959
00960
00961
00962
00963
00964
00965
00966
00967
00968
00969
00970
00971
00972
00973
00974
00975
00976
00977
00978
00979
00980
00981
00982
00983
00984
00985
00986
00987
00988
00989
00990
00991
00992
00993
00994
00995
00996
00997
00998
00999
01000
01001
01002
01003
01004
01005
01006
01007
01008
01009
01010
01011
01012
01013
01014
01015
01016
01017
01018
01019
01020
01021 --cyi;
01022 --cyr;
01023
01024
01025
01026
01027 *ierr = 0;
01028 *nz = 0;
01029 if (*fnu < 0.) {
01030 *ierr = 1;
01031 }
01032 if (*kode < 1 || *kode > 2) {
01033 *ierr = 1;
01034 }
01035 if (*n < 1) {
01036 *ierr = 1;
01037 }
01038 if (*ierr != 0) {
01039 return 0;
01040 }
01041
01042
01043
01044
01045
01046
01047
01048
01049
01050
01051
01052
01053 d__1 = d1mach_(&c__4);
01054 tol = max(d__1,1e-18);
01055 k1 = i1mach_(&c__15);
01056 k2 = i1mach_(&c__16);
01057 r1m5 = d1mach_(&c__5);
01058
01059 i__1 = abs(k1), i__2 = abs(k2);
01060 k = min(i__1,i__2);
01061 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
01062 k1 = i1mach_(&c__14) - 1;
01063 aa = r1m5 * (doublereal) ((real) k1);
01064 dig = min(aa,18.);
01065 aa *= 2.303;
01066
01067 d__1 = -aa;
01068 alim = elim + max(d__1,-41.45);
01069 rl = dig * 1.2 + 3.;
01070 fnul = (dig - 3.) * 6. + 10.;
01071
01072
01073
01074 az = zabs_(zr, zi);
01075 fn = *fnu + (doublereal) ((real) (*n - 1));
01076 aa = .5 / tol;
01077 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
01078 aa = min(aa,bb);
01079 if (az > aa) {
01080 goto L260;
01081 }
01082 if (fn > aa) {
01083 goto L260;
01084 }
01085 aa = sqrt(aa);
01086 if (az > aa) {
01087 *ierr = 3;
01088 }
01089 if (fn > aa) {
01090 *ierr = 3;
01091 }
01092
01093
01094
01095
01096 cii = 1.;
01097 inu = (integer) ((real) (*fnu));
01098 inuh = inu / 2;
01099 ir = inu - (inuh << 1);
01100 arg = (*fnu - (doublereal) ((real) (inu - ir))) * hpi;
01101 csgnr = cos(arg);
01102 csgni = sin(arg);
01103 if (inuh % 2 == 0) {
01104 goto L40;
01105 }
01106 csgnr = -csgnr;
01107 csgni = -csgni;
01108 L40:
01109
01110
01111
01112 znr = *zi;
01113 zni = -(*zr);
01114 if (*zi >= 0.) {
01115 goto L50;
01116 }
01117 znr = -znr;
01118 zni = -zni;
01119 csgni = -csgni;
01120 cii = -cii;
01121 L50:
01122 zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
01123 elim, &alim);
01124 if (*nz < 0) {
01125 goto L130;
01126 }
01127 nl = *n - *nz;
01128 if (nl == 0) {
01129 return 0;
01130 }
01131 rtol = 1. / tol;
01132 ascle = d1mach_(&c__1) * rtol * 1e3;
01133 i__1 = nl;
01134 for (i__ = 1; i__ <= i__1; ++i__) {
01135
01136
01137
01138 aa = cyr[i__];
01139 bb = cyi[i__];
01140 atol = 1.;
01141
01142 d__1 = abs(aa), d__2 = abs(bb);
01143 if (max(d__1,d__2) > ascle) {
01144 goto L55;
01145 }
01146 aa *= rtol;
01147 bb *= rtol;
01148 atol = tol;
01149 L55:
01150 str = aa * csgnr - bb * csgni;
01151 sti = aa * csgni + bb * csgnr;
01152 cyr[i__] = str * atol;
01153 cyi[i__] = sti * atol;
01154 str = -csgni * cii;
01155 csgni = csgnr * cii;
01156 csgnr = str;
01157
01158 }
01159 return 0;
01160 L130:
01161 if (*nz == -2) {
01162 goto L140;
01163 }
01164 *nz = 0;
01165 *ierr = 2;
01166 return 0;
01167 L140:
01168 *nz = 0;
01169 *ierr = 5;
01170 return 0;
01171 L260:
01172 *nz = 0;
01173 *ierr = 4;
01174 return 0;
01175 }
01176
01177 int zbesk_(doublereal *zr, doublereal *zi, doublereal *fnu,
01178 integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
01179 nz, integer *ierr)
01180 {
01181
01182 integer i__1, i__2;
01183 doublereal d__1;
01184
01185
01186 double sqrt(doublereal), log(doublereal);
01187
01188
01189 static integer k, k1, k2;
01190 static doublereal aa, bb, fn, az;
01191 static integer nn;
01192 static doublereal rl;
01193 static integer mr, nw;
01194 static doublereal dig, arg, aln, r1m5, ufl;
01195 static integer nuf;
01196 static doublereal tol, alim, elim;
01197 extern doublereal zabs_(doublereal *, doublereal *);
01198 static doublereal fnul;
01199 extern int zacon_(doublereal *, doublereal *, doublereal
01200 *, integer *, integer *, integer *, doublereal *, doublereal *,
01201 integer *, doublereal *, doublereal *, doublereal *, doublereal *,
01202 doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
01203 integer *, integer *, doublereal *, doublereal *, integer *,
01204 doublereal *, doublereal *, doublereal *), zbunk_(doublereal *,
01205 doublereal *, doublereal *, integer *, integer *, integer *,
01206 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
01207 doublereal *);
01208 extern doublereal d1mach_(integer *);
01209 extern int zuoik_(doublereal *, doublereal *, doublereal
01210 *, integer *, integer *, integer *, doublereal *, doublereal *,
01211 integer *, doublereal *, doublereal *, doublereal *);
01212 extern integer i1mach_(integer *);
01213
01214
01215
01216
01217
01218
01219
01220
01221
01222
01223
01224
01225
01226
01227
01228
01229
01230
01231
01232
01233
01234
01235
01236
01237
01238
01239
01240
01241
01242
01243
01244
01245
01246
01247
01248
01249
01250
01251
01252
01253
01254
01255
01256
01257
01258
01259
01260
01261
01262
01263
01264
01265
01266
01267
01268
01269
01270
01271
01272
01273
01274
01275
01276
01277
01278
01279
01280
01281
01282
01283
01284
01285
01286
01287
01288
01289
01290
01291
01292
01293
01294
01295
01296
01297
01298
01299
01300
01301
01302
01303
01304
01305
01306
01307
01308
01309
01310
01311
01312
01313
01314
01315
01316
01317
01318
01319
01320
01321
01322
01323
01324
01325
01326
01327
01328
01329
01330
01331
01332
01333
01334
01335
01336
01337
01338
01339
01340
01341
01342
01343
01344
01345
01346
01347
01348
01349
01350
01351
01352
01353
01354
01355
01356
01357
01358
01359
01360
01361
01362
01363
01364
01365
01366
01367
01368
01369 --cyi;
01370 --cyr;
01371
01372
01373 *ierr = 0;
01374 *nz = 0;
01375 if (*zi == 0.f && *zr == 0.f) {
01376 *ierr = 1;
01377 }
01378 if (*fnu < 0.) {
01379 *ierr = 1;
01380 }
01381 if (*kode < 1 || *kode > 2) {
01382 *ierr = 1;
01383 }
01384 if (*n < 1) {
01385 *ierr = 1;
01386 }
01387 if (*ierr != 0) {
01388 return 0;
01389 }
01390 nn = *n;
01391
01392
01393
01394
01395
01396
01397
01398
01399
01400
01401
01402
01403 d__1 = d1mach_(&c__4);
01404 tol = max(d__1,1e-18);
01405 k1 = i1mach_(&c__15);
01406 k2 = i1mach_(&c__16);
01407 r1m5 = d1mach_(&c__5);
01408
01409 i__1 = abs(k1), i__2 = abs(k2);
01410 k = min(i__1,i__2);
01411 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
01412 k1 = i1mach_(&c__14) - 1;
01413 aa = r1m5 * (doublereal) ((real) k1);
01414 dig = min(aa,18.);
01415 aa *= 2.303;
01416
01417 d__1 = -aa;
01418 alim = elim + max(d__1,-41.45);
01419 fnul = (dig - 3.) * 6. + 10.;
01420 rl = dig * 1.2 + 3.;
01421
01422
01423
01424 az = zabs_(zr, zi);
01425 fn = *fnu + (doublereal) ((real) (nn - 1));
01426 aa = .5 / tol;
01427 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
01428 aa = min(aa,bb);
01429 if (az > aa) {
01430 goto L260;
01431 }
01432 if (fn > aa) {
01433 goto L260;
01434 }
01435 aa = sqrt(aa);
01436 if (az > aa) {
01437 *ierr = 3;
01438 }
01439 if (fn > aa) {
01440 *ierr = 3;
01441 }
01442
01443
01444
01445
01446 ufl = d1mach_(&c__1) * 1e3;
01447 if (az < ufl) {
01448 goto L180;
01449 }
01450 if (*fnu > fnul) {
01451 goto L80;
01452 }
01453 if (fn <= 1.) {
01454 goto L60;
01455 }
01456 if (fn > 2.) {
01457 goto L50;
01458 }
01459 if (az > tol) {
01460 goto L60;
01461 }
01462 arg = az * .5;
01463 aln = -fn * log(arg);
01464 if (aln > elim) {
01465 goto L180;
01466 }
01467 goto L60;
01468 L50:
01469 zuoik_(zr, zi, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &elim,
01470 &alim);
01471 if (nuf < 0) {
01472 goto L180;
01473 }
01474 *nz += nuf;
01475 nn -= nuf;
01476
01477
01478
01479
01480 if (nn == 0) {
01481 goto L100;
01482 }
01483 L60:
01484 if (*zr < 0.) {
01485 goto L70;
01486 }
01487
01488
01489
01490 zbknu_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &alim);
01491 if (nw < 0) {
01492 goto L200;
01493 }
01494 *nz = nw;
01495 return 0;
01496
01497
01498
01499
01500 L70:
01501 if (*nz != 0) {
01502 goto L180;
01503 }
01504 mr = 1;
01505 if (*zi < 0.) {
01506 mr = -1;
01507 }
01508 zacon_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul, &
01509 tol, &elim, &alim);
01510 if (nw < 0) {
01511 goto L200;
01512 }
01513 *nz = nw;
01514 return 0;
01515
01516
01517
01518 L80:
01519 mr = 0;
01520 if (*zr >= 0.) {
01521 goto L90;
01522 }
01523 mr = 1;
01524 if (*zi < 0.) {
01525 mr = -1;
01526 }
01527 L90:
01528 zbunk_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &
01529 alim);
01530 if (nw < 0) {
01531 goto L200;
01532 }
01533 *nz += nw;
01534 return 0;
01535 L100:
01536 if (*zr < 0.) {
01537 goto L180;
01538 }
01539 return 0;
01540 L180:
01541 *nz = 0;
01542 *ierr = 2;
01543 return 0;
01544 L200:
01545 if (nw == -1) {
01546 goto L180;
01547 }
01548 *nz = 0;
01549 *ierr = 5;
01550 return 0;
01551 L260:
01552 *nz = 0;
01553 *ierr = 4;
01554 return 0;
01555 }
01556
01557 int zbesy_(doublereal *zr, doublereal *zi, doublereal *fnu,
01558 integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
01559 nz, doublereal *cwrkr, doublereal *cwrki, integer *ierr)
01560 {
01561
01562
01563 static doublereal cipr[4] = { 1.,0.,-1.,0. };
01564 static doublereal cipi[4] = { 0.,1.,0.,-1. };
01565 static doublereal hpi = 1.57079632679489662;
01566
01567
01568 integer i__1, i__2;
01569 doublereal d__1, d__2;
01570
01571
01572 double cos(doublereal), sin(doublereal), exp(doublereal);
01573
01574
01575 static integer i__, k, k1, i4, k2;
01576 static doublereal ey;
01577 static integer nz1, nz2;
01578 static doublereal d1m5, arg, exi, exr, sti, tay, tol, zni, zui, str, znr,
01579 zvi, zzi, zur, zvr, zzr, elim, ffnu, atol, rhpi;
01580 static integer ifnu;
01581 static doublereal rtol, ascle, csgni, csgnr, cspni;
01582 extern int zbesi_(doublereal *, doublereal *, doublereal
01583 *, integer *, integer *, doublereal *, doublereal *, integer *,
01584 integer *), zbesk_(doublereal *, doublereal *, doublereal *,
01585 integer *, integer *, doublereal *, doublereal *, integer *,
01586 integer *);
01587 static doublereal cspnr;
01588 extern doublereal d1mach_(integer *);
01589 extern integer i1mach_(integer *);
01590
01591
01592
01593
01594
01595
01596
01597
01598
01599
01600
01601
01602
01603
01604
01605
01606
01607
01608
01609
01610
01611
01612
01613
01614
01615
01616
01617
01618
01619
01620
01621
01622
01623
01624
01625
01626
01627
01628
01629
01630
01631
01632
01633
01634
01635
01636
01637
01638
01639
01640
01641
01642
01643
01644
01645
01646
01647
01648
01649
01650
01651
01652
01653
01654
01655
01656
01657
01658
01659
01660
01661
01662
01663
01664
01665
01666
01667
01668
01669
01670
01671
01672
01673
01674
01675
01676
01677
01678
01679
01680
01681
01682
01683
01684
01685
01686
01687
01688
01689
01690
01691
01692
01693
01694
01695
01696
01697
01698
01699
01700
01701
01702
01703
01704
01705
01706
01707
01708
01709
01710
01711
01712
01713
01714
01715
01716
01717
01718
01719
01720
01721
01722
01723
01724
01725
01726
01727
01728
01729
01730
01731
01732
01733
01734
01735
01736
01737
01738
01739
01740
01741
01742
01743
01744 --cwrki;
01745 --cwrkr;
01746 --cyi;
01747 --cyr;
01748
01749
01750
01751 *ierr = 0;
01752 *nz = 0;
01753 if (*zr == 0. && *zi == 0.) {
01754 *ierr = 1;
01755 }
01756 if (*fnu < 0.) {
01757 *ierr = 1;
01758 }
01759 if (*kode < 1 || *kode > 2) {
01760 *ierr = 1;
01761 }
01762 if (*n < 1) {
01763 *ierr = 1;
01764 }
01765 if (*ierr != 0) {
01766 return 0;
01767 }
01768 zzr = *zr;
01769 zzi = *zi;
01770 if (*zi < 0.) {
01771 zzi = -zzi;
01772 }
01773 znr = zzi;
01774 zni = -zzr;
01775 zbesi_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], &nz1, ierr);
01776 if (*ierr != 0 && *ierr != 3) {
01777 goto L90;
01778 }
01779 zbesk_(&znr, &zni, fnu, kode, n, &cwrkr[1], &cwrki[1], &nz2, ierr);
01780 if (*ierr != 0 && *ierr != 3) {
01781 goto L90;
01782 }
01783 *nz = min(nz1,nz2);
01784 ifnu = (integer) ((real) (*fnu));
01785 ffnu = *fnu - (doublereal) ((real) ifnu);
01786 arg = hpi * ffnu;
01787 csgnr = cos(arg);
01788 csgni = sin(arg);
01789 i4 = ifnu % 4 + 1;
01790 str = csgnr * cipr[i4 - 1] - csgni * cipi[i4 - 1];
01791 csgni = csgnr * cipi[i4 - 1] + csgni * cipr[i4 - 1];
01792 csgnr = str;
01793 rhpi = 1. / hpi;
01794 cspnr = csgnr * rhpi;
01795 cspni = -csgni * rhpi;
01796 str = -csgni;
01797 csgni = csgnr;
01798 csgnr = str;
01799 if (*kode == 2) {
01800 goto L60;
01801 }
01802 i__1 = *n;
01803 for (i__ = 1; i__ <= i__1; ++i__) {
01804
01805 str = csgnr * cyr[i__] - csgni * cyi[i__];
01806 str -= cspnr * cwrkr[i__] - cspni * cwrki[i__];
01807 sti = csgnr * cyi[i__] + csgni * cyr[i__];
01808 sti -= cspnr * cwrki[i__] + cspni * cwrkr[i__];
01809 cyr[i__] = str;
01810 cyi[i__] = sti;
01811 str = -csgni;
01812 csgni = csgnr;
01813 csgnr = str;
01814 str = cspni;
01815 cspni = -cspnr;
01816 cspnr = str;
01817
01818 }
01819 if (*zi < 0.) {
01820 i__1 = *n;
01821 for (i__ = 1; i__ <= i__1; ++i__) {
01822 cyi[i__] = -cyi[i__];
01823
01824 }
01825 }
01826 return 0;
01827 L60:
01828 exr = cos(*zr);
01829 exi = sin(*zr);
01830
01831 d__1 = d1mach_(&c__4);
01832 tol = max(d__1,1e-18);
01833 k1 = i1mach_(&c__15);
01834 k2 = i1mach_(&c__16);
01835
01836 i__1 = abs(k1), i__2 = abs(k2);
01837 k = min(i__1,i__2);
01838 d1m5 = d1mach_(&c__5);
01839
01840
01841
01842 elim = ((doublereal) ((real) k) * d1m5 - 3.) * 2.303;
01843 ey = 0.;
01844 tay = (d__1 = *zi + *zi, abs(d__1));
01845 if (tay < elim) {
01846 ey = exp(-tay);
01847 }
01848 str = (exr * cspnr - exi * cspni) * ey;
01849 cspni = (exr * cspni + exi * cspnr) * ey;
01850 cspnr = str;
01851 *nz = 0;
01852 rtol = 1. / tol;
01853 ascle = d1mach_(&c__1) * rtol * 1e3;
01854 i__1 = *n;
01855 for (i__ = 1; i__ <= i__1; ++i__) {
01856
01857
01858
01859
01860
01861 zvr = cwrkr[i__];
01862 zvi = cwrki[i__];
01863 atol = 1.;
01864
01865 d__1 = abs(zvr), d__2 = abs(zvi);
01866 if (max(d__1,d__2) > ascle) {
01867 goto L75;
01868 }
01869 zvr *= rtol;
01870 zvi *= rtol;
01871 atol = tol;
01872 L75:
01873 str = (zvr * cspnr - zvi * cspni) * atol;
01874 zvi = (zvr * cspni + zvi * cspnr) * atol;
01875 zvr = str;
01876 zur = cyr[i__];
01877 zui = cyi[i__];
01878 atol = 1.;
01879
01880 d__1 = abs(zur), d__2 = abs(zui);
01881 if (max(d__1,d__2) > ascle) {
01882 goto L85;
01883 }
01884 zur *= rtol;
01885 zui *= rtol;
01886 atol = tol;
01887 L85:
01888 str = (zur * csgnr - zui * csgni) * atol;
01889 zui = (zur * csgni + zui * csgnr) * atol;
01890 zur = str;
01891 cyr[i__] = zur - zvr;
01892 cyi[i__] = zui - zvi;
01893 if (*zi < 0.) {
01894 cyi[i__] = -cyi[i__];
01895 }
01896 if (cyr[i__] == 0. && cyi[i__] == 0. && ey == 0.) {
01897 ++(*nz);
01898 }
01899 str = -csgni;
01900 csgni = csgnr;
01901 csgnr = str;
01902 str = cspni;
01903 cspni = -cspnr;
01904 cspnr = str;
01905
01906 }
01907 return 0;
01908 L90:
01909 *nz = 0;
01910 return 0;
01911 }
01912
01913 int zairy_(doublereal *zr, doublereal *zi, integer *id,
01914 integer *kode, doublereal *air, doublereal *aii, integer *nz, integer
01915 *ierr)
01916 {
01917
01918
01919 static doublereal tth = .666666666666666667;
01920 static doublereal c1 = .35502805388781724;
01921 static doublereal c2 = .258819403792806799;
01922 static doublereal coef = .183776298473930683;
01923 static doublereal zeror = 0.;
01924 static doublereal zeroi = 0.;
01925 static doublereal coner = 1.;
01926 static doublereal conei = 0.;
01927
01928
01929 integer i__1, i__2;
01930 doublereal d__1;
01931
01932
01933 double log(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
01934 doublereal);
01935
01936
01937 extern int zzzsqrt_(doublereal *, doublereal *,
01938 doublereal *, doublereal *);
01939 static integer k;
01940 static doublereal d1, d2;
01941 static integer k1, k2;
01942 static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az;
01943 static integer nn;
01944 static doublereal rl;
01945 static integer mr;
01946 static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, dig, fid, cyi[1],
01947 r1m5, fnu, cyr[1], tol, sti, ptr, str, sfac, alim, elim, alaz;
01948 extern doublereal zabs_(doublereal *, doublereal *);
01949 static doublereal csqi, atrm, ztai, csqr, ztar, trm1i, trm2i, trm1r,
01950 trm2r;
01951 static integer iflag;
01952 extern int zacai_(doublereal *, doublereal *, doublereal
01953 *, integer *, integer *, integer *, doublereal *, doublereal *,
01954 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
01955 , zbknu_(doublereal *, doublereal *, doublereal *, integer *,
01956 integer *, doublereal *, doublereal *, integer *, doublereal *,
01957 doublereal *, doublereal *);
01958 extern doublereal d1mach_(integer *);
01959 extern integer i1mach_(integer *);
01960 extern int zzzexp_(doublereal *, doublereal *,
01961 doublereal *, doublereal *);
01962
01963
01964
01965
01966
01967
01968
01969
01970
01971
01972
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983
01984
01985
01986
01987
01988
01989
01990
01991
01992
01993
01994
01995
01996
01997
01998
01999
02000
02001
02002
02003
02004
02005
02006
02007
02008
02009
02010
02011
02012
02013
02014
02015
02016
02017
02018
02019
02020
02021
02022
02023
02024
02025
02026
02027
02028
02029
02030
02031
02032
02033
02034
02035
02036
02037
02038
02039
02040
02041
02042
02043
02044
02045
02046
02047
02048
02049
02050
02051
02052
02053
02054
02055
02056
02057
02058
02059
02060
02061
02062
02063
02064
02065
02066
02067
02068
02069
02070
02071
02072
02073
02074
02075
02076
02077
02078
02079
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090
02091
02092
02093 *ierr = 0;
02094 *nz = 0;
02095 if (*id < 0 || *id > 1) {
02096 *ierr = 1;
02097 }
02098 if (*kode < 1 || *kode > 2) {
02099 *ierr = 1;
02100 }
02101 if (*ierr != 0) {
02102 return 0;
02103 }
02104 az = zabs_(zr, zi);
02105
02106 d__1 = d1mach_(&c__4);
02107 tol = max(d__1,1e-18);
02108 fid = (doublereal) ((real) (*id));
02109 if (az > 1.) {
02110 goto L70;
02111 }
02112
02113
02114
02115 s1r = coner;
02116 s1i = conei;
02117 s2r = coner;
02118 s2i = conei;
02119 if (az < tol) {
02120 goto L170;
02121 }
02122 aa = az * az;
02123 if (aa < tol / az) {
02124 goto L40;
02125 }
02126 trm1r = coner;
02127 trm1i = conei;
02128 trm2r = coner;
02129 trm2i = conei;
02130 atrm = 1.;
02131 str = *zr * *zr - *zi * *zi;
02132 sti = *zr * *zi + *zi * *zr;
02133 z3r = str * *zr - sti * *zi;
02134 z3i = str * *zi + sti * *zr;
02135 az3 = az * aa;
02136 ak = fid + 2.;
02137 bk = 3. - fid - fid;
02138 ck = 4. - fid;
02139 dk = fid + 3. + fid;
02140 d1 = ak * dk;
02141 d2 = bk * ck;
02142 ad = min(d1,d2);
02143 ak = fid * 9. + 24.;
02144 bk = 30. - fid * 9.;
02145 for (k = 1; k <= 25; ++k) {
02146 str = (trm1r * z3r - trm1i * z3i) / d1;
02147 trm1i = (trm1r * z3i + trm1i * z3r) / d1;
02148 trm1r = str;
02149 s1r += trm1r;
02150 s1i += trm1i;
02151 str = (trm2r * z3r - trm2i * z3i) / d2;
02152 trm2i = (trm2r * z3i + trm2i * z3r) / d2;
02153 trm2r = str;
02154 s2r += trm2r;
02155 s2i += trm2i;
02156 atrm = atrm * az3 / ad;
02157 d1 += ak;
02158 d2 += bk;
02159 ad = min(d1,d2);
02160 if (atrm < tol * ad) {
02161 goto L40;
02162 }
02163 ak += 18.;
02164 bk += 18.;
02165
02166 }
02167 L40:
02168 if (*id == 1) {
02169 goto L50;
02170 }
02171 *air = s1r * c1 - c2 * (*zr * s2r - *zi * s2i);
02172 *aii = s1i * c1 - c2 * (*zr * s2i + *zi * s2r);
02173 if (*kode == 1) {
02174 return 0;
02175 }
02176 zzzsqrt_(zr, zi, &str, &sti);
02177 ztar = tth * (*zr * str - *zi * sti);
02178 ztai = tth * (*zr * sti + *zi * str);
02179 zzzexp_(&ztar, &ztai, &str, &sti);
02180 ptr = *air * str - *aii * sti;
02181 *aii = *air * sti + *aii * str;
02182 *air = ptr;
02183 return 0;
02184 L50:
02185 *air = -s2r * c2;
02186 *aii = -s2i * c2;
02187 if (az <= tol) {
02188 goto L60;
02189 }
02190 str = *zr * s1r - *zi * s1i;
02191 sti = *zr * s1i + *zi * s1r;
02192 cc = c1 / (fid + 1.);
02193 *air += cc * (str * *zr - sti * *zi);
02194 *aii += cc * (str * *zi + sti * *zr);
02195 L60:
02196 if (*kode == 1) {
02197 return 0;
02198 }
02199 zzzsqrt_(zr, zi, &str, &sti);
02200 ztar = tth * (*zr * str - *zi * sti);
02201 ztai = tth * (*zr * sti + *zi * str);
02202 zzzexp_(&ztar, &ztai, &str, &sti);
02203 ptr = str * *air - sti * *aii;
02204 *aii = str * *aii + sti * *air;
02205 *air = ptr;
02206 return 0;
02207
02208
02209
02210 L70:
02211 fnu = (fid + 1.) / 3.;
02212
02213
02214
02215
02216
02217
02218
02219
02220
02221
02222 k1 = i1mach_(&c__15);
02223 k2 = i1mach_(&c__16);
02224 r1m5 = d1mach_(&c__5);
02225
02226 i__1 = abs(k1), i__2 = abs(k2);
02227 k = min(i__1,i__2);
02228 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
02229 k1 = i1mach_(&c__14) - 1;
02230 aa = r1m5 * (doublereal) ((real) k1);
02231 dig = min(aa,18.);
02232 aa *= 2.303;
02233
02234 d__1 = -aa;
02235 alim = elim + max(d__1,-41.45);
02236 rl = dig * 1.2 + 3.;
02237 alaz = log(az);
02238
02239
02240
02241 aa = .5 / tol;
02242 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
02243 aa = min(aa,bb);
02244 aa = pow(aa, tth);
02245 if (az > aa) {
02246 goto L260;
02247 }
02248 aa = sqrt(aa);
02249 if (az > aa) {
02250 *ierr = 3;
02251 }
02252 zzzsqrt_(zr, zi, &csqr, &csqi);
02253 ztar = tth * (*zr * csqr - *zi * csqi);
02254 ztai = tth * (*zr * csqi + *zi * csqr);
02255
02256
02257
02258 iflag = 0;
02259 sfac = 1.;
02260 ak = ztai;
02261 if (*zr >= 0.) {
02262 goto L80;
02263 }
02264 bk = ztar;
02265 ck = -abs(bk);
02266 ztar = ck;
02267 ztai = ak;
02268 L80:
02269 if (*zi != 0.) {
02270 goto L90;
02271 }
02272 if (*zr > 0.) {
02273 goto L90;
02274 }
02275 ztar = 0.;
02276 ztai = ak;
02277 L90:
02278 aa = ztar;
02279 if (aa >= 0. && *zr > 0.) {
02280 goto L110;
02281 }
02282 if (*kode == 2) {
02283 goto L100;
02284 }
02285
02286
02287
02288 if (aa > -alim) {
02289 goto L100;
02290 }
02291 aa = -aa + alaz * .25;
02292 iflag = 1;
02293 sfac = tol;
02294 if (aa > elim) {
02295 goto L270;
02296 }
02297 L100:
02298
02299
02300
02301 mr = 1;
02302 if (*zi < 0.) {
02303 mr = -1;
02304 }
02305 zacai_(&ztar, &ztai, &fnu, kode, &mr, &c__1, cyr, cyi, &nn, &rl, &tol, &
02306 elim, &alim);
02307 if (nn < 0) {
02308 goto L280;
02309 }
02310 *nz += nn;
02311 goto L130;
02312 L110:
02313 if (*kode == 2) {
02314 goto L120;
02315 }
02316
02317
02318
02319 if (aa < alim) {
02320 goto L120;
02321 }
02322 aa = -aa - alaz * .25;
02323 iflag = 2;
02324 sfac = 1. / tol;
02325 if (aa < -elim) {
02326 goto L210;
02327 }
02328 L120:
02329 zbknu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, nz, &tol, &elim, &alim);
02330 L130:
02331 s1r = cyr[0] * coef;
02332 s1i = cyi[0] * coef;
02333 if (iflag != 0) {
02334 goto L150;
02335 }
02336 if (*id == 1) {
02337 goto L140;
02338 }
02339 *air = csqr * s1r - csqi * s1i;
02340 *aii = csqr * s1i + csqi * s1r;
02341 return 0;
02342 L140:
02343 *air = -(*zr * s1r - *zi * s1i);
02344 *aii = -(*zr * s1i + *zi * s1r);
02345 return 0;
02346 L150:
02347 s1r *= sfac;
02348 s1i *= sfac;
02349 if (*id == 1) {
02350 goto L160;
02351 }
02352 str = s1r * csqr - s1i * csqi;
02353 s1i = s1r * csqi + s1i * csqr;
02354 s1r = str;
02355 *air = s1r / sfac;
02356 *aii = s1i / sfac;
02357 return 0;
02358 L160:
02359 str = -(s1r * *zr - s1i * *zi);
02360 s1i = -(s1r * *zi + s1i * *zr);
02361 s1r = str;
02362 *air = s1r / sfac;
02363 *aii = s1i / sfac;
02364 return 0;
02365 L170:
02366 aa = d1mach_(&c__1) * 1e3;
02367 s1r = zeror;
02368 s1i = zeroi;
02369 if (*id == 1) {
02370 goto L190;
02371 }
02372 if (az <= aa) {
02373 goto L180;
02374 }
02375 s1r = c2 * *zr;
02376 s1i = c2 * *zi;
02377 L180:
02378 *air = c1 - s1r;
02379 *aii = -s1i;
02380 return 0;
02381 L190:
02382 *air = -c2;
02383 *aii = 0.;
02384 aa = sqrt(aa);
02385 if (az <= aa) {
02386 goto L200;
02387 }
02388 s1r = (*zr * *zr - *zi * *zi) * .5;
02389 s1i = *zr * *zi;
02390 L200:
02391 *air += c1 * s1r;
02392 *aii += c1 * s1i;
02393 return 0;
02394 L210:
02395 *nz = 1;
02396 *air = zeror;
02397 *aii = zeroi;
02398 return 0;
02399 L270:
02400 *nz = 0;
02401 *ierr = 2;
02402 return 0;
02403 L280:
02404 if (nn == -1) {
02405 goto L270;
02406 }
02407 *nz = 0;
02408 *ierr = 5;
02409 return 0;
02410 L260:
02411 *ierr = 4;
02412 *nz = 0;
02413 return 0;
02414 }
02415
02416 int zbiry_(doublereal *zr, doublereal *zi, integer *id,
02417 integer *kode, doublereal *bir, doublereal *bii, integer *ierr)
02418 {
02419
02420
02421 static doublereal tth = .666666666666666667;
02422 static doublereal c1 = .614926627446000736;
02423 static doublereal c2 = .448288357353826359;
02424 static doublereal coef = .577350269189625765;
02425 static doublereal pi = 3.14159265358979324;
02426 static doublereal coner = 1.;
02427 static doublereal conei = 0.;
02428
02429
02430 integer i__1, i__2;
02431 doublereal d__1;
02432
02433
02434 double exp(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
02435 doublereal), log(doublereal), cos(doublereal), sin(doublereal);
02436
02437
02438 extern int zzzsqrt_(doublereal *, doublereal *,
02439 doublereal *, doublereal *);
02440 static integer k;
02441 static doublereal d1, d2;
02442 static integer k1, k2;
02443 static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az, rl;
02444 static integer nz;
02445 static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, eaa, fid, dig, cyi[2]
02446 , fmr, r1m5, fnu, cyr[2], tol, sti, str, sfac, alim, elim;
02447 extern doublereal zabs_(doublereal *, doublereal *);
02448 static doublereal csqi, atrm, fnul, ztai, csqr;
02449 extern int zdiv_(doublereal *, doublereal *, doublereal *
02450 , doublereal *, doublereal *, doublereal *);
02451 static doublereal ztar, trm1i, trm2i, trm1r, trm2r;
02452 extern int zbinu_(doublereal *, doublereal *, doublereal
02453 *, integer *, integer *, doublereal *, doublereal *, integer *,
02454 doublereal *, doublereal *, doublereal *, doublereal *,
02455 doublereal *);
02456 extern doublereal d1mach_(integer *);
02457 extern integer i1mach_(integer *);
02458
02459
02460
02461
02462
02463
02464
02465
02466
02467
02468
02469
02470
02471
02472
02473
02474
02475
02476
02477
02478
02479
02480
02481
02482
02483
02484
02485
02486
02487
02488
02489
02490
02491
02492
02493
02494
02495
02496
02497
02498
02499
02500
02501
02502
02503
02504
02505
02506
02507
02508
02509
02510
02511
02512
02513
02514
02515
02516
02517
02518
02519
02520
02521
02522
02523
02524
02525
02526
02527
02528
02529
02530
02531
02532
02533
02534
02535
02536
02537
02538
02539
02540
02541
02542
02543
02544
02545
02546
02547
02548
02549
02550
02551
02552
02553
02554
02555
02556
02557
02558
02559
02560
02561
02562
02563
02564
02565
02566
02567
02568
02569
02570
02571
02572
02573
02574
02575
02576
02577
02578
02579
02580
02581
02582
02583 *ierr = 0;
02584 nz = 0;
02585 if (*id < 0 || *id > 1) {
02586 *ierr = 1;
02587 }
02588 if (*kode < 1 || *kode > 2) {
02589 *ierr = 1;
02590 }
02591 if (*ierr != 0) {
02592 return 0;
02593 }
02594 az = zabs_(zr, zi);
02595
02596 d__1 = d1mach_(&c__4);
02597 tol = max(d__1,1e-18);
02598 fid = (doublereal) ((real) (*id));
02599 if (az > 1.f) {
02600 goto L70;
02601 }
02602
02603
02604
02605 s1r = coner;
02606 s1i = conei;
02607 s2r = coner;
02608 s2i = conei;
02609 if (az < tol) {
02610 goto L130;
02611 }
02612 aa = az * az;
02613 if (aa < tol / az) {
02614 goto L40;
02615 }
02616 trm1r = coner;
02617 trm1i = conei;
02618 trm2r = coner;
02619 trm2i = conei;
02620 atrm = 1.;
02621 str = *zr * *zr - *zi * *zi;
02622 sti = *zr * *zi + *zi * *zr;
02623 z3r = str * *zr - sti * *zi;
02624 z3i = str * *zi + sti * *zr;
02625 az3 = az * aa;
02626 ak = fid + 2.;
02627 bk = 3. - fid - fid;
02628 ck = 4. - fid;
02629 dk = fid + 3. + fid;
02630 d1 = ak * dk;
02631 d2 = bk * ck;
02632 ad = min(d1,d2);
02633 ak = fid * 9. + 24.;
02634 bk = 30. - fid * 9.;
02635 for (k = 1; k <= 25; ++k) {
02636 str = (trm1r * z3r - trm1i * z3i) / d1;
02637 trm1i = (trm1r * z3i + trm1i * z3r) / d1;
02638 trm1r = str;
02639 s1r += trm1r;
02640 s1i += trm1i;
02641 str = (trm2r * z3r - trm2i * z3i) / d2;
02642 trm2i = (trm2r * z3i + trm2i * z3r) / d2;
02643 trm2r = str;
02644 s2r += trm2r;
02645 s2i += trm2i;
02646 atrm = atrm * az3 / ad;
02647 d1 += ak;
02648 d2 += bk;
02649 ad = min(d1,d2);
02650 if (atrm < tol * ad) {
02651 goto L40;
02652 }
02653 ak += 18.;
02654 bk += 18.;
02655
02656 }
02657 L40:
02658 if (*id == 1) {
02659 goto L50;
02660 }
02661 *bir = c1 * s1r + c2 * (*zr * s2r - *zi * s2i);
02662 *bii = c1 * s1i + c2 * (*zr * s2i + *zi * s2r);
02663 if (*kode == 1) {
02664 return 0;
02665 }
02666 zzzsqrt_(zr, zi, &str, &sti);
02667 ztar = tth * (*zr * str - *zi * sti);
02668 ztai = tth * (*zr * sti + *zi * str);
02669 aa = ztar;
02670 aa = -abs(aa);
02671 eaa = exp(aa);
02672 *bir *= eaa;
02673 *bii *= eaa;
02674 return 0;
02675 L50:
02676 *bir = s2r * c2;
02677 *bii = s2i * c2;
02678 if (az <= tol) {
02679 goto L60;
02680 }
02681 cc = c1 / (fid + 1.);
02682 str = s1r * *zr - s1i * *zi;
02683 sti = s1r * *zi + s1i * *zr;
02684 *bir += cc * (str * *zr - sti * *zi);
02685 *bii += cc * (str * *zi + sti * *zr);
02686 L60:
02687 if (*kode == 1) {
02688 return 0;
02689 }
02690 zzzsqrt_(zr, zi, &str, &sti);
02691 ztar = tth * (*zr * str - *zi * sti);
02692 ztai = tth * (*zr * sti + *zi * str);
02693 aa = ztar;
02694 aa = -abs(aa);
02695 eaa = exp(aa);
02696 *bir *= eaa;
02697 *bii *= eaa;
02698 return 0;
02699
02700
02701
02702 L70:
02703 fnu = (fid + 1.) / 3.;
02704
02705
02706
02707
02708
02709
02710
02711
02712
02713
02714
02715 k1 = i1mach_(&c__15);
02716 k2 = i1mach_(&c__16);
02717 r1m5 = d1mach_(&c__5);
02718
02719 i__1 = abs(k1), i__2 = abs(k2);
02720 k = min(i__1,i__2);
02721 elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
02722 k1 = i1mach_(&c__14) - 1;
02723 aa = r1m5 * (doublereal) ((real) k1);
02724 dig = min(aa,18.);
02725 aa *= 2.303;
02726
02727 d__1 = -aa;
02728 alim = elim + max(d__1,-41.45);
02729 rl = dig * 1.2 + 3.;
02730 fnul = (dig - 3.) * 6. + 10.;
02731
02732
02733
02734 aa = .5 / tol;
02735 bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
02736 aa = min(aa,bb);
02737 aa = pow(aa, tth);
02738 if (az > aa) {
02739 goto L260;
02740 }
02741 aa = sqrt(aa);
02742 if (az > aa) {
02743 *ierr = 3;
02744 }
02745 zzzsqrt_(zr, zi, &csqr, &csqi);
02746 ztar = tth * (*zr * csqr - *zi * csqi);
02747 ztai = tth * (*zr * csqi + *zi * csqr);
02748
02749
02750
02751 sfac = 1.;
02752 ak = ztai;
02753 if (*zr >= 0.) {
02754 goto L80;
02755 }
02756 bk = ztar;
02757 ck = -abs(bk);
02758 ztar = ck;
02759 ztai = ak;
02760 L80:
02761 if (*zi != 0. || *zr > 0.) {
02762 goto L90;
02763 }
02764 ztar = 0.;
02765 ztai = ak;
02766 L90:
02767 aa = ztar;
02768 if (*kode == 2) {
02769 goto L100;
02770 }
02771
02772
02773
02774 bb = abs(aa);
02775 if (bb < alim) {
02776 goto L100;
02777 }
02778 bb += log(az) * .25;
02779 sfac = tol;
02780 if (bb > elim) {
02781 goto L190;
02782 }
02783 L100:
02784 fmr = 0.;
02785 if (aa >= 0. && *zr > 0.) {
02786 goto L110;
02787 }
02788 fmr = pi;
02789 if (*zi < 0.) {
02790 fmr = -pi;
02791 }
02792 ztar = -ztar;
02793 ztai = -ztai;
02794 L110:
02795
02796
02797
02798
02799 zbinu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, &nz, &rl, &fnul, &tol, &
02800 elim, &alim);
02801 if (nz < 0) {
02802 goto L200;
02803 }
02804 aa = fmr * fnu;
02805 z3r = sfac;
02806 str = cos(aa);
02807 sti = sin(aa);
02808 s1r = (str * cyr[0] - sti * cyi[0]) * z3r;
02809 s1i = (str * cyi[0] + sti * cyr[0]) * z3r;
02810 fnu = (2. - fid) / 3.;
02811 zbinu_(&ztar, &ztai, &fnu, kode, &c__2, cyr, cyi, &nz, &rl, &fnul, &tol, &
02812 elim, &alim);
02813 cyr[0] *= z3r;
02814 cyi[0] *= z3r;
02815 cyr[1] *= z3r;
02816 cyi[1] *= z3r;
02817
02818
02819
02820 zdiv_(cyr, cyi, &ztar, &ztai, &str, &sti);
02821 s2r = (fnu + fnu) * str + cyr[1];
02822 s2i = (fnu + fnu) * sti + cyi[1];
02823 aa = fmr * (fnu - 1.);
02824 str = cos(aa);
02825 sti = sin(aa);
02826 s1r = coef * (s1r + s2r * str - s2i * sti);
02827 s1i = coef * (s1i + s2r * sti + s2i * str);
02828 if (*id == 1) {
02829 goto L120;
02830 }
02831 str = csqr * s1r - csqi * s1i;
02832 s1i = csqr * s1i + csqi * s1r;
02833 s1r = str;
02834 *bir = s1r / sfac;
02835 *bii = s1i / sfac;
02836 return 0;
02837 L120:
02838 str = *zr * s1r - *zi * s1i;
02839 s1i = *zr * s1i + *zi * s1r;
02840 s1r = str;
02841 *bir = s1r / sfac;
02842 *bii = s1i / sfac;
02843 return 0;
02844 L130:
02845 aa = c1 * (1. - fid) + fid * c2;
02846 *bir = aa;
02847 *bii = 0.;
02848 return 0;
02849 L190:
02850 *ierr = 2;
02851 nz = 0;
02852 return 0;
02853 L200:
02854 if (nz == -1) {
02855 goto L190;
02856 }
02857 nz = 0;
02858 *ierr = 5;
02859 return 0;
02860 L260:
02861 *ierr = 4;
02862 nz = 0;
02863 return 0;
02864 }
02865
02866 int zmlt_(doublereal *ar, doublereal *ai, doublereal *br,
02867 doublereal *bi, doublereal *cr, doublereal *ci)
02868 {
02869 static doublereal ca, cb;
02870
02871
02872
02873
02874
02875
02876
02877
02878 ca = *ar * *br - *ai * *bi;
02879 cb = *ar * *bi + *ai * *br;
02880 *cr = ca;
02881 *ci = cb;
02882 return 0;
02883 }
02884
02885 int zdiv_(doublereal *ar, doublereal *ai, doublereal *br,
02886 doublereal *bi, doublereal *cr, doublereal *ci)
02887 {
02888 static doublereal ca, cb, cc, cd, bm;
02889 extern doublereal zabs_(doublereal *, doublereal *);
02890
02891
02892
02893
02894
02895
02896
02897
02898 bm = 1. / zabs_(br, bi);
02899 cc = *br * bm;
02900 cd = *bi * bm;
02901 ca = (*ar * cc + *ai * cd) * bm;
02902 cb = (*ai * cc - *ar * cd) * bm;
02903 *cr = ca;
02904 *ci = cb;
02905 return 0;
02906 }
02907
02908 int zzzsqrt_(doublereal *ar, doublereal *ai, doublereal *br,
02909 doublereal *bi)
02910 {
02911
02912
02913 static doublereal drt = .7071067811865475244008443621;
02914 static doublereal dpi = 3.141592653589793238462643383;
02915
02916
02917 double sqrt(doublereal), atan(doublereal), cos(doublereal), sin(
02918 doublereal);
02919
02920
02921 static doublereal zm;
02922 extern doublereal zabs_(doublereal *, doublereal *);
02923 static doublereal dtheta;
02924
02925
02926
02927
02928
02929
02930
02931
02932 zm = zabs_(ar, ai);
02933 zm = sqrt(zm);
02934 if (*ar == 0.) {
02935 goto L10;
02936 }
02937 if (*ai == 0.) {
02938 goto L20;
02939 }
02940 dtheta = atan(*ai / *ar);
02941 if (dtheta <= 0.) {
02942 goto L40;
02943 }
02944 if (*ar < 0.) {
02945 dtheta -= dpi;
02946 }
02947 goto L50;
02948 L10:
02949 if (*ai > 0.) {
02950 goto L60;
02951 }
02952 if (*ai < 0.) {
02953 goto L70;
02954 }
02955 *br = 0.;
02956 *bi = 0.;
02957 return 0;
02958 L20:
02959 if (*ar > 0.) {
02960 goto L30;
02961 }
02962 *br = 0.;
02963 *bi = sqrt((abs(*ar)));
02964 return 0;
02965 L30:
02966 *br = sqrt(*ar);
02967 *bi = 0.;
02968 return 0;
02969 L40:
02970 if (*ar < 0.) {
02971 dtheta += dpi;
02972 }
02973 L50:
02974 dtheta *= .5;
02975 *br = zm * cos(dtheta);
02976 *bi = zm * sin(dtheta);
02977 return 0;
02978 L60:
02979 *br = zm * drt;
02980 *bi = zm * drt;
02981 return 0;
02982 L70:
02983 *br = zm * drt;
02984 *bi = -zm * drt;
02985 return 0;
02986 }
02987
02988 int zzzexp_(doublereal *ar, doublereal *ai, doublereal *br,
02989 doublereal *bi)
02990 {
02991
02992 double exp(doublereal), cos(doublereal), sin(doublereal);
02993
02994
02995 static doublereal ca, cb, zm;
02996
02997
02998
02999
03000
03001
03002
03003
03004 zm = exp(*ar);
03005 ca = zm * cos(*ai);
03006 cb = zm * sin(*ai);
03007 *br = ca;
03008 *bi = cb;
03009 return 0;
03010 }
03011
03012 int zzzlog_(doublereal *ar, doublereal *ai, doublereal *br,
03013 doublereal *bi, integer *ierr)
03014 {
03015
03016
03017 static doublereal dpi = 3.141592653589793238462643383;
03018 static doublereal dhpi = 1.570796326794896619231321696;
03019
03020
03021 double atan(doublereal), log(doublereal);
03022
03023
03024 static doublereal zm;
03025 extern doublereal zabs_(doublereal *, doublereal *);
03026 static doublereal dtheta;
03027
03028
03029
03030
03031
03032
03033
03034
03035
03036 *ierr = 0;
03037 if (*ar == 0.) {
03038 goto L10;
03039 }
03040 if (*ai == 0.) {
03041 goto L20;
03042 }
03043 dtheta = atan(*ai / *ar);
03044 if (dtheta <= 0.) {
03045 goto L40;
03046 }
03047 if (*ar < 0.) {
03048 dtheta -= dpi;
03049 }
03050 goto L50;
03051 L10:
03052 if (*ai == 0.) {
03053 goto L60;
03054 }
03055 *bi = dhpi;
03056 *br = log((abs(*ai)));
03057 if (*ai < 0.) {
03058 *bi = -(*bi);
03059 }
03060 return 0;
03061 L20:
03062 if (*ar > 0.) {
03063 goto L30;
03064 }
03065 *br = log((abs(*ar)));
03066 *bi = dpi;
03067 return 0;
03068 L30:
03069 *br = log(*ar);
03070 *bi = 0.;
03071 return 0;
03072 L40:
03073 if (*ar < 0.) {
03074 dtheta += dpi;
03075 }
03076 L50:
03077 zm = zabs_(ar, ai);
03078 *br = log(zm);
03079 *bi = dtheta;
03080 return 0;
03081 L60:
03082 *ierr = 1;
03083 return 0;
03084 }
03085
03086 doublereal zabs_(doublereal *zr, doublereal *zi)
03087 {
03088
03089 doublereal ret_val;
03090
03091
03092 double sqrt(doublereal);
03093
03094
03095 static doublereal q, s, u, v;
03096
03097
03098
03099
03100
03101
03102
03103
03104
03105 u = abs(*zr);
03106 v = abs(*zi);
03107 s = u + v;
03108
03109
03110
03111
03112 s *= 1.;
03113 if (s == 0.) {
03114 goto L20;
03115 }
03116 if (u > v) {
03117 goto L10;
03118 }
03119 q = u / v;
03120 ret_val = v * sqrt(q * q + 1.);
03121 return ret_val;
03122 L10:
03123 q = v / u;
03124 ret_val = u * sqrt(q * q + 1.);
03125 return ret_val;
03126 L20:
03127 ret_val = 0.;
03128 return ret_val;
03129 }
03130
03131 int zbknu_(doublereal *zr, doublereal *zi, doublereal *fnu,
03132 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
03133 nz, doublereal *tol, doublereal *elim, doublereal *alim)
03134 {
03135
03136
03137 static integer kmax = 30;
03138 static doublereal czeror = 0.;
03139 static doublereal czeroi = 0.;
03140 static doublereal coner = 1.;
03141 static doublereal conei = 0.;
03142 static doublereal ctwor = 2.;
03143 static doublereal r1 = 2.;
03144 static doublereal dpi = 3.14159265358979324;
03145 static doublereal rthpi = 1.25331413731550025;
03146 static doublereal spi = 1.90985931710274403;
03147 static doublereal hpi = 1.57079632679489662;
03148 static doublereal fpi = 1.89769999331517738;
03149 static doublereal tth = .666666666666666666;
03150 static doublereal cc[8] = { .577215664901532861,-.0420026350340952355,
03151 -.0421977345555443367,.00721894324666309954,
03152 -2.15241674114950973e-4,-2.01348547807882387e-5,
03153 1.13302723198169588e-6,6.11609510448141582e-9 };
03154
03155
03156 integer i__1;
03157 doublereal d__1;
03158
03159
03160 double sin(doublereal), exp(doublereal), cos(doublereal), atan(doublereal)
03161 , sqrt(doublereal), log(doublereal);
03162
03163
03164 extern int zzzsqrt_(doublereal *, doublereal *,
03165 doublereal *, doublereal *);
03166 static integer i__, j, k;
03167 static doublereal s, a1, a2, g1, g2, t1, t2, aa, bb, fc, ak, bk;
03168 static integer ic;
03169 static doublereal fi, fk, as;
03170 static integer kk;
03171 static doublereal fr, pi, qi, tm, pr, qr;
03172 static integer nw;
03173 static doublereal p1i, p2i, s1i, s2i, p2m, p1r, p2r, s1r, s2r, cbi, cbr,
03174 cki, caz, csi, ckr, fhs, fks, rak, czi, dnu, csr, elm, zdi, bry[3]
03175 , pti, czr, sti, zdr, cyr[2], rzi, ptr, cyi[2];
03176 static integer inu;
03177 static doublereal str, rzr, dnu2, cchi, cchr, alas, cshi;
03178 static integer inub, idum;
03179 extern doublereal zabs_(doublereal *, doublereal *);
03180 static doublereal cshr, fmui, rcaz, csrr[3], cssr[3], fmur;
03181 extern int zdiv_(doublereal *, doublereal *, doublereal *
03182 , doublereal *, doublereal *, doublereal *);
03183 static doublereal smui, smur;
03184 extern int zmlt_(doublereal *, doublereal *, doublereal *
03185 , doublereal *, doublereal *, doublereal *);
03186 static integer iflag, kflag;
03187 static doublereal coefi;
03188 static integer koded;
03189 static doublereal ascle, coefr, helim, celmr, csclr, crscr;
03190 extern int zshch_(doublereal *, doublereal *, doublereal
03191 *, doublereal *, doublereal *, doublereal *);
03192 static doublereal etest;
03193 extern int zuchk_(doublereal *, doublereal *, integer *,
03194 doublereal *, doublereal *), zkscl_(doublereal *, doublereal *,
03195 doublereal *, integer *, doublereal *, doublereal *, integer *,
03196 doublereal *, doublereal *, doublereal *, doublereal *,
03197 doublereal *);
03198 extern doublereal d1mach_(integer *);
03199 extern integer i1mach_(integer *);
03200 extern doublereal dgamln_(doublereal *, integer *);
03201 extern int zzzlog_(doublereal *, doublereal *,
03202 doublereal *, doublereal *, integer *), zzzexp_(doublereal *,
03203 doublereal *, doublereal *, doublereal *);
03204
03205
03206
03207
03208
03209
03210
03211
03212
03213
03214
03215
03216
03217
03218 --yi;
03219 --yr;
03220
03221
03222
03223 caz = zabs_(zr, zi);
03224 csclr = 1. / *tol;
03225 crscr = *tol;
03226 cssr[0] = csclr;
03227 cssr[1] = 1.;
03228 cssr[2] = crscr;
03229 csrr[0] = crscr;
03230 csrr[1] = 1.;
03231 csrr[2] = csclr;
03232 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
03233 bry[1] = 1. / bry[0];
03234 bry[2] = d1mach_(&c__2);
03235 *nz = 0;
03236 iflag = 0;
03237 koded = *kode;
03238 rcaz = 1. / caz;
03239 str = *zr * rcaz;
03240 sti = -(*zi) * rcaz;
03241 rzr = (str + str) * rcaz;
03242 rzi = (sti + sti) * rcaz;
03243 inu = (integer) ((real) (*fnu + .5));
03244 dnu = *fnu - (doublereal) ((real) inu);
03245 if (abs(dnu) == .5) {
03246 goto L110;
03247 }
03248 dnu2 = 0.;
03249 if (abs(dnu) > *tol) {
03250 dnu2 = dnu * dnu;
03251 }
03252 if (caz > r1) {
03253 goto L110;
03254 }
03255
03256
03257
03258 fc = 1.;
03259 zzzlog_(&rzr, &rzi, &smur, &smui, &idum);
03260 fmur = smur * dnu;
03261 fmui = smui * dnu;
03262 zshch_(&fmur, &fmui, &cshr, &cshi, &cchr, &cchi);
03263 if (dnu == 0.) {
03264 goto L10;
03265 }
03266 fc = dnu * dpi;
03267 fc /= sin(fc);
03268 smur = cshr / dnu;
03269 smui = cshi / dnu;
03270 L10:
03271 a2 = dnu + 1.;
03272
03273
03274
03275 t2 = exp(-dgamln_(&a2, &idum));
03276 t1 = 1. / (t2 * fc);
03277 if (abs(dnu) > .1) {
03278 goto L40;
03279 }
03280
03281
03282
03283 ak = 1.;
03284 s = cc[0];
03285 for (k = 2; k <= 8; ++k) {
03286 ak *= dnu2;
03287 tm = cc[k - 1] * ak;
03288 s += tm;
03289 if (abs(tm) < *tol) {
03290 goto L30;
03291 }
03292
03293 }
03294 L30:
03295 g1 = -s;
03296 goto L50;
03297 L40:
03298 g1 = (t1 - t2) / (dnu + dnu);
03299 L50:
03300 g2 = (t1 + t2) * .5;
03301 fr = fc * (cchr * g1 + smur * g2);
03302 fi = fc * (cchi * g1 + smui * g2);
03303 zzzexp_(&fmur, &fmui, &str, &sti);
03304 pr = str * .5 / t2;
03305 pi = sti * .5 / t2;
03306 zdiv_(&c_b168, &c_b169, &str, &sti, &ptr, &pti);
03307 qr = ptr / t1;
03308 qi = pti / t1;
03309 s1r = fr;
03310 s1i = fi;
03311 s2r = pr;
03312 s2i = pi;
03313 ak = 1.;
03314 a1 = 1.;
03315 ckr = coner;
03316 cki = conei;
03317 bk = 1. - dnu2;
03318 if (inu > 0 || *n > 1) {
03319 goto L80;
03320 }
03321
03322
03323
03324 if (caz < *tol) {
03325 goto L70;
03326 }
03327 zmlt_(zr, zi, zr, zi, &czr, &czi);
03328 czr *= .25;
03329 czi *= .25;
03330 t1 = caz * .25 * caz;
03331 L60:
03332 fr = (fr * ak + pr + qr) / bk;
03333 fi = (fi * ak + pi + qi) / bk;
03334 str = 1. / (ak - dnu);
03335 pr *= str;
03336 pi *= str;
03337 str = 1. / (ak + dnu);
03338 qr *= str;
03339 qi *= str;
03340 str = ckr * czr - cki * czi;
03341 rak = 1. / ak;
03342 cki = (ckr * czi + cki * czr) * rak;
03343 ckr = str * rak;
03344 s1r = ckr * fr - cki * fi + s1r;
03345 s1i = ckr * fi + cki * fr + s1i;
03346 a1 = a1 * t1 * rak;
03347 bk = bk + ak + ak + 1.;
03348 ak += 1.;
03349 if (a1 > *tol) {
03350 goto L60;
03351 }
03352 L70:
03353 yr[1] = s1r;
03354 yi[1] = s1i;
03355 if (koded == 1) {
03356 return 0;
03357 }
03358 zzzexp_(zr, zi, &str, &sti);
03359 zmlt_(&s1r, &s1i, &str, &sti, &yr[1], &yi[1]);
03360 return 0;
03361
03362
03363
03364 L80:
03365 if (caz < *tol) {
03366 goto L100;
03367 }
03368 zmlt_(zr, zi, zr, zi, &czr, &czi);
03369 czr *= .25;
03370 czi *= .25;
03371 t1 = caz * .25 * caz;
03372 L90:
03373 fr = (fr * ak + pr + qr) / bk;
03374 fi = (fi * ak + pi + qi) / bk;
03375 str = 1. / (ak - dnu);
03376 pr *= str;
03377 pi *= str;
03378 str = 1. / (ak + dnu);
03379 qr *= str;
03380 qi *= str;
03381 str = ckr * czr - cki * czi;
03382 rak = 1. / ak;
03383 cki = (ckr * czi + cki * czr) * rak;
03384 ckr = str * rak;
03385 s1r = ckr * fr - cki * fi + s1r;
03386 s1i = ckr * fi + cki * fr + s1i;
03387 str = pr - fr * ak;
03388 sti = pi - fi * ak;
03389 s2r = ckr * str - cki * sti + s2r;
03390 s2i = ckr * sti + cki * str + s2i;
03391 a1 = a1 * t1 * rak;
03392 bk = bk + ak + ak + 1.;
03393 ak += 1.;
03394 if (a1 > *tol) {
03395 goto L90;
03396 }
03397 L100:
03398 kflag = 2;
03399 a1 = *fnu + 1.;
03400 ak = a1 * abs(smur);
03401 if (ak > *alim) {
03402 kflag = 3;
03403 }
03404 str = cssr[kflag - 1];
03405 p2r = s2r * str;
03406 p2i = s2i * str;
03407 zmlt_(&p2r, &p2i, &rzr, &rzi, &s2r, &s2i);
03408 s1r *= str;
03409 s1i *= str;
03410 if (koded == 1) {
03411 goto L210;
03412 }
03413 zzzexp_(zr, zi, &fr, &fi);
03414 zmlt_(&s1r, &s1i, &fr, &fi, &s1r, &s1i);
03415 zmlt_(&s2r, &s2i, &fr, &fi, &s2r, &s2i);
03416 goto L210;
03417
03418
03419
03420
03421
03422
03423 L110:
03424 zzzsqrt_(zr, zi, &str, &sti);
03425 zdiv_(&rthpi, &czeroi, &str, &sti, &coefr, &coefi);
03426 kflag = 2;
03427 if (koded == 2) {
03428 goto L120;
03429 }
03430 if (*zr > *alim) {
03431 goto L290;
03432 }
03433
03434 str = exp(-(*zr)) * cssr[kflag - 1];
03435 sti = -str * sin(*zi);
03436 str *= cos(*zi);
03437 zmlt_(&coefr, &coefi, &str, &sti, &coefr, &coefi);
03438 L120:
03439 if (abs(dnu) == .5) {
03440 goto L300;
03441 }
03442
03443
03444
03445 ak = cos(dpi * dnu);
03446 ak = abs(ak);
03447 if (ak == czeror) {
03448 goto L300;
03449 }
03450 fhs = (d__1 = .25 - dnu2, abs(d__1));
03451 if (fhs == czeror) {
03452 goto L300;
03453 }
03454
03455
03456
03457
03458
03459
03460 t1 = (doublereal) ((real) (i1mach_(&c__14) - 1));
03461 t1 = t1 * d1mach_(&c__5) * 3.321928094;
03462 t1 = max(t1,12.);
03463 t1 = min(t1,60.);
03464 t2 = tth * t1 - 6.;
03465 if (*zr != 0.) {
03466 goto L130;
03467 }
03468 t1 = hpi;
03469 goto L140;
03470 L130:
03471 t1 = atan(*zi / *zr);
03472 t1 = abs(t1);
03473 L140:
03474 if (t2 > caz) {
03475 goto L170;
03476 }
03477
03478
03479
03480 etest = ak / (dpi * caz * *tol);
03481 fk = coner;
03482 if (etest < coner) {
03483 goto L180;
03484 }
03485 fks = ctwor;
03486 ckr = caz + caz + ctwor;
03487 p1r = czeror;
03488 p2r = coner;
03489 i__1 = kmax;
03490 for (i__ = 1; i__ <= i__1; ++i__) {
03491 ak = fhs / fks;
03492 cbr = ckr / (fk + coner);
03493 ptr = p2r;
03494 p2r = cbr * p2r - p1r * ak;
03495 p1r = ptr;
03496 ckr += ctwor;
03497 fks = fks + fk + fk + ctwor;
03498 fhs = fhs + fk + fk;
03499 fk += coner;
03500 str = abs(p2r) * fk;
03501 if (etest < str) {
03502 goto L160;
03503 }
03504
03505 }
03506 goto L310;
03507 L160:
03508 fk += spi * t1 * sqrt(t2 / caz);
03509 fhs = (d__1 = .25 - dnu2, abs(d__1));
03510 goto L180;
03511 L170:
03512
03513
03514
03515 a2 = sqrt(caz);
03516 ak = fpi * ak / (*tol * sqrt(a2));
03517 aa = t1 * 3. / (caz + 1.);
03518 bb = t1 * 14.7 / (caz + 28.);
03519 ak = (log(ak) + caz * cos(aa) / (caz * .008 + 1.)) / cos(bb);
03520 fk = ak * .12125 * ak / caz + 1.5;
03521 L180:
03522
03523
03524
03525 k = (integer) ((real) fk);
03526 fk = (doublereal) ((real) k);
03527 fks = fk * fk;
03528 p1r = czeror;
03529 p1i = czeroi;
03530 p2r = *tol;
03531 p2i = czeroi;
03532 csr = p2r;
03533 csi = p2i;
03534 i__1 = k;
03535 for (i__ = 1; i__ <= i__1; ++i__) {
03536 a1 = fks - fk;
03537 ak = (fks + fk) / (a1 + fhs);
03538 rak = 2. / (fk + coner);
03539 cbr = (fk + *zr) * rak;
03540 cbi = *zi * rak;
03541 ptr = p2r;
03542 pti = p2i;
03543 p2r = (ptr * cbr - pti * cbi - p1r) * ak;
03544 p2i = (pti * cbr + ptr * cbi - p1i) * ak;
03545 p1r = ptr;
03546 p1i = pti;
03547 csr += p2r;
03548 csi += p2i;
03549 fks = a1 - fk + coner;
03550 fk -= coner;
03551
03552 }
03553
03554
03555
03556
03557 tm = zabs_(&csr, &csi);
03558 ptr = 1. / tm;
03559 s1r = p2r * ptr;
03560 s1i = p2i * ptr;
03561 csr *= ptr;
03562 csi = -csi * ptr;
03563 zmlt_(&coefr, &coefi, &s1r, &s1i, &str, &sti);
03564 zmlt_(&str, &sti, &csr, &csi, &s1r, &s1i);
03565 if (inu > 0 || *n > 1) {
03566 goto L200;
03567 }
03568 zdr = *zr;
03569 zdi = *zi;
03570 if (iflag == 1) {
03571 goto L270;
03572 }
03573 goto L240;
03574 L200:
03575
03576
03577
03578 tm = zabs_(&p2r, &p2i);
03579 ptr = 1. / tm;
03580 p1r *= ptr;
03581 p1i *= ptr;
03582 p2r *= ptr;
03583 p2i = -p2i * ptr;
03584 zmlt_(&p1r, &p1i, &p2r, &p2i, &ptr, &pti);
03585 str = dnu + .5 - ptr;
03586 sti = -pti;
03587 zdiv_(&str, &sti, zr, zi, &str, &sti);
03588 str += 1.;
03589 zmlt_(&str, &sti, &s1r, &s1i, &s2r, &s2i);
03590
03591
03592
03593
03594 L210:
03595 str = dnu + 1.;
03596 ckr = str * rzr;
03597 cki = str * rzi;
03598 if (*n == 1) {
03599 --inu;
03600 }
03601 if (inu > 0) {
03602 goto L220;
03603 }
03604 if (*n > 1) {
03605 goto L215;
03606 }
03607 s1r = s2r;
03608 s1i = s2i;
03609 L215:
03610 zdr = *zr;
03611 zdi = *zi;
03612 if (iflag == 1) {
03613 goto L270;
03614 }
03615 goto L240;
03616 L220:
03617 inub = 1;
03618 if (iflag == 1) {
03619 goto L261;
03620 }
03621 L225:
03622 p1r = csrr[kflag - 1];
03623 ascle = bry[kflag - 1];
03624 i__1 = inu;
03625 for (i__ = inub; i__ <= i__1; ++i__) {
03626 str = s2r;
03627 sti = s2i;
03628 s2r = ckr * str - cki * sti + s1r;
03629 s2i = ckr * sti + cki * str + s1i;
03630 s1r = str;
03631 s1i = sti;
03632 ckr += rzr;
03633 cki += rzi;
03634 if (kflag >= 3) {
03635 goto L230;
03636 }
03637 p2r = s2r * p1r;
03638 p2i = s2i * p1r;
03639 str = abs(p2r);
03640 sti = abs(p2i);
03641 p2m = max(str,sti);
03642 if (p2m <= ascle) {
03643 goto L230;
03644 }
03645 ++kflag;
03646 ascle = bry[kflag - 1];
03647 s1r *= p1r;
03648 s1i *= p1r;
03649 s2r = p2r;
03650 s2i = p2i;
03651 str = cssr[kflag - 1];
03652 s1r *= str;
03653 s1i *= str;
03654 s2r *= str;
03655 s2i *= str;
03656 p1r = csrr[kflag - 1];
03657 L230:
03658 ;
03659 }
03660 if (*n != 1) {
03661 goto L240;
03662 }
03663 s1r = s2r;
03664 s1i = s2i;
03665 L240:
03666 str = csrr[kflag - 1];
03667 yr[1] = s1r * str;
03668 yi[1] = s1i * str;
03669 if (*n == 1) {
03670 return 0;
03671 }
03672 yr[2] = s2r * str;
03673 yi[2] = s2i * str;
03674 if (*n == 2) {
03675 return 0;
03676 }
03677 kk = 2;
03678 L250:
03679 ++kk;
03680 if (kk > *n) {
03681 return 0;
03682 }
03683 p1r = csrr[kflag - 1];
03684 ascle = bry[kflag - 1];
03685 i__1 = *n;
03686 for (i__ = kk; i__ <= i__1; ++i__) {
03687 p2r = s2r;
03688 p2i = s2i;
03689 s2r = ckr * p2r - cki * p2i + s1r;
03690 s2i = cki * p2r + ckr * p2i + s1i;
03691 s1r = p2r;
03692 s1i = p2i;
03693 ckr += rzr;
03694 cki += rzi;
03695 p2r = s2r * p1r;
03696 p2i = s2i * p1r;
03697 yr[i__] = p2r;
03698 yi[i__] = p2i;
03699 if (kflag >= 3) {
03700 goto L260;
03701 }
03702 str = abs(p2r);
03703 sti = abs(p2i);
03704 p2m = max(str,sti);
03705 if (p2m <= ascle) {
03706 goto L260;
03707 }
03708 ++kflag;
03709 ascle = bry[kflag - 1];
03710 s1r *= p1r;
03711 s1i *= p1r;
03712 s2r = p2r;
03713 s2i = p2i;
03714 str = cssr[kflag - 1];
03715 s1r *= str;
03716 s1i *= str;
03717 s2r *= str;
03718 s2i *= str;
03719 p1r = csrr[kflag - 1];
03720 L260:
03721 ;
03722 }
03723 return 0;
03724
03725
03726
03727 L261:
03728 helim = *elim * .5;
03729 elm = exp(-(*elim));
03730 celmr = elm;
03731 ascle = bry[0];
03732 zdr = *zr;
03733 zdi = *zi;
03734 ic = -1;
03735 j = 2;
03736 i__1 = inu;
03737 for (i__ = 1; i__ <= i__1; ++i__) {
03738 str = s2r;
03739 sti = s2i;
03740 s2r = str * ckr - sti * cki + s1r;
03741 s2i = sti * ckr + str * cki + s1i;
03742 s1r = str;
03743 s1i = sti;
03744 ckr += rzr;
03745 cki += rzi;
03746 as = zabs_(&s2r, &s2i);
03747 alas = log(as);
03748 p2r = -zdr + alas;
03749 if (p2r < -(*elim)) {
03750 goto L263;
03751 }
03752 zzzlog_(&s2r, &s2i, &str, &sti, &idum);
03753 p2r = -zdr + str;
03754 p2i = -zdi + sti;
03755 p2m = exp(p2r) / *tol;
03756 p1r = p2m * cos(p2i);
03757 p1i = p2m * sin(p2i);
03758 zuchk_(&p1r, &p1i, &nw, &ascle, tol);
03759 if (nw != 0) {
03760 goto L263;
03761 }
03762 j = 3 - j;
03763 cyr[j - 1] = p1r;
03764 cyi[j - 1] = p1i;
03765 if (ic == i__ - 1) {
03766 goto L264;
03767 }
03768 ic = i__;
03769 goto L262;
03770 L263:
03771 if (alas < helim) {
03772 goto L262;
03773 }
03774 zdr -= *elim;
03775 s1r *= celmr;
03776 s1i *= celmr;
03777 s2r *= celmr;
03778 s2i *= celmr;
03779 L262:
03780 ;
03781 }
03782 if (*n != 1) {
03783 goto L270;
03784 }
03785 s1r = s2r;
03786 s1i = s2i;
03787 goto L270;
03788 L264:
03789 kflag = 1;
03790 inub = i__ + 1;
03791 s2r = cyr[j - 1];
03792 s2i = cyi[j - 1];
03793 j = 3 - j;
03794 s1r = cyr[j - 1];
03795 s1i = cyi[j - 1];
03796 if (inub <= inu) {
03797 goto L225;
03798 }
03799 if (*n != 1) {
03800 goto L240;
03801 }
03802 s1r = s2r;
03803 s1i = s2i;
03804 goto L240;
03805 L270:
03806 yr[1] = s1r;
03807 yi[1] = s1i;
03808 if (*n == 1) {
03809 goto L280;
03810 }
03811 yr[2] = s2r;
03812 yi[2] = s2i;
03813 L280:
03814 ascle = bry[0];
03815 zkscl_(&zdr, &zdi, fnu, n, &yr[1], &yi[1], nz, &rzr, &rzi, &ascle, tol,
03816 elim);
03817 inu = *n - *nz;
03818 if (inu <= 0) {
03819 return 0;
03820 }
03821 kk = *nz + 1;
03822 s1r = yr[kk];
03823 s1i = yi[kk];
03824 yr[kk] = s1r * csrr[0];
03825 yi[kk] = s1i * csrr[0];
03826 if (inu == 1) {
03827 return 0;
03828 }
03829 kk = *nz + 2;
03830 s2r = yr[kk];
03831 s2i = yi[kk];
03832 yr[kk] = s2r * csrr[0];
03833 yi[kk] = s2i * csrr[0];
03834 if (inu == 2) {
03835 return 0;
03836 }
03837 t2 = *fnu + (doublereal) ((real) (kk - 1));
03838 ckr = t2 * rzr;
03839 cki = t2 * rzi;
03840 kflag = 1;
03841 goto L250;
03842 L290:
03843
03844
03845
03846 koded = 2;
03847 iflag = 1;
03848 kflag = 2;
03849 goto L120;
03850
03851
03852
03853 L300:
03854 s1r = coefr;
03855 s1i = coefi;
03856 s2r = coefr;
03857 s2i = coefi;
03858 goto L210;
03859
03860
03861 L310:
03862 *nz = -2;
03863 return 0;
03864 }
03865
03866 int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu,
03867 integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *
03868 rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *
03869 elim)
03870 {
03871
03872
03873 static doublereal zeror = 0.;
03874 static doublereal zeroi = 0.;
03875
03876
03877 integer i__1;
03878
03879
03880 double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
03881
03882
03883 static integer i__, ic;
03884 static doublereal as, fn;
03885 static integer kk, nn, nw;
03886 static doublereal s1i, s2i, s1r, s2r, acs, cki, elm, csi, ckr, cyi[2],
03887 zdi, csr, cyr[2], zdr, str, alas;
03888 static integer idum;
03889 extern doublereal zabs_(doublereal *, doublereal *);
03890 static doublereal helim, celmr;
03891 extern int zuchk_(doublereal *, doublereal *, integer *,
03892 doublereal *, doublereal *), zzzlog_(doublereal *, doublereal *,
03893 doublereal *, doublereal *, integer *);
03894
03895
03896
03897
03898
03899
03900
03901
03902
03903
03904
03905
03906 --yi;
03907 --yr;
03908
03909
03910
03911 *nz = 0;
03912 ic = 0;
03913 nn = min(2,*n);
03914 i__1 = nn;
03915 for (i__ = 1; i__ <= i__1; ++i__) {
03916 s1r = yr[i__];
03917 s1i = yi[i__];
03918 cyr[i__ - 1] = s1r;
03919 cyi[i__ - 1] = s1i;
03920 as = zabs_(&s1r, &s1i);
03921 acs = -(*zrr) + log(as);
03922 ++(*nz);
03923 yr[i__] = zeror;
03924 yi[i__] = zeroi;
03925 if (acs < -(*elim)) {
03926 goto L10;
03927 }
03928 zzzlog_(&s1r, &s1i, &csr, &csi, &idum);
03929 csr -= *zrr;
03930 csi -= *zri;
03931 str = exp(csr) / *tol;
03932 csr = str * cos(csi);
03933 csi = str * sin(csi);
03934 zuchk_(&csr, &csi, &nw, ascle, tol);
03935 if (nw != 0) {
03936 goto L10;
03937 }
03938 yr[i__] = csr;
03939 yi[i__] = csi;
03940 ic = i__;
03941 --(*nz);
03942 L10:
03943 ;
03944 }
03945 if (*n == 1) {
03946 return 0;
03947 }
03948 if (ic > 1) {
03949 goto L20;
03950 }
03951 yr[1] = zeror;
03952 yi[1] = zeroi;
03953 *nz = 2;
03954 L20:
03955 if (*n == 2) {
03956 return 0;
03957 }
03958 if (*nz == 0) {
03959 return 0;
03960 }
03961 fn = *fnu + 1.;
03962 ckr = fn * *rzr;
03963 cki = fn * *rzi;
03964 s1r = cyr[0];
03965 s1i = cyi[0];
03966 s2r = cyr[1];
03967 s2i = cyi[1];
03968 helim = *elim * .5;
03969 elm = exp(-(*elim));
03970 celmr = elm;
03971 zdr = *zrr;
03972 zdi = *zri;
03973
03974
03975
03976
03977 i__1 = *n;
03978 for (i__ = 3; i__ <= i__1; ++i__) {
03979 kk = i__;
03980 csr = s2r;
03981 csi = s2i;
03982 s2r = ckr * csr - cki * csi + s1r;
03983 s2i = cki * csr + ckr * csi + s1i;
03984 s1r = csr;
03985 s1i = csi;
03986 ckr += *rzr;
03987 cki += *rzi;
03988 as = zabs_(&s2r, &s2i);
03989 alas = log(as);
03990 acs = -zdr + alas;
03991 ++(*nz);
03992 yr[i__] = zeror;
03993 yi[i__] = zeroi;
03994 if (acs < -(*elim)) {
03995 goto L25;
03996 }
03997 zzzlog_(&s2r, &s2i, &csr, &csi, &idum);
03998 csr -= zdr;
03999 csi -= zdi;
04000 str = exp(csr) / *tol;
04001 csr = str * cos(csi);
04002 csi = str * sin(csi);
04003 zuchk_(&csr, &csi, &nw, ascle, tol);
04004 if (nw != 0) {
04005 goto L25;
04006 }
04007 yr[i__] = csr;
04008 yi[i__] = csi;
04009 --(*nz);
04010 if (ic == kk - 1) {
04011 goto L40;
04012 }
04013 ic = kk;
04014 goto L30;
04015 L25:
04016 if (alas < helim) {
04017 goto L30;
04018 }
04019 zdr -= *elim;
04020 s1r *= celmr;
04021 s1i *= celmr;
04022 s2r *= celmr;
04023 s2i *= celmr;
04024 L30:
04025 ;
04026 }
04027 *nz = *n;
04028 if (ic == *n) {
04029 *nz = *n - 1;
04030 }
04031 goto L45;
04032 L40:
04033 *nz = kk - 2;
04034 L45:
04035 i__1 = *nz;
04036 for (i__ = 1; i__ <= i__1; ++i__) {
04037 yr[i__] = zeror;
04038 yi[i__] = zeroi;
04039
04040 }
04041 return 0;
04042 }
04043
04044 int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr,
04045 doublereal *cshi, doublereal *cchr, doublereal *cchi)
04046 {
04047
04048 double sinh(doublereal), cosh(doublereal), sin(doublereal), cos(
04049 doublereal);
04050
04051
04052 static doublereal ch, cn, sh, sn;
04053
04054
04055
04056
04057
04058
04059
04060
04061
04062
04063 sh = sinh(*zr);
04064 ch = cosh(*zr);
04065 sn = sin(*zi);
04066 cn = cos(*zi);
04067 *cshr = sh * cn;
04068 *cshi = ch * sn;
04069 *cchr = ch * cn;
04070 *cchi = sh * sn;
04071 return 0;
04072 }
04073
04074 int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu,
04075 integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
04076 {
04077
04078
04079 static doublereal czeror = 0.;
04080 static doublereal czeroi = 0.;
04081 static doublereal coner = 1.;
04082 static doublereal conei = 0.;
04083 static doublereal rt2 = 1.41421356237309505;
04084
04085
04086 integer i__1;
04087 doublereal d__1;
04088
04089
04090 double sqrt(doublereal);
04091
04092
04093 static integer i__, k;
04094 static doublereal ak;
04095 static integer id, kk;
04096 static doublereal az, ap1, ap2, p1i, p2i, t1i, p1r, p2r, t1r, arg, rak,
04097 rho;
04098 static integer inu;
04099 static doublereal pti, tti, rzi, ptr, ttr, rzr, rap1, flam, dfnu, fdnu;
04100 static integer magz;
04101 extern doublereal zabs_(doublereal *, doublereal *);
04102 static integer idnu;
04103 static doublereal fnup;
04104 extern int zdiv_(doublereal *, doublereal *, doublereal *
04105 , doublereal *, doublereal *, doublereal *);
04106 static doublereal test, test1, amagz;
04107 static integer itime;
04108 static doublereal cdfnui, cdfnur;
04109
04110
04111
04112
04113
04114
04115
04116
04117
04118
04119
04120
04121
04122
04123
04124 --cyi;
04125 --cyr;
04126
04127
04128 az = zabs_(zr, zi);
04129 inu = (integer) ((real) (*fnu));
04130 idnu = inu + *n - 1;
04131 magz = (integer) ((real) az);
04132 amagz = (doublereal) ((real) (magz + 1));
04133 fdnu = (doublereal) ((real) idnu);
04134 fnup = max(amagz,fdnu);
04135 id = idnu - magz - 1;
04136 itime = 1;
04137 k = 1;
04138 ptr = 1. / az;
04139 rzr = ptr * (*zr + *zr) * ptr;
04140 rzi = -ptr * (*zi + *zi) * ptr;
04141 t1r = rzr * fnup;
04142 t1i = rzi * fnup;
04143 p2r = -t1r;
04144 p2i = -t1i;
04145 p1r = coner;
04146 p1i = conei;
04147 t1r += rzr;
04148 t1i += rzi;
04149 if (id > 0) {
04150 id = 0;
04151 }
04152 ap2 = zabs_(&p2r, &p2i);
04153 ap1 = zabs_(&p1r, &p1i);
04154
04155
04156
04157
04158
04159
04160 arg = (ap2 + ap2) / (ap1 * *tol);
04161 test1 = sqrt(arg);
04162 test = test1;
04163 rap1 = 1. / ap1;
04164 p1r *= rap1;
04165 p1i *= rap1;
04166 p2r *= rap1;
04167 p2i *= rap1;
04168 ap2 *= rap1;
04169 L10:
04170 ++k;
04171 ap1 = ap2;
04172 ptr = p2r;
04173 pti = p2i;
04174 p2r = p1r - (t1r * ptr - t1i * pti);
04175 p2i = p1i - (t1r * pti + t1i * ptr);
04176 p1r = ptr;
04177 p1i = pti;
04178 t1r += rzr;
04179 t1i += rzi;
04180 ap2 = zabs_(&p2r, &p2i);
04181 if (ap1 <= test) {
04182 goto L10;
04183 }
04184 if (itime == 2) {
04185 goto L20;
04186 }
04187 ak = zabs_(&t1r, &t1i) * .5;
04188 flam = ak + sqrt(ak * ak - 1.);
04189
04190 d__1 = ap2 / ap1;
04191 rho = min(d__1,flam);
04192 test = test1 * sqrt(rho / (rho * rho - 1.));
04193 itime = 2;
04194 goto L10;
04195 L20:
04196 kk = k + 1 - id;
04197 ak = (doublereal) ((real) kk);
04198 t1r = ak;
04199 t1i = czeroi;
04200 dfnu = *fnu + (doublereal) ((real) (*n - 1));
04201 p1r = 1. / ap2;
04202 p1i = czeroi;
04203 p2r = czeror;
04204 p2i = czeroi;
04205 i__1 = kk;
04206 for (i__ = 1; i__ <= i__1; ++i__) {
04207 ptr = p1r;
04208 pti = p1i;
04209 rap1 = dfnu + t1r;
04210 ttr = rzr * rap1;
04211 tti = rzi * rap1;
04212 p1r = ptr * ttr - pti * tti + p2r;
04213 p1i = ptr * tti + pti * ttr + p2i;
04214 p2r = ptr;
04215 p2i = pti;
04216 t1r -= coner;
04217
04218 }
04219 if (p1r != czeror || p1i != czeroi) {
04220 goto L40;
04221 }
04222 p1r = *tol;
04223 p1i = *tol;
04224 L40:
04225 zdiv_(&p2r, &p2i, &p1r, &p1i, &cyr[*n], &cyi[*n]);
04226 if (*n == 1) {
04227 return 0;
04228 }
04229 k = *n - 1;
04230 ak = (doublereal) ((real) k);
04231 t1r = ak;
04232 t1i = czeroi;
04233 cdfnur = *fnu * rzr;
04234 cdfnui = *fnu * rzi;
04235 i__1 = *n;
04236 for (i__ = 2; i__ <= i__1; ++i__) {
04237 ptr = cdfnur + (t1r * rzr - t1i * rzi) + cyr[k + 1];
04238 pti = cdfnui + (t1r * rzi + t1i * rzr) + cyi[k + 1];
04239 ak = zabs_(&ptr, &pti);
04240 if (ak != czeror) {
04241 goto L50;
04242 }
04243 ptr = *tol;
04244 pti = *tol;
04245 ak = *tol * rt2;
04246 L50:
04247 rak = coner / ak;
04248 cyr[k] = rak * ptr * rak;
04249 cyi[k] = -rak * pti * rak;
04250 t1r -= coner;
04251 --k;
04252
04253 }
04254 return 0;
04255 }
04256
04257 int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r,
04258 doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz,
04259 doublereal *ascle, doublereal *alim, integer *iuf)
04260 {
04261
04262
04263 static doublereal zeror = 0.;
04264 static doublereal zeroi = 0.;
04265
04266
04267 double log(doublereal);
04268
04269
04270 static doublereal aa, c1i, as1, as2, c1r, aln, s1di, s1dr;
04271 static integer idum;
04272 extern doublereal zabs_(doublereal *, doublereal *);
04273 extern int zzzlog_(doublereal *, doublereal *,
04274 doublereal *, doublereal *, integer *), zzzexp_(doublereal *,
04275 doublereal *, doublereal *, doublereal *);
04276
04277
04278
04279
04280
04281
04282
04283
04284
04285
04286
04287
04288
04289
04290
04291 *nz = 0;
04292 as1 = zabs_(s1r, s1i);
04293 as2 = zabs_(s2r, s2i);
04294 if (*s1r == 0. && *s1i == 0.) {
04295 goto L10;
04296 }
04297 if (as1 == 0.) {
04298 goto L10;
04299 }
04300 aln = -(*zrr) - *zrr + log(as1);
04301 s1dr = *s1r;
04302 s1di = *s1i;
04303 *s1r = zeror;
04304 *s1i = zeroi;
04305 as1 = zeror;
04306 if (aln < -(*alim)) {
04307 goto L10;
04308 }
04309 zzzlog_(&s1dr, &s1di, &c1r, &c1i, &idum);
04310 c1r = c1r - *zrr - *zrr;
04311 c1i = c1i - *zri - *zri;
04312 zzzexp_(&c1r, &c1i, s1r, s1i);
04313 as1 = zabs_(s1r, s1i);
04314 ++(*iuf);
04315 L10:
04316 aa = max(as1,as2);
04317 if (aa > *ascle) {
04318 return 0;
04319 }
04320 *s1r = zeror;
04321 *s1i = zeroi;
04322 *s2r = zeror;
04323 *s2i = zeroi;
04324 *nz = 1;
04325 *iuf = 0;
04326 return 0;
04327 }
04328
04329 int zbunk_(doublereal *zr, doublereal *zi, doublereal *fnu,
04330 integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
04331 yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
04332 {
04333 static doublereal ax, ay;
04334 extern int zunk1_(doublereal *, doublereal *, doublereal
04335 *, integer *, integer *, integer *, doublereal *, doublereal *,
04336 integer *, doublereal *, doublereal *, doublereal *), zunk2_(
04337 doublereal *, doublereal *, doublereal *, integer *, integer *,
04338 integer *, doublereal *, doublereal *, integer *, doublereal *,
04339 doublereal *, doublereal *);
04340
04341
04342
04343
04344
04345
04346
04347
04348
04349
04350
04351
04352 --yi;
04353 --yr;
04354
04355
04356 *nz = 0;
04357 ax = abs(*zr) * 1.7321;
04358 ay = abs(*zi);
04359 if (ay > ax) {
04360 goto L10;
04361 }
04362
04363
04364
04365
04366 zunk1_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
04367 goto L20;
04368 L10:
04369
04370
04371
04372
04373
04374 zunk2_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
04375 L20:
04376 return 0;
04377 }
04378
04379 int zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu,
04380 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04381 nz, doublereal *tol)
04382 {
04383
04384
04385 static doublereal zeror = 0.;
04386 static doublereal zeroi = 0.;
04387 static doublereal coner = 1.;
04388 static doublereal conei = 0.;
04389
04390
04391 integer i__1, i__2;
04392 doublereal d__1, d__2, d__3;
04393
04394
04395 double sqrt(doublereal), exp(doublereal);
04396
04397
04398 static integer i__, k, m;
04399 static doublereal ak, bk, ap, at;
04400 static integer kk, km;
04401 static doublereal az, p1i, p2i, p1r, p2r, ack, cki, fnf, fkk, ckr;
04402 static integer iaz;
04403 static doublereal rho;
04404 static integer inu;
04405 static doublereal pti, raz, sti, rzi, ptr, str, tst, rzr, rho2, flam,
04406 fkap, scle, tfnf;
04407 static integer idum;
04408 extern doublereal zabs_(doublereal *, doublereal *);
04409 static integer ifnu;
04410 static doublereal sumi, sumr;
04411 extern int zmlt_(doublereal *, doublereal *, doublereal *
04412 , doublereal *, doublereal *, doublereal *);
04413 static integer itime;
04414 extern doublereal d1mach_(integer *), dgamln_(doublereal *, integer *);
04415 static doublereal cnormi, cnormr;
04416 extern int zzzlog_(doublereal *, doublereal *,
04417 doublereal *, doublereal *, integer *), zzzexp_(doublereal *,
04418 doublereal *, doublereal *, doublereal *);
04419
04420
04421
04422
04423
04424
04425
04426
04427
04428
04429
04430 --yi;
04431 --yr;
04432
04433
04434 scle = d1mach_(&c__1) / *tol;
04435 *nz = 0;
04436 az = zabs_(zr, zi);
04437 iaz = (integer) ((real) az);
04438 ifnu = (integer) ((real) (*fnu));
04439 inu = ifnu + *n - 1;
04440 at = (doublereal) ((real) iaz) + 1.;
04441 raz = 1. / az;
04442 str = *zr * raz;
04443 sti = -(*zi) * raz;
04444 ckr = str * at * raz;
04445 cki = sti * at * raz;
04446 rzr = (str + str) * raz;
04447 rzi = (sti + sti) * raz;
04448 p1r = zeror;
04449 p1i = zeroi;
04450 p2r = coner;
04451 p2i = conei;
04452 ack = (at + 1.) * raz;
04453 rho = ack + sqrt(ack * ack - 1.);
04454 rho2 = rho * rho;
04455 tst = (rho2 + rho2) / ((rho2 - 1.) * (rho - 1.));
04456 tst /= *tol;
04457
04458
04459
04460 ak = at;
04461 for (i__ = 1; i__ <= 80; ++i__) {
04462 ptr = p2r;
04463 pti = p2i;
04464 p2r = p1r - (ckr * ptr - cki * pti);
04465 p2i = p1i - (cki * ptr + ckr * pti);
04466 p1r = ptr;
04467 p1i = pti;
04468 ckr += rzr;
04469 cki += rzi;
04470 ap = zabs_(&p2r, &p2i);
04471 if (ap > tst * ak * ak) {
04472 goto L20;
04473 }
04474 ak += 1.;
04475
04476 }
04477 goto L110;
04478 L20:
04479 ++i__;
04480 k = 0;
04481 if (inu < iaz) {
04482 goto L40;
04483 }
04484
04485
04486
04487 p1r = zeror;
04488 p1i = zeroi;
04489 p2r = coner;
04490 p2i = conei;
04491 at = (doublereal) ((real) inu) + 1.;
04492 str = *zr * raz;
04493 sti = -(*zi) * raz;
04494 ckr = str * at * raz;
04495 cki = sti * at * raz;
04496 ack = at * raz;
04497 tst = sqrt(ack / *tol);
04498 itime = 1;
04499 for (k = 1; k <= 80; ++k) {
04500 ptr = p2r;
04501 pti = p2i;
04502 p2r = p1r - (ckr * ptr - cki * pti);
04503 p2i = p1i - (ckr * pti + cki * ptr);
04504 p1r = ptr;
04505 p1i = pti;
04506 ckr += rzr;
04507 cki += rzi;
04508 ap = zabs_(&p2r, &p2i);
04509 if (ap < tst) {
04510 goto L30;
04511 }
04512 if (itime == 2) {
04513 goto L40;
04514 }
04515 ack = zabs_(&ckr, &cki);
04516 flam = ack + sqrt(ack * ack - 1.);
04517 fkap = ap / zabs_(&p1r, &p1i);
04518 rho = min(flam,fkap);
04519 tst *= sqrt(rho / (rho * rho - 1.));
04520 itime = 2;
04521 L30:
04522 ;
04523 }
04524 goto L110;
04525 L40:
04526
04527
04528
04529 ++k;
04530
04531 i__1 = i__ + iaz, i__2 = k + inu;
04532 kk = max(i__1,i__2);
04533 fkk = (doublereal) ((real) kk);
04534 p1r = zeror;
04535 p1i = zeroi;
04536
04537
04538
04539 p2r = scle;
04540 p2i = zeroi;
04541 fnf = *fnu - (doublereal) ((real) ifnu);
04542 tfnf = fnf + fnf;
04543 d__1 = fkk + tfnf + 1.;
04544 d__2 = fkk + 1.;
04545 d__3 = tfnf + 1.;
04546 bk = dgamln_(&d__1, &idum) - dgamln_(&d__2, &idum) - dgamln_(&d__3, &idum)
04547 ;
04548 bk = exp(bk);
04549 sumr = zeror;
04550 sumi = zeroi;
04551 km = kk - inu;
04552 i__1 = km;
04553 for (i__ = 1; i__ <= i__1; ++i__) {
04554 ptr = p2r;
04555 pti = p2i;
04556 p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04557 p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
04558 p1r = ptr;
04559 p1i = pti;
04560 ak = 1. - tfnf / (fkk + tfnf);
04561 ack = bk * ak;
04562 sumr += (ack + bk) * p1r;
04563 sumi += (ack + bk) * p1i;
04564 bk = ack;
04565 fkk += -1.;
04566
04567 }
04568 yr[*n] = p2r;
04569 yi[*n] = p2i;
04570 if (*n == 1) {
04571 goto L70;
04572 }
04573 i__1 = *n;
04574 for (i__ = 2; i__ <= i__1; ++i__) {
04575 ptr = p2r;
04576 pti = p2i;
04577 p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04578 p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
04579 p1r = ptr;
04580 p1i = pti;
04581 ak = 1. - tfnf / (fkk + tfnf);
04582 ack = bk * ak;
04583 sumr += (ack + bk) * p1r;
04584 sumi += (ack + bk) * p1i;
04585 bk = ack;
04586 fkk += -1.;
04587 m = *n - i__ + 1;
04588 yr[m] = p2r;
04589 yi[m] = p2i;
04590
04591 }
04592 L70:
04593 if (ifnu <= 0) {
04594 goto L90;
04595 }
04596 i__1 = ifnu;
04597 for (i__ = 1; i__ <= i__1; ++i__) {
04598 ptr = p2r;
04599 pti = p2i;
04600 p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04601 p2i = p1i + (fkk + fnf) * (rzr * pti + rzi * ptr);
04602 p1r = ptr;
04603 p1i = pti;
04604 ak = 1. - tfnf / (fkk + tfnf);
04605 ack = bk * ak;
04606 sumr += (ack + bk) * p1r;
04607 sumi += (ack + bk) * p1i;
04608 bk = ack;
04609 fkk += -1.;
04610
04611 }
04612 L90:
04613 ptr = *zr;
04614 pti = *zi;
04615 if (*kode == 2) {
04616 ptr = zeror;
04617 }
04618 zzzlog_(&rzr, &rzi, &str, &sti, &idum);
04619 p1r = -fnf * str + ptr;
04620 p1i = -fnf * sti + pti;
04621 d__1 = fnf + 1.;
04622 ap = dgamln_(&d__1, &idum);
04623 ptr = p1r - ap;
04624 pti = p1i;
04625
04626
04627
04628
04629 p2r += sumr;
04630 p2i += sumi;
04631 ap = zabs_(&p2r, &p2i);
04632 p1r = 1. / ap;
04633 zzzexp_(&ptr, &pti, &str, &sti);
04634 ckr = str * p1r;
04635 cki = sti * p1r;
04636 ptr = p2r * p1r;
04637 pti = -p2i * p1r;
04638 zmlt_(&ckr, &cki, &ptr, &pti, &cnormr, &cnormi);
04639 i__1 = *n;
04640 for (i__ = 1; i__ <= i__1; ++i__) {
04641 str = yr[i__] * cnormr - yi[i__] * cnormi;
04642 yi[i__] = yr[i__] * cnormi + yi[i__] * cnormr;
04643 yr[i__] = str;
04644
04645 }
04646 return 0;
04647 L110:
04648 *nz = -2;
04649 return 0;
04650 }
04651
04652 int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu,
04653 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04654 nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *
04655 elim, doublereal *alim)
04656 {
04657
04658 integer i__1;
04659
04660
04661 double cos(doublereal), sin(doublereal);
04662
04663
04664 static integer i__, nw;
04665 static doublereal c1i, c2i, c1r, c2r, act, acw, cti, ctr, pti, sti, ptr,
04666 str, ract;
04667 extern doublereal zabs_(doublereal *, doublereal *);
04668 static doublereal ascle, csclr, cinui, cinur;
04669 extern int zbknu_(doublereal *, doublereal *, doublereal
04670 *, integer *, integer *, doublereal *, doublereal *, integer *,
04671 doublereal *, doublereal *, doublereal *), zrati_(doublereal *,
04672 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
04673 doublereal *);
04674 extern doublereal d1mach_(integer *);
04675
04676
04677
04678
04679
04680
04681
04682
04683
04684
04685
04686
04687
04688
04689
04690
04691 --yi;
04692 --yr;
04693 --cwr;
04694 --cwi;
04695
04696
04697 *nz = 0;
04698 zbknu_(zrr, zri, fnu, kode, &c__2, &cwr[1], &cwi[1], &nw, tol, elim, alim)
04699 ;
04700 if (nw != 0) {
04701 goto L50;
04702 }
04703 zrati_(zrr, zri, fnu, n, &yr[1], &yi[1], tol);
04704
04705
04706
04707
04708 cinur = 1.;
04709 cinui = 0.;
04710 if (*kode == 1) {
04711 goto L10;
04712 }
04713 cinur = cos(*zri);
04714 cinui = sin(*zri);
04715 L10:
04716
04717
04718
04719
04720
04721
04722 acw = zabs_(&cwr[2], &cwi[2]);
04723 ascle = d1mach_(&c__1) * 1e3 / *tol;
04724 csclr = 1.;
04725 if (acw > ascle) {
04726 goto L20;
04727 }
04728 csclr = 1. / *tol;
04729 goto L30;
04730 L20:
04731 ascle = 1. / ascle;
04732 if (acw < ascle) {
04733 goto L30;
04734 }
04735 csclr = *tol;
04736 L30:
04737 c1r = cwr[1] * csclr;
04738 c1i = cwi[1] * csclr;
04739 c2r = cwr[2] * csclr;
04740 c2i = cwi[2] * csclr;
04741 str = yr[1];
04742 sti = yi[1];
04743
04744
04745
04746
04747 ptr = str * c1r - sti * c1i;
04748 pti = str * c1i + sti * c1r;
04749 ptr += c2r;
04750 pti += c2i;
04751 ctr = *zrr * ptr - *zri * pti;
04752 cti = *zrr * pti + *zri * ptr;
04753 act = zabs_(&ctr, &cti);
04754 ract = 1. / act;
04755 ctr *= ract;
04756 cti = -cti * ract;
04757 ptr = cinur * ract;
04758 pti = cinui * ract;
04759 cinur = ptr * ctr - pti * cti;
04760 cinui = ptr * cti + pti * ctr;
04761 yr[1] = cinur * csclr;
04762 yi[1] = cinui * csclr;
04763 if (*n == 1) {
04764 return 0;
04765 }
04766 i__1 = *n;
04767 for (i__ = 2; i__ <= i__1; ++i__) {
04768 ptr = str * cinur - sti * cinui;
04769 cinui = str * cinui + sti * cinur;
04770 cinur = ptr;
04771 str = yr[i__];
04772 sti = yi[i__];
04773 yr[i__] = cinur * csclr;
04774 yi[i__] = cinui * csclr;
04775
04776 }
04777 return 0;
04778 L50:
04779 *nz = -1;
04780 if (nw == -2) {
04781 *nz = -2;
04782 }
04783 return 0;
04784 }
04785
04786 int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu,
04787 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04788 nz, doublereal *tol, doublereal *elim, doublereal *alim)
04789 {
04790
04791
04792 static doublereal zeror = 0.;
04793 static doublereal zeroi = 0.;
04794 static doublereal coner = 1.;
04795 static doublereal conei = 0.;
04796
04797
04798 integer i__1;
04799
04800
04801 double sqrt(doublereal), exp(doublereal), cos(doublereal), sin(doublereal)
04802 ;
04803
04804
04805 static integer i__, k, l, m;
04806 static doublereal s, aa;
04807 static integer ib;
04808 static doublereal ak;
04809 static integer il;
04810 static doublereal az;
04811 static integer nn;
04812 static doublereal wi[2], rs, ss;
04813 static integer nw;
04814 static doublereal wr[2], s1i, s2i, s1r, s2r, cki, acz, arm, ckr, czi, hzi,
04815 raz, czr, sti, hzr, rzi, str, rzr, ak1i, ak1r, rtr1, dfnu;
04816 static integer idum;
04817 extern doublereal zabs_(doublereal *, doublereal *);
04818 static doublereal atol, fnup;
04819 extern int zdiv_(doublereal *, doublereal *, doublereal *
04820 , doublereal *, doublereal *, doublereal *), zmlt_(doublereal *,
04821 doublereal *, doublereal *, doublereal *, doublereal *,
04822 doublereal *);
04823 static integer iflag;
04824 static doublereal coefi, ascle, coefr, crscr;
04825 extern int zuchk_(doublereal *, doublereal *, integer *,
04826 doublereal *, doublereal *);
04827 extern doublereal d1mach_(integer *), dgamln_(doublereal *, integer *);
04828 extern int zzzlog_(doublereal *, doublereal *,
04829 doublereal *, doublereal *, integer *);
04830
04831
04832
04833
04834
04835
04836
04837
04838
04839
04840
04841
04842
04843
04844
04845
04846 --yi;
04847 --yr;
04848
04849
04850
04851 *nz = 0;
04852 az = zabs_(zr, zi);
04853 if (az == 0.) {
04854 goto L160;
04855 }
04856 arm = d1mach_(&c__1) * 1e3;
04857 rtr1 = sqrt(arm);
04858 crscr = 1.;
04859 iflag = 0;
04860 if (az < arm) {
04861 goto L150;
04862 }
04863 hzr = *zr * .5;
04864 hzi = *zi * .5;
04865 czr = zeror;
04866 czi = zeroi;
04867 if (az <= rtr1) {
04868 goto L10;
04869 }
04870 zmlt_(&hzr, &hzi, &hzr, &hzi, &czr, &czi);
04871 L10:
04872 acz = zabs_(&czr, &czi);
04873 nn = *n;
04874 zzzlog_(&hzr, &hzi, &ckr, &cki, &idum);
04875 L20:
04876 dfnu = *fnu + (doublereal) ((real) (nn - 1));
04877 fnup = dfnu + 1.;
04878
04879
04880
04881 ak1r = ckr * dfnu;
04882 ak1i = cki * dfnu;
04883 ak = dgamln_(&fnup, &idum);
04884 ak1r -= ak;
04885 if (*kode == 2) {
04886 ak1r -= *zr;
04887 }
04888 if (ak1r > -(*elim)) {
04889 goto L40;
04890 }
04891 L30:
04892 ++(*nz);
04893 yr[nn] = zeror;
04894 yi[nn] = zeroi;
04895 if (acz > dfnu) {
04896 goto L190;
04897 }
04898 --nn;
04899 if (nn == 0) {
04900 return 0;
04901 }
04902 goto L20;
04903 L40:
04904 if (ak1r > -(*alim)) {
04905 goto L50;
04906 }
04907 iflag = 1;
04908 ss = 1. / *tol;
04909 crscr = *tol;
04910 ascle = arm * ss;
04911 L50:
04912 aa = exp(ak1r);
04913 if (iflag == 1) {
04914 aa *= ss;
04915 }
04916 coefr = aa * cos(ak1i);
04917 coefi = aa * sin(ak1i);
04918 atol = *tol * acz / fnup;
04919 il = min(2,nn);
04920 i__1 = il;
04921 for (i__ = 1; i__ <= i__1; ++i__) {
04922 dfnu = *fnu + (doublereal) ((real) (nn - i__));
04923 fnup = dfnu + 1.;
04924 s1r = coner;
04925 s1i = conei;
04926 if (acz < *tol * fnup) {
04927 goto L70;
04928 }
04929 ak1r = coner;
04930 ak1i = conei;
04931 ak = fnup + 2.;
04932 s = fnup;
04933 aa = 2.;
04934 L60:
04935 rs = 1. / s;
04936 str = ak1r * czr - ak1i * czi;
04937 sti = ak1r * czi + ak1i * czr;
04938 ak1r = str * rs;
04939 ak1i = sti * rs;
04940 s1r += ak1r;
04941 s1i += ak1i;
04942 s += ak;
04943 ak += 2.;
04944 aa = aa * acz * rs;
04945 if (aa > atol) {
04946 goto L60;
04947 }
04948 L70:
04949 s2r = s1r * coefr - s1i * coefi;
04950 s2i = s1r * coefi + s1i * coefr;
04951 wr[i__ - 1] = s2r;
04952 wi[i__ - 1] = s2i;
04953 if (iflag == 0) {
04954 goto L80;
04955 }
04956 zuchk_(&s2r, &s2i, &nw, &ascle, tol);
04957 if (nw != 0) {
04958 goto L30;
04959 }
04960 L80:
04961 m = nn - i__ + 1;
04962 yr[m] = s2r * crscr;
04963 yi[m] = s2i * crscr;
04964 if (i__ == il) {
04965 goto L90;
04966 }
04967 zdiv_(&coefr, &coefi, &hzr, &hzi, &str, &sti);
04968 coefr = str * dfnu;
04969 coefi = sti * dfnu;
04970 L90:
04971 ;
04972 }
04973 if (nn <= 2) {
04974 return 0;
04975 }
04976 k = nn - 2;
04977 ak = (doublereal) ((real) k);
04978 raz = 1. / az;
04979 str = *zr * raz;
04980 sti = -(*zi) * raz;
04981 rzr = (str + str) * raz;
04982 rzi = (sti + sti) * raz;
04983 if (iflag == 1) {
04984 goto L120;
04985 }
04986 ib = 3;
04987 L100:
04988 i__1 = nn;
04989 for (i__ = ib; i__ <= i__1; ++i__) {
04990 yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
04991 yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
04992 ak += -1.;
04993 --k;
04994
04995 }
04996 return 0;
04997
04998
04999
05000 L120:
05001
05002
05003
05004
05005 s1r = wr[0];
05006 s1i = wi[0];
05007 s2r = wr[1];
05008 s2i = wi[1];
05009 i__1 = nn;
05010 for (l = 3; l <= i__1; ++l) {
05011 ckr = s2r;
05012 cki = s2i;
05013 s2r = s1r + (ak + *fnu) * (rzr * ckr - rzi * cki);
05014 s2i = s1i + (ak + *fnu) * (rzr * cki + rzi * ckr);
05015 s1r = ckr;
05016 s1i = cki;
05017 ckr = s2r * crscr;
05018 cki = s2i * crscr;
05019 yr[k] = ckr;
05020 yi[k] = cki;
05021 ak += -1.;
05022 --k;
05023 if (zabs_(&ckr, &cki) > ascle) {
05024 goto L140;
05025 }
05026
05027 }
05028 return 0;
05029 L140:
05030 ib = l + 1;
05031 if (ib > nn) {
05032 return 0;
05033 }
05034 goto L100;
05035 L150:
05036 *nz = *n;
05037 if (*fnu == 0.) {
05038 --(*nz);
05039 }
05040 L160:
05041 yr[1] = zeror;
05042 yi[1] = zeroi;
05043 if (*fnu != 0.) {
05044 goto L170;
05045 }
05046 yr[1] = coner;
05047 yi[1] = conei;
05048 L170:
05049 if (*n == 1) {
05050 return 0;
05051 }
05052 i__1 = *n;
05053 for (i__ = 2; i__ <= i__1; ++i__) {
05054 yr[i__] = zeror;
05055 yi[i__] = zeroi;
05056
05057 }
05058 return 0;
05059
05060
05061
05062
05063 L190:
05064 *nz = -(*nz);
05065 return 0;
05066 }
05067
05068 int zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu,
05069 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
05070 nz, doublereal *rl, doublereal *tol, doublereal *elim, doublereal *
05071 alim)
05072 {
05073
05074
05075 static doublereal pi = 3.14159265358979324;
05076 static doublereal rtpi = .159154943091895336;
05077 static doublereal zeror = 0.;
05078 static doublereal zeroi = 0.;
05079 static doublereal coner = 1.;
05080 static doublereal conei = 0.;
05081
05082
05083 integer i__1, i__2;
05084 doublereal d__1, d__2;
05085
05086
05087 double sqrt(doublereal), sin(doublereal), cos(doublereal);
05088
05089
05090 extern int zzzsqrt_(doublereal *, doublereal *,
05091 doublereal *, doublereal *);
05092 static integer i__, j, k, m;
05093 static doublereal s, aa, bb;
05094 static integer ib;
05095 static doublereal ak, bk;
05096 static integer il, jl;
05097 static doublereal az;
05098 static integer nn;
05099 static doublereal p1i, s2i, p1r, s2r, cki, dki, fdn, arg, aez, arm, ckr,
05100 dkr, czi, ezi, sgn;
05101 static integer inu;
05102 static doublereal raz, czr, ezr, sqk, sti, rzi, tzi, str, rzr, tzr, ak1i,
05103 ak1r, cs1i, cs2i, cs1r, cs2r, dnu2, rtr1, dfnu;
05104 extern doublereal zabs_(doublereal *, doublereal *);
05105 static doublereal atol;
05106 extern int zdiv_(doublereal *, doublereal *, doublereal *
05107 , doublereal *, doublereal *, doublereal *), zmlt_(doublereal *,
05108 doublereal *, doublereal *, doublereal *, doublereal *,
05109 doublereal *);
05110 static integer koded;
05111 extern doublereal d1mach_(integer *);
05112 extern int zzzexp_(doublereal *, doublereal *,
05113 doublereal *, doublereal *);
05114
05115
05116
05117
05118
05119
05120
05121
05122
05123
05124
05125
05126
05127 --yi;
05128 --yr;
05129
05130
05131
05132 *nz = 0;
05133 az = zabs_(zr, zi);
05134 arm = d1mach_(&c__1) * 1e3;
05135 rtr1 = sqrt(arm);
05136 il = min(2,*n);
05137 dfnu = *fnu + (doublereal) ((real) (*n - il));
05138
05139
05140
05141 raz = 1. / az;
05142 str = *zr * raz;
05143 sti = -(*zi) * raz;
05144 ak1r = rtpi * str * raz;
05145 ak1i = rtpi * sti * raz;
05146 zzzsqrt_(&ak1r, &ak1i, &ak1r, &ak1i);
05147 czr = *zr;
05148 czi = *zi;
05149 if (*kode != 2) {
05150 goto L10;
05151 }
05152 czr = zeror;
05153 czi = *zi;
05154 L10:
05155 if (abs(czr) > *elim) {
05156 goto L100;
05157 }
05158 dnu2 = dfnu + dfnu;
05159 koded = 1;
05160 if (abs(czr) > *alim && *n > 2) {
05161 goto L20;
05162 }
05163 koded = 0;
05164 zzzexp_(&czr, &czi, &str, &sti);
05165 zmlt_(&ak1r, &ak1i, &str, &sti, &ak1r, &ak1i);
05166 L20:
05167 fdn = 0.;
05168 if (dnu2 > rtr1) {
05169 fdn = dnu2 * dnu2;
05170 }
05171 ezr = *zr * 8.;
05172 ezi = *zi * 8.;
05173
05174
05175
05176
05177
05178 aez = az * 8.;
05179 s = *tol / aez;
05180 jl = (integer) ((real) (*rl + *rl)) + 2;
05181 p1r = zeror;
05182 p1i = zeroi;
05183 if (*zi == 0.) {
05184 goto L30;
05185 }
05186
05187
05188
05189
05190 inu = (integer) ((real) (*fnu));
05191 arg = (*fnu - (doublereal) ((real) inu)) * pi;
05192 inu = inu + *n - il;
05193 ak = -sin(arg);
05194 bk = cos(arg);
05195 if (*zi < 0.) {
05196 bk = -bk;
05197 }
05198 p1r = ak;
05199 p1i = bk;
05200 if (inu % 2 == 0) {
05201 goto L30;
05202 }
05203 p1r = -p1r;
05204 p1i = -p1i;
05205 L30:
05206 i__1 = il;
05207 for (k = 1; k <= i__1; ++k) {
05208 sqk = fdn - 1.;
05209 atol = s * abs(sqk);
05210 sgn = 1.;
05211 cs1r = coner;
05212 cs1i = conei;
05213 cs2r = coner;
05214 cs2i = conei;
05215 ckr = coner;
05216 cki = conei;
05217 ak = 0.;
05218 aa = 1.;
05219 bb = aez;
05220 dkr = ezr;
05221 dki = ezi;
05222 i__2 = jl;
05223 for (j = 1; j <= i__2; ++j) {
05224 zdiv_(&ckr, &cki, &dkr, &dki, &str, &sti);
05225 ckr = str * sqk;
05226 cki = sti * sqk;
05227 cs2r += ckr;
05228 cs2i += cki;
05229 sgn = -sgn;
05230 cs1r += ckr * sgn;
05231 cs1i += cki * sgn;
05232 dkr += ezr;
05233 dki += ezi;
05234 aa = aa * abs(sqk) / bb;
05235 bb += aez;
05236 ak += 8.;
05237 sqk -= ak;
05238 if (aa <= atol) {
05239 goto L50;
05240 }
05241
05242 }
05243 goto L110;
05244 L50:
05245 s2r = cs1r;
05246 s2i = cs1i;
05247 if (*zr + *zr >= *elim) {
05248 goto L60;
05249 }
05250 tzr = *zr + *zr;
05251 tzi = *zi + *zi;
05252 d__1 = -tzr;
05253 d__2 = -tzi;
05254 zzzexp_(&d__1, &d__2, &str, &sti);
05255 zmlt_(&str, &sti, &p1r, &p1i, &str, &sti);
05256 zmlt_(&str, &sti, &cs2r, &cs2i, &str, &sti);
05257 s2r += str;
05258 s2i += sti;
05259 L60:
05260 fdn = fdn + dfnu * 8. + 4.;
05261 p1r = -p1r;
05262 p1i = -p1i;
05263 m = *n - il + k;
05264 yr[m] = s2r * ak1r - s2i * ak1i;
05265 yi[m] = s2r * ak1i + s2i * ak1r;
05266
05267 }
05268 if (*n <= 2) {
05269 return 0;
05270 }
05271 nn = *n;
05272 k = nn - 2;
05273 ak = (doublereal) ((real) k);
05274 str = *zr * raz;
05275 sti = -(*zi) * raz;
05276 rzr = (str + str) * raz;
05277 rzi = (sti + sti) * raz;
05278 ib = 3;
05279 i__1 = nn;
05280 for (i__ = ib; i__ <= i__1; ++i__) {
05281 yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
05282 yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
05283 ak += -1.;
05284 --k;
05285
05286 }
05287 if (koded == 0) {
05288 return 0;
05289 }
05290 zzzexp_(&czr, &czi, &ckr, &cki);
05291 i__1 = nn;
05292 for (i__ = 1; i__ <= i__1; ++i__) {
05293 str = yr[i__] * ckr - yi[i__] * cki;
05294 yi[i__] = yr[i__] * cki + yi[i__] * ckr;
05295 yr[i__] = str;
05296
05297 }
05298 return 0;
05299 L100:
05300 *nz = -1;
05301 return 0;
05302 L110:
05303 *nz = -2;
05304 return 0;
05305 }
05306
05307 int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu,
05308 integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal
05309 *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *
05310 alim)
05311 {
05312
05313
05314 static doublereal zeror = 0.;
05315 static doublereal zeroi = 0.;
05316 static doublereal aic = 1.265512123484645396;
05317
05318
05319 integer i__1;
05320
05321
05322 double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
05323
05324
05325 static integer i__;
05326 static doublereal ax, ay;
05327 static integer nn, nw;
05328 static doublereal fnn, gnn, zbi, czi, gnu, zbr, czr, rcz, sti, zni, zri,
05329 str, znr, zrr, aarg, aphi, argi, phii, argr;
05330 static integer idum;
05331 extern doublereal zabs_(doublereal *, doublereal *);
05332 static doublereal phir;
05333 static integer init;
05334 static doublereal sumi, sumr, ascle;
05335 static integer iform;
05336 static doublereal asumi, bsumi, cwrki[16];
05337 extern int zuchk_(doublereal *, doublereal *, integer *,
05338 doublereal *, doublereal *);
05339 static doublereal asumr, bsumr, cwrkr[16];
05340 extern doublereal d1mach_(integer *);
05341 extern int zunhj_(doublereal *, doublereal *, doublereal
05342 *, integer *, doublereal *, doublereal *, doublereal *,
05343 doublereal *, doublereal *, doublereal *, doublereal *,
05344 doublereal *, doublereal *, doublereal *, doublereal *,
05345 doublereal *, doublereal *), zunik_(doublereal *, doublereal *,
05346 doublereal *, integer *, integer *, doublereal *, integer *,
05347 doublereal *, doublereal *, doublereal *, doublereal *,
05348 doublereal *, doublereal *, doublereal *, doublereal *,
05349 doublereal *, doublereal *);
05350 static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
05351 extern int zzzlog_(doublereal *, doublereal *,
05352 doublereal *, doublereal *, integer *);
05353
05354
05355
05356
05357
05358
05359
05360
05361
05362
05363
05364
05365
05366
05367
05368
05369
05370
05371
05372
05373
05374
05375
05376
05377
05378
05379
05380
05381
05382 --yi;
05383 --yr;
05384
05385
05386 *nuf = 0;
05387 nn = *n;
05388 zrr = *zr;
05389 zri = *zi;
05390 if (*zr >= 0.) {
05391 goto L10;
05392 }
05393 zrr = -(*zr);
05394 zri = -(*zi);
05395 L10:
05396 zbr = zrr;
05397 zbi = zri;
05398 ax = abs(*zr) * 1.7321;
05399 ay = abs(*zi);
05400 iform = 1;
05401 if (ay > ax) {
05402 iform = 2;
05403 }
05404 gnu = max(*fnu,1.);
05405 if (*ikflg == 1) {
05406 goto L20;
05407 }
05408 fnn = (doublereal) ((real) nn);
05409 gnn = *fnu + fnn - 1.;
05410 gnu = max(gnn,fnn);
05411 L20:
05412
05413
05414
05415
05416
05417 if (iform == 2) {
05418 goto L30;
05419 }
05420 init = 0;
05421 zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r,
05422 &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
05423 czr = -zeta1r + zeta2r;
05424 czi = -zeta1i + zeta2i;
05425 goto L50;
05426 L30:
05427 znr = zri;
05428 zni = -zrr;
05429 if (*zi > 0.) {
05430 goto L40;
05431 }
05432 znr = -znr;
05433 L40:
05434 zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r,
05435 &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
05436 czr = -zeta1r + zeta2r;
05437 czi = -zeta1i + zeta2i;
05438 aarg = zabs_(&argr, &argi);
05439 L50:
05440 if (*kode == 1) {
05441 goto L60;
05442 }
05443 czr -= zbr;
05444 czi -= zbi;
05445 L60:
05446 if (*ikflg == 1) {
05447 goto L70;
05448 }
05449 czr = -czr;
05450 czi = -czi;
05451 L70:
05452 aphi = zabs_(&phir, &phii);
05453 rcz = czr;
05454
05455
05456
05457 if (rcz > *elim) {
05458 goto L210;
05459 }
05460 if (rcz < *alim) {
05461 goto L80;
05462 }
05463 rcz += log(aphi);
05464 if (iform == 2) {
05465 rcz = rcz - log(aarg) * .25 - aic;
05466 }
05467 if (rcz > *elim) {
05468 goto L210;
05469 }
05470 goto L130;
05471 L80:
05472
05473
05474
05475 if (rcz < -(*elim)) {
05476 goto L90;
05477 }
05478 if (rcz > -(*alim)) {
05479 goto L130;
05480 }
05481 rcz += log(aphi);
05482 if (iform == 2) {
05483 rcz = rcz - log(aarg) * .25 - aic;
05484 }
05485 if (rcz > -(*elim)) {
05486 goto L110;
05487 }
05488 L90:
05489 i__1 = nn;
05490 for (i__ = 1; i__ <= i__1; ++i__) {
05491 yr[i__] = zeror;
05492 yi[i__] = zeroi;
05493
05494 }
05495 *nuf = nn;
05496 return 0;
05497 L110:
05498 ascle = d1mach_(&c__1) * 1e3 / *tol;
05499 zzzlog_(&phir, &phii, &str, &sti, &idum);
05500 czr += str;
05501 czi += sti;
05502 if (iform == 1) {
05503 goto L120;
05504 }
05505 zzzlog_(&argr, &argi, &str, &sti, &idum);
05506 czr = czr - str * .25 - aic;
05507 czi -= sti * .25;
05508 L120:
05509 ax = exp(rcz) / *tol;
05510 ay = czi;
05511 czr = ax * cos(ay);
05512 czi = ax * sin(ay);
05513 zuchk_(&czr, &czi, &nw, &ascle, tol);
05514 if (nw != 0) {
05515 goto L90;
05516 }
05517 L130:
05518 if (*ikflg == 2) {
05519 return 0;
05520 }
05521 if (*n == 1) {
05522 return 0;
05523 }
05524
05525
05526
05527 L140:
05528 gnu = *fnu + (doublereal) ((real) (nn - 1));
05529 if (iform == 2) {
05530 goto L150;
05531 }
05532 init = 0;
05533 zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r,
05534 &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
05535 czr = -zeta1r + zeta2r;
05536 czi = -zeta1i + zeta2i;
05537 goto L160;
05538 L150:
05539 zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r,
05540 &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
05541 czr = -zeta1r + zeta2r;
05542 czi = -zeta1i + zeta2i;
05543 aarg = zabs_(&argr, &argi);
05544 L160:
05545 if (*kode == 1) {
05546 goto L170;
05547 }
05548 czr -= zbr;
05549 czi -= zbi;
05550 L170:
05551 aphi = zabs_(&phir, &phii);
05552 rcz = czr;
05553 if (rcz < -(*elim)) {
05554 goto L180;
05555 }
05556 if (rcz > -(*alim)) {
05557 return 0;
05558 }
05559 rcz += log(aphi);
05560 if (iform == 2) {
05561 rcz = rcz - log(aarg) * .25 - aic;
05562 }
05563 if (rcz > -(*elim)) {
05564 goto L190;
05565 }
05566 L180:
05567 yr[nn] = zeror;
05568 yi[nn] = zeroi;
05569 --nn;
05570 ++(*nuf);
05571 if (nn == 0) {
05572 return 0;
05573 }
05574 goto L140;
05575 L190:
05576 ascle = d1mach_(&c__1) * 1e3 / *tol;
05577 zzzlog_(&phir, &phii, &str, &sti, &idum);
05578 czr += str;
05579 czi += sti;
05580 if (iform == 1) {
05581 goto L200;
05582 }
05583 zzzlog_(&argr, &argi, &str, &sti, &idum);
05584 czr = czr - str * .25 - aic;
05585 czi -= sti * .25;
05586 L200:
05587 ax = exp(rcz) / *tol;
05588 ay = czi;
05589 czr = ax * cos(ay);
05590 czi = ax * sin(ay);
05591 zuchk_(&czr, &czi, &nw, &ascle, tol);
05592 if (nw != 0) {
05593 goto L180;
05594 }
05595 return 0;
05596 L210:
05597 *nuf = -1;
05598 return 0;
05599 }
05600
05601 int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu,
05602 integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
05603 yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol,
05604 doublereal *elim, doublereal *alim)
05605 {
05606
05607
05608 static doublereal pi = 3.14159265358979324;
05609 static doublereal zeror = 0.;
05610 static doublereal coner = 1.;
05611
05612
05613 integer i__1;
05614
05615
05616 double d_sign(doublereal *, doublereal *), cos(doublereal), sin(
05617 doublereal);
05618
05619
05620 static integer i__;
05621 static doublereal fn;
05622 static integer nn, nw;
05623 static doublereal yy, c1i, c2i, c1m, as2, c1r, c2r, s1i, s2i, s1r, s2r,
05624 cki, arg, ckr, cpn;
05625 static integer iuf;
05626 static doublereal cyi[2], fmr, csr, azn, sgn;
05627 static integer inu;
05628 static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr,
05629 rzr, sc1i, sc2i, sc1r, sc2r, cscl, cscr;
05630 extern doublereal zabs_(doublereal *, doublereal *);
05631 static doublereal csrr[3], cssr[3], razn;
05632 extern int zs1s2_(doublereal *, doublereal *, doublereal
05633 *, doublereal *, doublereal *, doublereal *, integer *,
05634 doublereal *, doublereal *, integer *), zmlt_(doublereal *,
05635 doublereal *, doublereal *, doublereal *, doublereal *,
05636 doublereal *);
05637 static integer kflag;
05638 static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
05639 extern int zbinu_(doublereal *, doublereal *, doublereal
05640 *, integer *, integer *, doublereal *, doublereal *, integer *,
05641 doublereal *, doublereal *, doublereal *, doublereal *,
05642 doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
05643 integer *, integer *, doublereal *, doublereal *, integer *,
05644 doublereal *, doublereal *, doublereal *);
05645 extern doublereal d1mach_(integer *);
05646
05647
05648
05649
05650
05651
05652
05653
05654
05655
05656
05657
05658
05659
05660
05661
05662
05663 --yi;
05664 --yr;
05665
05666
05667 *nz = 0;
05668 znr = -(*zr);
05669 zni = -(*zi);
05670 nn = *n;
05671 zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol,
05672 elim, alim);
05673 if (nw < 0) {
05674 goto L90;
05675 }
05676
05677
05678
05679 nn = min(2,*n);
05680 zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
05681 if (nw != 0) {
05682 goto L90;
05683 }
05684 s1r = cyr[0];
05685 s1i = cyi[0];
05686 fmr = (doublereal) ((real) (*mr));
05687 sgn = -DSIGN(pi, fmr);
05688 csgnr = zeror;
05689 csgni = sgn;
05690 if (*kode == 1) {
05691 goto L10;
05692 }
05693 yy = -zni;
05694 cpn = cos(yy);
05695 spn = sin(yy);
05696 zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
05697 L10:
05698
05699
05700
05701
05702 inu = (integer) ((real) (*fnu));
05703 arg = (*fnu - (doublereal) ((real) inu)) * sgn;
05704 cpn = cos(arg);
05705 spn = sin(arg);
05706 cspnr = cpn;
05707 cspni = spn;
05708 if (inu % 2 == 0) {
05709 goto L20;
05710 }
05711 cspnr = -cspnr;
05712 cspni = -cspni;
05713 L20:
05714 iuf = 0;
05715 c1r = s1r;
05716 c1i = s1i;
05717 c2r = yr[1];
05718 c2i = yi[1];
05719 ascle = d1mach_(&c__1) * 1e3 / *tol;
05720 if (*kode == 1) {
05721 goto L30;
05722 }
05723 zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05724 *nz += nw;
05725 sc1r = c1r;
05726 sc1i = c1i;
05727 L30:
05728 zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
05729 zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
05730 yr[1] = str + ptr;
05731 yi[1] = sti + pti;
05732 if (*n == 1) {
05733 return 0;
05734 }
05735 cspnr = -cspnr;
05736 cspni = -cspni;
05737 s2r = cyr[1];
05738 s2i = cyi[1];
05739 c1r = s2r;
05740 c1i = s2i;
05741 c2r = yr[2];
05742 c2i = yi[2];
05743 if (*kode == 1) {
05744 goto L40;
05745 }
05746 zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05747 *nz += nw;
05748 sc2r = c1r;
05749 sc2i = c1i;
05750 L40:
05751 zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
05752 zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
05753 yr[2] = str + ptr;
05754 yi[2] = sti + pti;
05755 if (*n == 2) {
05756 return 0;
05757 }
05758 cspnr = -cspnr;
05759 cspni = -cspni;
05760 azn = zabs_(&znr, &zni);
05761 razn = 1. / azn;
05762 str = znr * razn;
05763 sti = -zni * razn;
05764 rzr = (str + str) * razn;
05765 rzi = (sti + sti) * razn;
05766 fn = *fnu + 1.;
05767 ckr = fn * rzr;
05768 cki = fn * rzi;
05769
05770
05771
05772 cscl = 1. / *tol;
05773 cscr = *tol;
05774 cssr[0] = cscl;
05775 cssr[1] = coner;
05776 cssr[2] = cscr;
05777 csrr[0] = cscr;
05778 csrr[1] = coner;
05779 csrr[2] = cscl;
05780 bry[0] = ascle;
05781 bry[1] = 1. / ascle;
05782 bry[2] = d1mach_(&c__2);
05783 as2 = zabs_(&s2r, &s2i);
05784 kflag = 2;
05785 if (as2 > bry[0]) {
05786 goto L50;
05787 }
05788 kflag = 1;
05789 goto L60;
05790 L50:
05791 if (as2 < bry[1]) {
05792 goto L60;
05793 }
05794 kflag = 3;
05795 L60:
05796 bscle = bry[kflag - 1];
05797 s1r *= cssr[kflag - 1];
05798 s1i *= cssr[kflag - 1];
05799 s2r *= cssr[kflag - 1];
05800 s2i *= cssr[kflag - 1];
05801 csr = csrr[kflag - 1];
05802 i__1 = *n;
05803 for (i__ = 3; i__ <= i__1; ++i__) {
05804 str = s2r;
05805 sti = s2i;
05806 s2r = ckr * str - cki * sti + s1r;
05807 s2i = ckr * sti + cki * str + s1i;
05808 s1r = str;
05809 s1i = sti;
05810 c1r = s2r * csr;
05811 c1i = s2i * csr;
05812 str = c1r;
05813 sti = c1i;
05814 c2r = yr[i__];
05815 c2i = yi[i__];
05816 if (*kode == 1) {
05817 goto L70;
05818 }
05819 if (iuf < 0) {
05820 goto L70;
05821 }
05822 zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05823 *nz += nw;
05824 sc1r = sc2r;
05825 sc1i = sc2i;
05826 sc2r = c1r;
05827 sc2i = c1i;
05828 if (iuf != 3) {
05829 goto L70;
05830 }
05831 iuf = -4;
05832 s1r = sc1r * cssr[kflag - 1];
05833 s1i = sc1i * cssr[kflag - 1];
05834 s2r = sc2r * cssr[kflag - 1];
05835 s2i = sc2i * cssr[kflag - 1];
05836 str = sc2r;
05837 sti = sc2i;
05838 L70:
05839 ptr = cspnr * c1r - cspni * c1i;
05840 pti = cspnr * c1i + cspni * c1r;
05841 yr[i__] = ptr + csgnr * c2r - csgni * c2i;
05842 yi[i__] = pti + csgnr * c2i + csgni * c2r;
05843 ckr += rzr;
05844 cki += rzi;
05845 cspnr = -cspnr;
05846 cspni = -cspni;
05847 if (kflag >= 3) {
05848 goto L80;
05849 }
05850 ptr = abs(c1r);
05851 pti = abs(c1i);
05852 c1m = max(ptr,pti);
05853 if (c1m <= bscle) {
05854 goto L80;
05855 }
05856 ++kflag;
05857 bscle = bry[kflag - 1];
05858 s1r *= csr;
05859 s1i *= csr;
05860 s2r = str;
05861 s2i = sti;
05862 s1r *= cssr[kflag - 1];
05863 s1i *= cssr[kflag - 1];
05864 s2r *= cssr[kflag - 1];
05865 s2i *= cssr[kflag - 1];
05866 csr = csrr[kflag - 1];
05867 L80:
05868 ;
05869 }
05870 return 0;
05871 L90:
05872 *nz = -1;
05873 if (nw == -2) {
05874 *nz = -2;
05875 }
05876 return 0;
05877 }
05878
05879 int zbinu_(doublereal *zr, doublereal *zi, doublereal *fnu,
05880 integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
05881 nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *
05882 elim, doublereal *alim)
05883 {
05884
05885
05886 static doublereal zeror = 0.;
05887 static doublereal zeroi = 0.;
05888
05889
05890 integer i__1;
05891
05892
05893 static integer i__;
05894 static doublereal az;
05895 static integer nn, nw;
05896 static doublereal cwi[2], cwr[2];
05897 static integer nui, inw;
05898 static doublereal dfnu;
05899 extern doublereal zabs_(doublereal *, doublereal *);
05900 static integer nlast;
05901 extern int zbuni_(doublereal *, doublereal *, doublereal
05902 *, integer *, integer *, doublereal *, doublereal *, integer *,
05903 integer *, integer *, doublereal *, doublereal *, doublereal *,
05904 doublereal *), zseri_(doublereal *, doublereal *, doublereal *,
05905 integer *, integer *, doublereal *, doublereal *, integer *,
05906 doublereal *, doublereal *, doublereal *), zmlri_(doublereal *,
05907 doublereal *, doublereal *, integer *, integer *, doublereal *,
05908 doublereal *, integer *, doublereal *), zasyi_(doublereal *,
05909 doublereal *, doublereal *, integer *, integer *, doublereal *,
05910 doublereal *, integer *, doublereal *, doublereal *, doublereal *,
05911 doublereal *), zuoik_(doublereal *, doublereal *, doublereal *,
05912 integer *, integer *, integer *, doublereal *, doublereal *,
05913 integer *, doublereal *, doublereal *, doublereal *), zwrsk_(
05914 doublereal *, doublereal *, doublereal *, integer *, integer *,
05915 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
05916 doublereal *, doublereal *, doublereal *);
05917
05918
05919
05920
05921
05922
05923
05924
05925
05926 --cyi;
05927 --cyr;
05928
05929
05930
05931 *nz = 0;
05932 az = zabs_(zr, zi);
05933 nn = *n;
05934 dfnu = *fnu + (doublereal) ((real) (*n - 1));
05935 if (az <= 2.) {
05936 goto L10;
05937 }
05938 if (az * az * .25 > dfnu + 1.) {
05939 goto L20;
05940 }
05941 L10:
05942
05943
05944
05945 zseri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol, elim, alim);
05946 inw = abs(nw);
05947 *nz += inw;
05948 nn -= inw;
05949 if (nn == 0) {
05950 return 0;
05951 }
05952 if (nw >= 0) {
05953 goto L120;
05954 }
05955 dfnu = *fnu + (doublereal) ((real) (nn - 1));
05956 L20:
05957 if (az < *rl) {
05958 goto L40;
05959 }
05960 if (dfnu <= 1.) {
05961 goto L30;
05962 }
05963 if (az + az < dfnu * dfnu) {
05964 goto L50;
05965 }
05966
05967
05968
05969 L30:
05970 zasyi_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, rl, tol, elim, alim)
05971 ;
05972 if (nw < 0) {
05973 goto L130;
05974 }
05975 goto L120;
05976 L40:
05977 if (dfnu <= 1.) {
05978 goto L70;
05979 }
05980 L50:
05981
05982
05983
05984 zuoik_(zr, zi, fnu, kode, &c__1, &nn, &cyr[1], &cyi[1], &nw, tol, elim,
05985 alim);
05986 if (nw < 0) {
05987 goto L130;
05988 }
05989 *nz += nw;
05990 nn -= nw;
05991 if (nn == 0) {
05992 return 0;
05993 }
05994 dfnu = *fnu + (doublereal) ((real) (nn - 1));
05995 if (dfnu > *fnul) {
05996 goto L110;
05997 }
05998 if (az > *fnul) {
05999 goto L110;
06000 }
06001 L60:
06002 if (az > *rl) {
06003 goto L80;
06004 }
06005 L70:
06006
06007
06008
06009 zmlri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol);
06010 if (nw < 0) {
06011 goto L130;
06012 }
06013 goto L120;
06014 L80:
06015
06016
06017
06018
06019
06020
06021 zuoik_(zr, zi, fnu, kode, &c__2, &c__2, cwr, cwi, &nw, tol, elim, alim);
06022 if (nw >= 0) {
06023 goto L100;
06024 }
06025 *nz = nn;
06026 i__1 = nn;
06027 for (i__ = 1; i__ <= i__1; ++i__) {
06028 cyr[i__] = zeror;
06029 cyi[i__] = zeroi;
06030
06031 }
06032 return 0;
06033 L100:
06034 if (nw > 0) {
06035 goto L130;
06036 }
06037 zwrsk_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, cwr, cwi, tol, elim,
06038 alim);
06039 if (nw < 0) {
06040 goto L130;
06041 }
06042 goto L120;
06043 L110:
06044
06045
06046
06047 nui = (integer) ((real) (*fnul - dfnu)) + 1;
06048 nui = max(nui,0);
06049 zbuni_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &nui, &nlast, fnul,
06050 tol, elim, alim);
06051 if (nw < 0) {
06052 goto L130;
06053 }
06054 *nz += nw;
06055 if (nlast == 0) {
06056 goto L120;
06057 }
06058 nn = nlast;
06059 goto L60;
06060 L120:
06061 return 0;
06062 L130:
06063 *nz = -1;
06064 if (nw == -2) {
06065 *nz = -2;
06066 }
06067 return 0;
06068 }
06069
06070 doublereal dgamln_(doublereal *z__, integer *ierr)
06071 {
06072
06073
06074 static doublereal gln[100] = { 0.,0.,.693147180559945309,
06075 1.791759469228055,3.17805383034794562,4.78749174278204599,
06076 6.579251212010101,8.5251613610654143,10.6046029027452502,
06077 12.8018274800814696,15.1044125730755153,17.5023078458738858,
06078 19.9872144956618861,22.5521638531234229,25.1912211827386815,
06079 27.8992713838408916,30.6718601060806728,33.5050734501368889,
06080 36.3954452080330536,39.339884187199494,42.335616460753485,
06081 45.380138898476908,48.4711813518352239,51.6066755677643736,
06082 54.7847293981123192,58.0036052229805199,61.261701761002002,
06083 64.5575386270063311,67.889743137181535,71.257038967168009,
06084 74.6582363488301644,78.0922235533153106,81.5579594561150372,
06085 85.0544670175815174,88.5808275421976788,92.1361756036870925,
06086 95.7196945421432025,99.3306124547874269,102.968198614513813,
06087 106.631760260643459,110.320639714757395,114.034211781461703,
06088 117.771881399745072,121.533081515438634,125.317271149356895,
06089 129.123933639127215,132.95257503561631,136.802722637326368,
06090 140.673923648234259,144.565743946344886,148.477766951773032,
06091 152.409592584497358,156.360836303078785,160.331128216630907,
06092 164.320112263195181,168.327445448427652,172.352797139162802,
06093 176.395848406997352,180.456291417543771,184.533828861449491,
06094 188.628173423671591,192.739047287844902,196.866181672889994,
06095 201.009316399281527,205.168199482641199,209.342586752536836,
06096 213.532241494563261,217.736934113954227,221.956441819130334,
06097 226.190548323727593,230.439043565776952,234.701723442818268,
06098 238.978389561834323,243.268849002982714,247.572914096186884,
06099 251.890402209723194,256.221135550009525,260.564940971863209,
06100 264.921649798552801,269.291097651019823,273.673124285693704,
06101 278.067573440366143,282.474292687630396,286.893133295426994,
06102 291.323950094270308,295.766601350760624,300.220948647014132,
06103 304.686856765668715,309.164193580146922,313.652829949879062,
06104 318.152639620209327,322.663499126726177,327.185287703775217,
06105 331.717887196928473,336.261181979198477,340.815058870799018,
06106 345.379407062266854,349.954118040770237,354.539085519440809,
06107 359.134205369575399 };
06108 static doublereal cf[22] = { .0833333333333333333,-.00277777777777777778,
06109 7.93650793650793651e-4,-5.95238095238095238e-4,
06110 8.41750841750841751e-4,-.00191752691752691753,
06111 .00641025641025641026,-.0295506535947712418,.179644372368830573,
06112 -1.39243221690590112,13.402864044168392,-156.848284626002017,
06113 2193.10333333333333,-36108.7712537249894,691472.268851313067,
06114 -15238221.5394074162,382900751.391414141,-10882266035.7843911,
06115 347320283765.002252,-12369602142269.2745,488788064793079.335,
06116 -21320333960919373.9 };
06117 static doublereal con = 1.83787706640934548;
06118
06119
06120 integer i__1;
06121 doublereal ret_val;
06122
06123
06124 double log(doublereal);
06125
06126
06127 static integer i__, k;
06128 static doublereal s, t1, fz, zm;
06129 static integer mz, nz;
06130 static doublereal zp;
06131 static integer i1m;
06132 static doublereal fln, tlg, rln, trm, tst, zsq, zinc, zmin, zdmy, wdtol;
06133 extern doublereal d1mach_(integer *);
06134 extern integer i1mach_(integer *);
06135
06136
06137
06138
06139
06140
06141
06142
06143
06144
06145
06146
06147
06148
06149
06150
06151
06152
06153
06154
06155
06156
06157
06158
06159
06160
06161
06162
06163
06164
06165
06166
06167
06168
06169
06170
06171
06172
06173
06174
06175
06176
06177
06178
06179 *ierr = 0;
06180 if (*z__ <= 0.) {
06181 goto L70;
06182 }
06183 if (*z__ > 101.) {
06184 goto L10;
06185 }
06186 nz = (integer) ((real) (*z__));
06187 fz = *z__ - (real) nz;
06188 if (fz > 0.) {
06189 goto L10;
06190 }
06191 if (nz > 100) {
06192 goto L10;
06193 }
06194 ret_val = gln[nz - 1];
06195 return ret_val;
06196 L10:
06197 wdtol = d1mach_(&c__4);
06198 wdtol = max(wdtol,5e-19);
06199 i1m = i1mach_(&c__14);
06200 rln = d1mach_(&c__5) * (real) i1m;
06201 fln = min(rln,20.);
06202 fln = max(fln,3.);
06203 fln += -3.;
06204 zm = fln * .3875 + 1.8;
06205 mz = (integer) ((real) zm) + 1;
06206 zmin = (real) mz;
06207 zdmy = *z__;
06208 zinc = 0.;
06209 if (*z__ >= zmin) {
06210 goto L20;
06211 }
06212 zinc = zmin - (real) nz;
06213 zdmy = *z__ + zinc;
06214 L20:
06215 zp = 1. / zdmy;
06216 t1 = cf[0] * zp;
06217 s = t1;
06218 if (zp < wdtol) {
06219 goto L40;
06220 }
06221 zsq = zp * zp;
06222 tst = t1 * wdtol;
06223 for (k = 2; k <= 22; ++k) {
06224 zp *= zsq;
06225 trm = cf[k - 1] * zp;
06226 if (abs(trm) < tst) {
06227 goto L40;
06228 }
06229 s += trm;
06230
06231 }
06232 L40:
06233 if (zinc != 0.) {
06234 goto L50;
06235 }
06236 tlg = log(*z__);
06237 ret_val = *z__ * (tlg - 1.) + (con - tlg) * .5 + s;
06238 return ret_val;
06239 L50:
06240 zp = 1.;
06241 nz = (integer) ((real) zinc);
06242 i__1 = nz;
06243 for (i__ = 1; i__ <= i__1; ++i__) {
06244 zp *= *z__ + (real) (i__ - 1);
06245
06246 }
06247 tlg = log(zdmy);
06248 ret_val = zdmy * (tlg - 1.) - log(zp) + (con - tlg) * .5 + s;
06249 return ret_val;
06250
06251
06252 L70:
06253 *ierr = 1;
06254 return ret_val;
06255 }
06256
06257 int zacai_(doublereal *zr, doublereal *zi, doublereal *fnu,
06258 integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
06259 yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim,
06260 doublereal *alim)
06261 {
06262
06263
06264 static doublereal pi = 3.14159265358979324;
06265
06266
06267 double d_sign(doublereal *, doublereal *), sin(doublereal), cos(
06268 doublereal);
06269
06270
06271 static doublereal az;
06272 static integer nn, nw;
06273 static doublereal yy, c1i, c2i, c1r, c2r, arg;
06274 static integer iuf;
06275 static doublereal cyi[2], fmr, sgn;
06276 static integer inu;
06277 static doublereal cyr[2], zni, znr, dfnu;
06278 extern doublereal zabs_(doublereal *, doublereal *);
06279 extern int zs1s2_(doublereal *, doublereal *, doublereal
06280 *, doublereal *, doublereal *, doublereal *, integer *,
06281 doublereal *, doublereal *, integer *);
06282 static doublereal ascle, csgni, csgnr, cspni, cspnr;
06283 extern int zbknu_(doublereal *, doublereal *, doublereal
06284 *, integer *, integer *, doublereal *, doublereal *, integer *,
06285 doublereal *, doublereal *, doublereal *), zseri_(doublereal *,
06286 doublereal *, doublereal *, integer *, integer *, doublereal *,
06287 doublereal *, integer *, doublereal *, doublereal *, doublereal *)
06288 ;
06289 extern doublereal d1mach_(integer *);
06290 extern int zmlri_(doublereal *, doublereal *, doublereal
06291 *, integer *, integer *, doublereal *, doublereal *, integer *,
06292 doublereal *), zasyi_(doublereal *, doublereal *, doublereal *,
06293 integer *, integer *, doublereal *, doublereal *, integer *,
06294 doublereal *, doublereal *, doublereal *, doublereal *);
06295
06296
06297
06298
06299
06300
06301
06302
06303
06304
06305
06306
06307
06308
06309
06310
06311
06312
06313
06314 --yi;
06315 --yr;
06316
06317
06318 *nz = 0;
06319 znr = -(*zr);
06320 zni = -(*zi);
06321 az = zabs_(zr, zi);
06322 nn = *n;
06323 dfnu = *fnu + (doublereal) ((real) (*n - 1));
06324 if (az <= 2.) {
06325 goto L10;
06326 }
06327 if (az * az * .25 > dfnu + 1.) {
06328 goto L20;
06329 }
06330 L10:
06331
06332
06333
06334 zseri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol, elim, alim);
06335 goto L40;
06336 L20:
06337 if (az < *rl) {
06338 goto L30;
06339 }
06340
06341
06342
06343 zasyi_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, tol, elim,
06344 alim);
06345 if (nw < 0) {
06346 goto L80;
06347 }
06348 goto L40;
06349 L30:
06350
06351
06352
06353 zmlri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol);
06354 if (nw < 0) {
06355 goto L80;
06356 }
06357 L40:
06358
06359
06360
06361 zbknu_(&znr, &zni, fnu, kode, &c__1, cyr, cyi, &nw, tol, elim, alim);
06362 if (nw != 0) {
06363 goto L80;
06364 }
06365 fmr = (doublereal) ((real) (*mr));
06366 sgn = -DSIGN(pi, fmr);
06367 csgnr = 0.;
06368 csgni = sgn;
06369 if (*kode == 1) {
06370 goto L50;
06371 }
06372 yy = -zni;
06373 csgnr = -csgni * sin(yy);
06374 csgni *= cos(yy);
06375 L50:
06376
06377
06378
06379
06380 inu = (integer) ((real) (*fnu));
06381 arg = (*fnu - (doublereal) ((real) inu)) * sgn;
06382 cspnr = cos(arg);
06383 cspni = sin(arg);
06384 if (inu % 2 == 0) {
06385 goto L60;
06386 }
06387 cspnr = -cspnr;
06388 cspni = -cspni;
06389 L60:
06390 c1r = cyr[0];
06391 c1i = cyi[0];
06392 c2r = yr[1];
06393 c2i = yi[1];
06394 if (*kode == 1) {
06395 goto L70;
06396 }
06397 iuf = 0;
06398 ascle = d1mach_(&c__1) * 1e3 / *tol;
06399 zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
06400 *nz += nw;
06401 L70:
06402 yr[1] = cspnr * c1r - cspni * c1i + csgnr * c2r - csgni * c2i;
06403 yi[1] = cspnr * c1i + cspni * c1r + csgnr * c2i + csgni * c2r;
06404 return 0;
06405 L80:
06406 *nz = -1;
06407 if (nw == -2) {
06408 *nz = -2;
06409 }
06410 return 0;
06411 }
06412
06413 int zuchk_(doublereal *yr, doublereal *yi, integer *nz,
06414 doublereal *ascle, doublereal *tol)
06415 {
06416 static doublereal wi, ss, st, wr;
06417
06418
06419
06420
06421
06422
06423
06424
06425
06426
06427
06428
06429
06430
06431
06432
06433 *nz = 0;
06434 wr = abs(*yr);
06435 wi = abs(*yi);
06436 st = min(wr,wi);
06437 if (st > *ascle) {
06438 return 0;
06439 }
06440 ss = max(wr,wi);
06441 st /= *tol;
06442 if (ss < st) {
06443 *nz = 1;
06444 }
06445 return 0;
06446 }
06447
06448 int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu,
06449 integer *ikflg, integer *ipmtr, doublereal *tol, integer *init,
06450 doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *
06451 zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr,
06452 doublereal *sumi, doublereal *cwrkr, doublereal *cwrki)
06453 {
06454
06455
06456 static doublereal zeror = 0.;
06457 static doublereal zeroi = 0.;
06458 static doublereal coner = 1.;
06459 static doublereal conei = 0.;
06460 static doublereal con[2] = { .398942280401432678,1.25331413731550025 };
06461 static doublereal c__[120] = { 1.,-.208333333333333333,.125,
06462 .334201388888888889,-.401041666666666667,.0703125,
06463 -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
06464 4.66958442342624743,-11.2070026162229938,8.78912353515625,
06465 -2.3640869140625,.112152099609375,-28.2120725582002449,
06466 84.6362176746007346,-91.8182415432400174,42.5349987453884549,
06467 -7.3687943594796317,.227108001708984375,212.570130039217123,
06468 -765.252468141181642,1059.99045252799988,-699.579627376132541,
06469 218.19051174421159,-26.4914304869515555,.572501420974731445,
06470 -1919.457662318407,8061.72218173730938,-13586.5500064341374,
06471 11655.3933368645332,-5305.64697861340311,1200.90291321635246,
06472 -108.090919788394656,1.7277275025844574,20204.2913309661486,
06473 -96980.5983886375135,192547.001232531532,-203400.177280415534,
06474 122200.46498301746,-41192.6549688975513,7109.51430248936372,
06475 -493.915304773088012,6.07404200127348304,-242919.187900551333,
06476 1311763.6146629772,-2998015.91853810675,3763271.297656404,
06477 -2813563.22658653411,1268365.27332162478,-331645.172484563578,
06478 45218.7689813627263,-2499.83048181120962,24.3805296995560639,
06479 3284469.85307203782,-19706819.1184322269,50952602.4926646422,
06480 -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
06481 13288767.1664218183,-2785618.12808645469,308186.404612662398,
06482 -13886.0897537170405,110.017140269246738,-49329253.664509962,
06483 325573074.185765749,-939462359.681578403,1553596899.57058006,
06484 -1621080552.10833708,1106842816.82301447,-495889784.275030309,
06485 142062907.797533095,-24474062.7257387285,2243768.17792244943,
06486 -84005.4336030240853,551.335896122020586,814789096.118312115,
06487 -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
06488 41280185579.753974,-33026599749.8007231,17954213731.1556001,
06489 -6563293792.61928433,1559279864.87925751,-225105661.889415278,
06490 17395107.5539781645,-549842.327572288687,3038.09051092238427,
06491 -14679261247.6956167,114498237732.02581,-399096175224.466498,
06492 819218669548.577329,-1098375156081.22331,1008158106865.38209,
06493 -645364869245.376503,287900649906.150589,-87867072178.0232657,
06494 17634730606.8349694,-2167164983.22379509,143157876.718888981,
06495 -3871833.44257261262,18257.7554742931747,286464035717.679043,
06496 -2406297900028.50396,9109341185239.89896,-20516899410934.4374,
06497 30565125519935.3206,-31667088584785.1584,23348364044581.8409,
06498 -12320491305598.2872,4612725780849.13197,-1196552880196.1816,
06499 205914503232.410016,-21822927757.5292237,1247009293.51271032,
06500 -29188388.1222208134,118838.426256783253 };
06501
06502
06503 integer i__1;
06504 doublereal d__1, d__2;
06505
06506
06507 double log(doublereal);
06508
06509
06510 extern int zzzsqrt_(doublereal *, doublereal *,
06511 doublereal *, doublereal *);
06512 static integer i__, j, k, l;
06513 static doublereal ac, si, ti, sr, tr, t2i, t2r, rfn, sri, sti, zni, srr,
06514 str, znr;
06515 static integer idum;
06516 extern int zdiv_(doublereal *, doublereal *, doublereal *
06517 , doublereal *, doublereal *, doublereal *);
06518 static doublereal test, crfni, crfnr;
06519 extern doublereal d1mach_(integer *);
06520 extern int zzzlog_(doublereal *, doublereal *,
06521 doublereal *, doublereal *, integer *);
06522
06523
06524
06525
06526
06527
06528
06529
06530
06531
06532
06533
06534
06535
06536
06537
06538
06539
06540
06541
06542
06543
06544
06545
06546 --cwrki;
06547 --cwrkr;
06548
06549
06550
06551 if (*init != 0) {
06552 goto L40;
06553 }
06554
06555
06556
06557 rfn = 1. / *fnu;
06558
06559
06560
06561 test = d1mach_(&c__1) * 1e3;
06562 ac = *fnu * test;
06563 if (abs(*zrr) > ac || abs(*zri) > ac) {
06564 goto L15;
06565 }
06566 *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
06567 *zeta1i = 0.;
06568 *zeta2r = *fnu;
06569 *zeta2i = 0.;
06570 *phir = 1.;
06571 *phii = 0.;
06572 return 0;
06573 L15:
06574 tr = *zrr * rfn;
06575 ti = *zri * rfn;
06576 sr = coner + (tr * tr - ti * ti);
06577 si = conei + (tr * ti + ti * tr);
06578 zzzsqrt_(&sr, &si, &srr, &sri);
06579 str = coner + srr;
06580 sti = conei + sri;
06581 zdiv_(&str, &sti, &tr, &ti, &znr, &zni);
06582 zzzlog_(&znr, &zni, &str, &sti, &idum);
06583 *zeta1r = *fnu * str;
06584 *zeta1i = *fnu * sti;
06585 *zeta2r = *fnu * srr;
06586 *zeta2i = *fnu * sri;
06587 zdiv_(&coner, &conei, &srr, &sri, &tr, &ti);
06588 srr = tr * rfn;
06589 sri = ti * rfn;
06590 zzzsqrt_(&srr, &sri, &cwrkr[16], &cwrki[16]);
06591 *phir = cwrkr[16] * con[*ikflg - 1];
06592 *phii = cwrki[16] * con[*ikflg - 1];
06593 if (*ipmtr != 0) {
06594 return 0;
06595 }
06596 zdiv_(&coner, &conei, &sr, &si, &t2r, &t2i);
06597 cwrkr[1] = coner;
06598 cwrki[1] = conei;
06599 crfnr = coner;
06600 crfni = conei;
06601 ac = 1.;
06602 l = 1;
06603 for (k = 2; k <= 15; ++k) {
06604 sr = zeror;
06605 si = zeroi;
06606 i__1 = k;
06607 for (j = 1; j <= i__1; ++j) {
06608 ++l;
06609 str = sr * t2r - si * t2i + c__[l - 1];
06610 si = sr * t2i + si * t2r;
06611 sr = str;
06612
06613 }
06614 str = crfnr * srr - crfni * sri;
06615 crfni = crfnr * sri + crfni * srr;
06616 crfnr = str;
06617 cwrkr[k] = crfnr * sr - crfni * si;
06618 cwrki[k] = crfnr * si + crfni * sr;
06619 ac *= rfn;
06620 test = (d__1 = cwrkr[k], abs(d__1)) + (d__2 = cwrki[k], abs(d__2));
06621 if (ac < *tol && test < *tol) {
06622 goto L30;
06623 }
06624
06625 }
06626 k = 15;
06627 L30:
06628 *init = k;
06629 L40:
06630 if (*ikflg == 2) {
06631 goto L60;
06632 }
06633
06634
06635
06636 sr = zeror;
06637 si = zeroi;
06638 i__1 = *init;
06639 for (i__ = 1; i__ <= i__1; ++i__) {
06640 sr += cwrkr[i__];
06641 si += cwrki[i__];
06642
06643 }
06644 *sumr = sr;
06645 *sumi = si;
06646 *phir = cwrkr[16] * con[0];
06647 *phii = cwrki[16] * con[0];
06648 return 0;
06649 L60:
06650
06651
06652
06653 sr = zeror;
06654 si = zeroi;
06655 tr = coner;
06656 i__1 = *init;
06657 for (i__ = 1; i__ <= i__1; ++i__) {
06658 sr += tr * cwrkr[i__];
06659 si += tr * cwrki[i__];
06660 tr = -tr;
06661
06662 }
06663 *sumr = sr;
06664 *sumi = si;
06665 *phir = cwrkr[16] * con[1];
06666 *phii = cwrki[16] * con[1];
06667 return 0;
06668 }
06669
06670 int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu,
06671 integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii,
06672 doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *
06673 zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr,
06674 doublereal *asumi, doublereal *bsumr, doublereal *bsumi)
06675 {
06676
06677
06678 static doublereal ar[14] = { 1.,.104166666666666667,.0835503472222222222,
06679 .12822657455632716,.291849026464140464,.881627267443757652,
06680 3.32140828186276754,14.9957629868625547,78.9230130115865181,
06681 474.451538868264323,3207.49009089066193,24086.5496408740049,
06682 198923.119169509794,1791902.00777534383 };
06683 static doublereal br[14] = { 1.,-.145833333333333333,
06684 -.0987413194444444444,-.143312053915895062,-.317227202678413548,
06685 -.942429147957120249,-3.51120304082635426,-15.7272636203680451,
06686 -82.2814390971859444,-492.355370523670524,-3316.21856854797251,
06687 -24827.6742452085896,-204526.587315129788,-1838444.9170682099 };
06688 static doublereal c__[105] = { 1.,-.208333333333333333,.125,
06689 .334201388888888889,-.401041666666666667,.0703125,
06690 -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
06691 4.66958442342624743,-11.2070026162229938,8.78912353515625,
06692 -2.3640869140625,.112152099609375,-28.2120725582002449,
06693 84.6362176746007346,-91.8182415432400174,42.5349987453884549,
06694 -7.3687943594796317,.227108001708984375,212.570130039217123,
06695 -765.252468141181642,1059.99045252799988,-699.579627376132541,
06696 218.19051174421159,-26.4914304869515555,.572501420974731445,
06697 -1919.457662318407,8061.72218173730938,-13586.5500064341374,
06698 11655.3933368645332,-5305.64697861340311,1200.90291321635246,
06699 -108.090919788394656,1.7277275025844574,20204.2913309661486,
06700 -96980.5983886375135,192547.001232531532,-203400.177280415534,
06701 122200.46498301746,-41192.6549688975513,7109.51430248936372,
06702 -493.915304773088012,6.07404200127348304,-242919.187900551333,
06703 1311763.6146629772,-2998015.91853810675,3763271.297656404,
06704 -2813563.22658653411,1268365.27332162478,-331645.172484563578,
06705 45218.7689813627263,-2499.83048181120962,24.3805296995560639,
06706 3284469.85307203782,-19706819.1184322269,50952602.4926646422,
06707 -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
06708 13288767.1664218183,-2785618.12808645469,308186.404612662398,
06709 -13886.0897537170405,110.017140269246738,-49329253.664509962,
06710 325573074.185765749,-939462359.681578403,1553596899.57058006,
06711 -1621080552.10833708,1106842816.82301447,-495889784.275030309,
06712 142062907.797533095,-24474062.7257387285,2243768.17792244943,
06713 -84005.4336030240853,551.335896122020586,814789096.118312115,
06714 -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
06715 41280185579.753974,-33026599749.8007231,17954213731.1556001,
06716 -6563293792.61928433,1559279864.87925751,-225105661.889415278,
06717 17395107.5539781645,-549842.327572288687,3038.09051092238427,
06718 -14679261247.6956167,114498237732.02581,-399096175224.466498,
06719 819218669548.577329,-1098375156081.22331,1008158106865.38209,
06720 -645364869245.376503,287900649906.150589,-87867072178.0232657,
06721 17634730606.8349694,-2167164983.22379509,143157876.718888981,
06722 -3871833.44257261262,18257.7554742931747 };
06723 static doublereal alfa[180] = { -.00444444444444444444,
06724 -9.22077922077922078e-4,-8.84892884892884893e-5,
06725 1.65927687832449737e-4,2.4669137274179291e-4,
06726 2.6599558934625478e-4,2.61824297061500945e-4,
06727 2.48730437344655609e-4,2.32721040083232098e-4,
06728 2.16362485712365082e-4,2.00738858762752355e-4,
06729 1.86267636637545172e-4,1.73060775917876493e-4,
06730 1.61091705929015752e-4,1.50274774160908134e-4,
06731 1.40503497391269794e-4,1.31668816545922806e-4,
06732 1.23667445598253261e-4,1.16405271474737902e-4,
06733 1.09798298372713369e-4,1.03772410422992823e-4,
06734 9.82626078369363448e-5,9.32120517249503256e-5,
06735 8.85710852478711718e-5,8.42963105715700223e-5,
06736 8.03497548407791151e-5,7.66981345359207388e-5,
06737 7.33122157481777809e-5,7.01662625163141333e-5,
06738 6.72375633790160292e-5,6.93735541354588974e-4,
06739 2.32241745182921654e-4,-1.41986273556691197e-5,
06740 -1.1644493167204864e-4,-1.50803558053048762e-4,
06741 -1.55121924918096223e-4,-1.46809756646465549e-4,
06742 -1.33815503867491367e-4,-1.19744975684254051e-4,
06743 -1.0618431920797402e-4,-9.37699549891194492e-5,
06744 -8.26923045588193274e-5,-7.29374348155221211e-5,
06745 -6.44042357721016283e-5,-5.69611566009369048e-5,
06746 -5.04731044303561628e-5,-4.48134868008882786e-5,
06747 -3.98688727717598864e-5,-3.55400532972042498e-5,
06748 -3.1741425660902248e-5,-2.83996793904174811e-5,
06749 -2.54522720634870566e-5,-2.28459297164724555e-5,
06750 -2.05352753106480604e-5,-1.84816217627666085e-5,
06751 -1.66519330021393806e-5,-1.50179412980119482e-5,
06752 -1.35554031379040526e-5,-1.22434746473858131e-5,
06753 -1.10641884811308169e-5,-3.54211971457743841e-4,
06754 -1.56161263945159416e-4,3.0446550359493641e-5,
06755 1.30198655773242693e-4,1.67471106699712269e-4,
06756 1.70222587683592569e-4,1.56501427608594704e-4,
06757 1.3633917097744512e-4,1.14886692029825128e-4,
06758 9.45869093034688111e-5,7.64498419250898258e-5,
06759 6.07570334965197354e-5,4.74394299290508799e-5,
06760 3.62757512005344297e-5,2.69939714979224901e-5,
06761 1.93210938247939253e-5,1.30056674793963203e-5,
06762 7.82620866744496661e-6,3.59257485819351583e-6,
06763 1.44040049814251817e-7,-2.65396769697939116e-6,
06764 -4.9134686709848591e-6,-6.72739296091248287e-6,
06765 -8.17269379678657923e-6,-9.31304715093561232e-6,
06766 -1.02011418798016441e-5,-1.0880596251059288e-5,
06767 -1.13875481509603555e-5,-1.17519675674556414e-5,
06768 -1.19987364870944141e-5,3.78194199201772914e-4,
06769 2.02471952761816167e-4,-6.37938506318862408e-5,
06770 -2.38598230603005903e-4,-3.10916256027361568e-4,
06771 -3.13680115247576316e-4,-2.78950273791323387e-4,
06772 -2.28564082619141374e-4,-1.75245280340846749e-4,
06773 -1.25544063060690348e-4,-8.22982872820208365e-5,
06774 -4.62860730588116458e-5,-1.72334302366962267e-5,
06775 5.60690482304602267e-6,2.313954431482868e-5,
06776 3.62642745856793957e-5,4.58006124490188752e-5,
06777 5.2459529495911405e-5,5.68396208545815266e-5,
06778 5.94349820393104052e-5,6.06478527578421742e-5,
06779 6.08023907788436497e-5,6.01577894539460388e-5,
06780 5.891996573446985e-5,5.72515823777593053e-5,
06781 5.52804375585852577e-5,5.3106377380288017e-5,
06782 5.08069302012325706e-5,4.84418647620094842e-5,
06783 4.6056858160747537e-5,-6.91141397288294174e-4,
06784 -4.29976633058871912e-4,1.83067735980039018e-4,
06785 6.60088147542014144e-4,8.75964969951185931e-4,
06786 8.77335235958235514e-4,7.49369585378990637e-4,
06787 5.63832329756980918e-4,3.68059319971443156e-4,
06788 1.88464535514455599e-4,3.70663057664904149e-5,
06789 -8.28520220232137023e-5,-1.72751952869172998e-4,
06790 -2.36314873605872983e-4,-2.77966150694906658e-4,
06791 -3.02079514155456919e-4,-3.12594712643820127e-4,
06792 -3.12872558758067163e-4,-3.05678038466324377e-4,
06793 -2.93226470614557331e-4,-2.77255655582934777e-4,
06794 -2.59103928467031709e-4,-2.39784014396480342e-4,
06795 -2.20048260045422848e-4,-2.00443911094971498e-4,
06796 -1.81358692210970687e-4,-1.63057674478657464e-4,
06797 -1.45712672175205844e-4,-1.29425421983924587e-4,
06798 -1.14245691942445952e-4,.00192821964248775885,
06799 .00135592576302022234,-7.17858090421302995e-4,
06800 -.00258084802575270346,-.00349271130826168475,
06801 -.00346986299340960628,-.00282285233351310182,
06802 -.00188103076404891354,-8.895317183839476e-4,
06803 3.87912102631035228e-6,7.28688540119691412e-4,
06804 .00126566373053457758,.00162518158372674427,.00183203153216373172,
06805 .00191588388990527909,.00190588846755546138,.00182798982421825727,
06806 .0017038950642112153,.00155097127171097686,.00138261421852276159,
06807 .00120881424230064774,.00103676532638344962,
06808 8.71437918068619115e-4,7.16080155297701002e-4,
06809 5.72637002558129372e-4,4.42089819465802277e-4,
06810 3.24724948503090564e-4,2.20342042730246599e-4,
06811 1.28412898401353882e-4,4.82005924552095464e-5 };
06812 static doublereal beta[210] = { .0179988721413553309,
06813 .00559964911064388073,.00288501402231132779,.00180096606761053941,
06814 .00124753110589199202,9.22878876572938311e-4,
06815 7.14430421727287357e-4,5.71787281789704872e-4,
06816 4.69431007606481533e-4,3.93232835462916638e-4,
06817 3.34818889318297664e-4,2.88952148495751517e-4,
06818 2.52211615549573284e-4,2.22280580798883327e-4,
06819 1.97541838033062524e-4,1.76836855019718004e-4,
06820 1.59316899661821081e-4,1.44347930197333986e-4,
06821 1.31448068119965379e-4,1.20245444949302884e-4,
06822 1.10449144504599392e-4,1.01828770740567258e-4,
06823 9.41998224204237509e-5,8.74130545753834437e-5,
06824 8.13466262162801467e-5,7.59002269646219339e-5,
06825 7.09906300634153481e-5,6.65482874842468183e-5,
06826 6.25146958969275078e-5,5.88403394426251749e-5,
06827 -.00149282953213429172,-8.78204709546389328e-4,
06828 -5.02916549572034614e-4,-2.94822138512746025e-4,
06829 -1.75463996970782828e-4,-1.04008550460816434e-4,
06830 -5.96141953046457895e-5,-3.1203892907609834e-5,
06831 -1.26089735980230047e-5,-2.42892608575730389e-7,
06832 8.05996165414273571e-6,1.36507009262147391e-5,
06833 1.73964125472926261e-5,1.9867297884213378e-5,
06834 2.14463263790822639e-5,2.23954659232456514e-5,
06835 2.28967783814712629e-5,2.30785389811177817e-5,
06836 2.30321976080909144e-5,2.28236073720348722e-5,
06837 2.25005881105292418e-5,2.20981015361991429e-5,
06838 2.16418427448103905e-5,2.11507649256220843e-5,
06839 2.06388749782170737e-5,2.01165241997081666e-5,
06840 1.95913450141179244e-5,1.9068936791043674e-5,
06841 1.85533719641636667e-5,1.80475722259674218e-5,
06842 5.5221307672129279e-4,4.47932581552384646e-4,
06843 2.79520653992020589e-4,1.52468156198446602e-4,
06844 6.93271105657043598e-5,1.76258683069991397e-5,
06845 -1.35744996343269136e-5,-3.17972413350427135e-5,
06846 -4.18861861696693365e-5,-4.69004889379141029e-5,
06847 -4.87665447413787352e-5,-4.87010031186735069e-5,
06848 -4.74755620890086638e-5,-4.55813058138628452e-5,
06849 -4.33309644511266036e-5,-4.09230193157750364e-5,
06850 -3.84822638603221274e-5,-3.60857167535410501e-5,
06851 -3.37793306123367417e-5,-3.15888560772109621e-5,
06852 -2.95269561750807315e-5,-2.75978914828335759e-5,
06853 -2.58006174666883713e-5,-2.413083567612802e-5,
06854 -2.25823509518346033e-5,-2.11479656768912971e-5,
06855 -1.98200638885294927e-5,-1.85909870801065077e-5,
06856 -1.74532699844210224e-5,-1.63997823854497997e-5,
06857 -4.74617796559959808e-4,-4.77864567147321487e-4,
06858 -3.20390228067037603e-4,-1.61105016119962282e-4,
06859 -4.25778101285435204e-5,3.44571294294967503e-5,
06860 7.97092684075674924e-5,1.031382367082722e-4,
06861 1.12466775262204158e-4,1.13103642108481389e-4,
06862 1.08651634848774268e-4,1.01437951597661973e-4,
06863 9.29298396593363896e-5,8.40293133016089978e-5,
06864 7.52727991349134062e-5,6.69632521975730872e-5,
06865 5.92564547323194704e-5,5.22169308826975567e-5,
06866 4.58539485165360646e-5,4.01445513891486808e-5,
06867 3.50481730031328081e-5,3.05157995034346659e-5,
06868 2.64956119950516039e-5,2.29363633690998152e-5,
06869 1.97893056664021636e-5,1.70091984636412623e-5,
06870 1.45547428261524004e-5,1.23886640995878413e-5,
06871 1.04775876076583236e-5,8.79179954978479373e-6,
06872 7.36465810572578444e-4,8.72790805146193976e-4,
06873 6.22614862573135066e-4,2.85998154194304147e-4,
06874 3.84737672879366102e-6,-1.87906003636971558e-4,
06875 -2.97603646594554535e-4,-3.45998126832656348e-4,
06876 -3.53382470916037712e-4,-3.35715635775048757e-4,
06877 -3.04321124789039809e-4,-2.66722723047612821e-4,
06878 -2.27654214122819527e-4,-1.89922611854562356e-4,
06879 -1.5505891859909387e-4,-1.2377824076187363e-4,
06880 -9.62926147717644187e-5,-7.25178327714425337e-5,
06881 -5.22070028895633801e-5,-3.50347750511900522e-5,
06882 -2.06489761035551757e-5,-8.70106096849767054e-6,
06883 1.1369868667510029e-6,9.16426474122778849e-6,
06884 1.5647778542887262e-5,2.08223629482466847e-5,
06885 2.48923381004595156e-5,2.80340509574146325e-5,
06886 3.03987774629861915e-5,3.21156731406700616e-5,
06887 -.00180182191963885708,-.00243402962938042533,
06888 -.00183422663549856802,-7.62204596354009765e-4,
06889 2.39079475256927218e-4,9.49266117176881141e-4,
06890 .00134467449701540359,.00148457495259449178,.00144732339830617591,
06891 .00130268261285657186,.00110351597375642682,
06892 8.86047440419791759e-4,6.73073208165665473e-4,
06893 4.77603872856582378e-4,3.05991926358789362e-4,
06894 1.6031569459472163e-4,4.00749555270613286e-5,
06895 -5.66607461635251611e-5,-1.32506186772982638e-4,
06896 -1.90296187989614057e-4,-2.32811450376937408e-4,
06897 -2.62628811464668841e-4,-2.82050469867598672e-4,
06898 -2.93081563192861167e-4,-2.97435962176316616e-4,
06899 -2.96557334239348078e-4,-2.91647363312090861e-4,
06900 -2.83696203837734166e-4,-2.73512317095673346e-4,
06901 -2.6175015580676858e-4,.00638585891212050914,
06902 .00962374215806377941,.00761878061207001043,.00283219055545628054,
06903 -.0020984135201272009,-.00573826764216626498,
06904 -.0077080424449541462,-.00821011692264844401,
06905 -.00765824520346905413,-.00647209729391045177,
06906 -.00499132412004966473,-.0034561228971313328,
06907 -.00201785580014170775,-7.59430686781961401e-4,
06908 2.84173631523859138e-4,.00110891667586337403,
06909 .00172901493872728771,.00216812590802684701,.00245357710494539735,
06910 .00261281821058334862,.00267141039656276912,.0026520307339598043,
06911 .00257411652877287315,.00245389126236094427,.00230460058071795494,
06912 .00213684837686712662,.00195896528478870911,.00177737008679454412,
06913 .00159690280765839059,.00142111975664438546 };
06914 static doublereal gama[30] = { .629960524947436582,.251984209978974633,
06915 .154790300415655846,.110713062416159013,.0857309395527394825,
06916 .0697161316958684292,.0586085671893713576,.0504698873536310685,
06917 .0442600580689154809,.0393720661543509966,.0354283195924455368,
06918 .0321818857502098231,.0294646240791157679,.0271581677112934479,
06919 .0251768272973861779,.0234570755306078891,.0219508390134907203,
06920 .020621082823564624,.0194388240897880846,.0183810633800683158,
06921 .0174293213231963172,.0165685837786612353,.0157865285987918445,
06922 .0150729501494095594,.0144193250839954639,.0138184805735341786,
06923 .0132643378994276568,.0127517121970498651,.0122761545318762767,
06924 .0118338262398482403 };
06925 static doublereal ex1 = .333333333333333333;
06926 static doublereal ex2 = .666666666666666667;
06927 static doublereal hpi = 1.57079632679489662;
06928 static doublereal gpi = 3.14159265358979324;
06929 static doublereal thpi = 4.71238898038468986;
06930 static doublereal zeror = 0.;
06931 static doublereal zeroi = 0.;
06932 static doublereal coner = 1.;
06933 static doublereal conei = 0.;
06934
06935
06936 integer i__1, i__2;
06937 doublereal d__1;
06938
06939
06940 double log(doublereal), pow_dd(doublereal *, doublereal *), atan(
06941 doublereal), cos(doublereal), sin(doublereal), sqrt(doublereal);
06942
06943
06944 extern int zzzsqrt_(doublereal *, doublereal *,
06945 doublereal *, doublereal *);
06946 static integer j, k, l, m, l1, l2;
06947 static doublereal ac, ap[30], pi[30];
06948 static integer is, jr, ks, ju;
06949 static doublereal pp, wi, pr[30];
06950 static integer lr;
06951 static doublereal wr, aw2;
06952 static integer kp1;
06953 static doublereal t2i, w2i, t2r, w2r, ang, fn13, fn23;
06954 static integer ias;
06955 static doublereal cri[14], dri[14];
06956 static integer ibs;
06957 static doublereal zai, zbi, zci, crr[14], drr[14], raw, zar, upi[14], sti,
06958 zbr, zcr, upr[14], str, raw2;
06959 static integer lrp1;
06960 static doublereal rfn13;
06961 static integer idum;
06962 extern doublereal zabs_(doublereal *, doublereal *);
06963 static doublereal atol, btol, tfni;
06964 static integer kmax;
06965 static doublereal azth, tzai, tfnr, rfnu;
06966 extern int zdiv_(doublereal *, doublereal *, doublereal *
06967 , doublereal *, doublereal *, doublereal *);
06968 static doublereal zthi, test, tzar, zthr, rfnu2, zetai, ptfni, sumai,
06969 sumbi, zetar, ptfnr, razth, sumar, sumbr, rzthi;
06970 extern doublereal d1mach_(integer *);
06971 static doublereal rzthr, rtzti, rtztr, przthi, przthr;
06972 extern int zzzlog_(doublereal *, doublereal *,
06973 doublereal *, doublereal *, integer *);
06974
06975
06976
06977
06978
06979
06980
06981
06982
06983
06984
06985
06986
06987
06988
06989
06990
06991
06992
06993
06994
06995
06996
06997
06998
06999
07000
07001
07002
07003
07004
07005
07006
07007
07008
07009
07010 rfnu = 1. / *fnu;
07011
07012
07013
07014 test = d1mach_(&c__1) * 1e3;
07015 ac = *fnu * test;
07016 if (abs(*zr) > ac || abs(*zi) > ac) {
07017 goto L15;
07018 }
07019 *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
07020 *zeta1i = 0.;
07021 *zeta2r = *fnu;
07022 *zeta2i = 0.;
07023 *phir = 1.;
07024 *phii = 0.;
07025 *argr = 1.;
07026 *argi = 0.;
07027 return 0;
07028 L15:
07029 zbr = *zr * rfnu;
07030 zbi = *zi * rfnu;
07031 rfnu2 = rfnu * rfnu;
07032
07033
07034
07035 fn13 = pow(*fnu, ex1);
07036 fn23 = fn13 * fn13;
07037 rfn13 = 1. / fn13;
07038 w2r = coner - zbr * zbr + zbi * zbi;
07039 w2i = conei - zbr * zbi - zbr * zbi;
07040 aw2 = zabs_(&w2r, &w2i);
07041 if (aw2 > .25) {
07042 goto L130;
07043 }
07044
07045
07046
07047 k = 1;
07048 pr[0] = coner;
07049 pi[0] = conei;
07050 sumar = gama[0];
07051 sumai = zeroi;
07052 ap[0] = 1.;
07053 if (aw2 < *tol) {
07054 goto L20;
07055 }
07056 for (k = 2; k <= 30; ++k) {
07057 pr[k - 1] = pr[k - 2] * w2r - pi[k - 2] * w2i;
07058 pi[k - 1] = pr[k - 2] * w2i + pi[k - 2] * w2r;
07059 sumar += pr[k - 1] * gama[k - 1];
07060 sumai += pi[k - 1] * gama[k - 1];
07061 ap[k - 1] = ap[k - 2] * aw2;
07062 if (ap[k - 1] < *tol) {
07063 goto L20;
07064 }
07065
07066 }
07067 k = 30;
07068 L20:
07069 kmax = k;
07070 zetar = w2r * sumar - w2i * sumai;
07071 zetai = w2r * sumai + w2i * sumar;
07072 *argr = zetar * fn23;
07073 *argi = zetai * fn23;
07074 zzzsqrt_(&sumar, &sumai, &zar, &zai);
07075 zzzsqrt_(&w2r, &w2i, &str, &sti);
07076 *zeta2r = str * *fnu;
07077 *zeta2i = sti * *fnu;
07078 str = coner + ex2 * (zetar * zar - zetai * zai);
07079 sti = conei + ex2 * (zetar * zai + zetai * zar);
07080 *zeta1r = str * *zeta2r - sti * *zeta2i;
07081 *zeta1i = str * *zeta2i + sti * *zeta2r;
07082 zar += zar;
07083 zai += zai;
07084 zzzsqrt_(&zar, &zai, &str, &sti);
07085 *phir = str * rfn13;
07086 *phii = sti * rfn13;
07087 if (*ipmtr == 1) {
07088 goto L120;
07089 }
07090
07091
07092
07093 sumbr = zeror;
07094 sumbi = zeroi;
07095 i__1 = kmax;
07096 for (k = 1; k <= i__1; ++k) {
07097 sumbr += pr[k - 1] * beta[k - 1];
07098 sumbi += pi[k - 1] * beta[k - 1];
07099
07100 }
07101 *asumr = zeror;
07102 *asumi = zeroi;
07103 *bsumr = sumbr;
07104 *bsumi = sumbi;
07105 l1 = 0;
07106 l2 = 30;
07107 btol = *tol * (abs(*bsumr) + abs(*bsumi));
07108 atol = *tol;
07109 pp = 1.;
07110 ias = 0;
07111 ibs = 0;
07112 if (rfnu2 < *tol) {
07113 goto L110;
07114 }
07115 for (is = 2; is <= 7; ++is) {
07116 atol /= rfnu2;
07117 pp *= rfnu2;
07118 if (ias == 1) {
07119 goto L60;
07120 }
07121 sumar = zeror;
07122 sumai = zeroi;
07123 i__1 = kmax;
07124 for (k = 1; k <= i__1; ++k) {
07125 m = l1 + k;
07126 sumar += pr[k - 1] * alfa[m - 1];
07127 sumai += pi[k - 1] * alfa[m - 1];
07128 if (ap[k - 1] < atol) {
07129 goto L50;
07130 }
07131
07132 }
07133 L50:
07134 *asumr += sumar * pp;
07135 *asumi += sumai * pp;
07136 if (pp < *tol) {
07137 ias = 1;
07138 }
07139 L60:
07140 if (ibs == 1) {
07141 goto L90;
07142 }
07143 sumbr = zeror;
07144 sumbi = zeroi;
07145 i__1 = kmax;
07146 for (k = 1; k <= i__1; ++k) {
07147 m = l2 + k;
07148 sumbr += pr[k - 1] * beta[m - 1];
07149 sumbi += pi[k - 1] * beta[m - 1];
07150 if (ap[k - 1] < atol) {
07151 goto L80;
07152 }
07153
07154 }
07155 L80:
07156 *bsumr += sumbr * pp;
07157 *bsumi += sumbi * pp;
07158 if (pp < btol) {
07159 ibs = 1;
07160 }
07161 L90:
07162 if (ias == 1 && ibs == 1) {
07163 goto L110;
07164 }
07165 l1 += 30;
07166 l2 += 30;
07167
07168 }
07169 L110:
07170 *asumr += coner;
07171 pp = rfnu * rfn13;
07172 *bsumr *= pp;
07173 *bsumi *= pp;
07174 L120:
07175 return 0;
07176
07177
07178
07179 L130:
07180 zzzsqrt_(&w2r, &w2i, &wr, &wi);
07181 if (wr < 0.) {
07182 wr = 0.;
07183 }
07184 if (wi < 0.) {
07185 wi = 0.;
07186 }
07187 str = coner + wr;
07188 sti = wi;
07189 zdiv_(&str, &sti, &zbr, &zbi, &zar, &zai);
07190 zzzlog_(&zar, &zai, &zcr, &zci, &idum);
07191 if (zci < 0.) {
07192 zci = 0.;
07193 }
07194 if (zci > hpi) {
07195 zci = hpi;
07196 }
07197 if (zcr < 0.) {
07198 zcr = 0.;
07199 }
07200 zthr = (zcr - wr) * 1.5;
07201 zthi = (zci - wi) * 1.5;
07202 *zeta1r = zcr * *fnu;
07203 *zeta1i = zci * *fnu;
07204 *zeta2r = wr * *fnu;
07205 *zeta2i = wi * *fnu;
07206 azth = zabs_(&zthr, &zthi);
07207 ang = thpi;
07208 if (zthr >= 0. && zthi < 0.) {
07209 goto L140;
07210 }
07211 ang = hpi;
07212 if (zthr == 0.) {
07213 goto L140;
07214 }
07215 ang = atan(zthi / zthr);
07216 if (zthr < 0.) {
07217 ang += gpi;
07218 }
07219 L140:
07220 pp = pow(azth, ex2);
07221 ang *= ex2;
07222 zetar = pp * cos(ang);
07223 zetai = pp * sin(ang);
07224 if (zetai < 0.) {
07225 zetai = 0.;
07226 }
07227 *argr = zetar * fn23;
07228 *argi = zetai * fn23;
07229 zdiv_(&zthr, &zthi, &zetar, &zetai, &rtztr, &rtzti);
07230 zdiv_(&rtztr, &rtzti, &wr, &wi, &zar, &zai);
07231 tzar = zar + zar;
07232 tzai = zai + zai;
07233 zzzsqrt_(&tzar, &tzai, &str, &sti);
07234 *phir = str * rfn13;
07235 *phii = sti * rfn13;
07236 if (*ipmtr == 1) {
07237 goto L120;
07238 }
07239 raw = 1. / sqrt(aw2);
07240 str = wr * raw;
07241 sti = -wi * raw;
07242 tfnr = str * rfnu * raw;
07243 tfni = sti * rfnu * raw;
07244 razth = 1. / azth;
07245 str = zthr * razth;
07246 sti = -zthi * razth;
07247 rzthr = str * razth * rfnu;
07248 rzthi = sti * razth * rfnu;
07249 zcr = rzthr * ar[1];
07250 zci = rzthi * ar[1];
07251 raw2 = 1. / aw2;
07252 str = w2r * raw2;
07253 sti = -w2i * raw2;
07254 t2r = str * raw2;
07255 t2i = sti * raw2;
07256 str = t2r * c__[1] + c__[2];
07257 sti = t2i * c__[1];
07258 upr[1] = str * tfnr - sti * tfni;
07259 upi[1] = str * tfni + sti * tfnr;
07260 *bsumr = upr[1] + zcr;
07261 *bsumi = upi[1] + zci;
07262 *asumr = zeror;
07263 *asumi = zeroi;
07264 if (rfnu < *tol) {
07265 goto L220;
07266 }
07267 przthr = rzthr;
07268 przthi = rzthi;
07269 ptfnr = tfnr;
07270 ptfni = tfni;
07271 upr[0] = coner;
07272 upi[0] = conei;
07273 pp = 1.;
07274 btol = *tol * (abs(*bsumr) + abs(*bsumi));
07275 ks = 0;
07276 kp1 = 2;
07277 l = 3;
07278 ias = 0;
07279 ibs = 0;
07280 for (lr = 2; lr <= 12; lr += 2) {
07281 lrp1 = lr + 1;
07282
07283
07284
07285
07286 i__1 = lrp1;
07287 for (k = lr; k <= i__1; ++k) {
07288 ++ks;
07289 ++kp1;
07290 ++l;
07291 zar = c__[l - 1];
07292 zai = zeroi;
07293 i__2 = kp1;
07294 for (j = 2; j <= i__2; ++j) {
07295 ++l;
07296 str = zar * t2r - t2i * zai + c__[l - 1];
07297 zai = zar * t2i + zai * t2r;
07298 zar = str;
07299
07300 }
07301 str = ptfnr * tfnr - ptfni * tfni;
07302 ptfni = ptfnr * tfni + ptfni * tfnr;
07303 ptfnr = str;
07304 upr[kp1 - 1] = ptfnr * zar - ptfni * zai;
07305 upi[kp1 - 1] = ptfni * zar + ptfnr * zai;
07306 crr[ks - 1] = przthr * br[ks];
07307 cri[ks - 1] = przthi * br[ks];
07308 str = przthr * rzthr - przthi * rzthi;
07309 przthi = przthr * rzthi + przthi * rzthr;
07310 przthr = str;
07311 drr[ks - 1] = przthr * ar[ks + 1];
07312 dri[ks - 1] = przthi * ar[ks + 1];
07313
07314 }
07315 pp *= rfnu2;
07316 if (ias == 1) {
07317 goto L180;
07318 }
07319 sumar = upr[lrp1 - 1];
07320 sumai = upi[lrp1 - 1];
07321 ju = lrp1;
07322 i__1 = lr;
07323 for (jr = 1; jr <= i__1; ++jr) {
07324 --ju;
07325 sumar = sumar + crr[jr - 1] * upr[ju - 1] - cri[jr - 1] * upi[ju
07326 - 1];
07327 sumai = sumai + crr[jr - 1] * upi[ju - 1] + cri[jr - 1] * upr[ju
07328 - 1];
07329
07330 }
07331 *asumr += sumar;
07332 *asumi += sumai;
07333 test = abs(sumar) + abs(sumai);
07334 if (pp < *tol && test < *tol) {
07335 ias = 1;
07336 }
07337 L180:
07338 if (ibs == 1) {
07339 goto L200;
07340 }
07341 sumbr = upr[lr + 1] + upr[lrp1 - 1] * zcr - upi[lrp1 - 1] * zci;
07342 sumbi = upi[lr + 1] + upr[lrp1 - 1] * zci + upi[lrp1 - 1] * zcr;
07343 ju = lrp1;
07344 i__1 = lr;
07345 for (jr = 1; jr <= i__1; ++jr) {
07346 --ju;
07347 sumbr = sumbr + drr[jr - 1] * upr[ju - 1] - dri[jr - 1] * upi[ju
07348 - 1];
07349 sumbi = sumbi + drr[jr - 1] * upi[ju - 1] + dri[jr - 1] * upr[ju
07350 - 1];
07351
07352 }
07353 *bsumr += sumbr;
07354 *bsumi += sumbi;
07355 test = abs(sumbr) + abs(sumbi);
07356 if (pp < btol && test < btol) {
07357 ibs = 1;
07358 }
07359 L200:
07360 if (ias == 1 && ibs == 1) {
07361 goto L220;
07362 }
07363
07364 }
07365 L220:
07366 *asumr += coner;
07367 str = -(*bsumr) * rfn13;
07368 sti = -(*bsumi) * rfn13;
07369 zdiv_(&str, &sti, &rtztr, &rtzti, bsumr, bsumi);
07370 goto L120;
07371 }
07372
07373 int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu,
07374 integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
07375 yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
07376 {
07377
07378
07379 static doublereal zeror = 0.;
07380 static doublereal zeroi = 0.;
07381 static doublereal coner = 1.;
07382 static doublereal pi = 3.14159265358979324;
07383
07384
07385 integer i__1;
07386
07387
07388 double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal),
07389 d_sign(doublereal *, doublereal *);
07390
07391
07392 static integer i__, j, k, m, ib, ic;
07393 static doublereal fn;
07394 static integer il, kk, nw;
07395 static doublereal c1i, c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, ang,
07396 asc, cki, fnf;
07397 static integer ifn;
07398 static doublereal ckr;
07399 static integer iuf;
07400 static doublereal cyi[2], fmr, csr, sgn;
07401 static integer inu;
07402 static doublereal bry[3], cyr[2], sti, rzi, zri, str, rzr, zrr, aphi,
07403 cscl, phii[2], crsc;
07404 extern doublereal zabs_(doublereal *, doublereal *);
07405 static doublereal phir[2];
07406 static integer init[2];
07407 static doublereal csrr[3], cssr[3], rast, sumi[2], razr;
07408 extern int zs1s2_(doublereal *, doublereal *, doublereal
07409 *, doublereal *, doublereal *, doublereal *, integer *,
07410 doublereal *, doublereal *, integer *);
07411 static doublereal sumr[2];
07412 static integer iflag, kflag;
07413 static doublereal ascle;
07414 static integer kdflg;
07415 static doublereal phidi;
07416 static integer ipard;
07417 static doublereal csgni, phidr;
07418 static integer initd;
07419 static doublereal cspni, cwrki[48] , sumdi;
07420 extern int zuchk_(doublereal *, doublereal *, integer *,
07421 doublereal *, doublereal *);
07422 static doublereal cspnr, cwrkr[48] , sumdr;
07423 extern doublereal d1mach_(integer *);
07424 extern int zunik_(doublereal *, doublereal *, doublereal
07425 *, integer *, integer *, doublereal *, integer *, doublereal *,
07426 doublereal *, doublereal *, doublereal *, doublereal *,
07427 doublereal *, doublereal *, doublereal *, doublereal *,
07428 doublereal *);
07429 static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
07430 2], zet1dr, zet2dr;
07431
07432
07433
07434
07435
07436
07437
07438
07439
07440
07441
07442
07443
07444
07445
07446 --yi;
07447 --yr;
07448
07449
07450
07451 kdflg = 1;
07452 *nz = 0;
07453
07454
07455
07456
07457 cscl = 1. / *tol;
07458 crsc = *tol;
07459 cssr[0] = cscl;
07460 cssr[1] = coner;
07461 cssr[2] = crsc;
07462 csrr[0] = crsc;
07463 csrr[1] = coner;
07464 csrr[2] = cscl;
07465 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
07466 bry[1] = 1. / bry[0];
07467 bry[2] = d1mach_(&c__2);
07468 zrr = *zr;
07469 zri = *zi;
07470 if (*zr >= 0.) {
07471 goto L10;
07472 }
07473 zrr = -(*zr);
07474 zri = -(*zi);
07475 L10:
07476 j = 2;
07477 i__1 = *n;
07478 for (i__ = 1; i__ <= i__1; ++i__) {
07479
07480
07481
07482 j = 3 - j;
07483 fn = *fnu + (doublereal) ((real) (i__ - 1));
07484 init[j - 1] = 0;
07485 zunik_(&zrr, &zri, &fn, &c__2, &c__0, tol, &init[j - 1], &phir[j - 1],
07486 &phii[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[j - 1],
07487 &zeta2i[j - 1], &sumr[j - 1], &sumi[j - 1], &cwrkr[(j << 4)
07488 - 16], &cwrki[(j << 4) - 16]);
07489 if (*kode == 1) {
07490 goto L20;
07491 }
07492 str = zrr + zeta2r[j - 1];
07493 sti = zri + zeta2i[j - 1];
07494 rast = fn / zabs_(&str, &sti);
07495 str = str * rast * rast;
07496 sti = -sti * rast * rast;
07497 s1r = zeta1r[j - 1] - str;
07498 s1i = zeta1i[j - 1] - sti;
07499 goto L30;
07500 L20:
07501 s1r = zeta1r[j - 1] - zeta2r[j - 1];
07502 s1i = zeta1i[j - 1] - zeta2i[j - 1];
07503 L30:
07504 rs1 = s1r;
07505
07506
07507
07508 if (abs(rs1) > *elim) {
07509 goto L60;
07510 }
07511 if (kdflg == 1) {
07512 kflag = 2;
07513 }
07514 if (abs(rs1) < *alim) {
07515 goto L40;
07516 }
07517
07518
07519
07520 aphi = zabs_(&phir[j - 1], &phii[j - 1]);
07521 rs1 += log(aphi);
07522 if (abs(rs1) > *elim) {
07523 goto L60;
07524 }
07525 if (kdflg == 1) {
07526 kflag = 1;
07527 }
07528 if (rs1 < 0.) {
07529 goto L40;
07530 }
07531 if (kdflg == 1) {
07532 kflag = 3;
07533 }
07534 L40:
07535
07536
07537
07538
07539 s2r = phir[j - 1] * sumr[j - 1] - phii[j - 1] * sumi[j - 1];
07540 s2i = phir[j - 1] * sumi[j - 1] + phii[j - 1] * sumr[j - 1];
07541 str = exp(s1r) * cssr[kflag - 1];
07542 s1r = str * cos(s1i);
07543 s1i = str * sin(s1i);
07544 str = s2r * s1r - s2i * s1i;
07545 s2i = s1r * s2i + s2r * s1i;
07546 s2r = str;
07547 if (kflag != 1) {
07548 goto L50;
07549 }
07550 zuchk_(&s2r, &s2i, &nw, bry, tol);
07551 if (nw != 0) {
07552 goto L60;
07553 }
07554 L50:
07555 cyr[kdflg - 1] = s2r;
07556 cyi[kdflg - 1] = s2i;
07557 yr[i__] = s2r * csrr[kflag - 1];
07558 yi[i__] = s2i * csrr[kflag - 1];
07559 if (kdflg == 2) {
07560 goto L75;
07561 }
07562 kdflg = 2;
07563 goto L70;
07564 L60:
07565 if (rs1 > 0.) {
07566 goto L300;
07567 }
07568
07569
07570
07571 if (*zr < 0.) {
07572 goto L300;
07573 }
07574 kdflg = 1;
07575 yr[i__] = zeror;
07576 yi[i__] = zeroi;
07577 ++(*nz);
07578 if (i__ == 1) {
07579 goto L70;
07580 }
07581 if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
07582 goto L70;
07583 }
07584 yr[i__ - 1] = zeror;
07585 yi[i__ - 1] = zeroi;
07586 ++(*nz);
07587 L70:
07588 ;
07589 }
07590 i__ = *n;
07591 L75:
07592 razr = 1. / zabs_(&zrr, &zri);
07593 str = zrr * razr;
07594 sti = -zri * razr;
07595 rzr = (str + str) * razr;
07596 rzi = (sti + sti) * razr;
07597 ckr = fn * rzr;
07598 cki = fn * rzi;
07599 ib = i__ + 1;
07600 if (*n < ib) {
07601 goto L160;
07602 }
07603
07604
07605
07606
07607 fn = *fnu + (doublereal) ((real) (*n - 1));
07608 ipard = 1;
07609 if (*mr != 0) {
07610 ipard = 0;
07611 }
07612 initd = 0;
07613 zunik_(&zrr, &zri, &fn, &c__2, &ipard, tol, &initd, &phidr, &phidi, &
07614 zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[32], &
07615 cwrki[32]);
07616 if (*kode == 1) {
07617 goto L80;
07618 }
07619 str = zrr + zet2dr;
07620 sti = zri + zet2di;
07621 rast = fn / zabs_(&str, &sti);
07622 str = str * rast * rast;
07623 sti = -sti * rast * rast;
07624 s1r = zet1dr - str;
07625 s1i = zet1di - sti;
07626 goto L90;
07627 L80:
07628 s1r = zet1dr - zet2dr;
07629 s1i = zet1di - zet2di;
07630 L90:
07631 rs1 = s1r;
07632 if (abs(rs1) > *elim) {
07633 goto L95;
07634 }
07635 if (abs(rs1) < *alim) {
07636 goto L100;
07637 }
07638
07639
07640
07641 aphi = zabs_(&phidr, &phidi);
07642 rs1 += log(aphi);
07643 if (abs(rs1) < *elim) {
07644 goto L100;
07645 }
07646 L95:
07647 if (abs(rs1) > 0.) {
07648 goto L300;
07649 }
07650
07651
07652
07653 if (*zr < 0.) {
07654 goto L300;
07655 }
07656 *nz = *n;
07657 i__1 = *n;
07658 for (i__ = 1; i__ <= i__1; ++i__) {
07659 yr[i__] = zeror;
07660 yi[i__] = zeroi;
07661
07662 }
07663 return 0;
07664
07665
07666
07667 L100:
07668 s1r = cyr[0];
07669 s1i = cyi[0];
07670 s2r = cyr[1];
07671 s2i = cyi[1];
07672 c1r = csrr[kflag - 1];
07673 ascle = bry[kflag - 1];
07674 i__1 = *n;
07675 for (i__ = ib; i__ <= i__1; ++i__) {
07676 c2r = s2r;
07677 c2i = s2i;
07678 s2r = ckr * c2r - cki * c2i + s1r;
07679 s2i = ckr * c2i + cki * c2r + s1i;
07680 s1r = c2r;
07681 s1i = c2i;
07682 ckr += rzr;
07683 cki += rzi;
07684 c2r = s2r * c1r;
07685 c2i = s2i * c1r;
07686 yr[i__] = c2r;
07687 yi[i__] = c2i;
07688 if (kflag >= 3) {
07689 goto L120;
07690 }
07691 str = abs(c2r);
07692 sti = abs(c2i);
07693 c2m = max(str,sti);
07694 if (c2m <= ascle) {
07695 goto L120;
07696 }
07697 ++kflag;
07698 ascle = bry[kflag - 1];
07699 s1r *= c1r;
07700 s1i *= c1r;
07701 s2r = c2r;
07702 s2i = c2i;
07703 s1r *= cssr[kflag - 1];
07704 s1i *= cssr[kflag - 1];
07705 s2r *= cssr[kflag - 1];
07706 s2i *= cssr[kflag - 1];
07707 c1r = csrr[kflag - 1];
07708 L120:
07709 ;
07710 }
07711 L160:
07712 if (*mr == 0) {
07713 return 0;
07714 }
07715
07716
07717
07718 *nz = 0;
07719 fmr = (doublereal) ((real) (*mr));
07720 sgn = -DSIGN(pi, fmr);
07721
07722
07723
07724 csgni = sgn;
07725 inu = (integer) ((real) (*fnu));
07726 fnf = *fnu - (doublereal) ((real) inu);
07727 ifn = inu + *n - 1;
07728 ang = fnf * sgn;
07729 cspnr = cos(ang);
07730 cspni = sin(ang);
07731 if (ifn % 2 == 0) {
07732 goto L170;
07733 }
07734 cspnr = -cspnr;
07735 cspni = -cspni;
07736 L170:
07737 asc = bry[0];
07738 iuf = 0;
07739 kk = *n;
07740 kdflg = 1;
07741 --ib;
07742 ic = ib - 1;
07743 i__1 = *n;
07744 for (k = 1; k <= i__1; ++k) {
07745 fn = *fnu + (doublereal) ((real) (kk - 1));
07746
07747
07748
07749
07750 m = 3;
07751 if (*n > 2) {
07752 goto L175;
07753 }
07754 L172:
07755 initd = init[j - 1];
07756 phidr = phir[j - 1];
07757 phidi = phii[j - 1];
07758 zet1dr = zeta1r[j - 1];
07759 zet1di = zeta1i[j - 1];
07760 zet2dr = zeta2r[j - 1];
07761 zet2di = zeta2i[j - 1];
07762 sumdr = sumr[j - 1];
07763 sumdi = sumi[j - 1];
07764 m = j;
07765 j = 3 - j;
07766 goto L180;
07767 L175:
07768 if (kk == *n && ib < *n) {
07769 goto L180;
07770 }
07771 if (kk == ib || kk == ic) {
07772 goto L172;
07773 }
07774 initd = 0;
07775 L180:
07776 zunik_(&zrr, &zri, &fn, &c__1, &c__0, tol, &initd, &phidr, &phidi, &
07777 zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[(m
07778 << 4) - 16], &cwrki[(m << 4) - 16]);
07779 if (*kode == 1) {
07780 goto L200;
07781 }
07782 str = zrr + zet2dr;
07783 sti = zri + zet2di;
07784 rast = fn / zabs_(&str, &sti);
07785 str = str * rast * rast;
07786 sti = -sti * rast * rast;
07787 s1r = -zet1dr + str;
07788 s1i = -zet1di + sti;
07789 goto L210;
07790 L200:
07791 s1r = -zet1dr + zet2dr;
07792 s1i = -zet1di + zet2di;
07793 L210:
07794
07795
07796
07797 rs1 = s1r;
07798 if (abs(rs1) > *elim) {
07799 goto L260;
07800 }
07801 if (kdflg == 1) {
07802 iflag = 2;
07803 }
07804 if (abs(rs1) < *alim) {
07805 goto L220;
07806 }
07807
07808
07809
07810 aphi = zabs_(&phidr, &phidi);
07811 rs1 += log(aphi);
07812 if (abs(rs1) > *elim) {
07813 goto L260;
07814 }
07815 if (kdflg == 1) {
07816 iflag = 1;
07817 }
07818 if (rs1 < 0.) {
07819 goto L220;
07820 }
07821 if (kdflg == 1) {
07822 iflag = 3;
07823 }
07824 L220:
07825 str = phidr * sumdr - phidi * sumdi;
07826 sti = phidr * sumdi + phidi * sumdr;
07827 s2r = -csgni * sti;
07828 s2i = csgni * str;
07829 str = exp(s1r) * cssr[iflag - 1];
07830 s1r = str * cos(s1i);
07831 s1i = str * sin(s1i);
07832 str = s2r * s1r - s2i * s1i;
07833 s2i = s2r * s1i + s2i * s1r;
07834 s2r = str;
07835 if (iflag != 1) {
07836 goto L230;
07837 }
07838 zuchk_(&s2r, &s2i, &nw, bry, tol);
07839 if (nw == 0) {
07840 goto L230;
07841 }
07842 s2r = zeror;
07843 s2i = zeroi;
07844 L230:
07845 cyr[kdflg - 1] = s2r;
07846 cyi[kdflg - 1] = s2i;
07847 c2r = s2r;
07848 c2i = s2i;
07849 s2r *= csrr[iflag - 1];
07850 s2i *= csrr[iflag - 1];
07851
07852
07853
07854 s1r = yr[kk];
07855 s1i = yi[kk];
07856 if (*kode == 1) {
07857 goto L250;
07858 }
07859 zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
07860 *nz += nw;
07861 L250:
07862 yr[kk] = s1r * cspnr - s1i * cspni + s2r;
07863 yi[kk] = cspnr * s1i + cspni * s1r + s2i;
07864 --kk;
07865 cspnr = -cspnr;
07866 cspni = -cspni;
07867 if (c2r != 0. || c2i != 0.) {
07868 goto L255;
07869 }
07870 kdflg = 1;
07871 goto L270;
07872 L255:
07873 if (kdflg == 2) {
07874 goto L275;
07875 }
07876 kdflg = 2;
07877 goto L270;
07878 L260:
07879 if (rs1 > 0.) {
07880 goto L300;
07881 }
07882 s2r = zeror;
07883 s2i = zeroi;
07884 goto L230;
07885 L270:
07886 ;
07887 }
07888 k = *n;
07889 L275:
07890 il = *n - k;
07891 if (il == 0) {
07892 return 0;
07893 }
07894
07895
07896
07897
07898
07899 s1r = cyr[0];
07900 s1i = cyi[0];
07901 s2r = cyr[1];
07902 s2i = cyi[1];
07903 csr = csrr[iflag - 1];
07904 ascle = bry[iflag - 1];
07905 fn = (doublereal) ((real) (inu + il));
07906 i__1 = il;
07907 for (i__ = 1; i__ <= i__1; ++i__) {
07908 c2r = s2r;
07909 c2i = s2i;
07910 s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
07911 s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
07912 s1r = c2r;
07913 s1i = c2i;
07914 fn += -1.;
07915 c2r = s2r * csr;
07916 c2i = s2i * csr;
07917 ckr = c2r;
07918 cki = c2i;
07919 c1r = yr[kk];
07920 c1i = yi[kk];
07921 if (*kode == 1) {
07922 goto L280;
07923 }
07924 zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
07925 *nz += nw;
07926 L280:
07927 yr[kk] = c1r * cspnr - c1i * cspni + c2r;
07928 yi[kk] = c1r * cspni + c1i * cspnr + c2i;
07929 --kk;
07930 cspnr = -cspnr;
07931 cspni = -cspni;
07932 if (iflag >= 3) {
07933 goto L290;
07934 }
07935 c2r = abs(ckr);
07936 c2i = abs(cki);
07937 c2m = max(c2r,c2i);
07938 if (c2m <= ascle) {
07939 goto L290;
07940 }
07941 ++iflag;
07942 ascle = bry[iflag - 1];
07943 s1r *= csr;
07944 s1i *= csr;
07945 s2r = ckr;
07946 s2i = cki;
07947 s1r *= cssr[iflag - 1];
07948 s1i *= cssr[iflag - 1];
07949 s2r *= cssr[iflag - 1];
07950 s2i *= cssr[iflag - 1];
07951 csr = csrr[iflag - 1];
07952 L290:
07953 ;
07954 }
07955 return 0;
07956 L300:
07957 *nz = -1;
07958 return 0;
07959 }
07960
07961 int zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu,
07962 integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
07963 yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
07964 {
07965
07966
07967 static doublereal zeror = 0.;
07968 static doublereal zeroi = 0.;
07969 static doublereal coner = 1.;
07970 static doublereal cr1r = 1.;
07971 static doublereal cr1i = 1.73205080756887729;
07972 static doublereal cr2r = -.5;
07973 static doublereal cr2i = -.866025403784438647;
07974 static doublereal hpi = 1.57079632679489662;
07975 static doublereal pi = 3.14159265358979324;
07976 static doublereal aic = 1.26551212348464539;
07977 static doublereal cipr[4] = { 1.,0.,-1.,0. };
07978 static doublereal cipi[4] = { 0.,-1.,0.,1. };
07979
07980
07981 integer i__1;
07982
07983
07984 double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal),
07985 d_sign(doublereal *, doublereal *);
07986
07987
07988 static integer i__, j, k, ib, ic;
07989 static doublereal fn;
07990 static integer il, kk, in, nw;
07991 static doublereal yy, c1i, c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r,
07992 aii, ang, asc, car, cki, fnf;
07993 static integer nai;
07994 static doublereal air;
07995 static integer ifn;
07996 static doublereal csi, ckr;
07997 static integer iuf;
07998 static doublereal cyi[2], fmr, sar, csr, sgn, zbi;
07999 static integer inu;
08000 static doublereal bry[3], cyr[2], pti, sti, zbr, zni, rzi, ptr, zri, str,
08001 znr, rzr, zrr, daii, aarg;
08002 static integer ndai;
08003 static doublereal dair, aphi, argi[2], cscl, phii[2], crsc, argr[2];
08004 static integer idum;
08005 extern doublereal zabs_(doublereal *, doublereal *);
08006 static doublereal phir[2], csrr[3], cssr[3], rast, razr;
08007 extern int zs1s2_(doublereal *, doublereal *, doublereal
08008 *, doublereal *, doublereal *, doublereal *, integer *,
08009 doublereal *, doublereal *, integer *);
08010 static integer iflag, kflag;
08011 static doublereal argdi, ascle;
08012 static integer kdflg;
08013 static doublereal phidi, argdr;
08014 static integer ipard;
08015 static doublereal csgni, phidr, cspni, asumi[2], bsumi[2];
08016 extern int zuchk_(doublereal *, doublereal *, integer *,
08017 doublereal *, doublereal *);
08018 static doublereal cspnr, asumr[2], bsumr[2];
08019 extern doublereal d1mach_(integer *);
08020 extern int zunhj_(doublereal *, doublereal *, doublereal
08021 *, integer *, doublereal *, doublereal *, doublereal *,
08022 doublereal *, doublereal *, doublereal *, doublereal *,
08023 doublereal *, doublereal *, doublereal *, doublereal *,
08024 doublereal *, doublereal *), zairy_(doublereal *, doublereal *,
08025 integer *, integer *, doublereal *, doublereal *, integer *,
08026 integer *);
08027 static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
08028 2], zet1dr, zet2dr, asumdi, bsumdi, asumdr, bsumdr;
08029
08030
08031
08032
08033
08034
08035
08036
08037
08038
08039
08040
08041
08042
08043
08044
08045
08046
08047
08048 --yi;
08049 --yr;
08050
08051
08052
08053 kdflg = 1;
08054 *nz = 0;
08055
08056
08057
08058
08059 cscl = 1. / *tol;
08060 crsc = *tol;
08061 cssr[0] = cscl;
08062 cssr[1] = coner;
08063 cssr[2] = crsc;
08064 csrr[0] = crsc;
08065 csrr[1] = coner;
08066 csrr[2] = cscl;
08067 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08068 bry[1] = 1. / bry[0];
08069 bry[2] = d1mach_(&c__2);
08070 zrr = *zr;
08071 zri = *zi;
08072 if (*zr >= 0.) {
08073 goto L10;
08074 }
08075 zrr = -(*zr);
08076 zri = -(*zi);
08077 L10:
08078 yy = zri;
08079 znr = zri;
08080 zni = -zrr;
08081 zbr = zrr;
08082 zbi = zri;
08083 inu = (integer) ((real) (*fnu));
08084 fnf = *fnu - (doublereal) ((real) inu);
08085 ang = -hpi * fnf;
08086 car = cos(ang);
08087 sar = sin(ang);
08088 c2r = hpi * sar;
08089 c2i = -hpi * car;
08090 kk = inu % 4 + 1;
08091 str = c2r * cipr[kk - 1] - c2i * cipi[kk - 1];
08092 sti = c2r * cipi[kk - 1] + c2i * cipr[kk - 1];
08093 csr = cr1r * str - cr1i * sti;
08094 csi = cr1r * sti + cr1i * str;
08095 if (yy > 0.) {
08096 goto L20;
08097 }
08098 znr = -znr;
08099 zbi = -zbi;
08100 L20:
08101
08102
08103
08104
08105
08106 j = 2;
08107 i__1 = *n;
08108 for (i__ = 1; i__ <= i__1; ++i__) {
08109
08110
08111
08112 j = 3 - j;
08113 fn = *fnu + (doublereal) ((real) (i__ - 1));
08114 zunhj_(&znr, &zni, &fn, &c__0, tol, &phir[j - 1], &phii[j - 1], &argr[
08115 j - 1], &argi[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[
08116 j - 1], &zeta2i[j - 1], &asumr[j - 1], &asumi[j - 1], &bsumr[
08117 j - 1], &bsumi[j - 1]);
08118 if (*kode == 1) {
08119 goto L30;
08120 }
08121 str = zbr + zeta2r[j - 1];
08122 sti = zbi + zeta2i[j - 1];
08123 rast = fn / zabs_(&str, &sti);
08124 str = str * rast * rast;
08125 sti = -sti * rast * rast;
08126 s1r = zeta1r[j - 1] - str;
08127 s1i = zeta1i[j - 1] - sti;
08128 goto L40;
08129 L30:
08130 s1r = zeta1r[j - 1] - zeta2r[j - 1];
08131 s1i = zeta1i[j - 1] - zeta2i[j - 1];
08132 L40:
08133
08134
08135
08136 rs1 = s1r;
08137 if (abs(rs1) > *elim) {
08138 goto L70;
08139 }
08140 if (kdflg == 1) {
08141 kflag = 2;
08142 }
08143 if (abs(rs1) < *alim) {
08144 goto L50;
08145 }
08146
08147
08148
08149 aphi = zabs_(&phir[j - 1], &phii[j - 1]);
08150 aarg = zabs_(&argr[j - 1], &argi[j - 1]);
08151 rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
08152 if (abs(rs1) > *elim) {
08153 goto L70;
08154 }
08155 if (kdflg == 1) {
08156 kflag = 1;
08157 }
08158 if (rs1 < 0.) {
08159 goto L50;
08160 }
08161 if (kdflg == 1) {
08162 kflag = 3;
08163 }
08164 L50:
08165
08166
08167
08168
08169 c2r = argr[j - 1] * cr2r - argi[j - 1] * cr2i;
08170 c2i = argr[j - 1] * cr2i + argi[j - 1] * cr2r;
08171 zairy_(&c2r, &c2i, &c__0, &c__2, &air, &aii, &nai, &idum);
08172 zairy_(&c2r, &c2i, &c__1, &c__2, &dair, &daii, &ndai, &idum);
08173 str = dair * bsumr[j - 1] - daii * bsumi[j - 1];
08174 sti = dair * bsumi[j - 1] + daii * bsumr[j - 1];
08175 ptr = str * cr2r - sti * cr2i;
08176 pti = str * cr2i + sti * cr2r;
08177 str = ptr + (air * asumr[j - 1] - aii * asumi[j - 1]);
08178 sti = pti + (air * asumi[j - 1] + aii * asumr[j - 1]);
08179 ptr = str * phir[j - 1] - sti * phii[j - 1];
08180 pti = str * phii[j - 1] + sti * phir[j - 1];
08181 s2r = ptr * csr - pti * csi;
08182 s2i = ptr * csi + pti * csr;
08183 str = exp(s1r) * cssr[kflag - 1];
08184 s1r = str * cos(s1i);
08185 s1i = str * sin(s1i);
08186 str = s2r * s1r - s2i * s1i;
08187 s2i = s1r * s2i + s2r * s1i;
08188 s2r = str;
08189 if (kflag != 1) {
08190 goto L60;
08191 }
08192 zuchk_(&s2r, &s2i, &nw, bry, tol);
08193 if (nw != 0) {
08194 goto L70;
08195 }
08196 L60:
08197 if (yy <= 0.) {
08198 s2i = -s2i;
08199 }
08200 cyr[kdflg - 1] = s2r;
08201 cyi[kdflg - 1] = s2i;
08202 yr[i__] = s2r * csrr[kflag - 1];
08203 yi[i__] = s2i * csrr[kflag - 1];
08204 str = csi;
08205 csi = -csr;
08206 csr = str;
08207 if (kdflg == 2) {
08208 goto L85;
08209 }
08210 kdflg = 2;
08211 goto L80;
08212 L70:
08213 if (rs1 > 0.) {
08214 goto L320;
08215 }
08216
08217
08218
08219 if (*zr < 0.) {
08220 goto L320;
08221 }
08222 kdflg = 1;
08223 yr[i__] = zeror;
08224 yi[i__] = zeroi;
08225 ++(*nz);
08226 str = csi;
08227 csi = -csr;
08228 csr = str;
08229 if (i__ == 1) {
08230 goto L80;
08231 }
08232 if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
08233 goto L80;
08234 }
08235 yr[i__ - 1] = zeror;
08236 yi[i__ - 1] = zeroi;
08237 ++(*nz);
08238 L80:
08239 ;
08240 }
08241 i__ = *n;
08242 L85:
08243 razr = 1. / zabs_(&zrr, &zri);
08244 str = zrr * razr;
08245 sti = -zri * razr;
08246 rzr = (str + str) * razr;
08247 rzi = (sti + sti) * razr;
08248 ckr = fn * rzr;
08249 cki = fn * rzi;
08250 ib = i__ + 1;
08251 if (*n < ib) {
08252 goto L180;
08253 }
08254
08255
08256
08257
08258 fn = *fnu + (doublereal) ((real) (*n - 1));
08259 ipard = 1;
08260 if (*mr != 0) {
08261 ipard = 0;
08262 }
08263 zunhj_(&znr, &zni, &fn, &ipard, tol, &phidr, &phidi, &argdr, &argdi, &
08264 zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, &
08265 bsumdi);
08266 if (*kode == 1) {
08267 goto L90;
08268 }
08269 str = zbr + zet2dr;
08270 sti = zbi + zet2di;
08271 rast = fn / zabs_(&str, &sti);
08272 str = str * rast * rast;
08273 sti = -sti * rast * rast;
08274 s1r = zet1dr - str;
08275 s1i = zet1di - sti;
08276 goto L100;
08277 L90:
08278 s1r = zet1dr - zet2dr;
08279 s1i = zet1di - zet2di;
08280 L100:
08281 rs1 = s1r;
08282 if (abs(rs1) > *elim) {
08283 goto L105;
08284 }
08285 if (abs(rs1) < *alim) {
08286 goto L120;
08287 }
08288
08289
08290
08291 aphi = zabs_(&phidr, &phidi);
08292 rs1 += log(aphi);
08293 if (abs(rs1) < *elim) {
08294 goto L120;
08295 }
08296 L105:
08297 if (rs1 > 0.) {
08298 goto L320;
08299 }
08300
08301
08302
08303 if (*zr < 0.) {
08304 goto L320;
08305 }
08306 *nz = *n;
08307 i__1 = *n;
08308 for (i__ = 1; i__ <= i__1; ++i__) {
08309 yr[i__] = zeror;
08310 yi[i__] = zeroi;
08311
08312 }
08313 return 0;
08314 L120:
08315 s1r = cyr[0];
08316 s1i = cyi[0];
08317 s2r = cyr[1];
08318 s2i = cyi[1];
08319 c1r = csrr[kflag - 1];
08320 ascle = bry[kflag - 1];
08321 i__1 = *n;
08322 for (i__ = ib; i__ <= i__1; ++i__) {
08323 c2r = s2r;
08324 c2i = s2i;
08325 s2r = ckr * c2r - cki * c2i + s1r;
08326 s2i = ckr * c2i + cki * c2r + s1i;
08327 s1r = c2r;
08328 s1i = c2i;
08329 ckr += rzr;
08330 cki += rzi;
08331 c2r = s2r * c1r;
08332 c2i = s2i * c1r;
08333 yr[i__] = c2r;
08334 yi[i__] = c2i;
08335 if (kflag >= 3) {
08336 goto L130;
08337 }
08338 str = abs(c2r);
08339 sti = abs(c2i);
08340 c2m = max(str,sti);
08341 if (c2m <= ascle) {
08342 goto L130;
08343 }
08344 ++kflag;
08345 ascle = bry[kflag - 1];
08346 s1r *= c1r;
08347 s1i *= c1r;
08348 s2r = c2r;
08349 s2i = c2i;
08350 s1r *= cssr[kflag - 1];
08351 s1i *= cssr[kflag - 1];
08352 s2r *= cssr[kflag - 1];
08353 s2i *= cssr[kflag - 1];
08354 c1r = csrr[kflag - 1];
08355 L130:
08356 ;
08357 }
08358 L180:
08359 if (*mr == 0) {
08360 return 0;
08361 }
08362
08363
08364
08365 *nz = 0;
08366 fmr = (doublereal) ((real) (*mr));
08367 sgn = -DSIGN(pi, fmr);
08368
08369
08370
08371 csgni = sgn;
08372 if (yy <= 0.) {
08373 csgni = -csgni;
08374 }
08375 ifn = inu + *n - 1;
08376 ang = fnf * sgn;
08377 cspnr = cos(ang);
08378 cspni = sin(ang);
08379 if (ifn % 2 == 0) {
08380 goto L190;
08381 }
08382 cspnr = -cspnr;
08383 cspni = -cspni;
08384 L190:
08385
08386
08387
08388
08389
08390
08391 csr = sar * csgni;
08392 csi = car * csgni;
08393 in = ifn % 4 + 1;
08394 c2r = cipr[in - 1];
08395 c2i = cipi[in - 1];
08396 str = csr * c2r + csi * c2i;
08397 csi = -csr * c2i + csi * c2r;
08398 csr = str;
08399 asc = bry[0];
08400 iuf = 0;
08401 kk = *n;
08402 kdflg = 1;
08403 --ib;
08404 ic = ib - 1;
08405 i__1 = *n;
08406 for (k = 1; k <= i__1; ++k) {
08407 fn = *fnu + (doublereal) ((real) (kk - 1));
08408
08409
08410
08411
08412 if (*n > 2) {
08413 goto L175;
08414 }
08415 L172:
08416 phidr = phir[j - 1];
08417 phidi = phii[j - 1];
08418 argdr = argr[j - 1];
08419 argdi = argi[j - 1];
08420 zet1dr = zeta1r[j - 1];
08421 zet1di = zeta1i[j - 1];
08422 zet2dr = zeta2r[j - 1];
08423 zet2di = zeta2i[j - 1];
08424 asumdr = asumr[j - 1];
08425 asumdi = asumi[j - 1];
08426 bsumdr = bsumr[j - 1];
08427 bsumdi = bsumi[j - 1];
08428 j = 3 - j;
08429 goto L210;
08430 L175:
08431 if (kk == *n && ib < *n) {
08432 goto L210;
08433 }
08434 if (kk == ib || kk == ic) {
08435 goto L172;
08436 }
08437 zunhj_(&znr, &zni, &fn, &c__0, tol, &phidr, &phidi, &argdr, &argdi, &
08438 zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr,
08439 &bsumdi);
08440 L210:
08441 if (*kode == 1) {
08442 goto L220;
08443 }
08444 str = zbr + zet2dr;
08445 sti = zbi + zet2di;
08446 rast = fn / zabs_(&str, &sti);
08447 str = str * rast * rast;
08448 sti = -sti * rast * rast;
08449 s1r = -zet1dr + str;
08450 s1i = -zet1di + sti;
08451 goto L230;
08452 L220:
08453 s1r = -zet1dr + zet2dr;
08454 s1i = -zet1di + zet2di;
08455 L230:
08456
08457
08458
08459 rs1 = s1r;
08460 if (abs(rs1) > *elim) {
08461 goto L280;
08462 }
08463 if (kdflg == 1) {
08464 iflag = 2;
08465 }
08466 if (abs(rs1) < *alim) {
08467 goto L240;
08468 }
08469
08470
08471
08472 aphi = zabs_(&phidr, &phidi);
08473 aarg = zabs_(&argdr, &argdi);
08474 rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
08475 if (abs(rs1) > *elim) {
08476 goto L280;
08477 }
08478 if (kdflg == 1) {
08479 iflag = 1;
08480 }
08481 if (rs1 < 0.) {
08482 goto L240;
08483 }
08484 if (kdflg == 1) {
08485 iflag = 3;
08486 }
08487 L240:
08488 zairy_(&argdr, &argdi, &c__0, &c__2, &air, &aii, &nai, &idum);
08489 zairy_(&argdr, &argdi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
08490 str = dair * bsumdr - daii * bsumdi;
08491 sti = dair * bsumdi + daii * bsumdr;
08492 str += air * asumdr - aii * asumdi;
08493 sti += air * asumdi + aii * asumdr;
08494 ptr = str * phidr - sti * phidi;
08495 pti = str * phidi + sti * phidr;
08496 s2r = ptr * csr - pti * csi;
08497 s2i = ptr * csi + pti * csr;
08498 str = exp(s1r) * cssr[iflag - 1];
08499 s1r = str * cos(s1i);
08500 s1i = str * sin(s1i);
08501 str = s2r * s1r - s2i * s1i;
08502 s2i = s2r * s1i + s2i * s1r;
08503 s2r = str;
08504 if (iflag != 1) {
08505 goto L250;
08506 }
08507 zuchk_(&s2r, &s2i, &nw, bry, tol);
08508 if (nw == 0) {
08509 goto L250;
08510 }
08511 s2r = zeror;
08512 s2i = zeroi;
08513 L250:
08514 if (yy <= 0.) {
08515 s2i = -s2i;
08516 }
08517 cyr[kdflg - 1] = s2r;
08518 cyi[kdflg - 1] = s2i;
08519 c2r = s2r;
08520 c2i = s2i;
08521 s2r *= csrr[iflag - 1];
08522 s2i *= csrr[iflag - 1];
08523
08524
08525
08526 s1r = yr[kk];
08527 s1i = yi[kk];
08528 if (*kode == 1) {
08529 goto L270;
08530 }
08531 zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
08532 *nz += nw;
08533 L270:
08534 yr[kk] = s1r * cspnr - s1i * cspni + s2r;
08535 yi[kk] = s1r * cspni + s1i * cspnr + s2i;
08536 --kk;
08537 cspnr = -cspnr;
08538 cspni = -cspni;
08539 str = csi;
08540 csi = -csr;
08541 csr = str;
08542 if (c2r != 0. || c2i != 0.) {
08543 goto L255;
08544 }
08545 kdflg = 1;
08546 goto L290;
08547 L255:
08548 if (kdflg == 2) {
08549 goto L295;
08550 }
08551 kdflg = 2;
08552 goto L290;
08553 L280:
08554 if (rs1 > 0.) {
08555 goto L320;
08556 }
08557 s2r = zeror;
08558 s2i = zeroi;
08559 goto L250;
08560 L290:
08561 ;
08562 }
08563 k = *n;
08564 L295:
08565 il = *n - k;
08566 if (il == 0) {
08567 return 0;
08568 }
08569
08570
08571
08572
08573
08574 s1r = cyr[0];
08575 s1i = cyi[0];
08576 s2r = cyr[1];
08577 s2i = cyi[1];
08578 csr = csrr[iflag - 1];
08579 ascle = bry[iflag - 1];
08580 fn = (doublereal) ((real) (inu + il));
08581 i__1 = il;
08582 for (i__ = 1; i__ <= i__1; ++i__) {
08583 c2r = s2r;
08584 c2i = s2i;
08585 s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
08586 s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
08587 s1r = c2r;
08588 s1i = c2i;
08589 fn += -1.;
08590 c2r = s2r * csr;
08591 c2i = s2i * csr;
08592 ckr = c2r;
08593 cki = c2i;
08594 c1r = yr[kk];
08595 c1i = yi[kk];
08596 if (*kode == 1) {
08597 goto L300;
08598 }
08599 zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
08600 *nz += nw;
08601 L300:
08602 yr[kk] = c1r * cspnr - c1i * cspni + c2r;
08603 yi[kk] = c1r * cspni + c1i * cspnr + c2i;
08604 --kk;
08605 cspnr = -cspnr;
08606 cspni = -cspni;
08607 if (iflag >= 3) {
08608 goto L310;
08609 }
08610 c2r = abs(ckr);
08611 c2i = abs(cki);
08612 c2m = max(c2r,c2i);
08613 if (c2m <= ascle) {
08614 goto L310;
08615 }
08616 ++iflag;
08617 ascle = bry[iflag - 1];
08618 s1r *= csr;
08619 s1i *= csr;
08620 s2r = ckr;
08621 s2i = cki;
08622 s1r *= cssr[iflag - 1];
08623 s1i *= cssr[iflag - 1];
08624 s2r *= cssr[iflag - 1];
08625 s2i *= cssr[iflag - 1];
08626 csr = csrr[iflag - 1];
08627 L310:
08628 ;
08629 }
08630 return 0;
08631 L320:
08632 *nz = -1;
08633 return 0;
08634 }
08635
08636 int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu,
08637 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
08638 nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol,
08639 doublereal *elim, doublereal *alim)
08640 {
08641
08642 integer i__1;
08643
08644
08645 static integer i__, k;
08646 static doublereal ax, ay;
08647 static integer nl, nw;
08648 static doublereal c1i, c1m, c1r, s1i, s2i, s1r, s2r, cyi[2], gnu, raz,
08649 cyr[2], sti, bry[3], rzi, str, rzr, dfnu;
08650 extern doublereal zabs_(doublereal *, doublereal *);
08651 static doublereal fnui;
08652 extern int zuni1_(doublereal *, doublereal *, doublereal
08653 *, integer *, integer *, doublereal *, doublereal *, integer *,
08654 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
08655 , zuni2_(doublereal *, doublereal *, doublereal *, integer *,
08656 integer *, doublereal *, doublereal *, integer *, integer *,
08657 doublereal *, doublereal *, doublereal *, doublereal *);
08658 static integer iflag;
08659 static doublereal ascle, csclr, cscrr;
08660 static integer iform;
08661 extern doublereal d1mach_(integer *);
08662
08663
08664
08665
08666
08667
08668
08669
08670
08671
08672
08673
08674
08675
08676 --yi;
08677 --yr;
08678
08679
08680 *nz = 0;
08681 ax = abs(*zr) * 1.7321;
08682 ay = abs(*zi);
08683 iform = 1;
08684 if (ay > ax) {
08685 iform = 2;
08686 }
08687 if (*nui == 0) {
08688 goto L60;
08689 }
08690 fnui = (doublereal) ((real) (*nui));
08691 dfnu = *fnu + (doublereal) ((real) (*n - 1));
08692 gnu = dfnu + fnui;
08693 if (iform == 2) {
08694 goto L10;
08695 }
08696
08697
08698
08699
08700 zuni1_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim,
08701 alim);
08702 goto L20;
08703 L10:
08704
08705
08706
08707
08708
08709 zuni2_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim,
08710 alim);
08711 L20:
08712 if (nw < 0) {
08713 goto L50;
08714 }
08715 if (nw != 0) {
08716 goto L90;
08717 }
08718 str = zabs_(cyr, cyi);
08719
08720
08721
08722 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08723 bry[1] = 1. / bry[0];
08724 bry[2] = bry[1];
08725 iflag = 2;
08726 ascle = bry[1];
08727 csclr = 1.;
08728 if (str > bry[0]) {
08729 goto L21;
08730 }
08731 iflag = 1;
08732 ascle = bry[0];
08733 csclr = 1. / *tol;
08734 goto L25;
08735 L21:
08736 if (str < bry[1]) {
08737 goto L25;
08738 }
08739 iflag = 3;
08740 ascle = bry[2];
08741 csclr = *tol;
08742 L25:
08743 cscrr = 1. / csclr;
08744 s1r = cyr[1] * csclr;
08745 s1i = cyi[1] * csclr;
08746 s2r = cyr[0] * csclr;
08747 s2i = cyi[0] * csclr;
08748 raz = 1. / zabs_(zr, zi);
08749 str = *zr * raz;
08750 sti = -(*zi) * raz;
08751 rzr = (str + str) * raz;
08752 rzi = (sti + sti) * raz;
08753 i__1 = *nui;
08754 for (i__ = 1; i__ <= i__1; ++i__) {
08755 str = s2r;
08756 sti = s2i;
08757 s2r = (dfnu + fnui) * (rzr * str - rzi * sti) + s1r;
08758 s2i = (dfnu + fnui) * (rzr * sti + rzi * str) + s1i;
08759 s1r = str;
08760 s1i = sti;
08761 fnui += -1.;
08762 if (iflag >= 3) {
08763 goto L30;
08764 }
08765 str = s2r * cscrr;
08766 sti = s2i * cscrr;
08767 c1r = abs(str);
08768 c1i = abs(sti);
08769 c1m = max(c1r,c1i);
08770 if (c1m <= ascle) {
08771 goto L30;
08772 }
08773 ++iflag;
08774 ascle = bry[iflag - 1];
08775 s1r *= cscrr;
08776 s1i *= cscrr;
08777 s2r = str;
08778 s2i = sti;
08779 csclr *= *tol;
08780 cscrr = 1. / csclr;
08781 s1r *= csclr;
08782 s1i *= csclr;
08783 s2r *= csclr;
08784 s2i *= csclr;
08785 L30:
08786 ;
08787 }
08788 yr[*n] = s2r * cscrr;
08789 yi[*n] = s2i * cscrr;
08790 if (*n == 1) {
08791 return 0;
08792 }
08793 nl = *n - 1;
08794 fnui = (doublereal) ((real) nl);
08795 k = nl;
08796 i__1 = nl;
08797 for (i__ = 1; i__ <= i__1; ++i__) {
08798 str = s2r;
08799 sti = s2i;
08800 s2r = (*fnu + fnui) * (rzr * str - rzi * sti) + s1r;
08801 s2i = (*fnu + fnui) * (rzr * sti + rzi * str) + s1i;
08802 s1r = str;
08803 s1i = sti;
08804 str = s2r * cscrr;
08805 sti = s2i * cscrr;
08806 yr[k] = str;
08807 yi[k] = sti;
08808 fnui += -1.;
08809 --k;
08810 if (iflag >= 3) {
08811 goto L40;
08812 }
08813 c1r = abs(str);
08814 c1i = abs(sti);
08815 c1m = max(c1r,c1i);
08816 if (c1m <= ascle) {
08817 goto L40;
08818 }
08819 ++iflag;
08820 ascle = bry[iflag - 1];
08821 s1r *= cscrr;
08822 s1i *= cscrr;
08823 s2r = str;
08824 s2i = sti;
08825 csclr *= *tol;
08826 cscrr = 1. / csclr;
08827 s1r *= csclr;
08828 s1i *= csclr;
08829 s2r *= csclr;
08830 s2i *= csclr;
08831 L40:
08832 ;
08833 }
08834 return 0;
08835 L50:
08836 *nz = -1;
08837 if (nw == -2) {
08838 *nz = -2;
08839 }
08840 return 0;
08841 L60:
08842 if (iform == 2) {
08843 goto L70;
08844 }
08845
08846
08847
08848
08849 zuni1_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim,
08850 alim);
08851 goto L80;
08852 L70:
08853
08854
08855
08856
08857
08858 zuni2_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim,
08859 alim);
08860 L80:
08861 if (nw < 0) {
08862 goto L50;
08863 }
08864 *nz = nw;
08865 return 0;
08866 L90:
08867 *nlast = *n;
08868 return 0;
08869 }
08870
08871 int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu,
08872 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
08873 nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
08874 elim, doublereal *alim)
08875 {
08876
08877
08878 static doublereal zeror = 0.;
08879 static doublereal zeroi = 0.;
08880 static doublereal coner = 1.;
08881
08882
08883 integer i__1;
08884
08885
08886 double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
08887
08888
08889 static integer i__, k, m, nd;
08890 static doublereal fn;
08891 static integer nn, nw;
08892 static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, cyi[2];
08893 static integer nuf;
08894 static doublereal bry[3], cyr[2], sti, rzi, str, rzr, aphi, cscl, phii,
08895 crsc;
08896 extern doublereal zabs_(doublereal *, doublereal *);
08897 static doublereal phir;
08898 static integer init;
08899 static doublereal csrr[3], cssr[3], rast, sumi, sumr;
08900 static integer iflag;
08901 static doublereal ascle, cwrki[16];
08902 extern int zuchk_(doublereal *, doublereal *, integer *,
08903 doublereal *, doublereal *);
08904 static doublereal cwrkr[16];
08905 extern doublereal d1mach_(integer *);
08906 extern int zunik_(doublereal *, doublereal *, doublereal
08907 *, integer *, integer *, doublereal *, integer *, doublereal *,
08908 doublereal *, doublereal *, doublereal *, doublereal *,
08909 doublereal *, doublereal *, doublereal *, doublereal *,
08910 doublereal *), zuoik_(doublereal *, doublereal *, doublereal *,
08911 integer *, integer *, integer *, doublereal *, doublereal *,
08912 integer *, doublereal *, doublereal *, doublereal *);
08913 static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
08914
08915
08916
08917
08918
08919
08920
08921
08922
08923
08924
08925
08926
08927
08928
08929
08930
08931
08932 --yi;
08933 --yr;
08934
08935
08936
08937 *nz = 0;
08938 nd = *n;
08939 *nlast = 0;
08940
08941
08942
08943
08944
08945 cscl = 1. / *tol;
08946 crsc = *tol;
08947 cssr[0] = cscl;
08948 cssr[1] = coner;
08949 cssr[2] = crsc;
08950 csrr[0] = crsc;
08951 csrr[1] = coner;
08952 csrr[2] = cscl;
08953 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08954
08955
08956
08957 fn = max(*fnu,1.);
08958 init = 0;
08959 zunik_(zr, zi, &fn, &c__1, &c__1, tol, &init, &phir, &phii, &zeta1r, &
08960 zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
08961 if (*kode == 1) {
08962 goto L10;
08963 }
08964 str = *zr + zeta2r;
08965 sti = *zi + zeta2i;
08966 rast = fn / zabs_(&str, &sti);
08967 str = str * rast * rast;
08968 sti = -sti * rast * rast;
08969 s1r = -zeta1r + str;
08970 s1i = -zeta1i + sti;
08971 goto L20;
08972 L10:
08973 s1r = -zeta1r + zeta2r;
08974 s1i = -zeta1i + zeta2i;
08975 L20:
08976 rs1 = s1r;
08977 if (abs(rs1) > *elim) {
08978 goto L130;
08979 }
08980 L30:
08981 nn = min(2,nd);
08982 i__1 = nn;
08983 for (i__ = 1; i__ <= i__1; ++i__) {
08984 fn = *fnu + (doublereal) ((real) (nd - i__));
08985 init = 0;
08986 zunik_(zr, zi, &fn, &c__1, &c__0, tol, &init, &phir, &phii, &zeta1r, &
08987 zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
08988 if (*kode == 1) {
08989 goto L40;
08990 }
08991 str = *zr + zeta2r;
08992 sti = *zi + zeta2i;
08993 rast = fn / zabs_(&str, &sti);
08994 str = str * rast * rast;
08995 sti = -sti * rast * rast;
08996 s1r = -zeta1r + str;
08997 s1i = -zeta1i + sti + *zi;
08998 goto L50;
08999 L40:
09000 s1r = -zeta1r + zeta2r;
09001 s1i = -zeta1i + zeta2i;
09002 L50:
09003
09004
09005
09006 rs1 = s1r;
09007 if (abs(rs1) > *elim) {
09008 goto L110;
09009 }
09010 if (i__ == 1) {
09011 iflag = 2;
09012 }
09013 if (abs(rs1) < *alim) {
09014 goto L60;
09015 }
09016
09017
09018
09019 aphi = zabs_(&phir, &phii);
09020 rs1 += log(aphi);
09021 if (abs(rs1) > *elim) {
09022 goto L110;
09023 }
09024 if (i__ == 1) {
09025 iflag = 1;
09026 }
09027 if (rs1 < 0.) {
09028 goto L60;
09029 }
09030 if (i__ == 1) {
09031 iflag = 3;
09032 }
09033 L60:
09034
09035
09036
09037 s2r = phir * sumr - phii * sumi;
09038 s2i = phir * sumi + phii * sumr;
09039 str = exp(s1r) * cssr[iflag - 1];
09040 s1r = str * cos(s1i);
09041 s1i = str * sin(s1i);
09042 str = s2r * s1r - s2i * s1i;
09043 s2i = s2r * s1i + s2i * s1r;
09044 s2r = str;
09045 if (iflag != 1) {
09046 goto L70;
09047 }
09048 zuchk_(&s2r, &s2i, &nw, bry, tol);
09049 if (nw != 0) {
09050 goto L110;
09051 }
09052 L70:
09053 cyr[i__ - 1] = s2r;
09054 cyi[i__ - 1] = s2i;
09055 m = nd - i__ + 1;
09056 yr[m] = s2r * csrr[iflag - 1];
09057 yi[m] = s2i * csrr[iflag - 1];
09058
09059 }
09060 if (nd <= 2) {
09061 goto L100;
09062 }
09063 rast = 1. / zabs_(zr, zi);
09064 str = *zr * rast;
09065 sti = -(*zi) * rast;
09066 rzr = (str + str) * rast;
09067 rzi = (sti + sti) * rast;
09068 bry[1] = 1. / bry[0];
09069 bry[2] = d1mach_(&c__2);
09070 s1r = cyr[0];
09071 s1i = cyi[0];
09072 s2r = cyr[1];
09073 s2i = cyi[1];
09074 c1r = csrr[iflag - 1];
09075 ascle = bry[iflag - 1];
09076 k = nd - 2;
09077 fn = (doublereal) ((real) k);
09078 i__1 = nd;
09079 for (i__ = 3; i__ <= i__1; ++i__) {
09080 c2r = s2r;
09081 c2i = s2i;
09082 s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
09083 s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
09084 s1r = c2r;
09085 s1i = c2i;
09086 c2r = s2r * c1r;
09087 c2i = s2i * c1r;
09088 yr[k] = c2r;
09089 yi[k] = c2i;
09090 --k;
09091 fn += -1.;
09092 if (iflag >= 3) {
09093 goto L90;
09094 }
09095 str = abs(c2r);
09096 sti = abs(c2i);
09097 c2m = max(str,sti);
09098 if (c2m <= ascle) {
09099 goto L90;
09100 }
09101 ++iflag;
09102 ascle = bry[iflag - 1];
09103 s1r *= c1r;
09104 s1i *= c1r;
09105 s2r = c2r;
09106 s2i = c2i;
09107 s1r *= cssr[iflag - 1];
09108 s1i *= cssr[iflag - 1];
09109 s2r *= cssr[iflag - 1];
09110 s2i *= cssr[iflag - 1];
09111 c1r = csrr[iflag - 1];
09112 L90:
09113 ;
09114 }
09115 L100:
09116 return 0;
09117
09118
09119
09120 L110:
09121 if (rs1 > 0.) {
09122 goto L120;
09123 }
09124 yr[nd] = zeror;
09125 yi[nd] = zeroi;
09126 ++(*nz);
09127 --nd;
09128 if (nd == 0) {
09129 goto L100;
09130 }
09131 zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim,
09132 alim);
09133 if (nuf < 0) {
09134 goto L120;
09135 }
09136 nd -= nuf;
09137 *nz += nuf;
09138 if (nd == 0) {
09139 goto L100;
09140 }
09141 fn = *fnu + (doublereal) ((real) (nd - 1));
09142 if (fn >= *fnul) {
09143 goto L30;
09144 }
09145 *nlast = nd;
09146 return 0;
09147 L120:
09148 *nz = -1;
09149 return 0;
09150 L130:
09151 if (rs1 > 0.) {
09152 goto L120;
09153 }
09154 *nz = *n;
09155 i__1 = *n;
09156 for (i__ = 1; i__ <= i__1; ++i__) {
09157 yr[i__] = zeror;
09158 yi[i__] = zeroi;
09159
09160 }
09161 return 0;
09162 }
09163
09164 int zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu,
09165 integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
09166 nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
09167 elim, doublereal *alim)
09168 {
09169
09170
09171 static doublereal zeror = 0.;
09172 static doublereal zeroi = 0.;
09173 static doublereal coner = 1.;
09174 static doublereal cipr[4] = { 1.,0.,-1.,0. };
09175 static doublereal cipi[4] = { 0.,1.,0.,-1. };
09176 static doublereal hpi = 1.57079632679489662;
09177 static doublereal aic = 1.265512123484645396;
09178
09179
09180 integer i__1;
09181
09182
09183 double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal);
09184
09185
09186 static integer i__, j, k, nd;
09187 static doublereal fn;
09188 static integer in, nn, nw;
09189 static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, aii, ang,
09190 car;
09191 static integer nai;
09192 static doublereal air, zbi, cyi[2], sar;
09193 static integer nuf, inu;
09194 static doublereal bry[3], raz, sti, zbr, zni, cyr[2], rzi, str, znr, rzr,
09195 daii, cidi, aarg;
09196 static integer ndai;
09197 static doublereal dair, aphi, argi, cscl, phii, crsc, argr;
09198 static integer idum;
09199 extern doublereal zabs_(doublereal *, doublereal *);
09200 static doublereal phir, csrr[3], cssr[3], rast;
09201 static integer iflag;
09202 static doublereal ascle, asumi, bsumi;
09203 extern int zuchk_(doublereal *, doublereal *, integer *,
09204 doublereal *, doublereal *);
09205 static doublereal asumr, bsumr;
09206 extern doublereal d1mach_(integer *);
09207 extern int zunhj_(doublereal *, doublereal *, doublereal
09208 *, integer *, doublereal *, doublereal *, doublereal *,
09209 doublereal *, doublereal *, doublereal *, doublereal *,
09210 doublereal *, doublereal *, doublereal *, doublereal *,
09211 doublereal *, doublereal *), zairy_(doublereal *, doublereal *,
09212 integer *, integer *, doublereal *, doublereal *, integer *,
09213 integer *), zuoik_(doublereal *, doublereal *, doublereal *,
09214 integer *, integer *, integer *, doublereal *, doublereal *,
09215 integer *, doublereal *, doublereal *, doublereal *);
09216 static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
09217
09218
09219
09220
09221
09222
09223
09224
09225
09226
09227
09228
09229
09230
09231
09232
09233
09234
09235
09236 --yi;
09237 --yr;
09238
09239
09240
09241 *nz = 0;
09242 nd = *n;
09243 *nlast = 0;
09244
09245
09246
09247
09248
09249 cscl = 1. / *tol;
09250 crsc = *tol;
09251 cssr[0] = cscl;
09252 cssr[1] = coner;
09253 cssr[2] = crsc;
09254 csrr[0] = crsc;
09255 csrr[1] = coner;
09256 csrr[2] = cscl;
09257 bry[0] = d1mach_(&c__1) * 1e3 / *tol;
09258
09259
09260
09261 znr = *zi;
09262 zni = -(*zr);
09263 zbr = *zr;
09264 zbi = *zi;
09265 cidi = -coner;
09266 inu = (integer) ((real) (*fnu));
09267 ang = hpi * (*fnu - (doublereal) ((real) inu));
09268 c2r = cos(ang);
09269 c2i = sin(ang);
09270 car = c2r;
09271 sar = c2i;
09272 in = inu + *n - 1;
09273 in = in % 4 + 1;
09274 str = c2r * cipr[in - 1] - c2i * cipi[in - 1];
09275 c2i = c2r * cipi[in - 1] + c2i * cipr[in - 1];
09276 c2r = str;
09277 if (*zi > 0.) {
09278 goto L10;
09279 }
09280 znr = -znr;
09281 zbi = -zbi;
09282 cidi = -cidi;
09283 c2i = -c2i;
09284 L10:
09285
09286
09287
09288 fn = max(*fnu,1.);
09289 zunhj_(&znr, &zni, &fn, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, &
09290 zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
09291 if (*kode == 1) {
09292 goto L20;
09293 }
09294 str = zbr + zeta2r;
09295 sti = zbi + zeta2i;
09296 rast = fn / zabs_(&str, &sti);
09297 str = str * rast * rast;
09298 sti = -sti * rast * rast;
09299 s1r = -zeta1r + str;
09300 s1i = -zeta1i + sti;
09301 goto L30;
09302 L20:
09303 s1r = -zeta1r + zeta2r;
09304 s1i = -zeta1i + zeta2i;
09305 L30:
09306 rs1 = s1r;
09307 if (abs(rs1) > *elim) {
09308 goto L150;
09309 }
09310 L40:
09311 nn = min(2,nd);
09312 i__1 = nn;
09313 for (i__ = 1; i__ <= i__1; ++i__) {
09314 fn = *fnu + (doublereal) ((real) (nd - i__));
09315 zunhj_(&znr, &zni, &fn, &c__0, tol, &phir, &phii, &argr, &argi, &
09316 zeta1r, &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &
09317 bsumi);
09318 if (*kode == 1) {
09319 goto L50;
09320 }
09321 str = zbr + zeta2r;
09322 sti = zbi + zeta2i;
09323 rast = fn / zabs_(&str, &sti);
09324 str = str * rast * rast;
09325 sti = -sti * rast * rast;
09326 s1r = -zeta1r + str;
09327 s1i = -zeta1i + sti + abs(*zi);
09328 goto L60;
09329 L50:
09330 s1r = -zeta1r + zeta2r;
09331 s1i = -zeta1i + zeta2i;
09332 L60:
09333
09334
09335
09336 rs1 = s1r;
09337 if (abs(rs1) > *elim) {
09338 goto L120;
09339 }
09340 if (i__ == 1) {
09341 iflag = 2;
09342 }
09343 if (abs(rs1) < *alim) {
09344 goto L70;
09345 }
09346
09347
09348
09349
09350 aphi = zabs_(&phir, &phii);
09351 aarg = zabs_(&argr, &argi);
09352 rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
09353 if (abs(rs1) > *elim) {
09354 goto L120;
09355 }
09356 if (i__ == 1) {
09357 iflag = 1;
09358 }
09359 if (rs1 < 0.) {
09360 goto L70;
09361 }
09362 if (i__ == 1) {
09363 iflag = 3;
09364 }
09365 L70:
09366
09367
09368
09369
09370 zairy_(&argr, &argi, &c__0, &c__2, &air, &aii, &nai, &idum);
09371 zairy_(&argr, &argi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
09372 str = dair * bsumr - daii * bsumi;
09373 sti = dair * bsumi + daii * bsumr;
09374 str += air * asumr - aii * asumi;
09375 sti += air * asumi + aii * asumr;
09376 s2r = phir * str - phii * sti;
09377 s2i = phir * sti + phii * str;
09378 str = exp(s1r) * cssr[iflag - 1];
09379 s1r = str * cos(s1i);
09380 s1i = str * sin(s1i);
09381 str = s2r * s1r - s2i * s1i;
09382 s2i = s2r * s1i + s2i * s1r;
09383 s2r = str;
09384 if (iflag != 1) {
09385 goto L80;
09386 }
09387 zuchk_(&s2r, &s2i, &nw, bry, tol);
09388 if (nw != 0) {
09389 goto L120;
09390 }
09391 L80:
09392 if (*zi <= 0.) {
09393 s2i = -s2i;
09394 }
09395 str = s2r * c2r - s2i * c2i;
09396 s2i = s2r * c2i + s2i * c2r;
09397 s2r = str;
09398 cyr[i__ - 1] = s2r;
09399 cyi[i__ - 1] = s2i;
09400 j = nd - i__ + 1;
09401 yr[j] = s2r * csrr[iflag - 1];
09402 yi[j] = s2i * csrr[iflag - 1];
09403 str = -c2i * cidi;
09404 c2i = c2r * cidi;
09405 c2r = str;
09406
09407 }
09408 if (nd <= 2) {
09409 goto L110;
09410 }
09411 raz = 1. / zabs_(zr, zi);
09412 str = *zr * raz;
09413 sti = -(*zi) * raz;
09414 rzr = (str + str) * raz;
09415 rzi = (sti + sti) * raz;
09416 bry[1] = 1. / bry[0];
09417 bry[2] = d1mach_(&c__2);
09418 s1r = cyr[0];
09419 s1i = cyi[0];
09420 s2r = cyr[1];
09421 s2i = cyi[1];
09422 c1r = csrr[iflag - 1];
09423 ascle = bry[iflag - 1];
09424 k = nd - 2;
09425 fn = (doublereal) ((real) k);
09426 i__1 = nd;
09427 for (i__ = 3; i__ <= i__1; ++i__) {
09428 c2r = s2r;
09429 c2i = s2i;
09430 s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
09431 s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
09432 s1r = c2r;
09433 s1i = c2i;
09434 c2r = s2r * c1r;
09435 c2i = s2i * c1r;
09436 yr[k] = c2r;
09437 yi[k] = c2i;
09438 --k;
09439 fn += -1.;
09440 if (iflag >= 3) {
09441 goto L100;
09442 }
09443 str = abs(c2r);
09444 sti = abs(c2i);
09445 c2m = max(str,sti);
09446 if (c2m <= ascle) {
09447 goto L100;
09448 }
09449 ++iflag;
09450 ascle = bry[iflag - 1];
09451 s1r *= c1r;
09452 s1i *= c1r;
09453 s2r = c2r;
09454 s2i = c2i;
09455 s1r *= cssr[iflag - 1];
09456 s1i *= cssr[iflag - 1];
09457 s2r *= cssr[iflag - 1];
09458 s2i *= cssr[iflag - 1];
09459 c1r = csrr[iflag - 1];
09460 L100:
09461 ;
09462 }
09463 L110:
09464 return 0;
09465 L120:
09466 if (rs1 > 0.) {
09467 goto L140;
09468 }
09469
09470
09471
09472 yr[nd] = zeror;
09473 yi[nd] = zeroi;
09474 ++(*nz);
09475 --nd;
09476 if (nd == 0) {
09477 goto L110;
09478 }
09479 zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim,
09480 alim);
09481 if (nuf < 0) {
09482 goto L140;
09483 }
09484 nd -= nuf;
09485 *nz += nuf;
09486 if (nd == 0) {
09487 goto L110;
09488 }
09489 fn = *fnu + (doublereal) ((real) (nd - 1));
09490 if (fn < *fnul) {
09491 goto L130;
09492 }
09493
09494
09495
09496
09497
09498
09499
09500
09501
09502 in = inu + nd - 1;
09503 in = in % 4 + 1;
09504 c2r = car * cipr[in - 1] - sar * cipi[in - 1];
09505 c2i = car * cipi[in - 1] + sar * cipr[in - 1];
09506 if (*zi <= 0.) {
09507 c2i = -c2i;
09508 }
09509 goto L40;
09510 L130:
09511 *nlast = nd;
09512 return 0;
09513 L140:
09514 *nz = -1;
09515 return 0;
09516 L150:
09517 if (rs1 > 0.) {
09518 goto L140;
09519 }
09520 *nz = *n;
09521 i__1 = *n;
09522 for (i__ = 1; i__ <= i__1; ++i__) {
09523 yr[i__] = zeror;
09524 yi[i__] = zeroi;
09525
09526 }
09527 return 0;
09528 }
09529
09530 int xerror_(char *mess, integer *nmess, integer *l1, integer
09531 *l2, ftnlen mess_len)
09532 {
09533
09534
09535
09536
09537 integer i__1, i__2;
09538
09539
09540 integer s_wsfe(cilist *), e_wsfe(void), s_wsle(cilist *), do_lio(integer *
09541 , integer *, char *, ftnlen), e_wsle(void);
09542
09543
09544 static integer i__, k, nn, nr, kmin;
09545
09546
09547
09548
09549
09550
09551
09552
09553
09554
09555
09556
09557
09558
09559 nn = *nmess / 70;
09560 nr = *nmess - nn * 70;
09561 if (nr != 0) {
09562 ++nn;
09563 }
09564 k = 1;
09565
09566
09567
09568
09569 i__1 = nn;
09570 for (i__ = 1; i__ <= i__1; ++i__) {
09571
09572 i__2 = k + 69;
09573 kmin = min(i__2,*nmess);
09574
09575
09576
09577
09578
09579 k += 70;
09580
09581 }
09582
09583
09584
09585
09586 return 0;
09587 }
09588