1*DECK ZACON 2 SUBROUTINE ZACON (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, 3 + TOL, ELIM, ALIM) 4C***BEGIN PROLOGUE ZACON 5C***SUBSIDIARY 6C***PURPOSE Subsidiary to ZBESH and ZBESK 7C***LIBRARY SLATEC 8C***TYPE ALL (CACON-A, ZACON-A) 9C***AUTHOR Amos, D. E., (SNL) 10C***DESCRIPTION 11C 12C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA 13C 14C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) 15C MP=PI*MR*CMPLX(0.0,1.0) 16C 17C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT 18C HALF Z PLANE 19C 20C***SEE ALSO ZBESH, ZBESK 21C***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 22C***REVISION HISTORY (YYMMDD) 23C 830501 DATE WRITTEN 24C 910415 Prologue converted to Version 4.0 format. (BAB) 25C***END PROLOGUE ZACON 26C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, 27C *S1,S2,Y,Z,ZN 28 DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, 29 * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, 30 * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, 31 * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, 32 * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, 33 * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS 34 INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ 35 DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) 36 EXTERNAL ZABS 37 DATA PI / 3.14159265358979324D0 / 38 DATA ZEROR,CONER / 0.0D0,1.0D0 / 39C***FIRST EXECUTABLE STATEMENT ZACON 40 NZ = 0 41 ZNR = -ZR 42 ZNI = -ZI 43 NN = N 44 CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, 45 * ELIM, ALIM) 46 IF (NW.LT.0) GO TO 90 47C----------------------------------------------------------------------- 48C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION 49C----------------------------------------------------------------------- 50 NN = MIN(2,N) 51 CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) 52 IF (NW.NE.0) GO TO 90 53 S1R = CYR(1) 54 S1I = CYI(1) 55 FMR = MR 56 SGN = -DSIGN(PI,FMR) 57 CSGNR = ZEROR 58 CSGNI = SGN 59 IF (KODE.EQ.1) GO TO 10 60 YY = -ZNI 61 CPN = COS(YY) 62 SPN = SIN(YY) 63 CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) 64 10 CONTINUE 65C----------------------------------------------------------------------- 66C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE 67C WHEN FNU IS LARGE 68C----------------------------------------------------------------------- 69 INU = FNU 70 ARG = (FNU-INU)*SGN 71 CPN = COS(ARG) 72 SPN = SIN(ARG) 73 CSPNR = CPN 74 CSPNI = SPN 75 IF (MOD(INU,2).EQ.0) GO TO 20 76 CSPNR = -CSPNR 77 CSPNI = -CSPNI 78 20 CONTINUE 79 IUF = 0 80 C1R = S1R 81 C1I = S1I 82 C2R = YR(1) 83 C2I = YI(1) 84 ASCLE = 1.0D+3*D1MACH(1)/TOL 85 IF (KODE.EQ.1) GO TO 30 86 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 87 NZ = NZ + NW 88 SC1R = C1R 89 SC1I = C1I 90 30 CONTINUE 91 CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) 92 CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) 93 YR(1) = STR + PTR 94 YI(1) = STI + PTI 95 IF (N.EQ.1) RETURN 96 CSPNR = -CSPNR 97 CSPNI = -CSPNI 98 S2R = CYR(2) 99 S2I = CYI(2) 100 C1R = S2R 101 C1I = S2I 102 C2R = YR(2) 103 C2I = YI(2) 104 IF (KODE.EQ.1) GO TO 40 105 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 106 NZ = NZ + NW 107 SC2R = C1R 108 SC2I = C1I 109 40 CONTINUE 110 CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) 111 CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) 112 YR(2) = STR + PTR 113 YI(2) = STI + PTI 114 IF (N.EQ.2) RETURN 115 CSPNR = -CSPNR 116 CSPNI = -CSPNI 117 AZN = ZABS(ZNR,ZNI) 118 RAZN = 1.0D0/AZN 119 STR = ZNR*RAZN 120 STI = -ZNI*RAZN 121 RZR = (STR+STR)*RAZN 122 RZI = (STI+STI)*RAZN 123 FN = FNU + 1.0D0 124 CKR = FN*RZR 125 CKI = FN*RZI 126C----------------------------------------------------------------------- 127C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS 128C----------------------------------------------------------------------- 129 CSCL = 1.0D0/TOL 130 CSCR = TOL 131 CSSR(1) = CSCL 132 CSSR(2) = CONER 133 CSSR(3) = CSCR 134 CSRR(1) = CSCR 135 CSRR(2) = CONER 136 CSRR(3) = CSCL 137 BRY(1) = ASCLE 138 BRY(2) = 1.0D0/ASCLE 139 BRY(3) = D1MACH(2) 140 AS2 = ZABS(S2R,S2I) 141 KFLAG = 2 142 IF (AS2.GT.BRY(1)) GO TO 50 143 KFLAG = 1 144 GO TO 60 145 50 CONTINUE 146 IF (AS2.LT.BRY(2)) GO TO 60 147 KFLAG = 3 148 60 CONTINUE 149 BSCLE = BRY(KFLAG) 150 S1R = S1R*CSSR(KFLAG) 151 S1I = S1I*CSSR(KFLAG) 152 S2R = S2R*CSSR(KFLAG) 153 S2I = S2I*CSSR(KFLAG) 154 CSR = CSRR(KFLAG) 155 DO 80 I=3,N 156 STR = S2R 157 STI = S2I 158 S2R = CKR*STR - CKI*STI + S1R 159 S2I = CKR*STI + CKI*STR + S1I 160 S1R = STR 161 S1I = STI 162 C1R = S2R*CSR 163 C1I = S2I*CSR 164 STR = C1R 165 STI = C1I 166 C2R = YR(I) 167 C2I = YI(I) 168 IF (KODE.EQ.1) GO TO 70 169 IF (IUF.LT.0) GO TO 70 170 CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) 171 NZ = NZ + NW 172 SC1R = SC2R 173 SC1I = SC2I 174 SC2R = C1R 175 SC2I = C1I 176 IF (IUF.NE.3) GO TO 70 177 IUF = -4 178 S1R = SC1R*CSSR(KFLAG) 179 S1I = SC1I*CSSR(KFLAG) 180 S2R = SC2R*CSSR(KFLAG) 181 S2I = SC2I*CSSR(KFLAG) 182 STR = SC2R 183 STI = SC2I 184 70 CONTINUE 185 PTR = CSPNR*C1R - CSPNI*C1I 186 PTI = CSPNR*C1I + CSPNI*C1R 187 YR(I) = PTR + CSGNR*C2R - CSGNI*C2I 188 YI(I) = PTI + CSGNR*C2I + CSGNI*C2R 189 CKR = CKR + RZR 190 CKI = CKI + RZI 191 CSPNR = -CSPNR 192 CSPNI = -CSPNI 193 IF (KFLAG.GE.3) GO TO 80 194 PTR = ABS(C1R) 195 PTI = ABS(C1I) 196 C1M = MAX(PTR,PTI) 197 IF (C1M.LE.BSCLE) GO TO 80 198 KFLAG = KFLAG + 1 199 BSCLE = BRY(KFLAG) 200 S1R = S1R*CSR 201 S1I = S1I*CSR 202 S2R = STR 203 S2I = STI 204 S1R = S1R*CSSR(KFLAG) 205 S1I = S1I*CSSR(KFLAG) 206 S2R = S2R*CSSR(KFLAG) 207 S2I = S2I*CSSR(KFLAG) 208 CSR = CSRR(KFLAG) 209 80 CONTINUE 210 RETURN 211 90 CONTINUE 212 NZ = -1 213 IF(NW.EQ.(-2)) NZ=-2 214 RETURN 215 END 216