1 SUBROUTINE cunk2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
16 COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CIP,
17 * ck, cone, crsc, cr1, cr2, cs, cscl, csgn, cspn, csr, css, cy,
18 * czero, c1, c2, dai, phi, rz, s1, s2, y, z, zb, zeta1,
19 * zeta2, zn, zr, phid, argd, zeta1d, zeta2d, asumd, bsumd
20 REAL AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I,
21 * c2m, c2r, elim, fmr, fn, fnf, fnu, hpi, pi, rs1, sar, sgn, spn,
23 INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK,
24 * kode, mr, n, nai, ndai, nw, nz, idum, j, ipard, ic
25 dimension bry(3), y(n), asum(2), bsum(2), phi(2), arg(2),
26 * zeta1(2), zeta2(2), cy(2), cip(4), css(3), csr(3)
27 DATA czero, cone, ci, cr1, cr2 /
28 1 (0.0e0,0.0e0),(1.0e0,0.0e0),(0.0e0,1.0e0),
29 1(1.0e0,1.73205080756887729e0),(-0.5e0,-8.66025403784438647e-01)/
31 1 1.57079632679489662e+00, 3.14159265358979324e+00,
32 1 1.26551212348464539e+00/
33 DATA cip(1),cip(2),cip(3),cip(4)/
34 1 (1.0e0,0.0e0), (0.0e0,-1.0e0), (-1.0e0,0.0e0), (0.0e0,1.0e0)/
42 cscl =
cmplx(1.0e0/tol,0.0e0)
43 crsc =
cmplx(tol,0.0e0)
50 bry(1) = 1.0e+3*r1mach(1)/tol
55 IF (x.LT.0.0e0) zr = -z
60 fnf = fnu - float(inu)
69 IF (yy.GT.0.0e0) go to 10
85 CALL
cunhj(zn, fn, 0, tol, phi(j), arg(j), zeta1(j), zeta2(j),
87 IF (kode.EQ.1) go to 20
89 s1 = zeta1(j) - cfn*(cfn/(zb+zeta2(j)))
92 s1 = zeta1(j) - zeta2(j)
98 IF (
abs(rs1).GT.elim) go to 60
99 IF (kdflg.EQ.1) kflag = 2
100 IF (
abs(rs1).LT.alim) go to 40
106 rs1 = rs1 + alog(aphi) - 0.25e0*alog(aarg) - aic
107 IF (
abs(rs1).GT.elim) go to 60
108 IF (kdflg.EQ.1) kflag = 1
109 IF (rs1.LT.0.0e0) go to 40
110 IF (kdflg.EQ.1) kflag = 3
117 CALL
cairy(c2, 0, 2, ai, nai, idum)
118 CALL
cairy(c2, 1, 2, dai, ndai, idum)
119 s2 = cs*phi(j)*(ai*asum(j)+cr2*dai*bsum(j))
122 c2m =
exp(c2r)*
REAL(css(kflag))
125 IF (kflag.NE.1) go to 50
126 CALL
cuchk(s2, nw, bry(1), tol)
127 IF (nw.NE.0) go to 60
129 IF (yy.LE.0.0e0) s2 = conjg(s2)
133 IF (kdflg.EQ.2) go to 75
137 IF (rs1.GT.0.0e0) go to 300
141 IF (x.LT.0.0e0) go to 300
147 IF (y(i-1).EQ.czero) go to 70
153 rz =
cmplx(2.0e0,0.0e0)/zr
154 ck =
cmplx(fn,0.0e0)*rz
156 IF (n.LT.ib) go to 170
163 IF (mr.NE.0) ipard = 0
164 CALL
cunhj(zn,fn,ipard,tol,phid,argd,zeta1d,zeta2d,asumd,bsumd)
165 IF (kode.EQ.1) go to 80
167 s1=zeta1d-cfn*(cfn/(zb+zeta2d))
173 IF (
abs(rs1).GT.elim) go to 95
174 IF (
abs(rs1).LT.alim) go to 100
180 rs1=rs1+alog(aphi)-0.25e0*alog(aarg)-aic
181 IF (
abs(rs1).LT.elim) go to 100
183 IF (rs1.GT.0.0e0) go to 300
187 IF (x.LT.0.0e0) go to 300
208 IF (kflag.GE.3) go to 120
214 IF (c2m.LE.ascle) go to 120
234 csgn =
cmplx(0.0e0,sgn)
235 IF (yy.LE.0.0e0) csgn = conjg(csgn)
240 cspn =
cmplx(cpn,spn)
241 IF (
mod(ifn,2).EQ.1) cspn = -cspn
248 cs =
cmplx(car,-sar)*csgn
264 IF (n.GT.2) go to 180
275 IF ((kk.EQ.n).AND.(ib.LT.n)) go to 190
276 IF ((kk.EQ.ib).OR.(kk.EQ.ic)) go to 175
277 CALL
cunhj(zn, fn, 0, tol, phid, argd, zeta1d, zeta2d,
280 IF (kode.EQ.1) go to 200
281 cfn =
cmplx(fn,0.0e0)
282 s1 = -zeta1d + cfn*(cfn/(zb+zeta2d))
285 s1 = -zeta1d + zeta2d
291 IF (
abs(rs1).GT.elim) go to 260
292 IF (kdflg.EQ.1) iflag = 2
293 IF (
abs(rs1).LT.alim) go to 220
299 rs1 = rs1 + alog(aphi) - 0.25e0*alog(aarg) - aic
300 IF (
abs(rs1).GT.elim) go to 260
301 IF (kdflg.EQ.1) iflag = 1
302 IF (rs1.LT.0.0e0) go to 220
303 IF (kdflg.EQ.1) iflag = 3
305 CALL
cairy(argd, 0, 2, ai, nai, idum)
306 CALL
cairy(argd, 1, 2, dai, ndai, idum)
307 s2 = cs*phid*(ai*asumd+dai*bsumd)
310 c2m =
exp(c2r)*
REAL(css(iflag))
313 IF (iflag.NE.1) go to 230
314 CALL
cuchk(s2, nw, bry(1), tol)
315 IF (nw.NE.0) s2 =
cmplx(0.0e0,0.0e0)
317 IF (yy.LE.0.0e0) s2 = conjg(s2)
325 IF (kode.EQ.1) go to 250
326 CALL
cs1s2(zr, s1, s2, nw, asc, alim, iuf)
333 IF (c2.NE.czero) go to 255
337 IF (kdflg.EQ.2) go to 275
341 IF (rs1.GT.0.0e0) go to 300
361 s2 = s1 +
cmplx(fn+fnf,0.0e0)*rz*s2
367 IF (kode.EQ.1) go to 280
368 CALL
cs1s2(zr, c1, c2, nw, asc, alim, iuf)
374 IF (iflag.GE.3) go to 290
380 IF (c2m.LE.ascle) go to 290
subroutine cairy(Z, ID, KODE, AI, NZ, IERR)
std::string dimension(void) const
octave_int< T > mod(const octave_int< T > &x, const octave_int< T > &y)
subroutine cuchk(Y, NZ, ASCLE, TOL)
subroutine cunk2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM)
octave_value sin(void) const
subroutine cs1s2(ZR, S1, S2, NZ, ASCLE, ALIM, IUF)
subroutine cunhj(Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM)
octave_value cos(void) const