diff --git a/contrib/bessel/Bessel.cpp b/contrib/bessel/Bessel.cpp new file mode 100644 index 0000000000000000000000000000000000000000..6ca41a605ac4e47b7edcc8440fc9da96c3daf093 --- /dev/null +++ b/contrib/bessel/Bessel.cpp @@ -0,0 +1,272 @@ +// GetDP - Copyright (C) 1997-2020 P. Dular and C. Geuzaine, University of Liege +// +// See the LICENSE.txt file for license information. Please report all +// issues on https://gitlab.onelab.info/getdp/getdp/issues. + +#include "Bessel.h" +#include <iostream> + +#if defined(HAVE_NO_FORTRAN) + +static void zbesj_(double*, double*, double*, int*, int*, double*, + double*, int*, int*) +{ + std::cerr << "Bessel functions require Fortran compiler"; +} + +static void zbesk_(double*, double*, double*, int*, int*, double*, + double*, int*, int*) +{ + std::cerr << "Bessel functions require Fortran compiler"; +} + +static void zbesy_(double*, double*, double*, int*, int*, double*, + double*, int*, double*, double*, int*) +{ + std::cerr << "Bessel functions require Fortran compiler"; +} + +static void zbesh_(double*, double*, double*, int*, int*, int*, + double*, double*, int*, int*) +{ + std::cerr << "Bessel functions require Fortran compiler"; +} + +static void zairy_(double*, double*, int*, int*, double*, + double*, int*, int*) +{ + std::cerr << "Bessel functions require Fortran compiler"; +} + +#else + +#if defined(HAVE_UNDERSCORE) +#define zbesj_ zbesj +#define zbesk_ zbesk +#define zbesy_ zbesy +#define zbesh_ zbesh +#define zairy_ zairy +#endif + +extern "C" { + void zbesj_(double*, double*, double*, int*, int*, double*, + double*, int*, int*); + void zbesk_(double*, double*, double*, int*, int*, double*, + double*, int*, int*); + + void zbesy_(double*, double*, double*, int*, int*, double*, + double*, int*, double*, + double*, int*); + void zbesh_(double*, double*, double*, int*, int*, int*, double*, + double*, int*, int*); + + void zairy_(double*, double*, int*, int*, double*, + double*, int*, int*); +} + +#endif + +static int BesselError(int ierr, const char *str) +{ + static int warn=0; + + switch(ierr){ + case 0 : + return 0; + case 1 : + std::cerr << "Input error in " << str; + return BESSEL_ERROR_INPUT; + case 2 : + return BESSEL_OVERFLOW; + case 3 : + if(!warn){ + std::cout << "Half machine accuracy lost in " << str << " (large argument or order)"; + warn = 1; + } + return BESSEL_HALF_ACCURACY; + case 4 : + std::cerr << "Complete loss of significance in " << str << " (argument or order too large)"; + return BESSEL_NO_ACCURACY; + case 5 : + std::cerr << "Failed to converge in " << str; + return BESSEL_NO_CONVERGENCE; + default: + std::cout << "Unknown Bessel status in " << str << " (" << ierr << ")"; + return ierr; + } +} + +// First kind Bessel functions + +int BesselJn(double n, int num, double x, double *val) +{ + int nz = 0, ierr = 0, kode = 1; + double xi = 0.0; + double* ji = new double[num]; + + zbesj_(&x, &xi, &n, &kode, &num, val, ji, &nz, &ierr) ; + + delete[] ji; + + return BesselError(ierr, "BesselJn"); +} + +int BesselJnComplex(double n, int num, double xr, double xi, double *valr, double *vali) +{ + int nz = 0, ierr = 0, kode = 1; + + zbesj_(&xr, &xi, &n, &kode, &num, valr, vali, &nz, &ierr) ; + + return BesselError(ierr, "BesselJnComplex"); +} + +int BesselKnComplex(double n, int num, double xr, double xi, double *valr, double *vali) +{ + int nz = 0, ierr = 0, kode = 1; + + zbesk_(&xr, &xi, &n, &kode, &num, valr, vali, &nz, &ierr) ; + + return BesselError(ierr, "BesselKnComplex"); +} + +int BesselSphericalJn(double n, int num, double x, double *val) +{ + int ierr = BesselJn(n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI/x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselSphericalJn"); +} + +int BesselAltSphericalJn(double n, int num, double x, double *val) +{ + int ierr = BesselJn(n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI*x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselAltSphericalJn"); +} + +// Second kind Bessel functions + +int BesselYn(double n, int num, double x, double *val) +{ + int nz = 0, ierr = 0, kode = 1; + double xi = 0.0; + double* yi = new double[num]; + double* auxyr = new double[num]; + double* auxyi = new double[num]; + + zbesy_(&x, &xi, &n, &kode, &num, val, yi, &nz, auxyr, auxyi, &ierr); + + delete[] yi; + delete[] auxyr; + delete[] auxyi; + + return BesselError(ierr, "BesselYn"); +} + +int BesselSphericalYn(double n, int num, double x, double *val) +{ + int ierr = BesselYn(n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI/x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselSphericalYn"); +} + +int BesselAltSphericalYn(double n, int num, double x, double *val) +{ + int ierr = BesselYn(n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI*x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselAltSphericalYn"); +} + +// Hankel functions (type = 1 or 2) + +int BesselHn(int type, double n, int num, double x, std::complex<double> *val) +{ + int nz = 0, ierr = 0, kode = 1; + double* hr = new double[num]; + double* hi = new double[num]; + double xi = 0.0; + + zbesh_(&x, &xi, &n, &kode, &type, &num, hr, hi, &nz, &ierr); + + for(int i=0; i < num; i++){ + val[i] = std::complex<double>(hr[i], hi[i]); + } + + delete[] hr; + delete[] hi; + + return BesselError(ierr, "BesselHn"); +} + +int BesselSphericalHn(int type, double n, int num, double x, std::complex<double> *val) +{ + int ierr = BesselHn(type, n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI/x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselSphericalHn"); +} + +int BesselAltSphericalHn(int type, double n, int num, double x, std::complex<double> *val) +{ + int ierr = BesselHn(type, n+0.5, num, x, val); + double coef = sqrt(0.5*M_PI*x); + for(int i = 0; i < num; i++){ + val[i] *= coef; + } + return BesselError(ierr, "BesselAltSphericalHn"); +} + +// Airy Function and derivative (id=1) + +int AiryComplex(double xr, double xi, int id, double *valr, double *vali) +{ + int nz = 0, ierr = 0, kode = 1; + + zairy_(&xr, &xi, &id, &kode, valr, vali, &nz, &ierr); + //val = std::complex<double>(valr, vali); + + return BesselError(ierr, "AiryComplex"); +} + +// Utilities for backward compatibility + +double Spherical_j_n(int n, double x) +{ + double res; + BesselSphericalJn(n, 1, x, &res); + return res; +} + +double AltSpherical_j_n(int n, double x) +{ + double res; + BesselAltSphericalJn(n, 1, x, &res); + return res; +} + +double Spherical_y_n(int n, double x) +{ + double res; + BesselSphericalYn(n, 1, x, &res); + return res; +} + +double AltSpherical_y_n(int n, double x) +{ + double res; + BesselAltSphericalYn(n, 1, x, &res); + return res; +} diff --git a/contrib/bessel/Bessel.h b/contrib/bessel/Bessel.h new file mode 100644 index 0000000000000000000000000000000000000000..ec3bc7e2eba7092b2015e13942f445dd6d3f8ddf --- /dev/null +++ b/contrib/bessel/Bessel.h @@ -0,0 +1,45 @@ +// GetDP - Copyright (C) 1997-2020 P. Dular and C. Geuzaine, University of Liege +// +// See the LICENSE.txt file for license information. Please report all +// issues on https://gitlab.onelab.info/getdp/getdp/issues. + +#ifndef BESSEL_H +#define BESSEL_H + +#include <cmath> +#include <complex> + +#define BESSEL_ERROR_INPUT 1 +#define BESSEL_OVERFLOW 2 +#define BESSEL_HALF_ACCURACY 3 +#define BESSEL_NO_ACCURACY 4 +#define BESSEL_NO_CONVERGENCE 5 + +// These routines provide a C++ interface to the Fortran Bessel +// functions from Donald E. Amos (Sandia National Laboratories) + +int BesselJn(double n, int num, double x, double *val); +int BesselSphericalJn(double n, int num, double x, double *val); +int BesselAltSphericalJn(double n, int num, double x, double *val); + +int BesselJnComplex(double n, int num, double xr, double xi, double *valr, double *vali); +int BesselKnComplex(double n, int num, double xr, double xi, double *valr, double *vali); + +int BesselYn(double n, int num, double x, double *val); +int BesselSphericalYn(double n, int num, double x, double *val); +int BesselAltSphericalYn(double n, int num, double x, double *val); + +int BesselHn(int type, double n, int num, double x, std::complex<double> *val); +int BesselSphericalHn(int type, double n, int num, double x, std::complex<double> *val); +int BesselAltSphericalHn(int type, double n, int num, double x, std::complex<double> *val); + +int AiryComplex(double xr, double xi, int id, double *valr, double *vali); + +// Utilities for backward compatibility + +double Spherical_j_n(int n, double x); +double AltSpherical_j_n(int n, double x); +double Spherical_y_n(int n, double x); +double AltSpherical_y_n(int n, double x); + +#endif diff --git a/contrib/bessel/BesselLib.f b/contrib/bessel/BesselLib.f new file mode 100644 index 0000000000000000000000000000000000000000..64cc0d70a456d989aa02065c25f4a9f6cb7a7fb6 --- /dev/null +++ b/contrib/bessel/BesselLib.f @@ -0,0 +1,7866 @@ + REAL FUNCTION R1MACH(I) + INTEGER I +C +C SINGLE-PRECISION MACHINE CONSTANTS +C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C R1MACH(5) = LOG10(B) +C +C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES, +C INCLUDING AUTO-DOUBLE COMPILERS. +C TO ALTER FOR A PARTICULAR ENVIRONMENT, THE DESIRED SET OF DATA +C STATEMENTS MAY BE ACTIVATED BY REMOVING THE C FROM COLUMN 1. +C CONSTANTS FOR OLDER MACHINES CAN BE OBTAINED BY +C mail netlib@research.bell-labs.com +C send old1mach from blas +C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. +C + INTEGER SMALL(2) + INTEGER LARGE(2) + INTEGER RIGHT(2) + INTEGER DIVER(2) + INTEGER LOG10(2) + INTEGER SC + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC + REAL RMACH(5) + EQUIVALENCE (RMACH(1),SMALL(1)) + EQUIVALENCE (RMACH(2),LARGE(1)) + EQUIVALENCE (RMACH(3),RIGHT(1)) + EQUIVALENCE (RMACH(4),DIVER(1)) + EQUIVALENCE (RMACH(5),LOG10(1)) + INTEGER J, K, L, T3E(3) + DATA T3E(1) / 9777664 / + DATA T3E(2) / 5323660 / + DATA T3E(3) / 46980 / +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C DATA RMACH(1) / O402400000000 / +C DATA RMACH(2) / O376777777777 / +C DATA RMACH(3) / O714400000000 / +C DATA RMACH(4) / O716400000000 / +C DATA RMACH(5) / O776464202324 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C DATA SMALL(1) / 8388608 / +C DATA LARGE(1) / 2147483647 / +C DATA RIGHT(1) / 880803840 / +C DATA DIVER(1) / 889192448 / +C DATA LOG10(1) / 1067065499 /, SC/987/ +C DATA RMACH(1) / O00040000000 / +C DATA RMACH(2) / O17777777777 / +C DATA RMACH(3) / O06440000000 / +C DATA RMACH(4) / O06500000000 / +C DATA RMACH(5) / O07746420233 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C DATA SMALL(1) / $00800000 / +C DATA LARGE(1) / $7F7FFFFF / +C DATA RIGHT(1) / $33800000 / +C DATA DIVER(1) / $34000000 / +C DATA LOG10(1) / $3E9A209B /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C DATA RMACH(1) / O000400000000 / +C DATA RMACH(2) / O377777777777 / +C DATA RMACH(3) / O146400000000 / +C DATA RMACH(4) / O147400000000 / +C DATA RMACH(5) / O177464202324 /, SC/987/ +C + IF (SC .NE. 987) THEN +* *** CHECK FOR AUTODOUBLE *** + SMALL(2) = 0 + RMACH(1) = 1E13 + IF (SMALL(2) .NE. 0) THEN +* *** AUTODOUBLED *** + IF ( SMALL(1) .EQ. 1117925532 + * .AND. SMALL(2) .EQ. -448790528) THEN +* *** IEEE BIG ENDIAN *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2146435071 + LARGE(2) = -1 + RIGHT(1) = 1017118720 + RIGHT(2) = 0 + DIVER(1) = 1018167296 + DIVER(2) = 0 + LOG10(1) = 1070810131 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(2) .EQ. 1117925532 + * .AND. SMALL(1) .EQ. -448790528) THEN +* *** IEEE LITTLE ENDIAN *** + SMALL(2) = 1048576 + SMALL(1) = 0 + LARGE(2) = 2146435071 + LARGE(1) = -1 + RIGHT(2) = 1017118720 + RIGHT(1) = 0 + DIVER(2) = 1018167296 + DIVER(1) = 0 + LOG10(2) = 1070810131 + LOG10(1) = 1352628735 + ELSE IF ( SMALL(1) .EQ. -2065213935 + * .AND. SMALL(2) .EQ. 10752) THEN +* *** VAX WITH D_FLOATING *** + SMALL(1) = 128 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 9344 + RIGHT(2) = 0 + DIVER(1) = 9472 + DIVER(2) = 0 + LOG10(1) = 546979738 + LOG10(2) = -805796613 + ELSE IF ( SMALL(1) .EQ. 1267827943 + * .AND. SMALL(2) .EQ. 704643072) THEN +* *** IBM MAINFRAME *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 856686592 + RIGHT(2) = 0 + DIVER(1) = 873463808 + DIVER(2) = 0 + LOG10(1) = 1091781651 + LOG10(2) = 1352628735 + ELSE + WRITE(*,9010) + STOP 777 + END IF + ELSE + RMACH(1) = 1234567. + IF (SMALL(1) .EQ. 1234613304) THEN +* *** IEEE *** + SMALL(1) = 8388608 + LARGE(1) = 2139095039 + RIGHT(1) = 864026624 + DIVER(1) = 872415232 + LOG10(1) = 1050288283 + ELSE IF (SMALL(1) .EQ. -1271379306) THEN +* *** VAX *** + SMALL(1) = 128 + LARGE(1) = -32769 + RIGHT(1) = 13440 + DIVER(1) = 13568 + LOG10(1) = 547045274 + ELSE IF (SMALL(1) .EQ. 1175639687) THEN +* *** IBM MAINFRAME *** + SMALL(1) = 1048576 + LARGE(1) = 2147483647 + RIGHT(1) = 990904320 + DIVER(1) = 1007681536 + LOG10(1) = 1091781651 + ELSE IF (SMALL(1) .EQ. 1251390520) THEN +* *** CONVEX C-1 *** + SMALL(1) = 8388608 + LARGE(1) = 2147483647 + RIGHT(1) = 880803840 + DIVER(1) = 889192448 + LOG10(1) = 1067065499 + ELSE + DO 10 L = 1, 3 + J = SMALL(1) / 10000000 + K = SMALL(1) - 10000000*J + IF (K .NE. T3E(L)) GO TO 20 + SMALL(1) = J + 10 CONTINUE +* *** CRAY T3E *** + CALL I1MT3E(SMALL, 16, 0, 0) + CALL I1MT3E(LARGE, 32751, 16777215, 16777215) + CALL I1MT3E(RIGHT, 15520, 0, 0) + CALL I1MT3E(DIVER, 15536, 0, 0) + CALL I1MT3E(LOG10, 16339, 4461392, 10451455) + GO TO 30 + 20 CALL I1MCRA(J, K, 16405, 9876536, 0) + IF (SMALL(1) .NE. J) THEN + WRITE(*,9020) + STOP 777 + END IF +* *** CRAY 1, XMP, 2, AND 3 *** + CALL I1MCRA(SMALL(1), K, 8195, 8388608, 0) + CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214) + CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0) + CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0) + CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216) + END IF + END IF + 30 SC = 987 + END IF +* SANITY CHECK + IF (RMACH(4) .GE. 1.0) STOP 776 + IF (I .LT. 1 .OR. I .GT. 5) THEN + WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.' + STOP + END IF + R1MACH = RMACH(I) + RETURN + 9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/ + *' appropriate for your machine from D1MACH.') + 9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/ + *' appropriate for your machine.') +* /* C source for R1MACH -- remove the * in column 1 */ +*#include <stdio.h> +*#include <float.h> +*#include <math.h> +*float r1mach_(long *i) +*{ +* switch(*i){ +* case 1: return FLT_MIN; +* case 2: return FLT_MAX; +* case 3: return FLT_EPSILON/FLT_RADIX; +* case 4: return FLT_EPSILON; +* case 5: return log10(FLT_RADIX); +* } +* fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i); +* exit(1); return 0; /* else complaint of missing return value */ +*} + END + SUBROUTINE I1MT3E(A, B, C, D) +**** SPECIAL COMPUTATION FOR CRAY T3E **** +**** 64-BIT INTEGERS, "REAL" = IEEE DOUBLE **** + INTEGER A(2), B, C, D + A(2) = 16777216*B + C + A(1) = 16777216*A(1) + D + END + SUBROUTINE I1MCRA(A, A1, B, C, D) +**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** + INTEGER A, A1, B, C, D + A1 = 16777216*B + C + A = 16777216*A1 + D + END +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + DOUBLE PRECISION FUNCTION D1MACH(I) + INTEGER I +C +C DOUBLE-PRECISION MACHINE CONSTANTS +C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C D1MACH( 5) = LOG10(B) +C +C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. +C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF +C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR +C MANY MACHINES YET. +C TO ALTER FOR A PARTICULAR ENVIRONMENT, THE DESIRED SET OF DATA +C STATEMENTS MAY BE ACTIVATED BY REMOVING THE C FROM COLUMN 1. +C CONSTANTS FOR OLDER MACHINES CAN BE OBTAINED BY +C mail netlib@research.bell-labs.com +C send old1mach from blas +C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. +C + INTEGER SMALL(2) + INTEGER LARGE(2) + INTEGER RIGHT(2) + INTEGER DIVER(2) + INTEGER LOG10(2) + INTEGER SC, CRAY1(38), J + COMMON /D9MACH/ CRAY1 + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC + DOUBLE PRECISION DMACH(5) + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGERS. +C DATA SMALL(1),SMALL(2) / 8388608, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / +C DATA DIVER(1),DIVER(2) / 620756992, 0 / +C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 +C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / +C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / +C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / +C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / +C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ +C +C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. + IF (SC .NE. 987) THEN + DMACH(1) = 1.D13 + IF ( SMALL(1) .EQ. 1117925532 + * .AND. SMALL(2) .EQ. -448790528) THEN +* *** IEEE BIG ENDIAN *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2146435071 + LARGE(2) = -1 + RIGHT(1) = 1017118720 + RIGHT(2) = 0 + DIVER(1) = 1018167296 + DIVER(2) = 0 + LOG10(1) = 1070810131 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(2) .EQ. 1117925532 + * .AND. SMALL(1) .EQ. -448790528) THEN +* *** IEEE LITTLE ENDIAN *** + SMALL(2) = 1048576 + SMALL(1) = 0 + LARGE(2) = 2146435071 + LARGE(1) = -1 + RIGHT(2) = 1017118720 + RIGHT(1) = 0 + DIVER(2) = 1018167296 + DIVER(1) = 0 + LOG10(2) = 1070810131 + LOG10(1) = 1352628735 + ELSE IF ( SMALL(1) .EQ. -2065213935 + * .AND. SMALL(2) .EQ. 10752) THEN +* *** VAX WITH D_FLOATING *** + SMALL(1) = 128 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 9344 + RIGHT(2) = 0 + DIVER(1) = 9472 + DIVER(2) = 0 + LOG10(1) = 546979738 + LOG10(2) = -805796613 + ELSE IF ( SMALL(1) .EQ. 1267827943 + * .AND. SMALL(2) .EQ. 704643072) THEN +* *** IBM MAINFRAME *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 856686592 + RIGHT(2) = 0 + DIVER(1) = 873463808 + DIVER(2) = 0 + LOG10(1) = 1091781651 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 1120022684 + * .AND. SMALL(2) .EQ. -448790528) THEN +* *** CONVEX C-1 *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 1019215872 + RIGHT(2) = 0 + DIVER(1) = 1020264448 + DIVER(2) = 0 + LOG10(1) = 1072907283 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 815547074 + * .AND. SMALL(2) .EQ. 58688) THEN +* *** VAX G-FLOATING *** + SMALL(1) = 16 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 15552 + RIGHT(2) = 0 + DIVER(1) = 15568 + DIVER(2) = 0 + LOG10(1) = 1142112243 + LOG10(2) = 2046775455 + ELSE + DMACH(2) = 1.D27 + 1 + DMACH(3) = 1.D27 + LARGE(2) = LARGE(2) - RIGHT(2) + IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN + CRAY1(1) = 67291416 + DO 10 J = 1, 20 + 10 CRAY1(J+1) = CRAY1(J) + CRAY1(J) + CRAY1(22) = CRAY1(21) + 321322 + DO 20 J = 22, 37 + 20 CRAY1(J+1) = CRAY1(J) + CRAY1(J) + IF (CRAY1(38) .EQ. SMALL(1)) THEN +* *** CRAY *** + CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) + SMALL(2) = 0 + CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) + CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) + CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) + RIGHT(2) = 0 + CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) + DIVER(2) = 0 + CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) + CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) + ELSE + WRITE(*,9000) + STOP 779 + END IF + ELSE + WRITE(*,9000) + STOP 779 + END IF + END IF + SC = 987 + END IF +* SANITY CHECK + IF (DMACH(4) .GE. 1.0D0) STOP 778 + IF (I .LT. 1 .OR. I .GT. 5) THEN + WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' + STOP + END IF + D1MACH = DMACH(I) + RETURN + 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ + *' appropriate for your machine.') +* /* Standard C source for D1MACH -- remove the * in column 1 */ +*#include <stdio.h> +*#include <float.h> +*#include <math.h> +*double d1mach_(long *i) +*{ +* switch(*i){ +* case 1: return DBL_MIN; +* case 2: return DBL_MAX; +* case 3: return DBL_EPSILON/FLT_RADIX; +* case 4: return DBL_EPSILON; +* case 5: return log10(FLT_RADIX); +* } +* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); +* exit(1); return 0; /* some compilers demand return values */ +*} + END + SUBROUTINE I1MCRY(A, A1, B, C, D) +**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** + INTEGER A, A1, B, C, D + A1 = 16777216*B + C + A = 16777216*A1 + D + END +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + INTEGER FUNCTION I1MACH(I) + INTEGER I +C +C I1MACH( 1) = THE STANDARD INPUT UNIT. +C I1MACH( 2) = THE STANDARD OUTPUT UNIT. +C I1MACH( 3) = THE STANDARD PUNCH UNIT. +C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. +C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. +C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. +C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C I1MACH( 7) = A, THE BASE. +C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. +C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. +C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C WHERE EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, THE BASE. +C SINGLE-PRECISION +C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. +C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. +C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. +C DOUBLE-PRECISION +C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. +C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. +C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. +C + INTEGER IMACH(16), OUTPUT, SANITY, SMALL(2) + SAVE IMACH, SANITY + REAL RMACH + EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1)) + INTEGER J, K, T3E(3) + DATA T3E(1) / 9777664 / + DATA T3E(2) / 5323660 / + DATA T3E(3) / 46980 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C +C DATA IMACH( 1) / 0 / +C DATA IMACH( 2) / 0 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 1 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 +C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. +C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) /-1024 / +C DATA IMACH(16) / 1023 /, SANITY/987/ +C + IF (SANITY .NE. 987) THEN +* *** CHECK FOR AUTODOUBLE *** + SMALL(2) = 0 + RMACH = 1E13 + IF (SMALL(2) .NE. 0) THEN +* *** AUTODOUBLED *** + IF ( (SMALL(1) .EQ. 1117925532 + * .AND. SMALL(2) .EQ. -448790528) + * .OR. (SMALL(2) .EQ. 1117925532 + * .AND. SMALL(1) .EQ. -448790528)) THEN +* *** IEEE *** + IMACH(10) = 2 + IMACH(14) = 53 + IMACH(15) = -1021 + IMACH(16) = 1024 + ELSE IF ( SMALL(1) .EQ. -2065213935 + * .AND. SMALL(2) .EQ. 10752) THEN +* *** VAX WITH D_FLOATING *** + IMACH(10) = 2 + IMACH(14) = 56 + IMACH(15) = -127 + IMACH(16) = 127 + ELSE IF ( SMALL(1) .EQ. 1267827943 + * .AND. SMALL(2) .EQ. 704643072) THEN +* *** IBM MAINFRAME *** + IMACH(10) = 16 + IMACH(14) = 14 + IMACH(15) = -64 + IMACH(16) = 63 + ELSE + WRITE(*,9010) + STOP 777 + END IF + IMACH(11) = IMACH(14) + IMACH(12) = IMACH(15) + IMACH(13) = IMACH(16) + ELSE + RMACH = 1234567. + IF (SMALL(1) .EQ. 1234613304) THEN +* *** IEEE *** + IMACH(10) = 2 + IMACH(11) = 24 + IMACH(12) = -125 + IMACH(13) = 128 + IMACH(14) = 53 + IMACH(15) = -1021 + IMACH(16) = 1024 + SANITY = 987 + ELSE IF (SMALL(1) .EQ. -1271379306) THEN +* *** VAX *** + IMACH(10) = 2 + IMACH(11) = 24 + IMACH(12) = -127 + IMACH(13) = 127 + IMACH(14) = 56 + IMACH(15) = -127 + IMACH(16) = 127 + SANITY = 987 + ELSE IF (SMALL(1) .EQ. 1175639687) THEN +* *** IBM MAINFRAME *** + IMACH(10) = 16 + IMACH(11) = 6 + IMACH(12) = -64 + IMACH(13) = 63 + IMACH(14) = 14 + IMACH(15) = -64 + IMACH(16) = 63 + SANITY = 987 + ELSE IF (SMALL(1) .EQ. 1251390520) THEN +* *** CONVEX C-1 *** + IMACH(10) = 2 + IMACH(11) = 24 + IMACH(12) = -128 + IMACH(13) = 127 + IMACH(14) = 53 + IMACH(15) = -1024 + IMACH(16) = 1023 + ELSE + DO 10 I = 1, 3 + J = SMALL(1) / 10000000 + K = SMALL(1) - 10000000*J + IF (K .NE. T3E(I)) GO TO 20 + SMALL(1) = J + 10 CONTINUE +* *** CRAY T3E *** + IMACH(10) = 2 + IMACH(11) = 53 + IMACH(12) = -1024 + IMACH(13) = 1023 + IMACH(14) = 0 + IMACH(15) = 0 + IMACH(16) = 0 + GO TO 30 + 20 CALL I1MCR1(J, K, 16405, 9876536, 0) + IF (SMALL(1) .NE. J) THEN + WRITE(*,9020) + STOP 777 + END IF +* *** CRAY 1, XMP, 2, AND 3 *** + IMACH(1) = 5 + IMACH(2) = 6 + IMACH(3) = 102 + IMACH(4) = 6 + IMACH(5) = 64 + IMACH(6) = 8 + IMACH(7) = 2 + IMACH(8) = 63 + CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215) + IMACH(10) = 2 + IMACH(11) = 47 + IMACH(12) = -8189 + IMACH(13) = 8190 + IMACH(14) = 94 + IMACH(15) = -8099 + IMACH(16) = 8190 + GO TO 35 + END IF + END IF + 30 IMACH( 1) = 5 + IMACH( 2) = 6 + IMACH( 3) = 7 + IMACH( 4) = 6 + IMACH( 5) = 32 + IMACH( 6) = 4 + IMACH( 7) = 2 + IMACH( 8) = 31 + IMACH( 9) = 2147483647 + 35 SANITY = 987 + END IF + 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/ + * ' statements appropriate for your machine and setting'/ + * ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.') + 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/ + * ' appropriate for your machine.') + IF (I .LT. 1 .OR. I .GT. 16) GO TO 40 + I1MACH = IMACH(I) +C REMOVE THE FOLLOWING LINE IF FORTRAN66 IS PREFERRED TO FORTRAN77. + IF (I .EQ. 6) I1MACH = 1 + RETURN + 40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.' + STOP +* /* C source for I1MACH -- remove the * in column 1 */ +* /* Note that some values may need changing. */ +*#include <stdio.h> +*#include <float.h> +*#include <limits.h> +*#include <math.h> +* +*long i1mach_(long *i) +*{ +* switch(*i){ +* case 1: return 5; /* standard input */ +* case 2: return 6; /* standard output */ +* case 3: return 7; /* standard punch */ +* case 4: return 0; /* standard error */ +* case 5: return 32; /* bits per integer */ +* case 6: return 1; /* Fortran 77 value */ +* case 7: return 2; /* base for integers */ +* case 8: return 31; /* digits of integer base */ +* case 9: return LONG_MAX; +* case 10: return FLT_RADIX; +* case 11: return FLT_MANT_DIG; +* case 12: return FLT_MIN_EXP; +* case 13: return FLT_MAX_EXP; +* case 14: return DBL_MANT_DIG; +* case 15: return DBL_MIN_EXP; +* case 16: return DBL_MAX_EXP; +* } +* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); +* exit(1);return 0; /* some compilers demand return values */ +*} + END + SUBROUTINE I1MCR1(A, A1, B, C, D) +**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** + INTEGER A, A1, B, C, D + A1 = 16777216*B + C + A = 16777216*A1 + D + END +c----------------------------------------------------------------------- + double precision function dgamln(z,ierr) +c Logarithm of Gamma function +c author Amos, Donald E., Sandia National Laboratories +c +c dgamln computes the natural log of the gamma function for +c z.gt.0. the asymptotic expansion is used to generate values +c greater than zmin which are adjusted by the recursion +c g(z+1)=z*g(z) for z.le.zmin. the function was made as +c portable as possible by computimg zmin from the number of base +c 10 digits in a word, rln=amax1(-alog10(r1mach(4)),0.5e-18) +c limited to 18 digits of (relative) accuracy. +c +c since integer arguments are common, a table look up on 100 +c values is used for speed of execution. +c +c description of arguments +c +c input z is d0uble precision +c z - argument, z.gt.0.0d0 +c +c output dgamln is double precision +c dgamln - natural log of the gamma function at z.ne.0.0d0 +c ierr - error flag +c ierr=0, normal return, computation completed +c ierr=1, z.le.0.0d0, no computation +c +c +c***routines called i1mach,d1mach + double precision cf, con, fln, fz, gln, rln, s, tlg, trm, tst, + * t1, wdtol, z, zdmy, zinc, zm, zmin, zp, zsq, d1mach + integer i, ierr, i1m, k, mz, nz, i1mach + dimension cf(22), gln(100) +c lngamma(n), n=1,100 + data gln(1), gln(2), gln(3), gln(4), gln(5), gln(6), gln(7), + 1 gln(8), gln(9), gln(10), gln(11), gln(12), gln(13), gln(14), + 2 gln(15), gln(16), gln(17), gln(18), gln(19), gln(20), + 3 gln(21), gln(22)/ + 4 0.00000000000000000d+00, 0.00000000000000000d+00, + 5 6.93147180559945309d-01, 1.79175946922805500d+00, + 6 3.17805383034794562d+00, 4.78749174278204599d+00, + 7 6.57925121201010100d+00, 8.52516136106541430d+00, + 8 1.06046029027452502d+01, 1.28018274800814696d+01, + 9 1.51044125730755153d+01, 1.75023078458738858d+01, + a 1.99872144956618861d+01, 2.25521638531234229d+01, + b 2.51912211827386815d+01, 2.78992713838408916d+01, + c 3.06718601060806728d+01, 3.35050734501368889d+01, + d 3.63954452080330536d+01, 3.93398841871994940d+01, + e 4.23356164607534850d+01, 4.53801388984769080d+01/ + data gln(23), gln(24), gln(25), gln(26), gln(27), gln(28), + 1 gln(29), gln(30), gln(31), gln(32), gln(33), gln(34), + 2 gln(35), gln(36), gln(37), gln(38), gln(39), gln(40), + 3 gln(41), gln(42), gln(43), gln(44)/ + 4 4.84711813518352239d+01, 5.16066755677643736d+01, + 5 5.47847293981123192d+01, 5.80036052229805199d+01, + 6 6.12617017610020020d+01, 6.45575386270063311d+01, + 7 6.78897431371815350d+01, 7.12570389671680090d+01, + 8 7.46582363488301644d+01, 7.80922235533153106d+01, + 9 8.15579594561150372d+01, 8.50544670175815174d+01, + a 8.85808275421976788d+01, 9.21361756036870925d+01, + b 9.57196945421432025d+01, 9.93306124547874269d+01, + c 1.02968198614513813d+02, 1.06631760260643459d+02, + d 1.10320639714757395d+02, 1.14034211781461703d+02, + e 1.17771881399745072d+02, 1.21533081515438634d+02/ + data gln(45), gln(46), gln(47), gln(48), gln(49), gln(50), + 1 gln(51), gln(52), gln(53), gln(54), gln(55), gln(56), + 2 gln(57), gln(58), gln(59), gln(60), gln(61), gln(62), + 3 gln(63), gln(64), gln(65), gln(66)/ + 4 1.25317271149356895d+02, 1.29123933639127215d+02, + 5 1.32952575035616310d+02, 1.36802722637326368d+02, + 6 1.40673923648234259d+02, 1.44565743946344886d+02, + 7 1.48477766951773032d+02, 1.52409592584497358d+02, + 8 1.56360836303078785d+02, 1.60331128216630907d+02, + 9 1.64320112263195181d+02, 1.68327445448427652d+02, + a 1.72352797139162802d+02, 1.76395848406997352d+02, + b 1.80456291417543771d+02, 1.84533828861449491d+02, + c 1.88628173423671591d+02, 1.92739047287844902d+02, + d 1.96866181672889994d+02, 2.01009316399281527d+02, + e 2.05168199482641199d+02, 2.09342586752536836d+02/ + data gln(67), gln(68), gln(69), gln(70), gln(71), gln(72), + 1 gln(73), gln(74), gln(75), gln(76), gln(77), gln(78), + 2 gln(79), gln(80), gln(81), gln(82), gln(83), gln(84), + 3 gln(85), gln(86), gln(87), gln(88)/ + 4 2.13532241494563261d+02, 2.17736934113954227d+02, + 5 2.21956441819130334d+02, 2.26190548323727593d+02, + 6 2.30439043565776952d+02, 2.34701723442818268d+02, + 7 2.38978389561834323d+02, 2.43268849002982714d+02, + 8 2.47572914096186884d+02, 2.51890402209723194d+02, + 9 2.56221135550009525d+02, 2.60564940971863209d+02, + a 2.64921649798552801d+02, 2.69291097651019823d+02, + b 2.73673124285693704d+02, 2.78067573440366143d+02, + c 2.82474292687630396d+02, 2.86893133295426994d+02, + d 2.91323950094270308d+02, 2.95766601350760624d+02, + e 3.00220948647014132d+02, 3.04686856765668715d+02/ + data gln(89), gln(90), gln(91), gln(92), gln(93), gln(94), + 1 gln(95), gln(96), gln(97), gln(98), gln(99), gln(100)/ + 2 3.09164193580146922d+02, 3.13652829949879062d+02, + 3 3.18152639620209327d+02, 3.22663499126726177d+02, + 4 3.27185287703775217d+02, 3.31717887196928473d+02, + 5 3.36261181979198477d+02, 3.40815058870799018d+02, + 6 3.45379407062266854d+02, 3.49954118040770237d+02, + 7 3.54539085519440809d+02, 3.59134205369575399d+02/ +c coefficients of asymptotic expansion + data cf(1), cf(2), cf(3), cf(4), cf(5), cf(6), cf(7), cf(8), + 1 cf(9), cf(10), cf(11), cf(12), cf(13), cf(14), cf(15), + 2 cf(16), cf(17), cf(18), cf(19), cf(20), cf(21), cf(22)/ + 3 8.33333333333333333d-02, -2.77777777777777778d-03, + 4 7.93650793650793651d-04, -5.95238095238095238d-04, + 5 8.41750841750841751d-04, -1.91752691752691753d-03, + 6 6.41025641025641026d-03, -2.95506535947712418d-02, + 7 1.79644372368830573d-01, -1.39243221690590112d+00, + 8 1.34028640441683920d+01, -1.56848284626002017d+02, + 9 2.19310333333333333d+03, -3.61087712537249894d+04, + a 6.91472268851313067d+05, -1.52382215394074162d+07, + b 3.82900751391414141d+08, -1.08822660357843911d+10, + c 3.47320283765002252d+11, -1.23696021422692745d+13, + d 4.88788064793079335d+14, -2.13203339609193739d+16/ +c +c ln(2*pi) + data con / 1.83787706640934548d+00/ +c +c***first executable statement dgamln + ierr=0 + if (z.le.0.0d0) go to 70 + if (z.gt.101.0d0) go to 10 + nz = int(sngl(z)) + fz = z - float(nz) + if (fz.gt.0.0d0) go to 10 + if (nz.gt.100) go to 10 + dgamln = gln(nz) + return + 10 continue + wdtol = d1mach(4) + wdtol = dmax1(wdtol,0.5d-18) + i1m = i1mach(14) + rln = d1mach(5)*float(i1m) + fln = dmin1(rln,20.0d0) + fln = dmax1(fln,3.0d0) + fln = fln - 3.0d0 + zm = 1.8000d0 + 0.3875d0*fln + mz = int(sngl(zm)) + 1 + zmin = float(mz) + zdmy = z + zinc = 0.0d0 + if (z.ge.zmin) go to 20 + zinc = zmin - float(nz) + zdmy = z + zinc + 20 continue + zp = 1.0d0/zdmy + t1 = cf(1)*zp + s = t1 + if (zp.lt.wdtol) go to 40 + zsq = zp*zp + tst = t1*wdtol + do 30 k=2,22 + zp = zp*zsq + trm = cf(k)*zp + if (dabs(trm).lt.tst) go to 40 + s = s + trm + 30 continue + 40 continue + if (zinc.ne.0.0d0) go to 50 + tlg = dlog(z) + dgamln = z*(tlg-1.0d0) + 0.5d0*(con-tlg) + s + return + 50 continue + zp = 1.0d0 + nz = int(sngl(zinc)) + do 60 i=1,nz + zp = zp*(z+float(i-1)) + 60 continue + tlg = dlog(zdmy) + dgamln = zdmy*(tlg-1.0d0) - dlog(zp) + 0.5d0*(con-tlg) + s + return +c +c + 70 continue + dgamln = d1mach(7) + ierr=1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine xerror(mess,nmess,l1,l2) +c +c this is a dummy xerror routine to print error messages with nmess +c characters. l1 and l2 are dummy parameters to make this call +c compatible with the slatec xerror routine. this is a fortran 77 +c routine. +c + character*(*) mess + nn=nmess/70 + nr=nmess-70*nn + if(nr.ne.0) nn=nn+1 + k=1 + print 900 + 900 format(/) + do 10 i=1,nn + kmin=min0(k+69,nmess) + print *, mess(k:kmin) + k=k+70 + 10 continue + print 900 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + double precision function zabs2(zr, zi) +c refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c zabs2 computes the absolute value or magnitude of a double +c precision complex variable cmplx(zr,zi) +c + double precision zr, zi, u, v, q, s + u = dabs(zr) + v = dabs(zi) + s = u + v +c----------------------------------------------------------------------- +c s*1.0d0 makes an unnormalized underflow on cdc machines into a +c true floating zero +c----------------------------------------------------------------------- + s = s*1.0d+0 + if (s.eq.0.0d+0) go to 20 + if (u.gt.v) go to 10 + q = u/v + zabs2 = v*dsqrt(1.d+0+q*q) + return + 10 q = v/u + zabs2 = u*dsqrt(1.d+0+q*q) + return + 20 zabs2 = 0.0d+0 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zacai(zr, zi, fnu, kode, mr, n, yr, yi, nz, rl, tol, + * elim, alim) +c Refer to zairy +c +c zacai applies the analytic continuation formula +c +c k(fnu,zn*exp(mp))=k(fnu,zn)*exp(-mp*fnu) - mp*i(fnu,zn) +c mp=pi*mr*cmplx(0.0,1.0) +c +c to continue the k function from the right half to the left +c half z plane for use with zairy where fnu=1/3 or 2/3 and n=1. +c zacai is the same as zacon with the parts for larger orders and +c recurrence removed. a recursive call to zacon can result if zacon +c is called from zairy. +c +c***routines called zasyi,zbknu,zmlri,zseri,zs1s2,d1mach,zabs2 +c complex csgn,cspn,c1,c2,y,z,zn,cy + double precision alim, arg, ascle, az, csgnr, csgni, cspnr, + * cspni, c1r, c1i, c2r, c2i, cyr, cyi, dfnu, elim, fmr, fnu, pi, + * rl, sgn, tol, yy, yr, yi, zr, zi, znr, zni, d1mach, zabs2 + integer inu, iuf, kode, mr, n, nn, nw, nz + dimension yr(n), yi(n), cyr(2), cyi(2) + data pi / 3.14159265358979324d0 / + nz = 0 + znr = -zr + zni = -zi + az = zabs2(zr,zi) + nn = n + dfnu = fnu + dble(float(n-1)) + if (az.le.2.0d0) go to 10 + if (az*az*0.25d0.gt.dfnu+1.0d0) go to 20 + 10 continue +c----------------------------------------------------------------------- +c power series for the i function +c----------------------------------------------------------------------- + call zseri(znr, zni, fnu, kode, nn, yr, yi, nw, tol, elim, alim) + go to 40 + 20 continue + if (az.lt.rl) go to 30 +c----------------------------------------------------------------------- +c asymptotic expansion for large z for the i function +c----------------------------------------------------------------------- + call zasyi(znr, zni, fnu, kode, nn, yr, yi, nw, rl, tol, elim, + * alim) + if (nw.lt.0) go to 80 + go to 40 + 30 continue +c----------------------------------------------------------------------- +c miller algorithm normalized by the series for the i function +c----------------------------------------------------------------------- + call zmlri(znr, zni, fnu, kode, nn, yr, yi, nw, tol) + if(nw.lt.0) go to 80 + 40 continue +c----------------------------------------------------------------------- +c analytic continuation to the left half plane for the k function +c----------------------------------------------------------------------- + call zbknu(znr, zni, fnu, kode, 1, cyr, cyi, nw, tol, elim, alim) + if (nw.ne.0) go to 80 + fmr = dble(float(mr)) + sgn = -dsign(pi,fmr) + csgnr = 0.0d0 + csgni = sgn + if (kode.eq.1) go to 50 + yy = -zni + csgnr = -csgni*dsin(yy) + csgni = csgni*dcos(yy) + 50 continue +c----------------------------------------------------------------------- +c calculate cspn=exp(fnu*pi*i) to minimize losses of significance +c when fnu is large +c----------------------------------------------------------------------- + inu = int(sngl(fnu)) + arg = (fnu-dble(float(inu)))*sgn + cspnr = dcos(arg) + cspni = dsin(arg) + if (mod(inu,2).eq.0) go to 60 + cspnr = -cspnr + cspni = -cspni + 60 continue + c1r = cyr(1) + c1i = cyi(1) + c2r = yr(1) + c2i = yi(1) + if (kode.eq.1) go to 70 + iuf = 0 + ascle = 1.0d+3*d1mach(1)/tol + call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) + nz = nz + nw + 70 continue + yr(1) = cspnr*c1r - cspni*c1i + csgnr*c2r - csgni*c2i + yi(1) = cspnr*c1i + cspni*c1r + csgnr*c2i + csgni*c2r + return + 80 continue + nz = -1 + if(nw.eq.(-2)) nz=-2 + return + end +c----------------------------------------------------------------------- + subroutine zacon(zr, zi, fnu, kode, mr, n, yr, yi, nz, rl, fnul, + * tol, elim, alim) +c Refer to zbesk,zbesh +c +c zacon applies the analytic continuation formula +c +c k(fnu,zn*exp(mp))=k(fnu,zn)*exp(-mp*fnu) - mp*i(fnu,zn) +c mp=pi*mr*cmplx(0.0,1.0) +c +c to continue the k function from the right half to the left +c half z plane +c +c***routines called zbinu,zbknu,zs1s2,d1mach,zabs2,zmlt +c +c complex ck,cone,cscl,cscr,csgn,cspn,cy,czero,c1,c2,rz,sc1,sc2,st, +c *s1,s2,y,z,zn + double precision alim, arg, ascle, as2, azn, bry, bscle, cki, + * ckr, coner, cpn, cscl, cscr, csgni, csgnr, cspni, cspnr, + * csr, csrr, cssr, cyi, cyr, c1i, c1m, c1r, c2i, c2r, elim, fmr, + * fn, fnu, fnul, pi, pti, ptr, razn, rl, rzi, rzr, sc1i, sc1r, + * sc2i, sc2r, sgn, spn, sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, + * yy, zeror, zi, zni, znr, zr, d1mach, zabs2 + integer i, inu, iuf, kflag, kode, mr, n, nn, nw, nz + dimension yr(n), yi(n), cyr(2), cyi(2), cssr(3), csrr(3), bry(3) + data pi / 3.14159265358979324d0 / + data zeror,coner / 0.0d0,1.0d0 / + nz = 0 + znr = -zr + zni = -zi + nn = n + call zbinu(znr, zni, fnu, kode, nn, yr, yi, nw, rl, fnul, tol, + * elim, alim) + if (nw.lt.0) go to 90 +c----------------------------------------------------------------------- +c analytic continuation to the left half plane for the k function +c----------------------------------------------------------------------- + nn = min0(2,n) + call zbknu(znr, zni, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) + if (nw.ne.0) go to 90 + s1r = cyr(1) + s1i = cyi(1) + fmr = dble(float(mr)) + sgn = -dsign(pi,fmr) + csgnr = zeror + csgni = sgn + if (kode.eq.1) go to 10 + yy = -zni + cpn = dcos(yy) + spn = dsin(yy) + call zmlt(csgnr, csgni, cpn, spn, csgnr, csgni) + 10 continue +c----------------------------------------------------------------------- +c calculate cspn=exp(fnu*pi*i) to minimize losses of significance +c when fnu is large +c----------------------------------------------------------------------- + inu = int(sngl(fnu)) + arg = (fnu-dble(float(inu)))*sgn + cpn = dcos(arg) + spn = dsin(arg) + cspnr = cpn + cspni = spn + if (mod(inu,2).eq.0) go to 20 + cspnr = -cspnr + cspni = -cspni + 20 continue + iuf = 0 + c1r = s1r + c1i = s1i + c2r = yr(1) + c2i = yi(1) + ascle = 1.0d+3*d1mach(1)/tol + if (kode.eq.1) go to 30 + call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) + nz = nz + nw + sc1r = c1r + sc1i = c1i + 30 continue + call zmlt(cspnr, cspni, c1r, c1i, str, sti) + call zmlt(csgnr, csgni, c2r, c2i, ptr, pti) + yr(1) = str + ptr + yi(1) = sti + pti + if (n.eq.1) return + cspnr = -cspnr + cspni = -cspni + s2r = cyr(2) + s2i = cyi(2) + c1r = s2r + c1i = s2i + c2r = yr(2) + c2i = yi(2) + if (kode.eq.1) go to 40 + call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) + nz = nz + nw + sc2r = c1r + sc2i = c1i + 40 continue + call zmlt(cspnr, cspni, c1r, c1i, str, sti) + call zmlt(csgnr, csgni, c2r, c2i, ptr, pti) + yr(2) = str + ptr + yi(2) = sti + pti + if (n.eq.2) return + cspnr = -cspnr + cspni = -cspni + azn = zabs2(znr,zni) + razn = 1.0d0/azn + str = znr*razn + sti = -zni*razn + rzr = (str+str)*razn + rzi = (sti+sti)*razn + fn = fnu + 1.0d0 + ckr = fn*rzr + cki = fn*rzi +c----------------------------------------------------------------------- +c scale near exponent extremes during recurrence on k functions +c----------------------------------------------------------------------- + cscl = 1.0d0/tol + cscr = tol + cssr(1) = cscl + cssr(2) = coner + cssr(3) = cscr + csrr(1) = cscr + csrr(2) = coner + csrr(3) = cscl + bry(1) = ascle + bry(2) = 1.0d0/ascle + bry(3) = d1mach(2) + as2 = zabs2(s2r,s2i) + kflag = 2 + if (as2.gt.bry(1)) go to 50 + kflag = 1 + go to 60 + 50 continue + if (as2.lt.bry(2)) go to 60 + kflag = 3 + 60 continue + bscle = bry(kflag) + s1r = s1r*cssr(kflag) + s1i = s1i*cssr(kflag) + s2r = s2r*cssr(kflag) + s2i = s2i*cssr(kflag) + csr = csrr(kflag) + do 80 i=3,n + str = s2r + sti = s2i + s2r = ckr*str - cki*sti + s1r + s2i = ckr*sti + cki*str + s1i + s1r = str + s1i = sti + c1r = s2r*csr + c1i = s2i*csr + str = c1r + sti = c1i + c2r = yr(i) + c2i = yi(i) + if (kode.eq.1) go to 70 + if (iuf.lt.0) go to 70 + call zs1s2(znr, zni, c1r, c1i, c2r, c2i, nw, ascle, alim, iuf) + nz = nz + nw + sc1r = sc2r + sc1i = sc2i + sc2r = c1r + sc2i = c1i + if (iuf.ne.3) go to 70 + iuf = -4 + s1r = sc1r*cssr(kflag) + s1i = sc1i*cssr(kflag) + s2r = sc2r*cssr(kflag) + s2i = sc2i*cssr(kflag) + str = sc2r + sti = sc2i + 70 continue + ptr = cspnr*c1r - cspni*c1i + pti = cspnr*c1i + cspni*c1r + yr(i) = ptr + csgnr*c2r - csgni*c2i + yi(i) = pti + csgnr*c2i + csgni*c2r + ckr = ckr + rzr + cki = cki + rzi + cspnr = -cspnr + cspni = -cspni + if (kflag.ge.3) go to 80 + ptr = dabs(c1r) + pti = dabs(c1i) + c1m = dmax1(ptr,pti) + if (c1m.le.bscle) go to 80 + kflag = kflag + 1 + bscle = bry(kflag) + s1r = s1r*csr + s1i = s1i*csr + s2r = str + s2i = sti + s1r = s1r*cssr(kflag) + s1i = s1i*cssr(kflag) + s2r = s2r*cssr(kflag) + s2i = s2i*cssr(kflag) + csr = csrr(kflag) + 80 continue + return + 90 continue + nz = -1 + if(nw.eq.(-2)) nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zdiv(ar, ai, br, bi, cr, ci) +c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c +c double precision complex divide c=a/b. +c +c***routines called zabs2 +c + double precision ar, ai, br, bi, cr, ci, bm, ca, cb, cc, cd + double precision zabs2 + bm = 1.0d0/zabs2(br,bi) + cc = br*bm + cd = bi*bm + ca = (ar*cc+ai*cd)*bm + cb = (ai*cc-ar*cd)*bm + cr = ca + ci = cb + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zexp(ar, ai, br, bi) +c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c +c double precision complex exponential function b=exp(a) +c + double precision ar, ai, br, bi, zm, ca, cb + zm = dexp(ar) + ca = zm*dcos(ai) + cb = zm*dsin(ai) + br = ca + bi = cb + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zkscl(zrr,zri,fnu,n,yr,yi,nz,rzr,rzi,ascle,tol,elim) +c geuz for g77 + EXTERNAL zlog +c refer to zbesk +c +c set k functions to zero on underflow, continue recurrence +c on scaled functions until two members come on scale, then +c return with min(nz+2,n) values scaled by 1/tol. +c +c routines called zuchk,zabs2,zlog +c +c complex ck,cs,cy,czero,rz,s1,s2,y,zr,zd,celm + double precision acs, as, ascle, cki, ckr, csi, csr, cyi, + * cyr, elim, fn, fnu, rzi, rzr, str, s1i, s1r, s2i, + * s2r, tol, yi, yr, zeroi, zeror, zri, zrr, zabs2, + * zdr, zdi, celmr, elm, helim, alas + integer i, ic, idum, kk, n, nn, nw, nz + dimension yr(n), yi(n), cyr(2), cyi(2) + data zeror,zeroi / 0.0d0 , 0.0d0 / +c + nz = 0 + ic = 0 + nn = min0(2,n) + do 10 i=1,nn + s1r = yr(i) + s1i = yi(i) + cyr(i) = s1r + cyi(i) = s1i + as = zabs2(s1r,s1i) + acs = -zrr + dlog(as) + nz = nz + 1 + yr(i) = zeror + yi(i) = zeroi + if (acs.lt.(-elim)) go to 10 + call zlog(s1r, s1i, csr, csi, idum) + csr = csr - zrr + csi = csi - zri + str = dexp(csr)/tol + csr = str*dcos(csi) + csi = str*dsin(csi) + call zuchk(csr, csi, nw, ascle, tol) + if (nw.ne.0) go to 10 + yr(i) = csr + yi(i) = csi + ic = i + nz = nz - 1 + 10 continue + if (n.eq.1) return + if (ic.gt.1) go to 20 + yr(1) = zeror + yi(1) = zeroi + nz = 2 + 20 continue + if (n.eq.2) return + if (nz.eq.0) return + fn = fnu + 1.0d0 + ckr = fn*rzr + cki = fn*rzi + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + helim = 0.5d0*elim + elm = dexp(-elim) + celmr = elm + zdr = zrr + zdi = zri +c +c find two consecutive y values on scale. scale recurrence if +c s2 gets larger than exp(elim/2) +c + do 30 i=3,n + kk = i + csr = s2r + csi = s2i + s2r = ckr*csr - cki*csi + s1r + s2i = cki*csr + ckr*csi + s1i + s1r = csr + s1i = csi + ckr = ckr + rzr + cki = cki + rzi + as = zabs2(s2r,s2i) + alas = dlog(as) + acs = -zdr + alas + nz = nz + 1 + yr(i) = zeror + yi(i) = zeroi + if (acs.lt.(-elim)) go to 25 + call zlog(s2r, s2i, csr, csi, idum) + csr = csr - zdr + csi = csi - zdi + str = dexp(csr)/tol + csr = str*dcos(csi) + csi = str*dsin(csi) + call zuchk(csr, csi, nw, ascle, tol) + if (nw.ne.0) go to 25 + yr(i) = csr + yi(i) = csi + nz = nz - 1 + if (ic.eq.kk-1) go to 40 + ic = kk + go to 30 + 25 continue + if(alas.lt.helim) go to 30 + zdr = zdr - elim + s1r = s1r*celmr + s1i = s1i*celmr + s2r = s2r*celmr + s2i = s2i*celmr + 30 continue + nz = n + if(ic.eq.n) nz=n-1 + go to 45 + 40 continue + nz = kk - 2 + 45 continue + do 50 i=1,nz + yr(i) = zeror + yi(i) = zeroi + 50 continue + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zlog(ar, ai, br, bi, ierr) +c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c +c double precision complex logarithm b=clog(a) +c ierr=0,normal return ierr=1, z=cmplx(0.0,0.0) +c***routines called zabs2 + double precision ar, ai, br, bi, zm, dtheta, dpi, dhpi + double precision zabs2 + data dpi , dhpi / 3.141592653589793238462643383d+0, + 1 1.570796326794896619231321696d+0/ +c + ierr=0 + if (ar.eq.0.0d+0) go to 10 + if (ai.eq.0.0d+0) go to 20 + dtheta = datan(ai/ar) + if (dtheta.le.0.0d+0) go to 40 + if (ar.lt.0.0d+0) dtheta = dtheta - dpi + go to 50 + 10 if (ai.eq.0.0d+0) go to 60 + bi = dhpi + br = dlog(dabs(ai)) + if (ai.lt.0.0d+0) bi = -bi + return + 20 if (ar.gt.0.0d+0) go to 30 + br = dlog(dabs(ar)) + bi = dpi + return + 30 br = dlog(ar) + bi = 0.0d+0 + return + 40 if (ar.lt.0.0d+0) dtheta = dtheta + dpi + 50 zm = zabs2(ar,ai) + br = dlog(zm) + bi = dtheta + return + 60 continue + ierr=1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zmlt(ar, ai, br, bi, cr, ci) +c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c +c double precision complex multiply, c=a*b. +c + double precision ar, ai, br, bi, cr, ci, ca, cb + ca = ar*br - ai*bi + cb = ar*bi + ai*br + cr = ca + ci = cb + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zrati(zr, zi, fnu, n, cyr, cyi, tol) +c Refer to zbesi,zbesk,zbesh +c +c zrati computes ratios of i bessel functions by backward +c recurrence. the starting index is determined by forward +c recurrence as described in j. res. of nat. bur. of standards-b, +c mathematical sciences, vol 77b, p111-114, september, 1973, +c bessel functions i and j of complex argument and integer order, +c by d. j. sookne. +c +c***routines called zabs2,zdiv +c complex z,cy(1),cone,czero,p1,p2,t1,rz,pt,cdfnu + double precision ak, amagz, ap1, ap2, arg, az, cdfnui, cdfnur, + * conei, coner, cyi, cyr, czeroi, czeror, dfnu, fdnu, flam, fnu, + * fnup, pti, ptr, p1i, p1r, p2i, p2r, rak, rap1, rho, rt2, rzi, + * rzr, test, test1, tol, tti, ttr, t1i, t1r, zi, zr, zabs2 + integer i, id, idnu, inu, itime, k, kk, magz, n + dimension cyr(n), cyi(n) + data czeror,czeroi,coner,conei,rt2/ + 1 0.0d0, 0.0d0, 1.0d0, 0.0d0, 1.41421356237309505d0 / + az = zabs2(zr,zi) + inu = int(sngl(fnu)) + idnu = inu + n - 1 + magz = int(sngl(az)) + amagz = dble(float(magz+1)) + fdnu = dble(float(idnu)) + fnup = dmax1(amagz,fdnu) + id = idnu - magz - 1 + itime = 1 + k = 1 + ptr = 1.0d0/az + rzr = ptr*(zr+zr)*ptr + rzi = -ptr*(zi+zi)*ptr + t1r = rzr*fnup + t1i = rzi*fnup + p2r = -t1r + p2i = -t1i + p1r = coner + p1i = conei + t1r = t1r + rzr + t1i = t1i + rzi + if (id.gt.0) id = 0 + ap2 = zabs2(p2r,p2i) + ap1 = zabs2(p1r,p1i) +c----------------------------------------------------------------------- +c the overflow test on k(fnu+i-1,z) before the call to cbknu +c guarantees that p2 is on scale. scale test1 and all subsequent +c p2 values by ap1 to ensure that an overflow does not occur +c prematurely. +c----------------------------------------------------------------------- + arg = (ap2+ap2)/(ap1*tol) + test1 = dsqrt(arg) + test = test1 + rap1 = 1.0d0/ap1 + p1r = p1r*rap1 + p1i = p1i*rap1 + p2r = p2r*rap1 + p2i = p2i*rap1 + ap2 = ap2*rap1 + 10 continue + k = k + 1 + ap1 = ap2 + ptr = p2r + pti = p2i + p2r = p1r - (t1r*ptr-t1i*pti) + p2i = p1i - (t1r*pti+t1i*ptr) + p1r = ptr + p1i = pti + t1r = t1r + rzr + t1i = t1i + rzi + ap2 = zabs2(p2r,p2i) + if (ap1.le.test) go to 10 + if (itime.eq.2) go to 20 + ak = zabs2(t1r,t1i)*0.5d0 + flam = ak + dsqrt(ak*ak-1.0d0) + rho = dmin1(ap2/ap1,flam) + test = test1*dsqrt(rho/(rho*rho-1.0d0)) + itime = 2 + go to 10 + 20 continue + kk = k + 1 - id + ak = dble(float(kk)) + t1r = ak + t1i = czeroi + dfnu = fnu + dble(float(n-1)) + p1r = 1.0d0/ap2 + p1i = czeroi + p2r = czeror + p2i = czeroi + do 30 i=1,kk + ptr = p1r + pti = p1i + rap1 = dfnu + t1r + ttr = rzr*rap1 + tti = rzi*rap1 + p1r = (ptr*ttr-pti*tti) + p2r + p1i = (ptr*tti+pti*ttr) + p2i + p2r = ptr + p2i = pti + t1r = t1r - coner + 30 continue + if (p1r.ne.czeror .or. p1i.ne.czeroi) go to 40 + p1r = tol + p1i = tol + 40 continue + call zdiv(p2r, p2i, p1r, p1i, cyr(n), cyi(n)) + if (n.eq.1) return + k = n - 1 + ak = dble(float(k)) + t1r = ak + t1i = czeroi + cdfnur = fnu*rzr + cdfnui = fnu*rzi + do 60 i=2,n + ptr = cdfnur + (t1r*rzr-t1i*rzi) + cyr(k+1) + pti = cdfnui + (t1r*rzi+t1i*rzr) + cyi(k+1) + ak = zabs2(ptr,pti) + if (ak.ne.czeror) go to 50 + ptr = tol + pti = tol + ak = tol*rt2 + 50 continue + rak = coner/ak + cyr(k) = rak*ptr*rak + cyi(k) = -rak*pti*rak + t1r = t1r - coner + k = k - 1 + 60 continue + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nz, ascle, alim, + * iuf) +c geuz for g77 + EXTERNAL zexp + EXTERNAL zlog +c Refer to zbesk,zairy +c +c zs1s2 tests for a possible underflow resulting from the +c addition of the i and k functions in the analytic con- +c tinuation formula where s1=k function and s2=i function. +c on kode=1 the i and k functions are different orders of +c magnitude, but for kode=2 they can be of the same order +c of magnitude and the maximum must be at least one +c precision above the underflow limit. +c +c***routines called zabs2,zexp,zlog +c complex czero,c1,s1,s1d,s2,zr + double precision aa, alim, aln, ascle, as1, as2, c1i, c1r, s1di, + * s1dr, s1i, s1r, s2i, s2r, zeroi, zeror, zri, zrr, zabs2 + integer iuf, idum, nz + data zeror,zeroi / 0.0d0 , 0.0d0 / + nz = 0 + as1 = zabs2(s1r,s1i) + as2 = zabs2(s2r,s2i) + if (s1r.eq.0.0d0 .and. s1i.eq.0.0d0) go to 10 + if (as1.eq.0.0d0) go to 10 + aln = -zrr - zrr + dlog(as1) + s1dr = s1r + s1di = s1i + s1r = zeror + s1i = zeroi + as1 = zeror + if (aln.lt.(-alim)) go to 10 + call zlog(s1dr, s1di, c1r, c1i, idum) + c1r = c1r - zrr - zrr + c1i = c1i - zri - zri + call zexp(c1r, c1i, s1r, s1i) + as1 = zabs2(s1r,s1i) + iuf = iuf + 1 + 10 continue + aa = dmax1(as1,as2) + if (aa.gt.ascle) return + s1r = zeror + s1i = zeroi + s2r = zeror + s2i = zeroi + nz = 1 + iuf = 0 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zshch(zr, zi, cshr, cshi, cchr, cchi) +c Refer to zbesk,zbesh +c +c zshch computes the complex hyperbolic functions csh=sinh(x+i*y) +c and cch=cosh(x+i*y), where i**2=-1. +c + double precision cchi, cchr, ch, cn, cshi, cshr, sh, sn, zi, zr, + * dcosh, dsinh + sh = dsinh(zr) + ch = dcosh(zr) + sn = dsin(zi) + cn = dcos(zi) + cshr = sh*cn + cshi = ch*sn + cchr = ch*cn + cchi = sh*sn + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zsqrt(ar, ai, br, bi) +c Refer to zbesh,zbesi,zbesj,zbesk,zbesy,zairy,zbiry +c +c double precision complex square root, b=csqrt(a) +c +c***routines called zabs2 +c + double precision ar, ai, br, bi, zm, dtheta, dpi, drt + double precision zabs2 + data drt , dpi / 7.071067811865475244008443621d-1, + 1 3.141592653589793238462643383d+0/ + zm = zabs2(ar,ai) + zm = dsqrt(zm) + if (ar.eq.0.0d+0) go to 10 + if (ai.eq.0.0d+0) go to 20 + dtheta = datan(ai/ar) + if (dtheta.le.0.0d+0) go to 40 + if (ar.lt.0.0d+0) dtheta = dtheta - dpi + go to 50 + 10 if (ai.gt.0.0d+0) go to 60 + if (ai.lt.0.0d+0) go to 70 + br = 0.0d+0 + bi = 0.0d+0 + return + 20 if (ar.gt.0.0d+0) go to 30 + br = 0.0d+0 + bi = dsqrt(dabs(ar)) + return + 30 br = dsqrt(ar) + bi = 0.0d+0 + return + 40 if (ar.lt.0.0d+0) dtheta = dtheta + dpi + 50 dtheta = dtheta*0.5d+0 + br = zm*dcos(dtheta) + bi = zm*dsin(dtheta) + return + 60 br = zm*drt + bi = zm*drt + return + 70 br = zm*drt + bi = -zm*drt + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zuchk(yr, yi, nz, ascle, tol) +c refer to zseri,zuoik,zunk1,zunk2,zuni1,zuni2,zkscl +c +c y enters as a scaled quantity whose magnitude is greater than +c exp(-alim)=ascle=1.0e+3*d1mach(1)/tol. the test is made to see +c if the magnitude of the real or imaginary part would underflow +c when y is scaled (by tol) to its proper value. y is accepted +c if the underflow is at least one precision below the magnitude +c of the largest component; otherwise the phase angle does not have +c absolute accuracy and an underflow is assumed. +c +c complex y + double precision ascle, ss, st, tol, wr, wi, yr, yi + integer nz + nz = 0 + wr = dabs(yr) + wi = dabs(yi) + st = dmin1(wr,wi) + if (st.gt.ascle) return + ss = dmax1(wr,wi) + st = st/tol + if (ss.lt.st) nz = 1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zunhj(zr, zi, fnu, ipmtr, tol, phir, phii, argr, argi, + * zeta1r, zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) +c geuz for g77 + EXTERNAL zsqrt + EXTERNAL zlog +c refer to zbesi,zbesk +c +c zunhj computes parameters for bessel functions c(fnu,z) = +c j(fnu,z), y(fnu,z) or h(i,fnu,z) i=1,2 for large orders fnu +c by means of the uniform asymptotic expansion +c +c c(fnu,z)=c1*phi*( asum*airy(arg) + c2*bsum*dairy(arg) ) +c +c for proper choices of c1, c2, airy and dairy where airy is +c an airy function and dairy is its derivative. +c +c (2/3)*fnu*zeta**1.5 = zeta1-zeta2, +c +c zeta1=0.5*fnu*clog((1+w)/(1-w)), zeta2=fnu*w for scaling +c purposes in airy functions from cairy or cbiry. +c +c mconj=sign of aimag(z), but is ambiguous when z is real and +c must be specified. ipmtr=0 returns all parameters. ipmtr= +c 1 computes all except asum and bsum. +c +c***routines called zabs2,zdiv,zlog,zsqrt,d1mach +c complex arg,asum,bsum,cfnu,cone,cr,czero,dr,p,phi,przth,ptfn, +c *rfn13,rtzta,rzth,suma,sumb,tfn,t2,up,w,w2,z,za,zb,zc,zeta,zeta1, +c *zeta2,zth + double precision alfa, ang, ap, ar, argi, argr, asumi, asumr, + * atol, aw2, azth, beta, br, bsumi, bsumr, btol, c, conei, coner, + * cri, crr, dri, drr, ex1, ex2, fnu, fn13, fn23, gama, gpi, hpi, + * phii, phir, pi, pp, pr, przthi, przthr, ptfni, ptfnr, raw, raw2, + * razth, rfnu, rfnu2, rfn13, rtzti, rtztr, rzthi, rzthr, sti, str, + * sumai, sumar, sumbi, sumbr, test, tfni, tfnr, thpi, tol, tzai, + * tzar, t2i, t2r, upi, upr, wi, wr, w2i, w2r, zai, zar, zbi, zbr, + * zci, zcr, zeroi, zeror, zetai, zetar, zeta1i, zeta1r, zeta2i, + * zeta2r, zi, zr, zthi, zthr, zabs2, ac, d1mach + integer ias, ibs, ipmtr, is, j, jr, ju, k, kmax, kp1, ks, l, lr, + * lrp1, l1, l2, m, idum + dimension ar(14), br(14), c(105), alfa(180), beta(210), gama(30), + * ap(30), pr(30), pi(30), upr(14), upi(14), crr(14), cri(14), + * drr(14), dri(14) + data ar(1), ar(2), ar(3), ar(4), ar(5), ar(6), ar(7), ar(8), + 1 ar(9), ar(10), ar(11), ar(12), ar(13), ar(14)/ + 2 1.00000000000000000d+00, 1.04166666666666667d-01, + 3 8.35503472222222222d-02, 1.28226574556327160d-01, + 4 2.91849026464140464d-01, 8.81627267443757652d-01, + 5 3.32140828186276754d+00, 1.49957629868625547d+01, + 6 7.89230130115865181d+01, 4.74451538868264323d+02, + 7 3.20749009089066193d+03, 2.40865496408740049d+04, + 8 1.98923119169509794d+05, 1.79190200777534383d+06/ + data br(1), br(2), br(3), br(4), br(5), br(6), br(7), br(8), + 1 br(9), br(10), br(11), br(12), br(13), br(14)/ + 2 1.00000000000000000d+00, -1.45833333333333333d-01, + 3 -9.87413194444444444d-02, -1.43312053915895062d-01, + 4 -3.17227202678413548d-01, -9.42429147957120249d-01, + 5 -3.51120304082635426d+00, -1.57272636203680451d+01, + 6 -8.22814390971859444d+01, -4.92355370523670524d+02, + 7 -3.31621856854797251d+03, -2.48276742452085896d+04, + 8 -2.04526587315129788d+05, -1.83844491706820990d+06/ + data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), + 1 c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), + 2 c(19), c(20), c(21), c(22), c(23), c(24)/ + 3 1.00000000000000000d+00, -2.08333333333333333d-01, + 4 1.25000000000000000d-01, 3.34201388888888889d-01, + 5 -4.01041666666666667d-01, 7.03125000000000000d-02, + 6 -1.02581259645061728d+00, 1.84646267361111111d+00, + 7 -8.91210937500000000d-01, 7.32421875000000000d-02, + 8 4.66958442342624743d+00, -1.12070026162229938d+01, + 9 8.78912353515625000d+00, -2.36408691406250000d+00, + a 1.12152099609375000d-01, -2.82120725582002449d+01, + b 8.46362176746007346d+01, -9.18182415432400174d+01, + c 4.25349987453884549d+01, -7.36879435947963170d+00, + d 2.27108001708984375d-01, 2.12570130039217123d+02, + e -7.65252468141181642d+02, 1.05999045252799988d+03/ + data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), + 1 c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), + 2 c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ + 3 -6.99579627376132541d+02, 2.18190511744211590d+02, + 4 -2.64914304869515555d+01, 5.72501420974731445d-01, + 5 -1.91945766231840700d+03, 8.06172218173730938d+03, + 6 -1.35865500064341374d+04, 1.16553933368645332d+04, + 7 -5.30564697861340311d+03, 1.20090291321635246d+03, + 8 -1.08090919788394656d+02, 1.72772750258445740d+00, + 9 2.02042913309661486d+04, -9.69805983886375135d+04, + a 1.92547001232531532d+05, -2.03400177280415534d+05, + b 1.22200464983017460d+05, -4.11926549688975513d+04, + c 7.10951430248936372d+03, -4.93915304773088012d+02, + d 6.07404200127348304d+00, -2.42919187900551333d+05, + e 1.31176361466297720d+06, -2.99801591853810675d+06/ + data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), + 1 c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), + 2 c(65), c(66), c(67), c(68), c(69), c(70), c(71), c(72)/ + 3 3.76327129765640400d+06, -2.81356322658653411d+06, + 4 1.26836527332162478d+06, -3.31645172484563578d+05, + 5 4.52187689813627263d+04, -2.49983048181120962d+03, + 6 2.43805296995560639d+01, 3.28446985307203782d+06, + 7 -1.97068191184322269d+07, 5.09526024926646422d+07, + 8 -7.41051482115326577d+07, 6.63445122747290267d+07, + 9 -3.75671766607633513d+07, 1.32887671664218183d+07, + a -2.78561812808645469d+06, 3.08186404612662398d+05, + b -1.38860897537170405d+04, 1.10017140269246738d+02, + c -4.93292536645099620d+07, 3.25573074185765749d+08, + d -9.39462359681578403d+08, 1.55359689957058006d+09, + e -1.62108055210833708d+09, 1.10684281682301447d+09/ + data c(73), c(74), c(75), c(76), c(77), c(78), c(79), c(80), + 1 c(81), c(82), c(83), c(84), c(85), c(86), c(87), c(88), + 2 c(89), c(90), c(91), c(92), c(93), c(94), c(95), c(96)/ + 3 -4.95889784275030309d+08, 1.42062907797533095d+08, + 4 -2.44740627257387285d+07, 2.24376817792244943d+06, + 5 -8.40054336030240853d+04, 5.51335896122020586d+02, + 6 8.14789096118312115d+08, -5.86648149205184723d+09, + 7 1.86882075092958249d+10, -3.46320433881587779d+10, + 8 4.12801855797539740d+10, -3.30265997498007231d+10, + 9 1.79542137311556001d+10, -6.56329379261928433d+09, + a 1.55927986487925751d+09, -2.25105661889415278d+08, + b 1.73951075539781645d+07, -5.49842327572288687d+05, + c 3.03809051092238427d+03, -1.46792612476956167d+10, + d 1.14498237732025810d+11, -3.99096175224466498d+11, + e 8.19218669548577329d+11, -1.09837515608122331d+12/ + data c(97), c(98), c(99), c(100), c(101), c(102), c(103), c(104), + 1 c(105)/ + 2 1.00815810686538209d+12, -6.45364869245376503d+11, + 3 2.87900649906150589d+11, -8.78670721780232657d+10, + 4 1.76347306068349694d+10, -2.16716498322379509d+09, + 5 1.43157876718888981d+08, -3.87183344257261262d+06, + 6 1.82577554742931747d+04/ + data alfa(1), alfa(2), alfa(3), alfa(4), alfa(5), alfa(6), + 1 alfa(7), alfa(8), alfa(9), alfa(10), alfa(11), alfa(12), + 2 alfa(13), alfa(14), alfa(15), alfa(16), alfa(17), alfa(18), + 3 alfa(19), alfa(20), alfa(21), alfa(22)/ + 4 -4.44444444444444444d-03, -9.22077922077922078d-04, + 5 -8.84892884892884893d-05, 1.65927687832449737d-04, + 6 2.46691372741792910d-04, 2.65995589346254780d-04, + 7 2.61824297061500945d-04, 2.48730437344655609d-04, + 8 2.32721040083232098d-04, 2.16362485712365082d-04, + 9 2.00738858762752355d-04, 1.86267636637545172d-04, + a 1.73060775917876493d-04, 1.61091705929015752d-04, + b 1.50274774160908134d-04, 1.40503497391269794d-04, + c 1.31668816545922806d-04, 1.23667445598253261d-04, + d 1.16405271474737902d-04, 1.09798298372713369d-04, + e 1.03772410422992823d-04, 9.82626078369363448d-05/ + data alfa(23), alfa(24), alfa(25), alfa(26), alfa(27), alfa(28), + 1 alfa(29), alfa(30), alfa(31), alfa(32), alfa(33), alfa(34), + 2 alfa(35), alfa(36), alfa(37), alfa(38), alfa(39), alfa(40), + 3 alfa(41), alfa(42), alfa(43), alfa(44)/ + 4 9.32120517249503256d-05, 8.85710852478711718d-05, + 5 8.42963105715700223d-05, 8.03497548407791151d-05, + 6 7.66981345359207388d-05, 7.33122157481777809d-05, + 7 7.01662625163141333d-05, 6.72375633790160292d-05, + 8 6.93735541354588974d-04, 2.32241745182921654d-04, + 9 -1.41986273556691197d-05, -1.16444931672048640d-04, + a -1.50803558053048762d-04, -1.55121924918096223d-04, + b -1.46809756646465549d-04, -1.33815503867491367d-04, + c -1.19744975684254051d-04, -1.06184319207974020d-04, + d -9.37699549891194492d-05, -8.26923045588193274d-05, + e -7.29374348155221211d-05, -6.44042357721016283d-05/ + data alfa(45), alfa(46), alfa(47), alfa(48), alfa(49), alfa(50), + 1 alfa(51), alfa(52), alfa(53), alfa(54), alfa(55), alfa(56), + 2 alfa(57), alfa(58), alfa(59), alfa(60), alfa(61), alfa(62), + 3 alfa(63), alfa(64), alfa(65), alfa(66)/ + 4 -5.69611566009369048d-05, -5.04731044303561628d-05, + 5 -4.48134868008882786d-05, -3.98688727717598864d-05, + 6 -3.55400532972042498d-05, -3.17414256609022480d-05, + 7 -2.83996793904174811d-05, -2.54522720634870566d-05, + 8 -2.28459297164724555d-05, -2.05352753106480604d-05, + 9 -1.84816217627666085d-05, -1.66519330021393806d-05, + a -1.50179412980119482d-05, -1.35554031379040526d-05, + b -1.22434746473858131d-05, -1.10641884811308169d-05, + c -3.54211971457743841d-04, -1.56161263945159416d-04, + d 3.04465503594936410d-05, 1.30198655773242693d-04, + e 1.67471106699712269d-04, 1.70222587683592569d-04/ + data alfa(67), alfa(68), alfa(69), alfa(70), alfa(71), alfa(72), + 1 alfa(73), alfa(74), alfa(75), alfa(76), alfa(77), alfa(78), + 2 alfa(79), alfa(80), alfa(81), alfa(82), alfa(83), alfa(84), + 3 alfa(85), alfa(86), alfa(87), alfa(88)/ + 4 1.56501427608594704d-04, 1.36339170977445120d-04, + 5 1.14886692029825128d-04, 9.45869093034688111d-05, + 6 7.64498419250898258d-05, 6.07570334965197354d-05, + 7 4.74394299290508799d-05, 3.62757512005344297d-05, + 8 2.69939714979224901d-05, 1.93210938247939253d-05, + 9 1.30056674793963203d-05, 7.82620866744496661d-06, + a 3.59257485819351583d-06, 1.44040049814251817d-07, + b -2.65396769697939116d-06, -4.91346867098485910d-06, + c -6.72739296091248287d-06, -8.17269379678657923d-06, + d -9.31304715093561232d-06, -1.02011418798016441d-05, + e -1.08805962510592880d-05, -1.13875481509603555d-05/ + data alfa(89), alfa(90), alfa(91), alfa(92), alfa(93), alfa(94), + 1 alfa(95), alfa(96), alfa(97), alfa(98), alfa(99), alfa(100), + 2 alfa(101), alfa(102), alfa(103), alfa(104), alfa(105), + 3 alfa(106), alfa(107), alfa(108), alfa(109), alfa(110)/ + 4 -1.17519675674556414d-05, -1.19987364870944141d-05, + 5 3.78194199201772914d-04, 2.02471952761816167d-04, + 6 -6.37938506318862408d-05, -2.38598230603005903d-04, + 7 -3.10916256027361568d-04, -3.13680115247576316d-04, + 8 -2.78950273791323387d-04, -2.28564082619141374d-04, + 9 -1.75245280340846749d-04, -1.25544063060690348d-04, + a -8.22982872820208365d-05, -4.62860730588116458d-05, + b -1.72334302366962267d-05, 5.60690482304602267d-06, + c 2.31395443148286800d-05, 3.62642745856793957d-05, + d 4.58006124490188752d-05, 5.24595294959114050d-05, + e 5.68396208545815266d-05, 5.94349820393104052d-05/ + data alfa(111), alfa(112), alfa(113), alfa(114), alfa(115), + 1 alfa(116), alfa(117), alfa(118), alfa(119), alfa(120), + 2 alfa(121), alfa(122), alfa(123), alfa(124), alfa(125), + 3 alfa(126), alfa(127), alfa(128), alfa(129), alfa(130)/ + 4 6.06478527578421742d-05, 6.08023907788436497d-05, + 5 6.01577894539460388d-05, 5.89199657344698500d-05, + 6 5.72515823777593053d-05, 5.52804375585852577d-05, + 7 5.31063773802880170d-05, 5.08069302012325706d-05, + 8 4.84418647620094842d-05, 4.60568581607475370d-05, + 9 -6.91141397288294174d-04, -4.29976633058871912d-04, + a 1.83067735980039018d-04, 6.60088147542014144d-04, + b 8.75964969951185931d-04, 8.77335235958235514d-04, + c 7.49369585378990637d-04, 5.63832329756980918d-04, + d 3.68059319971443156d-04, 1.88464535514455599d-04/ + data alfa(131), alfa(132), alfa(133), alfa(134), alfa(135), + 1 alfa(136), alfa(137), alfa(138), alfa(139), alfa(140), + 2 alfa(141), alfa(142), alfa(143), alfa(144), alfa(145), + 3 alfa(146), alfa(147), alfa(148), alfa(149), alfa(150)/ + 4 3.70663057664904149d-05, -8.28520220232137023d-05, + 5 -1.72751952869172998d-04, -2.36314873605872983d-04, + 6 -2.77966150694906658d-04, -3.02079514155456919d-04, + 7 -3.12594712643820127d-04, -3.12872558758067163d-04, + 8 -3.05678038466324377d-04, -2.93226470614557331d-04, + 9 -2.77255655582934777d-04, -2.59103928467031709d-04, + a -2.39784014396480342d-04, -2.20048260045422848d-04, + b -2.00443911094971498d-04, -1.81358692210970687d-04, + c -1.63057674478657464d-04, -1.45712672175205844d-04, + d -1.29425421983924587d-04, -1.14245691942445952d-04/ + data alfa(151), alfa(152), alfa(153), alfa(154), alfa(155), + 1 alfa(156), alfa(157), alfa(158), alfa(159), alfa(160), + 2 alfa(161), alfa(162), alfa(163), alfa(164), alfa(165), + 3 alfa(166), alfa(167), alfa(168), alfa(169), alfa(170)/ + 4 1.92821964248775885d-03, 1.35592576302022234d-03, + 5 -7.17858090421302995d-04, -2.58084802575270346d-03, + 6 -3.49271130826168475d-03, -3.46986299340960628d-03, + 7 -2.82285233351310182d-03, -1.88103076404891354d-03, + 8 -8.89531718383947600d-04, 3.87912102631035228d-06, + 9 7.28688540119691412d-04, 1.26566373053457758d-03, + a 1.62518158372674427d-03, 1.83203153216373172d-03, + b 1.91588388990527909d-03, 1.90588846755546138d-03, + c 1.82798982421825727d-03, 1.70389506421121530d-03, + d 1.55097127171097686d-03, 1.38261421852276159d-03/ + data alfa(171), alfa(172), alfa(173), alfa(174), alfa(175), + 1 alfa(176), alfa(177), alfa(178), alfa(179), alfa(180)/ + 2 1.20881424230064774d-03, 1.03676532638344962d-03, + 3 8.71437918068619115d-04, 7.16080155297701002d-04, + 4 5.72637002558129372d-04, 4.42089819465802277d-04, + 5 3.24724948503090564d-04, 2.20342042730246599d-04, + 6 1.28412898401353882d-04, 4.82005924552095464d-05/ + data beta(1), beta(2), beta(3), beta(4), beta(5), beta(6), + 1 beta(7), beta(8), beta(9), beta(10), beta(11), beta(12), + 2 beta(13), beta(14), beta(15), beta(16), beta(17), beta(18), + 3 beta(19), beta(20), beta(21), beta(22)/ + 4 1.79988721413553309d-02, 5.59964911064388073d-03, + 5 2.88501402231132779d-03, 1.80096606761053941d-03, + 6 1.24753110589199202d-03, 9.22878876572938311d-04, + 7 7.14430421727287357d-04, 5.71787281789704872d-04, + 8 4.69431007606481533d-04, 3.93232835462916638d-04, + 9 3.34818889318297664d-04, 2.88952148495751517d-04, + a 2.52211615549573284d-04, 2.22280580798883327d-04, + b 1.97541838033062524d-04, 1.76836855019718004d-04, + c 1.59316899661821081d-04, 1.44347930197333986d-04, + d 1.31448068119965379d-04, 1.20245444949302884d-04, + e 1.10449144504599392d-04, 1.01828770740567258d-04/ + data beta(23), beta(24), beta(25), beta(26), beta(27), beta(28), + 1 beta(29), beta(30), beta(31), beta(32), beta(33), beta(34), + 2 beta(35), beta(36), beta(37), beta(38), beta(39), beta(40), + 3 beta(41), beta(42), beta(43), beta(44)/ + 4 9.41998224204237509d-05, 8.74130545753834437d-05, + 5 8.13466262162801467d-05, 7.59002269646219339d-05, + 6 7.09906300634153481d-05, 6.65482874842468183d-05, + 7 6.25146958969275078d-05, 5.88403394426251749d-05, + 8 -1.49282953213429172d-03, -8.78204709546389328d-04, + 9 -5.02916549572034614d-04, -2.94822138512746025d-04, + a -1.75463996970782828d-04, -1.04008550460816434d-04, + b -5.96141953046457895d-05, -3.12038929076098340d-05, + c -1.26089735980230047d-05, -2.42892608575730389d-07, + d 8.05996165414273571d-06, 1.36507009262147391d-05, + e 1.73964125472926261d-05, 1.98672978842133780d-05/ + data beta(45), beta(46), beta(47), beta(48), beta(49), beta(50), + 1 beta(51), beta(52), beta(53), beta(54), beta(55), beta(56), + 2 beta(57), beta(58), beta(59), beta(60), beta(61), beta(62), + 3 beta(63), beta(64), beta(65), beta(66)/ + 4 2.14463263790822639d-05, 2.23954659232456514d-05, + 5 2.28967783814712629d-05, 2.30785389811177817d-05, + 6 2.30321976080909144d-05, 2.28236073720348722d-05, + 7 2.25005881105292418d-05, 2.20981015361991429d-05, + 8 2.16418427448103905d-05, 2.11507649256220843d-05, + 9 2.06388749782170737d-05, 2.01165241997081666d-05, + a 1.95913450141179244d-05, 1.90689367910436740d-05, + b 1.85533719641636667d-05, 1.80475722259674218d-05, + c 5.52213076721292790d-04, 4.47932581552384646d-04, + d 2.79520653992020589d-04, 1.52468156198446602d-04, + e 6.93271105657043598d-05, 1.76258683069991397d-05/ + data beta(67), beta(68), beta(69), beta(70), beta(71), beta(72), + 1 beta(73), beta(74), beta(75), beta(76), beta(77), beta(78), + 2 beta(79), beta(80), beta(81), beta(82), beta(83), beta(84), + 3 beta(85), beta(86), beta(87), beta(88)/ + 4 -1.35744996343269136d-05, -3.17972413350427135d-05, + 5 -4.18861861696693365d-05, -4.69004889379141029d-05, + 6 -4.87665447413787352d-05, -4.87010031186735069d-05, + 7 -4.74755620890086638d-05, -4.55813058138628452d-05, + 8 -4.33309644511266036d-05, -4.09230193157750364d-05, + 9 -3.84822638603221274d-05, -3.60857167535410501d-05, + a -3.37793306123367417d-05, -3.15888560772109621d-05, + b -2.95269561750807315d-05, -2.75978914828335759d-05, + c -2.58006174666883713d-05, -2.41308356761280200d-05, + d -2.25823509518346033d-05, -2.11479656768912971d-05, + e -1.98200638885294927d-05, -1.85909870801065077d-05/ + data beta(89), beta(90), beta(91), beta(92), beta(93), beta(94), + 1 beta(95), beta(96), beta(97), beta(98), beta(99), beta(100), + 2 beta(101), beta(102), beta(103), beta(104), beta(105), + 3 beta(106), beta(107), beta(108), beta(109), beta(110)/ + 4 -1.74532699844210224d-05, -1.63997823854497997d-05, + 5 -4.74617796559959808d-04, -4.77864567147321487d-04, + 6 -3.20390228067037603d-04, -1.61105016119962282d-04, + 7 -4.25778101285435204d-05, 3.44571294294967503d-05, + 8 7.97092684075674924d-05, 1.03138236708272200d-04, + 9 1.12466775262204158d-04, 1.13103642108481389d-04, + a 1.08651634848774268d-04, 1.01437951597661973d-04, + b 9.29298396593363896d-05, 8.40293133016089978d-05, + c 7.52727991349134062d-05, 6.69632521975730872d-05, + d 5.92564547323194704d-05, 5.22169308826975567d-05, + e 4.58539485165360646d-05, 4.01445513891486808d-05/ + data beta(111), beta(112), beta(113), beta(114), beta(115), + 1 beta(116), beta(117), beta(118), beta(119), beta(120), + 2 beta(121), beta(122), beta(123), beta(124), beta(125), + 3 beta(126), beta(127), beta(128), beta(129), beta(130)/ + 4 3.50481730031328081d-05, 3.05157995034346659d-05, + 5 2.64956119950516039d-05, 2.29363633690998152d-05, + 6 1.97893056664021636d-05, 1.70091984636412623d-05, + 7 1.45547428261524004d-05, 1.23886640995878413d-05, + 8 1.04775876076583236d-05, 8.79179954978479373d-06, + 9 7.36465810572578444d-04, 8.72790805146193976d-04, + a 6.22614862573135066d-04, 2.85998154194304147d-04, + b 3.84737672879366102d-06, -1.87906003636971558d-04, + c -2.97603646594554535d-04, -3.45998126832656348d-04, + d -3.53382470916037712d-04, -3.35715635775048757d-04/ + data beta(131), beta(132), beta(133), beta(134), beta(135), + 1 beta(136), beta(137), beta(138), beta(139), beta(140), + 2 beta(141), beta(142), beta(143), beta(144), beta(145), + 3 beta(146), beta(147), beta(148), beta(149), beta(150)/ + 4 -3.04321124789039809d-04, -2.66722723047612821d-04, + 5 -2.27654214122819527d-04, -1.89922611854562356d-04, + 6 -1.55058918599093870d-04, -1.23778240761873630d-04, + 7 -9.62926147717644187d-05, -7.25178327714425337d-05, + 8 -5.22070028895633801d-05, -3.50347750511900522d-05, + 9 -2.06489761035551757d-05, -8.70106096849767054d-06, + a 1.13698686675100290d-06, 9.16426474122778849d-06, + b 1.56477785428872620d-05, 2.08223629482466847d-05, + c 2.48923381004595156d-05, 2.80340509574146325d-05, + d 3.03987774629861915d-05, 3.21156731406700616d-05/ + data beta(151), beta(152), beta(153), beta(154), beta(155), + 1 beta(156), beta(157), beta(158), beta(159), beta(160), + 2 beta(161), beta(162), beta(163), beta(164), beta(165), + 3 beta(166), beta(167), beta(168), beta(169), beta(170)/ + 4 -1.80182191963885708d-03, -2.43402962938042533d-03, + 5 -1.83422663549856802d-03, -7.62204596354009765d-04, + 6 2.39079475256927218d-04, 9.49266117176881141d-04, + 7 1.34467449701540359d-03, 1.48457495259449178d-03, + 8 1.44732339830617591d-03, 1.30268261285657186d-03, + 9 1.10351597375642682d-03, 8.86047440419791759d-04, + a 6.73073208165665473d-04, 4.77603872856582378d-04, + b 3.05991926358789362d-04, 1.60315694594721630d-04, + c 4.00749555270613286d-05, -5.66607461635251611d-05, + d -1.32506186772982638d-04, -1.90296187989614057d-04/ + data beta(171), beta(172), beta(173), beta(174), beta(175), + 1 beta(176), beta(177), beta(178), beta(179), beta(180), + 2 beta(181), beta(182), beta(183), beta(184), beta(185), + 3 beta(186), beta(187), beta(188), beta(189), beta(190)/ + 4 -2.32811450376937408d-04, -2.62628811464668841d-04, + 5 -2.82050469867598672d-04, -2.93081563192861167d-04, + 6 -2.97435962176316616d-04, -2.96557334239348078d-04, + 7 -2.91647363312090861d-04, -2.83696203837734166d-04, + 8 -2.73512317095673346d-04, -2.61750155806768580d-04, + 9 6.38585891212050914d-03, 9.62374215806377941d-03, + a 7.61878061207001043d-03, 2.83219055545628054d-03, + b -2.09841352012720090d-03, -5.73826764216626498d-03, + c -7.70804244495414620d-03, -8.21011692264844401d-03, + d -7.65824520346905413d-03, -6.47209729391045177d-03/ + data beta(191), beta(192), beta(193), beta(194), beta(195), + 1 beta(196), beta(197), beta(198), beta(199), beta(200), + 2 beta(201), beta(202), beta(203), beta(204), beta(205), + 3 beta(206), beta(207), beta(208), beta(209), beta(210)/ + 4 -4.99132412004966473d-03, -3.45612289713133280d-03, + 5 -2.01785580014170775d-03, -7.59430686781961401d-04, + 6 2.84173631523859138d-04, 1.10891667586337403d-03, + 7 1.72901493872728771d-03, 2.16812590802684701d-03, + 8 2.45357710494539735d-03, 2.61281821058334862d-03, + 9 2.67141039656276912d-03, 2.65203073395980430d-03, + a 2.57411652877287315d-03, 2.45389126236094427d-03, + b 2.30460058071795494d-03, 2.13684837686712662d-03, + c 1.95896528478870911d-03, 1.77737008679454412d-03, + d 1.59690280765839059d-03, 1.42111975664438546d-03/ + data gama(1), gama(2), gama(3), gama(4), gama(5), gama(6), + 1 gama(7), gama(8), gama(9), gama(10), gama(11), gama(12), + 2 gama(13), gama(14), gama(15), gama(16), gama(17), gama(18), + 3 gama(19), gama(20), gama(21), gama(22)/ + 4 6.29960524947436582d-01, 2.51984209978974633d-01, + 5 1.54790300415655846d-01, 1.10713062416159013d-01, + 6 8.57309395527394825d-02, 6.97161316958684292d-02, + 7 5.86085671893713576d-02, 5.04698873536310685d-02, + 8 4.42600580689154809d-02, 3.93720661543509966d-02, + 9 3.54283195924455368d-02, 3.21818857502098231d-02, + a 2.94646240791157679d-02, 2.71581677112934479d-02, + b 2.51768272973861779d-02, 2.34570755306078891d-02, + c 2.19508390134907203d-02, 2.06210828235646240d-02, + d 1.94388240897880846d-02, 1.83810633800683158d-02, + e 1.74293213231963172d-02, 1.65685837786612353d-02/ + data gama(23), gama(24), gama(25), gama(26), gama(27), gama(28), + 1 gama(29), gama(30)/ + 2 1.57865285987918445d-02, 1.50729501494095594d-02, + 3 1.44193250839954639d-02, 1.38184805735341786d-02, + 4 1.32643378994276568d-02, 1.27517121970498651d-02, + 5 1.22761545318762767d-02, 1.18338262398482403d-02/ + data ex1, ex2, hpi, gpi, thpi / + 1 3.33333333333333333d-01, 6.66666666666666667d-01, + 2 1.57079632679489662d+00, 3.14159265358979324d+00, + 3 4.71238898038468986d+00/ + data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / +c + rfnu = 1.0d0/fnu +c----------------------------------------------------------------------- +c overflow test (z/fnu too small) +c----------------------------------------------------------------------- + test = d1mach(1)*1.0d+3 + ac = fnu*test + if (dabs(zr).gt.ac .or. dabs(zi).gt.ac) go to 15 + zeta1r = 2.0d0*dabs(dlog(test))+fnu + zeta1i = 0.0d0 + zeta2r = fnu + zeta2i = 0.0d0 + phir = 1.0d0 + phii = 0.0d0 + argr = 1.0d0 + argi = 0.0d0 + return + 15 continue + zbr = zr*rfnu + zbi = zi*rfnu + rfnu2 = rfnu*rfnu +c----------------------------------------------------------------------- +c compute in the fourth quadrant +c----------------------------------------------------------------------- + fn13 = fnu**ex1 + fn23 = fn13*fn13 + rfn13 = 1.0d0/fn13 + w2r = coner - zbr*zbr + zbi*zbi + w2i = conei - zbr*zbi - zbr*zbi + aw2 = zabs2(w2r,w2i) + if (aw2.gt.0.25d0) go to 130 +c----------------------------------------------------------------------- +c power series for cabs(w2).le.0.25d0 +c----------------------------------------------------------------------- + k = 1 + pr(1) = coner + pi(1) = conei + sumar = gama(1) + sumai = zeroi + ap(1) = 1.0d0 + if (aw2.lt.tol) go to 20 + do 10 k=2,30 + pr(k) = pr(k-1)*w2r - pi(k-1)*w2i + pi(k) = pr(k-1)*w2i + pi(k-1)*w2r + sumar = sumar + pr(k)*gama(k) + sumai = sumai + pi(k)*gama(k) + ap(k) = ap(k-1)*aw2 + if (ap(k).lt.tol) go to 20 + 10 continue + k = 30 + 20 continue + kmax = k + zetar = w2r*sumar - w2i*sumai + zetai = w2r*sumai + w2i*sumar + argr = zetar*fn23 + argi = zetai*fn23 + call zsqrt(sumar, sumai, zar, zai) + call zsqrt(w2r, w2i, str, sti) + zeta2r = str*fnu + zeta2i = sti*fnu + str = coner + ex2*(zetar*zar-zetai*zai) + sti = conei + ex2*(zetar*zai+zetai*zar) + zeta1r = str*zeta2r - sti*zeta2i + zeta1i = str*zeta2i + sti*zeta2r + zar = zar + zar + zai = zai + zai + call zsqrt(zar, zai, str, sti) + phir = str*rfn13 + phii = sti*rfn13 + if (ipmtr.eq.1) go to 120 +c----------------------------------------------------------------------- +c sum series for asum and bsum +c----------------------------------------------------------------------- + sumbr = zeror + sumbi = zeroi + do 30 k=1,kmax + sumbr = sumbr + pr(k)*beta(k) + sumbi = sumbi + pi(k)*beta(k) + 30 continue + asumr = zeror + asumi = zeroi + bsumr = sumbr + bsumi = sumbi + l1 = 0 + l2 = 30 + btol = tol*(dabs(bsumr)+dabs(bsumi)) + atol = tol + pp = 1.0d0 + ias = 0 + ibs = 0 + if (rfnu2.lt.tol) go to 110 + do 100 is=2,7 + atol = atol/rfnu2 + pp = pp*rfnu2 + if (ias.eq.1) go to 60 + sumar = zeror + sumai = zeroi + do 40 k=1,kmax + m = l1 + k + sumar = sumar + pr(k)*alfa(m) + sumai = sumai + pi(k)*alfa(m) + if (ap(k).lt.atol) go to 50 + 40 continue + 50 continue + asumr = asumr + sumar*pp + asumi = asumi + sumai*pp + if (pp.lt.tol) ias = 1 + 60 continue + if (ibs.eq.1) go to 90 + sumbr = zeror + sumbi = zeroi + do 70 k=1,kmax + m = l2 + k + sumbr = sumbr + pr(k)*beta(m) + sumbi = sumbi + pi(k)*beta(m) + if (ap(k).lt.atol) go to 80 + 70 continue + 80 continue + bsumr = bsumr + sumbr*pp + bsumi = bsumi + sumbi*pp + if (pp.lt.btol) ibs = 1 + 90 continue + if (ias.eq.1 .and. ibs.eq.1) go to 110 + l1 = l1 + 30 + l2 = l2 + 30 + 100 continue + 110 continue + asumr = asumr + coner + pp = rfnu*rfn13 + bsumr = bsumr*pp + bsumi = bsumi*pp + 120 continue + return +c----------------------------------------------------------------------- +c cabs(w2).gt.0.25d0 +c----------------------------------------------------------------------- + 130 continue + call zsqrt(w2r, w2i, wr, wi) + if (wr.lt.0.0d0) wr = 0.0d0 + if (wi.lt.0.0d0) wi = 0.0d0 + str = coner + wr + sti = wi + call zdiv(str, sti, zbr, zbi, zar, zai) + call zlog(zar, zai, zcr, zci, idum) + if (zci.lt.0.0d0) zci = 0.0d0 + if (zci.gt.hpi) zci = hpi + if (zcr.lt.0.0d0) zcr = 0.0d0 + zthr = (zcr-wr)*1.5d0 + zthi = (zci-wi)*1.5d0 + zeta1r = zcr*fnu + zeta1i = zci*fnu + zeta2r = wr*fnu + zeta2i = wi*fnu + azth = zabs2(zthr,zthi) + ang = thpi + if (zthr.ge.0.0d0 .and. zthi.lt.0.0d0) go to 140 + ang = hpi + if (zthr.eq.0.0d0) go to 140 + ang = datan(zthi/zthr) + if (zthr.lt.0.0d0) ang = ang + gpi + 140 continue + pp = azth**ex2 + ang = ang*ex2 + zetar = pp*dcos(ang) + zetai = pp*dsin(ang) + if (zetai.lt.0.0d0) zetai = 0.0d0 + argr = zetar*fn23 + argi = zetai*fn23 + call zdiv(zthr, zthi, zetar, zetai, rtztr, rtzti) + call zdiv(rtztr, rtzti, wr, wi, zar, zai) + tzar = zar + zar + tzai = zai + zai + call zsqrt(tzar, tzai, str, sti) + phir = str*rfn13 + phii = sti*rfn13 + if (ipmtr.eq.1) go to 120 + raw = 1.0d0/dsqrt(aw2) + str = wr*raw + sti = -wi*raw + tfnr = str*rfnu*raw + tfni = sti*rfnu*raw + razth = 1.0d0/azth + str = zthr*razth + sti = -zthi*razth + rzthr = str*razth*rfnu + rzthi = sti*razth*rfnu + zcr = rzthr*ar(2) + zci = rzthi*ar(2) + raw2 = 1.0d0/aw2 + str = w2r*raw2 + sti = -w2i*raw2 + t2r = str*raw2 + t2i = sti*raw2 + str = t2r*c(2) + c(3) + sti = t2i*c(2) + upr(2) = str*tfnr - sti*tfni + upi(2) = str*tfni + sti*tfnr + bsumr = upr(2) + zcr + bsumi = upi(2) + zci + asumr = zeror + asumi = zeroi + if (rfnu.lt.tol) go to 220 + przthr = rzthr + przthi = rzthi + ptfnr = tfnr + ptfni = tfni + upr(1) = coner + upi(1) = conei + pp = 1.0d0 + btol = tol*(dabs(bsumr)+dabs(bsumi)) + ks = 0 + kp1 = 2 + l = 3 + ias = 0 + ibs = 0 + do 210 lr=2,12,2 + lrp1 = lr + 1 +c----------------------------------------------------------------------- +c compute two additional cr, dr, and up for two more terms in +c next suma and sumb +c----------------------------------------------------------------------- + do 160 k=lr,lrp1 + ks = ks + 1 + kp1 = kp1 + 1 + l = l + 1 + zar = c(l) + zai = zeroi + do 150 j=2,kp1 + l = l + 1 + str = zar*t2r - t2i*zai + c(l) + zai = zar*t2i + zai*t2r + zar = str + 150 continue + str = ptfnr*tfnr - ptfni*tfni + ptfni = ptfnr*tfni + ptfni*tfnr + ptfnr = str + upr(kp1) = ptfnr*zar - ptfni*zai + upi(kp1) = ptfni*zar + ptfnr*zai + crr(ks) = przthr*br(ks+1) + cri(ks) = przthi*br(ks+1) + str = przthr*rzthr - przthi*rzthi + przthi = przthr*rzthi + przthi*rzthr + przthr = str + drr(ks) = przthr*ar(ks+2) + dri(ks) = przthi*ar(ks+2) + 160 continue + pp = pp*rfnu2 + if (ias.eq.1) go to 180 + sumar = upr(lrp1) + sumai = upi(lrp1) + ju = lrp1 + do 170 jr=1,lr + ju = ju - 1 + sumar = sumar + crr(jr)*upr(ju) - cri(jr)*upi(ju) + sumai = sumai + crr(jr)*upi(ju) + cri(jr)*upr(ju) + 170 continue + asumr = asumr + sumar + asumi = asumi + sumai + test = dabs(sumar) + dabs(sumai) + if (pp.lt.tol .and. test.lt.tol) ias = 1 + 180 continue + if (ibs.eq.1) go to 200 + sumbr = upr(lr+2) + upr(lrp1)*zcr - upi(lrp1)*zci + sumbi = upi(lr+2) + upr(lrp1)*zci + upi(lrp1)*zcr + ju = lrp1 + do 190 jr=1,lr + ju = ju - 1 + sumbr = sumbr + drr(jr)*upr(ju) - dri(jr)*upi(ju) + sumbi = sumbi + drr(jr)*upi(ju) + dri(jr)*upr(ju) + 190 continue + bsumr = bsumr + sumbr + bsumi = bsumi + sumbi + test = dabs(sumbr) + dabs(sumbi) + if (pp.lt.btol .and. test.lt.btol) ibs = 1 + 200 continue + if (ias.eq.1 .and. ibs.eq.1) go to 220 + 210 continue + 220 continue + asumr = asumr + coner + str = -bsumr*rfn13 + sti = -bsumi*rfn13 + call zdiv(str, sti, rtztr, rtzti, bsumr, bsumi) + go to 120 + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zuni1(zr, zi, fnu, kode, n, yr, yi, nz, nlast, fnul, + * tol, elim, alim) +c refer to zbesi,zbesk +c +c zuni1 computes i(fnu,z) by means of the uniform asymptotic +c expansion for i(fnu,z) in -pi/3.le.arg z.le.pi/3. +c +c fnul is the smallest order permitted for the asymptotic +c expansion. nlast=0 means all of the y values were set. +c nlast.ne.0 is the number left to be computed by another +c formula for orders fnu to fnu+nlast-1 because fnu+nlast-1.lt.fnul. +c y(i)=czero for i=nlast+1,n +c +c***routines called zuchk,zunik,zuoik,d1mach,zabs2 +c complex cfn,cone,crsc,cscl,csr,css,cwrk,czero,c1,c2,phi,rz,sum,s1, +c *s2,y,z,zeta1,zeta2 + double precision alim, aphi, ascle, bry, coner, crsc, + * cscl, csrr, cssr, cwrki, cwrkr, c1r, c2i, c2m, c2r, elim, fn, + * fnu, fnul, phii, phir, rast, rs1, rzi, rzr, sti, str, sumi, + * sumr, s1i, s1r, s2i, s2r, tol, yi, yr, zeroi, zeror, zeta1i, + * zeta1r, zeta2i, zeta2r, zi, zr, cyr, cyi, d1mach, zabs2 + integer i, iflag, init, k, kode, m, n, nd, nlast, nn, nuf, nw, nz + dimension bry(3), yr(n), yi(n), cwrkr(16), cwrki(16), cssr(3), + * csrr(3), cyr(2), cyi(2) + data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / +c + nz = 0 + nd = n + nlast = 0 +c----------------------------------------------------------------------- +c computed values with exponents between alim and elim in mag- +c nitude are scaled to keep intermediate arithmetic on scale, +c exp(alim)=exp(elim)*tol +c----------------------------------------------------------------------- + cscl = 1.0d0/tol + crsc = tol + cssr(1) = cscl + cssr(2) = coner + cssr(3) = crsc + csrr(1) = crsc + csrr(2) = coner + csrr(3) = cscl + bry(1) = 1.0d+3*d1mach(1)/tol +c----------------------------------------------------------------------- +c check for underflow and overflow on first member +c----------------------------------------------------------------------- + fn = dmax1(fnu,1.0d0) + init = 0 + call zunik(zr, zi, fn, 1, 1, tol, init, phir, phii, zeta1r, + * zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) + if (kode.eq.1) go to 10 + str = zr + zeta2r + sti = zi + zeta2i + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zeta1r + str + s1i = -zeta1i + sti + go to 20 + 10 continue + s1r = -zeta1r + zeta2r + s1i = -zeta1i + zeta2i + 20 continue + rs1 = s1r + if (dabs(rs1).gt.elim) go to 130 + 30 continue + nn = min0(2,nd) + do 80 i=1,nn + fn = fnu + dble(float(nd-i)) + init = 0 + call zunik(zr, zi, fn, 1, 0, tol, init, phir, phii, zeta1r, + * zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) + if (kode.eq.1) go to 40 + str = zr + zeta2r + sti = zi + zeta2i + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zeta1r + str + s1i = -zeta1i + sti + zi + go to 50 + 40 continue + s1r = -zeta1r + zeta2r + s1i = -zeta1i + zeta2i + 50 continue +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + rs1 = s1r + if (dabs(rs1).gt.elim) go to 110 + if (i.eq.1) iflag = 2 + if (dabs(rs1).lt.alim) go to 60 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- + aphi = zabs2(phir,phii) + rs1 = rs1 + dlog(aphi) + if (dabs(rs1).gt.elim) go to 110 + if (i.eq.1) iflag = 1 + if (rs1.lt.0.0d0) go to 60 + if (i.eq.1) iflag = 3 + 60 continue +c----------------------------------------------------------------------- +c scale s1 if cabs(s1).lt.ascle +c----------------------------------------------------------------------- + s2r = phir*sumr - phii*sumi + s2i = phir*sumi + phii*sumr + str = dexp(s1r)*cssr(iflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s2r*s1i + s2i*s1r + s2r = str + if (iflag.ne.1) go to 70 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.ne.0) go to 110 + 70 continue + cyr(i) = s2r + cyi(i) = s2i + m = nd - i + 1 + yr(m) = s2r*csrr(iflag) + yi(m) = s2i*csrr(iflag) + 80 continue + if (nd.le.2) go to 100 + rast = 1.0d0/zabs2(zr,zi) + str = zr*rast + sti = -zi*rast + rzr = (str+str)*rast + rzi = (sti+sti)*rast + bry(2) = 1.0d0/bry(1) + bry(3) = d1mach(2) + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + c1r = csrr(iflag) + ascle = bry(iflag) + k = nd - 2 + fn = dble(float(k)) + do 90 i=3,nd + c2r = s2r + c2i = s2i + s2r = s1r + (fnu+fn)*(rzr*c2r-rzi*c2i) + s2i = s1i + (fnu+fn)*(rzr*c2i+rzi*c2r) + s1r = c2r + s1i = c2i + c2r = s2r*c1r + c2i = s2i*c1r + yr(k) = c2r + yi(k) = c2i + k = k - 1 + fn = fn - 1.0d0 + if (iflag.ge.3) go to 90 + str = dabs(c2r) + sti = dabs(c2i) + c2m = dmax1(str,sti) + if (c2m.le.ascle) go to 90 + iflag = iflag + 1 + ascle = bry(iflag) + s1r = s1r*c1r + s1i = s1i*c1r + s2r = c2r + s2i = c2i + s1r = s1r*cssr(iflag) + s1i = s1i*cssr(iflag) + s2r = s2r*cssr(iflag) + s2i = s2i*cssr(iflag) + c1r = csrr(iflag) + 90 continue + 100 continue + return +c----------------------------------------------------------------------- +c set underflow and update parameters +c----------------------------------------------------------------------- + 110 continue + if (rs1.gt.0.0d0) go to 120 + yr(nd) = zeror + yi(nd) = zeroi + nz = nz + 1 + nd = nd - 1 + if (nd.eq.0) go to 100 + call zuoik(zr, zi, fnu, kode, 1, nd, yr, yi, nuf, tol, elim, alim) + if (nuf.lt.0) go to 120 + nd = nd - nuf + nz = nz + nuf + if (nd.eq.0) go to 100 + fn = fnu + dble(float(nd-1)) + if (fn.ge.fnul) go to 30 + nlast = nd + return + 120 continue + nz = -1 + return + 130 continue + if (rs1.gt.0.0d0) go to 120 + nz = n + do 140 i=1,n + yr(i) = zeror + yi(i) = zeroi + 140 continue + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zuni2(zr, zi, fnu, kode, n, yr, yi, nz, nlast, fnul, + * tol, elim, alim) +c refer to zbesi,zbesk +c +c zuni2 computes i(fnu,z) in the right half plane by means of +c uniform asymptotic expansion for j(fnu,zn) where zn is z*i +c or -z*i and zn is in the right half plane also. +c +c fnul is the smallest order permitted for the asymptotic +c expansion. nlast=0 means all of the y values were set. +c nlast.ne.0 is the number left to be computed by another +c formula for orders fnu to fnu+nlast-1 because fnu+nlast-1.lt.fnul. +c y(i)=czero for i=nlast+1,n +c +c***routines called zairy,zuchk,zunhj,zuoik,d1mach,zabs2 +c complex ai,arg,asum,bsum,cfn,ci,cid,cip,cone,crsc,cscl,csr,css, +c *czero,c1,c2,dai,phi,rz,s1,s2,y,z,zb,zeta1,zeta2,zn + double precision aarg, aic, aii, air, alim, ang, aphi, argi, + * argr, ascle, asumi, asumr, bry, bsumi, bsumr, cidi, cipi, cipr, + * coner, crsc, cscl, csrr, cssr, c1r, c2i, c2m, c2r, daii, + * dair, elim, fn, fnu, fnul, hpi, phii, phir, rast, raz, rs1, rzi, + * rzr, sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, zbi, zbr, zeroi, + * zeror, zeta1i, zeta1r, zeta2i, zeta2r, zi, zni, znr, zr, cyr, + * cyi, d1mach, zabs2, car, sar + integer i, iflag, in, inu, j, k, kode, n, nai, nd, ndai, nlast, + * nn, nuf, nw, nz, idum + dimension bry(3), yr(n), yi(n), cipr(4), cipi(4), cssr(3), + * csrr(3), cyr(2), cyi(2) + data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / + data cipr(1),cipi(1),cipr(2),cipi(2),cipr(3),cipi(3),cipr(4), + * cipi(4)/ 1.0d0,0.0d0, 0.0d0,1.0d0, -1.0d0,0.0d0, 0.0d0,-1.0d0/ + data hpi, aic / + 1 1.57079632679489662d+00, 1.265512123484645396d+00/ +c + nz = 0 + nd = n + nlast = 0 +c----------------------------------------------------------------------- +c computed values with exponents between alim and elim in mag- +c nitude are scaled to keep intermediate arithmetic on scale, +c exp(alim)=exp(elim)*tol +c----------------------------------------------------------------------- + cscl = 1.0d0/tol + crsc = tol + cssr(1) = cscl + cssr(2) = coner + cssr(3) = crsc + csrr(1) = crsc + csrr(2) = coner + csrr(3) = cscl + bry(1) = 1.0d+3*d1mach(1)/tol +c----------------------------------------------------------------------- +c zn is in the right half plane after rotation by ci or -ci +c----------------------------------------------------------------------- + znr = zi + zni = -zr + zbr = zr + zbi = zi + cidi = -coner + inu = int(sngl(fnu)) + ang = hpi*(fnu-dble(float(inu))) + c2r = dcos(ang) + c2i = dsin(ang) + car = c2r + sar = c2i + in = inu + n - 1 + in = mod(in,4) + 1 + str = c2r*cipr(in) - c2i*cipi(in) + c2i = c2r*cipi(in) + c2i*cipr(in) + c2r = str + if (zi.gt.0.0d0) go to 10 + znr = -znr + zbi = -zbi + cidi = -cidi + c2i = -c2i + 10 continue +c----------------------------------------------------------------------- +c check for underflow and overflow on first member +c----------------------------------------------------------------------- + fn = dmax1(fnu,1.0d0) + call zunhj(znr, zni, fn, 1, tol, phir, phii, argr, argi, zeta1r, + * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) + if (kode.eq.1) go to 20 + str = zbr + zeta2r + sti = zbi + zeta2i + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zeta1r + str + s1i = -zeta1i + sti + go to 30 + 20 continue + s1r = -zeta1r + zeta2r + s1i = -zeta1i + zeta2i + 30 continue + rs1 = s1r + if (dabs(rs1).gt.elim) go to 150 + 40 continue + nn = min0(2,nd) + do 90 i=1,nn + fn = fnu + dble(float(nd-i)) + call zunhj(znr, zni, fn, 0, tol, phir, phii, argr, argi, + * zeta1r, zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) + if (kode.eq.1) go to 50 + str = zbr + zeta2r + sti = zbi + zeta2i + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zeta1r + str + s1i = -zeta1i + sti + dabs(zi) + go to 60 + 50 continue + s1r = -zeta1r + zeta2r + s1i = -zeta1i + zeta2i + 60 continue +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + rs1 = s1r + if (dabs(rs1).gt.elim) go to 120 + if (i.eq.1) iflag = 2 + if (dabs(rs1).lt.alim) go to 70 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + aphi = zabs2(phir,phii) + aarg = zabs2(argr,argi) + rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic + if (dabs(rs1).gt.elim) go to 120 + if (i.eq.1) iflag = 1 + if (rs1.lt.0.0d0) go to 70 + if (i.eq.1) iflag = 3 + 70 continue +c----------------------------------------------------------------------- +c scale s1 to keep intermediate arithmetic on scale near +c exponent extremes +c----------------------------------------------------------------------- + call zairy(argr, argi, 0, 2, air, aii, nai, idum) + call zairy(argr, argi, 1, 2, dair, daii, ndai, idum) + str = dair*bsumr - daii*bsumi + sti = dair*bsumi + daii*bsumr + str = str + (air*asumr-aii*asumi) + sti = sti + (air*asumi+aii*asumr) + s2r = phir*str - phii*sti + s2i = phir*sti + phii*str + str = dexp(s1r)*cssr(iflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s2r*s1i + s2i*s1r + s2r = str + if (iflag.ne.1) go to 80 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.ne.0) go to 120 + 80 continue + if (zi.le.0.0d0) s2i = -s2i + str = s2r*c2r - s2i*c2i + s2i = s2r*c2i + s2i*c2r + s2r = str + cyr(i) = s2r + cyi(i) = s2i + j = nd - i + 1 + yr(j) = s2r*csrr(iflag) + yi(j) = s2i*csrr(iflag) + str = -c2i*cidi + c2i = c2r*cidi + c2r = str + 90 continue + if (nd.le.2) go to 110 + raz = 1.0d0/zabs2(zr,zi) + str = zr*raz + sti = -zi*raz + rzr = (str+str)*raz + rzi = (sti+sti)*raz + bry(2) = 1.0d0/bry(1) + bry(3) = d1mach(2) + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + c1r = csrr(iflag) + ascle = bry(iflag) + k = nd - 2 + fn = dble(float(k)) + do 100 i=3,nd + c2r = s2r + c2i = s2i + s2r = s1r + (fnu+fn)*(rzr*c2r-rzi*c2i) + s2i = s1i + (fnu+fn)*(rzr*c2i+rzi*c2r) + s1r = c2r + s1i = c2i + c2r = s2r*c1r + c2i = s2i*c1r + yr(k) = c2r + yi(k) = c2i + k = k - 1 + fn = fn - 1.0d0 + if (iflag.ge.3) go to 100 + str = dabs(c2r) + sti = dabs(c2i) + c2m = dmax1(str,sti) + if (c2m.le.ascle) go to 100 + iflag = iflag + 1 + ascle = bry(iflag) + s1r = s1r*c1r + s1i = s1i*c1r + s2r = c2r + s2i = c2i + s1r = s1r*cssr(iflag) + s1i = s1i*cssr(iflag) + s2r = s2r*cssr(iflag) + s2i = s2i*cssr(iflag) + c1r = csrr(iflag) + 100 continue + 110 continue + return + 120 continue + if (rs1.gt.0.0d0) go to 140 +c----------------------------------------------------------------------- +c set underflow and update parameters +c----------------------------------------------------------------------- + yr(nd) = zeror + yi(nd) = zeroi + nz = nz + 1 + nd = nd - 1 + if (nd.eq.0) go to 110 + call zuoik(zr, zi, fnu, kode, 1, nd, yr, yi, nuf, tol, elim, alim) + if (nuf.lt.0) go to 140 + nd = nd - nuf + nz = nz + nuf + if (nd.eq.0) go to 110 + fn = fnu + dble(float(nd-1)) + if (fn.lt.fnul) go to 130 +c fn = cidi +c j = nuf + 1 +c k = mod(j,4) + 1 +c s1r = cipr(k) +c s1i = cipi(k) +c if (fn.lt.0.0d0) s1i = -s1i +c str = c2r*s1r - c2i*s1i +c c2i = c2r*s1i + c2i*s1r +c c2r = str + in = inu + nd - 1 + in = mod(in,4) + 1 + c2r = car*cipr(in) - sar*cipi(in) + c2i = car*cipi(in) + sar*cipr(in) + if (zi.le.0.0d0) c2i = -c2i + go to 40 + 130 continue + nlast = nd + return + 140 continue + nz = -1 + return + 150 continue + if (rs1.gt.0.0d0) go to 140 + nz = n + do 160 i=1,n + yr(i) = zeror + yi(i) = zeroi + 160 continue + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zunik(zrr, zri, fnu, ikflg, ipmtr, tol, init, phir, + * phii, zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) +c geuz for g77 + EXTERNAL zsqrt + EXTERNAL zlog +c Refer to zbesi,zbesk +c +c zunik computes parameters for the uniform asymptotic +c expansions of the i and k functions on ikflg= 1 or 2 +c respectively by +c +c w(fnu,zr) = phi*exp(zeta)*sum +c +c where zeta=-zeta1 + zeta2 or +c zeta1 - zeta2 +c +c the first call must have init=0. subsequent calls with the +c same zr and fnu will return the i or k function on ikflg= +c 1 or 2 with no change in init. cwrk is a complex work +c array. ipmtr=0 computes all parameters. ipmtr=1 computes phi, +c zeta1,zeta2. +c +c***routines called zdiv,zlog,zsqrt,d1mach +c complex cfn,con,cone,crfn,cwrk,czero,phi,s,sr,sum,t,t2,zeta1, +c *zeta2,zn,zr + double precision ac, c, con, conei, coner, crfni, crfnr, cwrki, + * cwrkr, fnu, phii, phir, rfn, si, sr, sri, srr, sti, str, sumi, + * sumr, test, ti, tol, tr, t2i, t2r, zeroi, zeror, zeta1i, zeta1r, + * zeta2i, zeta2r, zni, znr, zri, zrr, d1mach + integer i, idum, ikflg, init, ipmtr, j, k, l + dimension c(120), cwrkr(16), cwrki(16), con(2) + data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / + data con(1), con(2) / + 1 3.98942280401432678d-01, 1.25331413731550025d+00 / + data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), + 1 c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), + 2 c(19), c(20), c(21), c(22), c(23), c(24)/ + 3 1.00000000000000000d+00, -2.08333333333333333d-01, + 4 1.25000000000000000d-01, 3.34201388888888889d-01, + 5 -4.01041666666666667d-01, 7.03125000000000000d-02, + 6 -1.02581259645061728d+00, 1.84646267361111111d+00, + 7 -8.91210937500000000d-01, 7.32421875000000000d-02, + 8 4.66958442342624743d+00, -1.12070026162229938d+01, + 9 8.78912353515625000d+00, -2.36408691406250000d+00, + a 1.12152099609375000d-01, -2.82120725582002449d+01, + b 8.46362176746007346d+01, -9.18182415432400174d+01, + c 4.25349987453884549d+01, -7.36879435947963170d+00, + d 2.27108001708984375d-01, 2.12570130039217123d+02, + e -7.65252468141181642d+02, 1.05999045252799988d+03/ + data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), + 1 c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), + 2 c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ + 3 -6.99579627376132541d+02, 2.18190511744211590d+02, + 4 -2.64914304869515555d+01, 5.72501420974731445d-01, + 5 -1.91945766231840700d+03, 8.06172218173730938d+03, + 6 -1.35865500064341374d+04, 1.16553933368645332d+04, + 7 -5.30564697861340311d+03, 1.20090291321635246d+03, + 8 -1.08090919788394656d+02, 1.72772750258445740d+00, + 9 2.02042913309661486d+04, -9.69805983886375135d+04, + a 1.92547001232531532d+05, -2.03400177280415534d+05, + b 1.22200464983017460d+05, -4.11926549688975513d+04, + c 7.10951430248936372d+03, -4.93915304773088012d+02, + d 6.07404200127348304d+00, -2.42919187900551333d+05, + e 1.31176361466297720d+06, -2.99801591853810675d+06/ + data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), + 1 c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), + 2 c(65), c(66), c(67), c(68), c(69), c(70), c(71), c(72)/ + 3 3.76327129765640400d+06, -2.81356322658653411d+06, + 4 1.26836527332162478d+06, -3.31645172484563578d+05, + 5 4.52187689813627263d+04, -2.49983048181120962d+03, + 6 2.43805296995560639d+01, 3.28446985307203782d+06, + 7 -1.97068191184322269d+07, 5.09526024926646422d+07, + 8 -7.41051482115326577d+07, 6.63445122747290267d+07, + 9 -3.75671766607633513d+07, 1.32887671664218183d+07, + a -2.78561812808645469d+06, 3.08186404612662398d+05, + b -1.38860897537170405d+04, 1.10017140269246738d+02, + c -4.93292536645099620d+07, 3.25573074185765749d+08, + d -9.39462359681578403d+08, 1.55359689957058006d+09, + e -1.62108055210833708d+09, 1.10684281682301447d+09/ + data c(73), c(74), c(75), c(76), c(77), c(78), c(79), c(80), + 1 c(81), c(82), c(83), c(84), c(85), c(86), c(87), c(88), + 2 c(89), c(90), c(91), c(92), c(93), c(94), c(95), c(96)/ + 3 -4.95889784275030309d+08, 1.42062907797533095d+08, + 4 -2.44740627257387285d+07, 2.24376817792244943d+06, + 5 -8.40054336030240853d+04, 5.51335896122020586d+02, + 6 8.14789096118312115d+08, -5.86648149205184723d+09, + 7 1.86882075092958249d+10, -3.46320433881587779d+10, + 8 4.12801855797539740d+10, -3.30265997498007231d+10, + 9 1.79542137311556001d+10, -6.56329379261928433d+09, + a 1.55927986487925751d+09, -2.25105661889415278d+08, + b 1.73951075539781645d+07, -5.49842327572288687d+05, + c 3.03809051092238427d+03, -1.46792612476956167d+10, + d 1.14498237732025810d+11, -3.99096175224466498d+11, + e 8.19218669548577329d+11, -1.09837515608122331d+12/ + data c(97), c(98), c(99), c(100), c(101), c(102), c(103), c(104), + 1 c(105), c(106), c(107), c(108), c(109), c(110), c(111), + 2 c(112), c(113), c(114), c(115), c(116), c(117), c(118)/ + 3 1.00815810686538209d+12, -6.45364869245376503d+11, + 4 2.87900649906150589d+11, -8.78670721780232657d+10, + 5 1.76347306068349694d+10, -2.16716498322379509d+09, + 6 1.43157876718888981d+08, -3.87183344257261262d+06, + 7 1.82577554742931747d+04, 2.86464035717679043d+11, + 8 -2.40629790002850396d+12, 9.10934118523989896d+12, + 9 -2.05168994109344374d+13, 3.05651255199353206d+13, + a -3.16670885847851584d+13, 2.33483640445818409d+13, + b -1.23204913055982872d+13, 4.61272578084913197d+12, + c -1.19655288019618160d+12, 2.05914503232410016d+11, + d -2.18229277575292237d+10, 1.24700929351271032d+09/ + data c(119), c(120)/ + 1 -2.91883881222208134d+07, 1.18838426256783253d+05/ +c + if (init.ne.0) go to 40 +c----------------------------------------------------------------------- +c initialize all variables +c----------------------------------------------------------------------- + rfn = 1.0d0/fnu +c----------------------------------------------------------------------- +c overflow test (zr/fnu too small) +c----------------------------------------------------------------------- + test = d1mach(1)*1.0d+3 + ac = fnu*test + if (dabs(zrr).gt.ac .or. dabs(zri).gt.ac) go to 15 + zeta1r = 2.0d0*dabs(dlog(test))+fnu + zeta1i = 0.0d0 + zeta2r = fnu + zeta2i = 0.0d0 + phir = 1.0d0 + phii = 0.0d0 + return + 15 continue + tr = zrr*rfn + ti = zri*rfn + sr = coner + (tr*tr-ti*ti) + si = conei + (tr*ti+ti*tr) + call zsqrt(sr, si, srr, sri) + str = coner + srr + sti = conei + sri + call zdiv(str, sti, tr, ti, znr, zni) + call zlog(znr, zni, str, sti, idum) + zeta1r = fnu*str + zeta1i = fnu*sti + zeta2r = fnu*srr + zeta2i = fnu*sri + call zdiv(coner, conei, srr, sri, tr, ti) + srr = tr*rfn + sri = ti*rfn + call zsqrt(srr, sri, cwrkr(16), cwrki(16)) + phir = cwrkr(16)*con(ikflg) + phii = cwrki(16)*con(ikflg) + if (ipmtr.ne.0) return + call zdiv(coner, conei, sr, si, t2r, t2i) + cwrkr(1) = coner + cwrki(1) = conei + crfnr = coner + crfni = conei + ac = 1.0d0 + l = 1 + do 20 k=2,15 + sr = zeror + si = zeroi + do 10 j=1,k + l = l + 1 + str = sr*t2r - si*t2i + c(l) + si = sr*t2i + si*t2r + sr = str + 10 continue + str = crfnr*srr - crfni*sri + crfni = crfnr*sri + crfni*srr + crfnr = str + cwrkr(k) = crfnr*sr - crfni*si + cwrki(k) = crfnr*si + crfni*sr + ac = ac*rfn + test = dabs(cwrkr(k)) + dabs(cwrki(k)) + if (ac.lt.tol .and. test.lt.tol) go to 30 + 20 continue + k = 15 + 30 continue + init = k + 40 continue + if (ikflg.eq.2) go to 60 +c----------------------------------------------------------------------- +c compute sum for the i function +c----------------------------------------------------------------------- + sr = zeror + si = zeroi + do 50 i=1,init + sr = sr + cwrkr(i) + si = si + cwrki(i) + 50 continue + sumr = sr + sumi = si + phir = cwrkr(16)*con(1) + phii = cwrki(16)*con(1) + return + 60 continue +c----------------------------------------------------------------------- +c compute sum for the k function +c----------------------------------------------------------------------- + sr = zeror + si = zeroi + tr = coner + do 70 i=1,init + sr = sr + tr*cwrkr(i) + si = si + tr*cwrki(i) + tr = -tr + 70 continue + sumr = sr + sumi = si + phir = cwrkr(16)*con(2) + phii = cwrki(16)*con(2) + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zunk1(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, + * alim) +c refer to zbesk +c +c zunk1 computes k(fnu,z) and its analytic continuation from the +c right half plane to the left half plane by means of the +c uniform asymptotic expansion. +c mr indicates the direction of rotation for analytic continuation. +c nz=-1 means an overflow will occur +c +c***routines called zkscl,zs1s2,zuchk,zunik,d1mach,zabs2 +c complex cfn,ck,cone,crsc,cs,cscl,csgn,cspn,csr,css,cwrk,cy,czero, +c *c1,c2,phi,phid,rz,sum,sumd,s1,s2,y,z,zeta1,zeta1d,zeta2,zeta2d,zr + double precision alim, ang, aphi, asc, ascle, bry, cki, ckr, + * coner, crsc, cscl, csgni, cspni, cspnr, csr, csrr, cssr, + * cwrki, cwrkr, cyi, cyr, c1i, c1r, c2i, c2m, c2r, elim, fmr, fn, + * fnf, fnu, phidi, phidr, phii, phir, pi, rast, razr, rs1, rzi, + * rzr, sgn, sti, str, sumdi, sumdr, sumi, sumr, s1i, s1r, s2i, + * s2r, tol, yi, yr, zeroi, zeror, zeta1i, zeta1r, zeta2i, zeta2r, + * zet1di, zet1dr, zet2di, zet2dr, zi, zr, zri, zrr, d1mach, zabs2 + integer i, ib, iflag, ifn, il, init, inu, iuf, k, kdflg, kflag, + * kk, kode, mr, n, nw, nz, initd, ic, ipard, j + dimension bry(3), init(2), yr(n), yi(n), sumr(2), sumi(2), + * zeta1r(2), zeta1i(2), zeta2r(2), zeta2i(2), cyr(2), cyi(2), + * cwrkr(16,3), cwrki(16,3), cssr(3), csrr(3), phir(2), phii(2) + data zeror,zeroi,coner / 0.0d0, 0.0d0, 1.0d0 / + data pi / 3.14159265358979324d0 / +c + kdflg = 1 + nz = 0 +c----------------------------------------------------------------------- +c exp(-alim)=exp(-elim)/tol=approx. one precision greater than +c the underflow limit +c----------------------------------------------------------------------- + cscl = 1.0d0/tol + crsc = tol + cssr(1) = cscl + cssr(2) = coner + cssr(3) = crsc + csrr(1) = crsc + csrr(2) = coner + csrr(3) = cscl + bry(1) = 1.0d+3*d1mach(1)/tol + bry(2) = 1.0d0/bry(1) + bry(3) = d1mach(2) + zrr = zr + zri = zi + if (zr.ge.0.0d0) go to 10 + zrr = -zr + zri = -zi + 10 continue + j = 2 + do 70 i=1,n +c----------------------------------------------------------------------- +c j flip flops between 1 and 2 in j = 3 - j +c----------------------------------------------------------------------- + j = 3 - j + fn = fnu + dble(float(i-1)) + init(j) = 0 + call zunik(zrr, zri, fn, 2, 0, tol, init(j), phir(j), phii(j), + * zeta1r(j), zeta1i(j), zeta2r(j), zeta2i(j), sumr(j), sumi(j), + * cwrkr(1,j), cwrki(1,j)) + if (kode.eq.1) go to 20 + str = zrr + zeta2r(j) + sti = zri + zeta2i(j) + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = zeta1r(j) - str + s1i = zeta1i(j) - sti + go to 30 + 20 continue + s1r = zeta1r(j) - zeta2r(j) + s1i = zeta1i(j) - zeta2i(j) + 30 continue + rs1 = s1r +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + if (dabs(rs1).gt.elim) go to 60 + if (kdflg.eq.1) kflag = 2 + if (dabs(rs1).lt.alim) go to 40 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- + aphi = zabs2(phir(j),phii(j)) + rs1 = rs1 + dlog(aphi) + if (dabs(rs1).gt.elim) go to 60 + if (kdflg.eq.1) kflag = 1 + if (rs1.lt.0.0d0) go to 40 + if (kdflg.eq.1) kflag = 3 + 40 continue +c----------------------------------------------------------------------- +c scale s1 to keep intermediate arithmetic on scale near +c exponent extremes +c----------------------------------------------------------------------- + s2r = phir(j)*sumr(j) - phii(j)*sumi(j) + s2i = phir(j)*sumi(j) + phii(j)*sumr(j) + str = dexp(s1r)*cssr(kflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s1r*s2i + s2r*s1i + s2r = str + if (kflag.ne.1) go to 50 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.ne.0) go to 60 + 50 continue + cyr(kdflg) = s2r + cyi(kdflg) = s2i + yr(i) = s2r*csrr(kflag) + yi(i) = s2i*csrr(kflag) + if (kdflg.eq.2) go to 75 + kdflg = 2 + go to 70 + 60 continue + if (rs1.gt.0.0d0) go to 300 +c----------------------------------------------------------------------- +c for zr.lt.0.0, the i function to be added will overflow +c----------------------------------------------------------------------- + if (zr.lt.0.0d0) go to 300 + kdflg = 1 + yr(i)=zeror + yi(i)=zeroi + nz=nz+1 + if (i.eq.1) go to 70 + if ((yr(i-1).eq.zeror).and.(yi(i-1).eq.zeroi)) go to 70 + yr(i-1)=zeror + yi(i-1)=zeroi + nz=nz+1 + 70 continue + i = n + 75 continue + razr = 1.0d0/zabs2(zrr,zri) + str = zrr*razr + sti = -zri*razr + rzr = (str+str)*razr + rzi = (sti+sti)*razr + ckr = fn*rzr + cki = fn*rzi + ib = i + 1 + if (n.lt.ib) go to 160 +c----------------------------------------------------------------------- +c test last member for underflow and overflow. set sequence to zero +c on underflow. +c----------------------------------------------------------------------- + fn = fnu + dble(float(n-1)) + ipard = 1 + if (mr.ne.0) ipard = 0 + initd = 0 + call zunik(zrr, zri, fn, 2, ipard, tol, initd, phidr, phidi, + * zet1dr, zet1di, zet2dr, zet2di, sumdr, sumdi, cwrkr(1,3), + * cwrki(1,3)) + if (kode.eq.1) go to 80 + str = zrr + zet2dr + sti = zri + zet2di + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = zet1dr - str + s1i = zet1di - sti + go to 90 + 80 continue + s1r = zet1dr - zet2dr + s1i = zet1di - zet2di + 90 continue + rs1 = s1r + if (dabs(rs1).gt.elim) go to 95 + if (dabs(rs1).lt.alim) go to 100 +c---------------------------------------------------------------------------- +c refine estimate and test +c------------------------------------------------------------------------- + aphi = zabs2(phidr,phidi) + rs1 = rs1+dlog(aphi) + if (dabs(rs1).lt.elim) go to 100 + 95 continue + if (dabs(rs1).gt.0.0d0) go to 300 +c----------------------------------------------------------------------- +c for zr.lt.0.0, the i function to be added will overflow +c----------------------------------------------------------------------- + if (zr.lt.0.0d0) go to 300 + nz = n + do 96 i=1,n + yr(i) = zeror + yi(i) = zeroi + 96 continue + return +c--------------------------------------------------------------------------- +c forward recur for remainder of the sequence +c---------------------------------------------------------------------------- + 100 continue + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + c1r = csrr(kflag) + ascle = bry(kflag) + do 120 i=ib,n + c2r = s2r + c2i = s2i + s2r = ckr*c2r - cki*c2i + s1r + s2i = ckr*c2i + cki*c2r + s1i + s1r = c2r + s1i = c2i + ckr = ckr + rzr + cki = cki + rzi + c2r = s2r*c1r + c2i = s2i*c1r + yr(i) = c2r + yi(i) = c2i + if (kflag.ge.3) go to 120 + str = dabs(c2r) + sti = dabs(c2i) + c2m = dmax1(str,sti) + if (c2m.le.ascle) go to 120 + kflag = kflag + 1 + ascle = bry(kflag) + s1r = s1r*c1r + s1i = s1i*c1r + s2r = c2r + s2i = c2i + s1r = s1r*cssr(kflag) + s1i = s1i*cssr(kflag) + s2r = s2r*cssr(kflag) + s2i = s2i*cssr(kflag) + c1r = csrr(kflag) + 120 continue + 160 continue + if (mr.eq.0) return +c----------------------------------------------------------------------- +c analytic continuation for re(z).lt.0.0d0 +c----------------------------------------------------------------------- + nz = 0 + fmr = dble(float(mr)) + sgn = -dsign(pi,fmr) +c----------------------------------------------------------------------- +c cspn and csgn are coeff of k and i functions resp. +c----------------------------------------------------------------------- + csgni = sgn + inu = int(sngl(fnu)) + fnf = fnu - dble(float(inu)) + ifn = inu + n - 1 + ang = fnf*sgn + cspnr = dcos(ang) + cspni = dsin(ang) + if (mod(ifn,2).eq.0) go to 170 + cspnr = -cspnr + cspni = -cspni + 170 continue + asc = bry(1) + iuf = 0 + kk = n + kdflg = 1 + ib = ib - 1 + ic = ib - 1 + do 270 k=1,n + fn = fnu + dble(float(kk-1)) +c----------------------------------------------------------------------- +c logic to sort out cases whose parameters were set for the k +c function above +c----------------------------------------------------------------------- + m=3 + if (n.gt.2) go to 175 + 172 continue + initd = init(j) + phidr = phir(j) + phidi = phii(j) + zet1dr = zeta1r(j) + zet1di = zeta1i(j) + zet2dr = zeta2r(j) + zet2di = zeta2i(j) + sumdr = sumr(j) + sumdi = sumi(j) + m = j + j = 3 - j + go to 180 + 175 continue + if ((kk.eq.n).and.(ib.lt.n)) go to 180 + if ((kk.eq.ib).or.(kk.eq.ic)) go to 172 + initd = 0 + 180 continue + call zunik(zrr, zri, fn, 1, 0, tol, initd, phidr, phidi, + * zet1dr, zet1di, zet2dr, zet2di, sumdr, sumdi, + * cwrkr(1,m), cwrki(1,m)) + if (kode.eq.1) go to 200 + str = zrr + zet2dr + sti = zri + zet2di + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zet1dr + str + s1i = -zet1di + sti + go to 210 + 200 continue + s1r = -zet1dr + zet2dr + s1i = -zet1di + zet2di + 210 continue +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + rs1 = s1r + if (dabs(rs1).gt.elim) go to 260 + if (kdflg.eq.1) iflag = 2 + if (dabs(rs1).lt.alim) go to 220 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- + aphi = zabs2(phidr,phidi) + rs1 = rs1 + dlog(aphi) + if (dabs(rs1).gt.elim) go to 260 + if (kdflg.eq.1) iflag = 1 + if (rs1.lt.0.0d0) go to 220 + if (kdflg.eq.1) iflag = 3 + 220 continue + str = phidr*sumdr - phidi*sumdi + sti = phidr*sumdi + phidi*sumdr + s2r = -csgni*sti + s2i = csgni*str + str = dexp(s1r)*cssr(iflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s2r*s1i + s2i*s1r + s2r = str + if (iflag.ne.1) go to 230 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.eq.0) go to 230 + s2r = zeror + s2i = zeroi + 230 continue + cyr(kdflg) = s2r + cyi(kdflg) = s2i + c2r = s2r + c2i = s2i + s2r = s2r*csrr(iflag) + s2i = s2i*csrr(iflag) +c----------------------------------------------------------------------- +c add i and k functions, k sequence in y(i), i=1,n +c----------------------------------------------------------------------- + s1r = yr(kk) + s1i = yi(kk) + if (kode.eq.1) go to 250 + call zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nw, asc, alim, iuf) + nz = nz + nw + 250 continue + yr(kk) = s1r*cspnr - s1i*cspni + s2r + yi(kk) = cspnr*s1i + cspni*s1r + s2i + kk = kk - 1 + cspnr = -cspnr + cspni = -cspni + if (c2r.ne.0.0d0 .or. c2i.ne.0.0d0) go to 255 + kdflg = 1 + go to 270 + 255 continue + if (kdflg.eq.2) go to 275 + kdflg = 2 + go to 270 + 260 continue + if (rs1.gt.0.0d0) go to 300 + s2r = zeror + s2i = zeroi + go to 230 + 270 continue + k = n + 275 continue + il = n - k + if (il.eq.0) return +c----------------------------------------------------------------------- +c recur backward for remainder of i sequence and add in the +c k functions, scaling the i sequence during recurrence to keep +c intermediate arithmetic on scale near exponent extremes. +c----------------------------------------------------------------------- + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + csr = csrr(iflag) + ascle = bry(iflag) + fn = dble(float(inu+il)) + do 290 i=1,il + c2r = s2r + c2i = s2i + s2r = s1r + (fn+fnf)*(rzr*c2r-rzi*c2i) + s2i = s1i + (fn+fnf)*(rzr*c2i+rzi*c2r) + s1r = c2r + s1i = c2i + fn = fn - 1.0d0 + c2r = s2r*csr + c2i = s2i*csr + ckr = c2r + cki = c2i + c1r = yr(kk) + c1i = yi(kk) + if (kode.eq.1) go to 280 + call zs1s2(zrr, zri, c1r, c1i, c2r, c2i, nw, asc, alim, iuf) + nz = nz + nw + 280 continue + yr(kk) = c1r*cspnr - c1i*cspni + c2r + yi(kk) = c1r*cspni + c1i*cspnr + c2i + kk = kk - 1 + cspnr = -cspnr + cspni = -cspni + if (iflag.ge.3) go to 290 + c2r = dabs(ckr) + c2i = dabs(cki) + c2m = dmax1(c2r,c2i) + if (c2m.le.ascle) go to 290 + iflag = iflag + 1 + ascle = bry(iflag) + s1r = s1r*csr + s1i = s1i*csr + s2r = ckr + s2i = cki + s1r = s1r*cssr(iflag) + s1i = s1i*cssr(iflag) + s2r = s2r*cssr(iflag) + s2i = s2i*cssr(iflag) + csr = csrr(iflag) + 290 continue + return + 300 continue + nz = -1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zunk2(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, + * alim) +c refer to zbesk +c +c zunk2 computes k(fnu,z) and its analytic continuation from the +c right half plane to the left half plane by means of the +c uniform asymptotic expansions for h(kind,fnu,zn) and j(fnu,zn) +c where zn is in the right half plane, kind=(3-mr)/2, mr=+1 or +c -1. here zn=zr*i or -zr*i where zr=z if z is in the right +c half plane or zr=-z if z is in the left half plane. mr indic- +c ates the direction of rotation for analytic continuation. +c nz=-1 means an overflow will occur +c +c***routines called zairy,zkscl,zs1s2,zuchk,zunhj,d1mach,zabs2 +c complex ai,arg,argd,asum,asumd,bsum,bsumd,cfn,ci,cip,ck,cone,crsc, +c *cr1,cr2,cs,cscl,csgn,cspn,csr,css,cy,czero,c1,c2,dai,phi,phid,rz, +c *s1,s2,y,z,zb,zeta1,zeta1d,zeta2,zeta2d,zn,zr + double precision aarg, aic, aii, air, alim, ang, aphi, argdi, + * argdr, argi, argr, asc, ascle, asumdi, asumdr, asumi, asumr, + * bry, bsumdi, bsumdr, bsumi, bsumr, car, cipi, cipr, cki, ckr, + * coner, crsc, cr1i, cr1r, cr2i, cr2r, cscl, csgni, csi, + * cspni, cspnr, csr, csrr, cssr, cyi, cyr, c1i, c1r, c2i, c2m, + * c2r, daii, dair, elim, fmr, fn, fnf, fnu, hpi, phidi, phidr, + * phii, phir, pi, pti, ptr, rast, razr, rs1, rzi, rzr, sar, sgn, + * sti, str, s1i, s1r, s2i, s2r, tol, yi, yr, yy, zbi, zbr, zeroi, + * zeror, zeta1i, zeta1r, zeta2i, zeta2r, zet1di, zet1dr, zet2di, + * zet2dr, zi, zni, znr, zr, zri, zrr, d1mach, zabs2 + integer i, ib, iflag, ifn, il, in, inu, iuf, k, kdflg, kflag, kk, + * kode, mr, n, nai, ndai, nw, nz, idum, j, ipard, ic + dimension bry(3), yr(n), yi(n), asumr(2), asumi(2), bsumr(2), + * bsumi(2), phir(2), phii(2), argr(2), argi(2), zeta1r(2), + * zeta1i(2), zeta2r(2), zeta2i(2), cyr(2), cyi(2), cipr(4), + * cipi(4), cssr(3), csrr(3) + data zeror,zeroi,coner,cr1r,cr1i,cr2r,cr2i / + 1 0.0d0, 0.0d0, 1.0d0, + 1 1.0d0,1.73205080756887729d0 , -0.5d0,-8.66025403784438647d-01 / + data hpi, pi, aic / + 1 1.57079632679489662d+00, 3.14159265358979324d+00, + 1 1.26551212348464539d+00/ + data cipr(1),cipi(1),cipr(2),cipi(2),cipr(3),cipi(3),cipr(4), + * cipi(4) / + 1 1.0d0,0.0d0 , 0.0d0,-1.0d0 , -1.0d0,0.0d0 , 0.0d0,1.0d0 / +c + kdflg = 1 + nz = 0 +c----------------------------------------------------------------------- +c exp(-alim)=exp(-elim)/tol=approx. one precision greater than +c the underflow limit +c----------------------------------------------------------------------- + cscl = 1.0d0/tol + crsc = tol + cssr(1) = cscl + cssr(2) = coner + cssr(3) = crsc + csrr(1) = crsc + csrr(2) = coner + csrr(3) = cscl + bry(1) = 1.0d+3*d1mach(1)/tol + bry(2) = 1.0d0/bry(1) + bry(3) = d1mach(2) + zrr = zr + zri = zi + if (zr.ge.0.0d0) go to 10 + zrr = -zr + zri = -zi + 10 continue + yy = zri + znr = zri + zni = -zrr + zbr = zrr + zbi = zri + inu = int(sngl(fnu)) + fnf = fnu - dble(float(inu)) + ang = -hpi*fnf + car = dcos(ang) + sar = dsin(ang) + c2r = hpi*sar + c2i = -hpi*car + kk = mod(inu,4) + 1 + str = c2r*cipr(kk) - c2i*cipi(kk) + sti = c2r*cipi(kk) + c2i*cipr(kk) + csr = cr1r*str - cr1i*sti + csi = cr1r*sti + cr1i*str + if (yy.gt.0.0d0) go to 20 + znr = -znr + zbi = -zbi + 20 continue +c----------------------------------------------------------------------- +c k(fnu,z) is computed from h(2,fnu,-i*z) where z is in the first +c quadrant. fourth quadrant values (yy.le.0.0e0) are computed by +c conjugation since the k function is real on the positive real axis +c----------------------------------------------------------------------- + j = 2 + do 80 i=1,n +c----------------------------------------------------------------------- +c j flip flops between 1 and 2 in j = 3 - j +c----------------------------------------------------------------------- + j = 3 - j + fn = fnu + dble(float(i-1)) + call zunhj(znr, zni, fn, 0, tol, phir(j), phii(j), argr(j), + * argi(j), zeta1r(j), zeta1i(j), zeta2r(j), zeta2i(j), asumr(j), + * asumi(j), bsumr(j), bsumi(j)) + if (kode.eq.1) go to 30 + str = zbr + zeta2r(j) + sti = zbi + zeta2i(j) + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = zeta1r(j) - str + s1i = zeta1i(j) - sti + go to 40 + 30 continue + s1r = zeta1r(j) - zeta2r(j) + s1i = zeta1i(j) - zeta2i(j) + 40 continue +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + rs1 = s1r + if (dabs(rs1).gt.elim) go to 70 + if (kdflg.eq.1) kflag = 2 + if (dabs(rs1).lt.alim) go to 50 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- + aphi = zabs2(phir(j),phii(j)) + aarg = zabs2(argr(j),argi(j)) + rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic + if (dabs(rs1).gt.elim) go to 70 + if (kdflg.eq.1) kflag = 1 + if (rs1.lt.0.0d0) go to 50 + if (kdflg.eq.1) kflag = 3 + 50 continue +c----------------------------------------------------------------------- +c scale s1 to keep intermediate arithmetic on scale near +c exponent extremes +c----------------------------------------------------------------------- + c2r = argr(j)*cr2r - argi(j)*cr2i + c2i = argr(j)*cr2i + argi(j)*cr2r + call zairy(c2r, c2i, 0, 2, air, aii, nai, idum) + call zairy(c2r, c2i, 1, 2, dair, daii, ndai, idum) + str = dair*bsumr(j) - daii*bsumi(j) + sti = dair*bsumi(j) + daii*bsumr(j) + ptr = str*cr2r - sti*cr2i + pti = str*cr2i + sti*cr2r + str = ptr + (air*asumr(j)-aii*asumi(j)) + sti = pti + (air*asumi(j)+aii*asumr(j)) + ptr = str*phir(j) - sti*phii(j) + pti = str*phii(j) + sti*phir(j) + s2r = ptr*csr - pti*csi + s2i = ptr*csi + pti*csr + str = dexp(s1r)*cssr(kflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s1r*s2i + s2r*s1i + s2r = str + if (kflag.ne.1) go to 60 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.ne.0) go to 70 + 60 continue + if (yy.le.0.0d0) s2i = -s2i + cyr(kdflg) = s2r + cyi(kdflg) = s2i + yr(i) = s2r*csrr(kflag) + yi(i) = s2i*csrr(kflag) + str = csi + csi = -csr + csr = str + if (kdflg.eq.2) go to 85 + kdflg = 2 + go to 80 + 70 continue + if (rs1.gt.0.0d0) go to 320 +c----------------------------------------------------------------------- +c for zr.lt.0.0, the i function to be added will overflow +c----------------------------------------------------------------------- + if (zr.lt.0.0d0) go to 320 + kdflg = 1 + yr(i)=zeror + yi(i)=zeroi + nz=nz+1 + str = csi + csi =-csr + csr = str + if (i.eq.1) go to 80 + if ((yr(i-1).eq.zeror).and.(yi(i-1).eq.zeroi)) go to 80 + yr(i-1)=zeror + yi(i-1)=zeroi + nz=nz+1 + 80 continue + i = n + 85 continue + razr = 1.0d0/zabs2(zrr,zri) + str = zrr*razr + sti = -zri*razr + rzr = (str+str)*razr + rzi = (sti+sti)*razr + ckr = fn*rzr + cki = fn*rzi + ib = i + 1 + if (n.lt.ib) go to 180 +c----------------------------------------------------------------------- +c test last member for underflow and overflow. set sequence to zero +c on underflow. +c----------------------------------------------------------------------- + fn = fnu + dble(float(n-1)) + ipard = 1 + if (mr.ne.0) ipard = 0 + call zunhj(znr, zni, fn, ipard, tol, phidr, phidi, argdr, argdi, + * zet1dr, zet1di, zet2dr, zet2di, asumdr, asumdi, bsumdr, bsumdi) + if (kode.eq.1) go to 90 + str = zbr + zet2dr + sti = zbi + zet2di + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = zet1dr - str + s1i = zet1di - sti + go to 100 + 90 continue + s1r = zet1dr - zet2dr + s1i = zet1di - zet2di + 100 continue + rs1 = s1r + if (dabs(rs1).gt.elim) go to 105 + if (dabs(rs1).lt.alim) go to 120 +c---------------------------------------------------------------------------- +c refine estimate and test +c------------------------------------------------------------------------- + aphi = zabs2(phidr,phidi) + rs1 = rs1+dlog(aphi) + if (dabs(rs1).lt.elim) go to 120 + 105 continue + if (rs1.gt.0.0d0) go to 320 +c----------------------------------------------------------------------- +c for zr.lt.0.0, the i function to be added will overflow +c----------------------------------------------------------------------- + if (zr.lt.0.0d0) go to 320 + nz = n + do 106 i=1,n + yr(i) = zeror + yi(i) = zeroi + 106 continue + return + 120 continue + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + c1r = csrr(kflag) + ascle = bry(kflag) + do 130 i=ib,n + c2r = s2r + c2i = s2i + s2r = ckr*c2r - cki*c2i + s1r + s2i = ckr*c2i + cki*c2r + s1i + s1r = c2r + s1i = c2i + ckr = ckr + rzr + cki = cki + rzi + c2r = s2r*c1r + c2i = s2i*c1r + yr(i) = c2r + yi(i) = c2i + if (kflag.ge.3) go to 130 + str = dabs(c2r) + sti = dabs(c2i) + c2m = dmax1(str,sti) + if (c2m.le.ascle) go to 130 + kflag = kflag + 1 + ascle = bry(kflag) + s1r = s1r*c1r + s1i = s1i*c1r + s2r = c2r + s2i = c2i + s1r = s1r*cssr(kflag) + s1i = s1i*cssr(kflag) + s2r = s2r*cssr(kflag) + s2i = s2i*cssr(kflag) + c1r = csrr(kflag) + 130 continue + 180 continue + if (mr.eq.0) return +c----------------------------------------------------------------------- +c analytic continuation for re(z).lt.0.0d0 +c----------------------------------------------------------------------- + nz = 0 + fmr = dble(float(mr)) + sgn = -dsign(pi,fmr) +c----------------------------------------------------------------------- +c cspn and csgn are coeff of k and i funcions resp. +c----------------------------------------------------------------------- + csgni = sgn + if (yy.le.0.0d0) csgni = -csgni + ifn = inu + n - 1 + ang = fnf*sgn + cspnr = dcos(ang) + cspni = dsin(ang) + if (mod(ifn,2).eq.0) go to 190 + cspnr = -cspnr + cspni = -cspni + 190 continue +c----------------------------------------------------------------------- +c cs=coeff of the j function to get the i function. i(fnu,z) is +c computed from exp(i*fnu*hpi)*j(fnu,-i*z) where z is in the first +c quadrant. fourth quadrant values (yy.le.0.0e0) are computed by +c conjugation since the i function is real on the positive real axis +c----------------------------------------------------------------------- + csr = sar*csgni + csi = car*csgni + in = mod(ifn,4) + 1 + c2r = cipr(in) + c2i = cipi(in) + str = csr*c2r + csi*c2i + csi = -csr*c2i + csi*c2r + csr = str + asc = bry(1) + iuf = 0 + kk = n + kdflg = 1 + ib = ib - 1 + ic = ib - 1 + do 290 k=1,n + fn = fnu + dble(float(kk-1)) +c----------------------------------------------------------------------- +c logic to sort out cases whose parameters were set for the k +c function above +c----------------------------------------------------------------------- + if (n.gt.2) go to 175 + 172 continue + phidr = phir(j) + phidi = phii(j) + argdr = argr(j) + argdi = argi(j) + zet1dr = zeta1r(j) + zet1di = zeta1i(j) + zet2dr = zeta2r(j) + zet2di = zeta2i(j) + asumdr = asumr(j) + asumdi = asumi(j) + bsumdr = bsumr(j) + bsumdi = bsumi(j) + j = 3 - j + go to 210 + 175 continue + if ((kk.eq.n).and.(ib.lt.n)) go to 210 + if ((kk.eq.ib).or.(kk.eq.ic)) go to 172 + call zunhj(znr, zni, fn, 0, tol, phidr, phidi, argdr, + * argdi, zet1dr, zet1di, zet2dr, zet2di, asumdr, + * asumdi, bsumdr, bsumdi) + 210 continue + if (kode.eq.1) go to 220 + str = zbr + zet2dr + sti = zbi + zet2di + rast = fn/zabs2(str,sti) + str = str*rast*rast + sti = -sti*rast*rast + s1r = -zet1dr + str + s1i = -zet1di + sti + go to 230 + 220 continue + s1r = -zet1dr + zet2dr + s1i = -zet1di + zet2di + 230 continue +c----------------------------------------------------------------------- +c test for underflow and overflow +c----------------------------------------------------------------------- + rs1 = s1r + if (dabs(rs1).gt.elim) go to 280 + if (kdflg.eq.1) iflag = 2 + if (dabs(rs1).lt.alim) go to 240 +c----------------------------------------------------------------------- +c refine test and scale +c----------------------------------------------------------------------- + aphi = zabs2(phidr,phidi) + aarg = zabs2(argdr,argdi) + rs1 = rs1 + dlog(aphi) - 0.25d0*dlog(aarg) - aic + if (dabs(rs1).gt.elim) go to 280 + if (kdflg.eq.1) iflag = 1 + if (rs1.lt.0.0d0) go to 240 + if (kdflg.eq.1) iflag = 3 + 240 continue + call zairy(argdr, argdi, 0, 2, air, aii, nai, idum) + call zairy(argdr, argdi, 1, 2, dair, daii, ndai, idum) + str = dair*bsumdr - daii*bsumdi + sti = dair*bsumdi + daii*bsumdr + str = str + (air*asumdr-aii*asumdi) + sti = sti + (air*asumdi+aii*asumdr) + ptr = str*phidr - sti*phidi + pti = str*phidi + sti*phidr + s2r = ptr*csr - pti*csi + s2i = ptr*csi + pti*csr + str = dexp(s1r)*cssr(iflag) + s1r = str*dcos(s1i) + s1i = str*dsin(s1i) + str = s2r*s1r - s2i*s1i + s2i = s2r*s1i + s2i*s1r + s2r = str + if (iflag.ne.1) go to 250 + call zuchk(s2r, s2i, nw, bry(1), tol) + if (nw.eq.0) go to 250 + s2r = zeror + s2i = zeroi + 250 continue + if (yy.le.0.0d0) s2i = -s2i + cyr(kdflg) = s2r + cyi(kdflg) = s2i + c2r = s2r + c2i = s2i + s2r = s2r*csrr(iflag) + s2i = s2i*csrr(iflag) +c----------------------------------------------------------------------- +c add i and k functions, k sequence in y(i), i=1,n +c----------------------------------------------------------------------- + s1r = yr(kk) + s1i = yi(kk) + if (kode.eq.1) go to 270 + call zs1s2(zrr, zri, s1r, s1i, s2r, s2i, nw, asc, alim, iuf) + nz = nz + nw + 270 continue + yr(kk) = s1r*cspnr - s1i*cspni + s2r + yi(kk) = s1r*cspni + s1i*cspnr + s2i + kk = kk - 1 + cspnr = -cspnr + cspni = -cspni + str = csi + csi = -csr + csr = str + if (c2r.ne.0.0d0 .or. c2i.ne.0.0d0) go to 255 + kdflg = 1 + go to 290 + 255 continue + if (kdflg.eq.2) go to 295 + kdflg = 2 + go to 290 + 280 continue + if (rs1.gt.0.0d0) go to 320 + s2r = zeror + s2i = zeroi + go to 250 + 290 continue + k = n + 295 continue + il = n - k + if (il.eq.0) return +c----------------------------------------------------------------------- +c recur backward for remainder of i sequence and add in the +c k functions, scaling the i sequence during recurrence to keep +c intermediate arithmetic on scale near exponent extremes. +c----------------------------------------------------------------------- + s1r = cyr(1) + s1i = cyi(1) + s2r = cyr(2) + s2i = cyi(2) + csr = csrr(iflag) + ascle = bry(iflag) + fn = dble(float(inu+il)) + do 310 i=1,il + c2r = s2r + c2i = s2i + s2r = s1r + (fn+fnf)*(rzr*c2r-rzi*c2i) + s2i = s1i + (fn+fnf)*(rzr*c2i+rzi*c2r) + s1r = c2r + s1i = c2i + fn = fn - 1.0d0 + c2r = s2r*csr + c2i = s2i*csr + ckr = c2r + cki = c2i + c1r = yr(kk) + c1i = yi(kk) + if (kode.eq.1) go to 300 + call zs1s2(zrr, zri, c1r, c1i, c2r, c2i, nw, asc, alim, iuf) + nz = nz + nw + 300 continue + yr(kk) = c1r*cspnr - c1i*cspni + c2r + yi(kk) = c1r*cspni + c1i*cspnr + c2i + kk = kk - 1 + cspnr = -cspnr + cspni = -cspni + if (iflag.ge.3) go to 310 + c2r = dabs(ckr) + c2i = dabs(cki) + c2m = dmax1(c2r,c2i) + if (c2m.le.ascle) go to 310 + iflag = iflag + 1 + ascle = bry(iflag) + s1r = s1r*csr + s1i = s1i*csr + s2r = ckr + s2i = cki + s1r = s1r*cssr(iflag) + s1i = s1i*cssr(iflag) + s2r = s2r*cssr(iflag) + s2i = s2i*cssr(iflag) + csr = csrr(iflag) + 310 continue + return + 320 continue + nz = -1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zuoik(zr, zi, fnu, kode, ikflg, n, yr, yi, nuf, tol, + * elim, alim) +c geuz for g77 + EXTERNAL zlog +c refer to zbesi,zbesk,zbesh +c +c zuoik computes the leading terms of the uniform asymptotic +c expansions for the i and k functions and compares them +c (in logarithmic form) to alim and elim for over and underflow +c where alim.lt.elim. if the magnitude, based on the leading +c exponential, is less than alim or greater than -alim, then +c the result is on scale. if not, then a refined test using other +c multipliers (in logarithmic form) is made based on elim. here +c exp(-elim)=smallest machine number*1.0e+3 and exp(-alim)= +c exp(-elim)/tol +c +c ikflg=1 means the i sequence is tested +c =2 means the k sequence is tested +c nuf = 0 means the last member of the sequence is on scale +c =-1 means an overflow would occur +c ikflg=1 and nuf.gt.0 means the last nuf y values were set to zero +c the first n-nuf values must be set by another routine +c ikflg=2 and nuf.eq.n means all y values were set to zero +c ikflg=2 and 0.lt.nuf.lt.n not considered. y must be set by +c another routine +c +c***routines called zuchk,zunhj,zunik,d1mach,zabs2,zlog +c complex arg,asum,bsum,cwrk,cz,czero,phi,sum,y,z,zb,zeta1,zeta2,zn, +c *zr + double precision aarg, aic, alim, aphi, argi, argr, asumi, asumr, + * ascle, ax, ay, bsumi, bsumr, cwrki, cwrkr, czi, czr, elim, fnn, + * fnu, gnn, gnu, phii, phir, rcz, str, sti, sumi, sumr, tol, yi, + * yr, zbi, zbr, zeroi, zeror, zeta1i, zeta1r, zeta2i, zeta2r, zi, + * zni, znr, zr, zri, zrr, d1mach, zabs2 + integer i, idum, iform, ikflg, init, kode, n, nn, nuf, nw + dimension yr(n), yi(n), cwrkr(16), cwrki(16) + data zeror,zeroi / 0.0d0, 0.0d0 / + data aic / 1.265512123484645396d+00 / + nuf = 0 + nn = n + zrr = zr + zri = zi + if (zr.ge.0.0d0) go to 10 + zrr = -zr + zri = -zi + 10 continue + zbr = zrr + zbi = zri + ax = dabs(zr)*1.7321d0 + ay = dabs(zi) + iform = 1 + if (ay.gt.ax) iform = 2 + gnu = dmax1(fnu,1.0d0) + if (ikflg.eq.1) go to 20 + fnn = dble(float(nn)) + gnn = fnu + fnn - 1.0d0 + gnu = dmax1(gnn,fnn) + 20 continue +c----------------------------------------------------------------------- +c only the magnitude of arg and phi are needed along with the +c real parts of zeta1, zeta2 and zb. no attempt is made to get +c the sign of the imaginary part correct. +c----------------------------------------------------------------------- + if (iform.eq.2) go to 30 + init = 0 + call zunik(zrr, zri, gnu, ikflg, 1, tol, init, phir, phii, + * zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) + czr = -zeta1r + zeta2r + czi = -zeta1i + zeta2i + go to 50 + 30 continue + znr = zri + zni = -zrr + if (zi.gt.0.0d0) go to 40 + znr = -znr + 40 continue + call zunhj(znr, zni, gnu, 1, tol, phir, phii, argr, argi, zeta1r, + * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) + czr = -zeta1r + zeta2r + czi = -zeta1i + zeta2i + aarg = zabs2(argr,argi) + 50 continue + if (kode.eq.1) go to 60 + czr = czr - zbr + czi = czi - zbi + 60 continue + if (ikflg.eq.1) go to 70 + czr = -czr + czi = -czi + 70 continue + aphi = zabs2(phir,phii) + rcz = czr +c----------------------------------------------------------------------- +c overflow test +c----------------------------------------------------------------------- + if (rcz.gt.elim) go to 210 + if (rcz.lt.alim) go to 80 + rcz = rcz + dlog(aphi) + if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic + if (rcz.gt.elim) go to 210 + go to 130 + 80 continue +c----------------------------------------------------------------------- +c underflow test +c----------------------------------------------------------------------- + if (rcz.lt.(-elim)) go to 90 + if (rcz.gt.(-alim)) go to 130 + rcz = rcz + dlog(aphi) + if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic + if (rcz.gt.(-elim)) go to 110 + 90 continue + do 100 i=1,nn + yr(i) = zeror + yi(i) = zeroi + 100 continue + nuf = nn + return + 110 continue + ascle = 1.0d+3*d1mach(1)/tol + call zlog(phir, phii, str, sti, idum) + czr = czr + str + czi = czi + sti + if (iform.eq.1) go to 120 + call zlog(argr, argi, str, sti, idum) + czr = czr - 0.25d0*str - aic + czi = czi - 0.25d0*sti + 120 continue + ax = dexp(rcz)/tol + ay = czi + czr = ax*dcos(ay) + czi = ax*dsin(ay) + call zuchk(czr, czi, nw, ascle, tol) + if (nw.ne.0) go to 90 + 130 continue + if (ikflg.eq.2) return + if (n.eq.1) return +c----------------------------------------------------------------------- +c set underflows on i sequence +c----------------------------------------------------------------------- + 140 continue + gnu = fnu + dble(float(nn-1)) + if (iform.eq.2) go to 150 + init = 0 + call zunik(zrr, zri, gnu, ikflg, 1, tol, init, phir, phii, + * zeta1r, zeta1i, zeta2r, zeta2i, sumr, sumi, cwrkr, cwrki) + czr = -zeta1r + zeta2r + czi = -zeta1i + zeta2i + go to 160 + 150 continue + call zunhj(znr, zni, gnu, 1, tol, phir, phii, argr, argi, zeta1r, + * zeta1i, zeta2r, zeta2i, asumr, asumi, bsumr, bsumi) + czr = -zeta1r + zeta2r + czi = -zeta1i + zeta2i + aarg = zabs2(argr,argi) + 160 continue + if (kode.eq.1) go to 170 + czr = czr - zbr + czi = czi - zbi + 170 continue + aphi = zabs2(phir,phii) + rcz = czr + if (rcz.lt.(-elim)) go to 180 + if (rcz.gt.(-alim)) return + rcz = rcz + dlog(aphi) + if (iform.eq.2) rcz = rcz - 0.25d0*dlog(aarg) - aic + if (rcz.gt.(-elim)) go to 190 + 180 continue + yr(nn) = zeror + yi(nn) = zeroi + nn = nn - 1 + nuf = nuf + 1 + if (nn.eq.0) return + go to 140 + 190 continue + ascle = 1.0d+3*d1mach(1)/tol + call zlog(phir, phii, str, sti, idum) + czr = czr + str + czi = czi + sti + if (iform.eq.1) go to 200 + call zlog(argr, argi, str, sti, idum) + czr = czr - 0.25d0*str - aic + czi = czi - 0.25d0*sti + 200 continue + ax = dexp(rcz)/tol + ay = czi + czr = ax*dcos(ay) + czi = ax*dsin(ay) + call zuchk(czr, czi, nw, ascle, tol) + if (nw.ne.0) go to 180 + return + 210 continue + nuf = -1 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + + + + + + + + + + + + + + + + + subroutine zbesj(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) +c j-Bessel function of complex argument and first kind +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, cbesj computes an n member sequence of complex +c bessel functions cy(i)=j(fnu+i-1,z) for real, nonnegative +c orders fnu+i-1, i=1,...,n and complex z in the cut plane +c -pi.lt.arg(z).le.pi. on kode=2, cbesj returns the scaled +c functions +c +c cy(i)=exp(-abs(y))*j(fnu+i-1,z) i = 1,...,n , y=aimag(z) +c +c which remove the exponential growth in both the upper and +c lower half planes for z to infinity. +c +c Input zr,zi,fnu are double precision +c zr,zi - z=cmplx(zr,zi), -pi.lt.arg(z).le.pi +c fnu - order of initial j function, fnu.ge.0.0d0 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c cy(i)=j(fnu+i-1,z), i=1,...,n +c = 2 returns +c cy(i)=j(fnu+i-1,z)exp(-abs(y)), i=1,...,n +c n - number of members of the sequence, n.ge.1 +c +c Output cyr,cyi are double precision +c cyr,cyi- double precision vectors whose first n components +c contain real and imaginary parts for the sequence +c cy(i)=j(fnu+i-1,z) or +c cy(i)=j(fnu+i-1,z)exp(-abs(y)) i=1,...,n +c depending on kode, y=aimag(z). +c nz - number of components set to zero due to underflow, +c nz= 0 , normal return +c nz.gt.0 , last nz components of cy set zero due +c to underflow, cy(i)=cmplx(0.0d0,0.0d0), +c i = n-nz+1,...,n +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, aimag(z) +c too large on kode=1 +c ierr=3, cabs(z) or fnu+n-1 large - computation done +c but losses of signifcance by argument +c reduction produce less than half of machine +c accuracy +c ierr=4, cabs(z) or fnu+n-1 too large - no computa- +c tion because of complete losses of signifi- +c cance by argument reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c the computation is carried out by the formula +c +c j(fnu,z)=exp( fnu*pi*i/2)*i(fnu,-i*z) aimag(z).ge.0.0 +c +c j(fnu,z)=exp(-fnu*pi*i/2)*i(fnu, i*z) aimag(z).lt.0.0 +c +c where i**2 = -1 and i(fnu,z) is the i bessel function. +c +c for negative orders,the formula +c +c j(-fnu,z) = j(fnu,z)*cos(pi*fnu) - y(fnu,z)*sin(pi*fnu) +c +c can be used. however,for large orders close to integers, the +c the function changes radically. when fnu is a large positive +c integer,the magnitude of j(-fnu,z)=j(fnu,z)*cos(pi*fnu) is a +c large negative power of ten. but when fnu is not an integer, +c y(fnu,z) dominates in magnitude with a large positive power of +c ten and the most that the second term can be reduced is by +c unit roundoff from the coefficient. thus, wide changes can +c occur within unit roundoff of a large integer for fnu. here, +c large means fnu.gt.cabs(z). +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z or fnu+n-1 is +c large, losses of significance by argument reduction occur. +c consequently, if either one exceeds u1=sqrt(0.5/ur), then +c losses exceeding half precision are likely and an error flag +c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c if either is larger than u2=0.5/ur, then all significance is +c lost and ierr=4. in order to use the int function, arguments +c must be further restricted not to exceed the largest machine +c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is +c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 +c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision +c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision +c arithmetic respectively. this makes u2 and u3 limiting in +c their respective arithmetics. this means that one can expect +c to retain, in the worst cases on 32 bit machines, no digits +c in single and only 7 digits in double precision arithmetic. +c similar considerations hold for other machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zbinu,i1mach,d1mach +c +c complex ci,csgn,cy,z,zn + double precision aa, alim, arg, cii, csgni, csgnr, cyi, cyr, dig, + * elim, fnu, fnul, hpi, rl, r1m5, str, tol, zi, zni, znr, zr, + * d1mach, bb, fn, az, zabs2, ascle, rtol, atol, sti + integer i, ierr, inu, inuh, ir, k, kode, k1, k2, n, nl, nz, i1mach + dimension cyr(n), cyi(n) + data hpi /1.57079632679489662d0/ + +c write(*,*)'zr, zi, fnu, kode, n, nz',zr, zi, fnu, kode, n,nz +c write(*,*)'cyr',(cyr(i),i=1,n) +c write(*,*)'cyi',(cyi(i),i=1,n) + +c + ierr = 0 + nz=0 + if (fnu.lt.0.0d0) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (n.lt.1) ierr=1 + if (ierr.ne.0) return +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0e-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c fnul is the lower boundary of the asymptotic series for large fnu. +c----------------------------------------------------------------------- + tol = dmax1(d1mach(4),1.0d-18) + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + rl = 1.2d0*dig + 3.0d0 + fnul = 10.0d0 + 6.0d0*(dig-3.0d0) +c----------------------------------------------------------------------- +c test for proper range +c----------------------------------------------------------------------- + az = zabs2(zr,zi) + fn = fnu+dble(float(n-1)) + aa = 0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa = dmin1(aa,bb) + if (az.gt.aa) go to 260 + if (fn.gt.aa) go to 260 + aa = dsqrt(aa) + if (az.gt.aa) ierr=3 + if (fn.gt.aa) ierr=3 +c----------------------------------------------------------------------- +c calculate csgn=exp(fnu*hpi*i) to minimize losses of significance +c when fnu is large +c----------------------------------------------------------------------- + cii = 1.0d0 + inu = int(sngl(fnu)) + inuh = inu/2 + ir = inu - 2*inuh + arg = (fnu-dble(float(inu-ir)))*hpi + csgnr = dcos(arg) + csgni = dsin(arg) + if (mod(inuh,2).eq.0) go to 40 + csgnr = -csgnr + csgni = -csgni + 40 continue +c----------------------------------------------------------------------- +c zn is in the right half plane +c----------------------------------------------------------------------- + znr = zi + zni = -zr + if (zi.ge.0.0d0) go to 50 + znr = -znr + zni = -zni + csgni = -csgni + cii = -cii + 50 continue + call zbinu(znr, zni, fnu, kode, n, cyr, cyi, nz, rl, fnul, tol, + * elim, alim) + if (nz.lt.0) go to 130 + nl = n - nz + if (nl.eq.0) return + rtol = 1.0d0/tol + ascle = d1mach(1)*rtol*1.0d+3 + do 60 i=1,nl +c str = cyr(i)*csgnr - cyi(i)*csgni +c cyi(i) = cyr(i)*csgni + cyi(i)*csgnr +c cyr(i) = str + aa = cyr(i) + bb = cyi(i) + atol = 1.0d0 + if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 55 + aa = aa*rtol + bb = bb*rtol + atol = tol + 55 continue + str = aa*csgnr - bb*csgni + sti = aa*csgni + bb*csgnr + cyr(i) = str*atol + cyi(i) = sti*atol + str = -csgni*cii + csgni = csgnr*cii + csgnr = str + 60 continue + return + 130 continue + if(nz.eq.(-2)) go to 140 + nz = 0 + ierr = 2 + return + 140 continue + nz=0 + ierr=5 + return + 260 continue + nz=0 + ierr=4 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbesy(zr, zi, fnu, kode, n, cyr, cyi, nz, cwrkr, cwrki, + * ierr) +c y-Bessel function of complex argument and of second kind +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, cbesy computes an n member sequence of complex +c bessel functions cy(i)=y(fnu+i-1,z) for real, nonnegative +c orders fnu+i-1, i=1,...,n and complex z in the cut plane +c -pi.lt.arg(z).le.pi. on kode=2, cbesy returns the scaled +c functions +c +c cy(i)=exp(-abs(y))*y(fnu+i-1,z) i = 1,...,n , y=aimag(z) +c +c which remove the exponential growth in both the upper and +c lower half planes for z to infinity. +c +c input zr,zi,fnu are double precision +c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), +c -pi.lt.arg(z).le.pi +c fnu - order of initial y function, fnu.ge.0.0d0 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c cy(i)=y(fnu+i-1,z), i=1,...,n +c = 2 returns +c cy(i)=y(fnu+i-1,z)*exp(-abs(y)), i=1,...,n +c where y=aimag(z) +c n - number of members of the sequence, n.ge.1 +c cwrkr, - double precision work vectors of dimension at +c cwrki at least n +c +c output cyr,cyi are double precision +c cyr,cyi- double precision vectors whose first n components +c contain real and imaginary parts for the sequence +c cy(i)=y(fnu+i-1,z) or +c cy(i)=y(fnu+i-1,z)*exp(-abs(y)) i=1,...,n +c depending on kode. +c nz - nz=0 , a normal return +c nz.gt.0 , nz components of cy set to zero due to +c underflow (generally on kode=2) +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, fnu is +c too large or cabs(z) is too small or both +c ierr=3, cabs(z) or fnu+n-1 large - computation done +c but losses of signifcance by argument +c reduction produce less than half of machine +c accuracy +c ierr=4, cabs(z) or fnu+n-1 too large - no computa- +c tion because of complete losses of signifi- +c cance by argument reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c the computation is carried out by the formula +c +c y(fnu,z)=0.5*(h(1,fnu,z)-h(2,fnu,z))/i +c +c where i**2 = -1 and the hankel bessel functions h(1,fnu,z) +c and h(2,fnu,z) are calculated in cbesh. +c +c for negative orders,the formula +c +c y(-fnu,z) = y(fnu,z)*cos(pi*fnu) + j(fnu,z)*sin(pi*fnu) +c +c can be used. however,for large orders close to half odd +c integers the function changes radically. when fnu is a large +c positive half odd integer,the magnitude of y(-fnu,z)=j(fnu,z)* +c sin(pi*fnu) is a large negative power of ten. but when fnu is +c not a half odd integer, y(fnu,z) dominates in magnitude with a +c large positive power of ten and the most that the second term +c can be reduced is by unit roundoff from the coefficient. thus, +c wide changes can occur within unit roundoff of a large half +c odd integer. here, large means fnu.gt.cabs(z). +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z or fnu+n-1 is +c large, losses of significance by argument reduction occur. +c consequently, if either one exceeds u1=sqrt(0.5/ur), then +c losses exceeding half precision are likely and an error flag +c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c if either is larger than u2=0.5/ur, then all significance is +c lost and ierr=4. in order to use the int function, arguments +c must be further restricted not to exceed the largest machine +c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is +c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 +c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision +c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision +c arithmetic respectively. this makes u2 and u3 limiting in +c their respective arithmetics. this means that one can expect +c to retain, in the worst cases on 32 bit machines, no digits +c in single and only 7 digits in double precision arithmetic. +c similar considerations hold for other machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zbesh,i1mach,d1mach +c +c complex cwrk,cy,c1,c2,ex,hci,z,zu,zv + double precision cwrki, cwrkr, cyi, cyr, c1i, c1r, c2i, c2r, + * elim, exi, exr, ey, fnu, hcii, sti, str, tay, zi, zr, dexp, + * d1mach, ascle, rtol, atol, aa, bb, tol + integer i, ierr, k, kode, k1, k2, n, nz, nz1, nz2, i1mach + dimension cyr(n), cyi(n), cwrkr(n), cwrki(n) +c + ierr = 0 + nz=0 + if (zr.eq.0.0d0 .and. zi.eq.0.0d0) ierr=1 + if (fnu.lt.0.0d0) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (n.lt.1) ierr=1 + if (ierr.ne.0) return + hcii = 0.5d0 + call zbesh(zr, zi, fnu, kode, 1, n, cyr, cyi, nz1, ierr) + if (ierr.ne.0.and.ierr.ne.3) go to 170 + call zbesh(zr, zi, fnu, kode, 2, n, cwrkr, cwrki, nz2, ierr) + if (ierr.ne.0.and.ierr.ne.3) go to 170 + nz = min0(nz1,nz2) + if (kode.eq.2) go to 60 + do 50 i=1,n + str = cwrkr(i) - cyr(i) + sti = cwrki(i) - cyi(i) + cyr(i) = -sti*hcii + cyi(i) = str*hcii + 50 continue + return + 60 continue + tol = dmax1(d1mach(4),1.0d-18) + k1 = i1mach(15) + k2 = i1mach(16) + k = min0(iabs(k1),iabs(k2)) + r1m5 = d1mach(5) +c----------------------------------------------------------------------- +c elim is the approximate exponential under- and overflow limit +c----------------------------------------------------------------------- + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + exr = dcos(zr) + exi = dsin(zr) + ey = 0.0d0 + tay = dabs(zi+zi) + if (tay.lt.elim) ey = dexp(-tay) + if (zi.lt.0.0d0) go to 90 + c1r = exr*ey + c1i = exi*ey + c2r = exr + c2i = -exi + 70 continue + nz = 0 + rtol = 1.0d0/tol + ascle = d1mach(1)*rtol*1.0d+3 + do 80 i=1,n +c str = c1r*cyr(i) - c1i*cyi(i) +c sti = c1r*cyi(i) + c1i*cyr(i) +c str = -str + c2r*cwrkr(i) - c2i*cwrki(i) +c sti = -sti + c2r*cwrki(i) + c2i*cwrkr(i) +c cyr(i) = -sti*hcii +c cyi(i) = str*hcii + aa = cwrkr(i) + bb = cwrki(i) + atol = 1.0d0 + if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 75 + aa = aa*rtol + bb = bb*rtol + atol = tol + 75 continue + str = (aa*c2r - bb*c2i)*atol + sti = (aa*c2i + bb*c2r)*atol + aa = cyr(i) + bb = cyi(i) + atol = 1.0d0 + if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 85 + aa = aa*rtol + bb = bb*rtol + atol = tol + 85 continue + str = str - (aa*c1r - bb*c1i)*atol + sti = sti - (aa*c1i + bb*c1r)*atol + cyr(i) = -sti*hcii + cyi(i) = str*hcii + if (str.eq.0.0d0 .and. sti.eq.0.0d0 .and. ey.eq.0.0d0) nz = nz + * + 1 + 80 continue + return + 90 continue + c1r = exr + c1i = exi + c2r = exr*ey + c2i = -exi*ey + go to 70 + 170 continue + nz = 0 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbesh(zr, zi, fnu, kode, m, n, cyr, cyi, nz, ierr) +c h-Bessel functions of complex argument and third kind,hankel functions +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, zbesh computes an n member sequence of complex +c hankel (bessel) functions cy(j)=h(m,fnu+j-1,z) for kinds m=1 +c or 2, real, nonnegative orders fnu+j-1, j=1,...,n, and complex +c z.ne.cmplx(0.0,0.0) in the cut plane -pi.lt.arg(z).le.pi. +c on kode=2, zbesh returns the scaled hankel functions +c +c cy(i)=exp(-mm*z*i)*h(m,fnu+j-1,z) mm=3-2*m, i**2=-1. +c +c which removes the exponential behavior in both the upper and +c lower half planes. +c +c input zr,zi,fnu are double precision +c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), +c -pt.lt.arg(z).le.pi +c fnu - order of initial h function, fnu.ge.0.0d0 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c cy(j)=h(m,fnu+j-1,z), j=1,...,n +c = 2 returns +c cy(j)=h(m,fnu+j-1,z)*exp(-i*z*(3-2m)) +c j=1,...,n , i**2=-1 +c m - kind of hankel function, m=1 or 2 +c n - number of members in the sequence, n.ge.1 +c +c output cyr,cyi are double precision +c cyr,cyi- double precision vectors whose first n components +c contain real and imaginary parts for the sequence +c cy(j)=h(m,fnu+j-1,z) or +c cy(j)=h(m,fnu+j-1,z)*exp(-i*z*(3-2m)) j=1,...,n +c depending on kode, i**2=-1. +c nz - number of components set to zero due to underflow, +c nz= 0 , normal return +c nz.gt.0 , first nz components of cy set to zero due +c to underflow, cy(j)=cmplx(0.0d0,0.0d0) +c j=1,...,nz when y.gt.0.0 and m=1 or +c y.lt.0.0 and m=2. for the complmentary +c half planes, nz states only the number +c of underflows. +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, fnu too +c large or cabs(z) too small or both +c ierr=3, cabs(z) or fnu+n-1 large - computation done +c but losses of signifcance by argument +c reduction produce less than half of machine +c accuracy +c ierr=4, cabs(z) or fnu+n-1 too large - no computa- +c tion because of complete losses of signifi- +c cance by argument reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c the computation is carried out by the relation +c +c h(m,fnu,z)=(1/mp)*exp(-mp*fnu)*k(fnu,z*exp(-mp)) +c mp=mm*hpi*i, mm=3-2*m, hpi=pi/2, i**2=-1 +c +c for m=1 or 2 where the k bessel function is computed for the +c right half plane re(z).ge.0.0. the k function is continued +c to the left half plane by the relation +c +c k(fnu,z*exp(mp)) = exp(-mp*fnu)*k(fnu,z)-mp*i(fnu,z) +c mp=mr*pi*i, mr=+1 or -1, re(z).gt.0, i**2=-1 +c +c where i(fnu,z) is the i bessel function. +c +c exponential decay of h(m,fnu,z) occurs in the upper half z +c plane for m=1 and the lower half z plane for m=2. exponential +c growth occurs in the complementary half planes. scaling +c by exp(-mm*z*i) removes the exponential behavior in the +c whole z plane for z to infinity. +c +c for negative orders,the formulae +c +c h(1,-fnu,z) = h(1,fnu,z)*cexp( pi*fnu*i) +c h(2,-fnu,z) = h(2,fnu,z)*cexp(-pi*fnu*i) +c i**2=-1 +c +c can be used. +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z or fnu+n-1 is +c large, losses of significance by argument reduction occur. +c consequently, if either one exceeds u1=sqrt(0.5/ur), then +c losses exceeding half precision are likely and an error flag +c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c if either is larger than u2=0.5/ur, then all significance is +c lost and ierr=4. in order to use the int function, arguments +c must be further restricted not to exceed the largest machine +c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is +c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 +c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision +c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision +c arithmetic respectively. this makes u2 and u3 limiting in +c their respective arithmetics. this means that one can expect +c to retain, in the worst cases on 32 bit machines, no digits +c in single and only 7 digits in double precision arithmetic. +c similar considerations hold for other machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0d-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zacon,zbknu,zbunk,zuoik,zabs2,i1mach,d1mach +c +c complex cy,z,zn,zt,csgn + double precision aa, alim, aln, arg, az, cyi, cyr, dig, elim, + * fmm, fn, fnu, fnul, hpi, rhpi, rl, r1m5, sgn, str, tol, ufl, zi, + * zni, znr, zr, zti, d1mach, zabs2, bb, ascle, rtol, atol, sti, + * csgnr, csgni + integer i, ierr, inu, inuh, ir, k, kode, k1, k2, m, + * mm, mr, n, nn, nuf, nw, nz, i1mach + dimension cyr(n), cyi(n) + data hpi /1.57079632679489662d0/ +c + ierr = 0 + nz=0 + if (zr.eq.0.0d0 .and. zi.eq.0.0d0) ierr=1 + if (fnu.lt.0.0d0) ierr=1 + if (m.lt.1 .or. m.gt.2) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (n.lt.1) ierr=1 + if (ierr.ne.0) return + nn = n +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0e-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c fnul is the lower boundary of the asymptotic series for large fnu +c----------------------------------------------------------------------- + tol = dmax1(d1mach(4),1.0d-18) + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + fnul = 10.0d0 + 6.0d0*(dig-3.0d0) + rl = 1.2d0*dig + 3.0d0 + fn = fnu + dble(float(nn-1)) + mm = 3 - m - m + fmm = dble(float(mm)) + znr = fmm*zi + zni = -fmm*zr +c----------------------------------------------------------------------- +c test for proper range +c----------------------------------------------------------------------- + az = zabs2(zr,zi) + aa = 0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa = dmin1(aa,bb) + if (az.gt.aa) go to 260 + if (fn.gt.aa) go to 260 + aa = dsqrt(aa) + if (az.gt.aa) ierr=3 + if (fn.gt.aa) ierr=3 +c----------------------------------------------------------------------- +c overflow test on the last member of the sequence +c----------------------------------------------------------------------- + ufl = d1mach(1)*1.0d+3 + if (az.lt.ufl) go to 230 + if (fnu.gt.fnul) go to 90 + if (fn.le.1.0d0) go to 70 + if (fn.gt.2.0d0) go to 60 + if (az.gt.tol) go to 70 + arg = 0.5d0*az + aln = -fn*dlog(arg) + if (aln.gt.elim) go to 230 + go to 70 + 60 continue + call zuoik(znr, zni, fnu, kode, 2, nn, cyr, cyi, nuf, tol, elim, + * alim) + if (nuf.lt.0) go to 230 + nz = nz + nuf + nn = nn - nuf +c----------------------------------------------------------------------- +c here nn=n or nn=0 since nuf=0,nn, or -1 on return from cuoik +c if nuf=nn, then cy(i)=czero for all i +c----------------------------------------------------------------------- + if (nn.eq.0) go to 140 + 70 continue + if ((znr.lt.0.0d0) .or. (znr.eq.0.0d0 .and. zni.lt.0.0d0 .and. + * m.eq.2)) go to 80 +c----------------------------------------------------------------------- +c right half plane computation, xn.ge.0. .and. (xn.ne.0. .or. +c yn.ge.0. .or. m=1) +c----------------------------------------------------------------------- + call zbknu(znr, zni, fnu, kode, nn, cyr, cyi, nz, tol, elim, alim) + go to 110 +c----------------------------------------------------------------------- +c left half plane computation +c----------------------------------------------------------------------- + 80 continue + mr = -mm + call zacon(znr, zni, fnu, kode, mr, nn, cyr, cyi, nw, rl, fnul, + * tol, elim, alim) + if (nw.lt.0) go to 240 + nz=nw + go to 110 + 90 continue +c----------------------------------------------------------------------- +c uniform asymptotic expansions for fnu.gt.fnul +c----------------------------------------------------------------------- + mr = 0 + if ((znr.ge.0.0d0) .and. (znr.ne.0.0d0 .or. zni.ge.0.0d0 .or. + * m.ne.2)) go to 100 + mr = -mm + if (znr.ne.0.0d0 .or. zni.ge.0.0d0) go to 100 + znr = -znr + zni = -zni + 100 continue + call zbunk(znr, zni, fnu, kode, mr, nn, cyr, cyi, nw, tol, elim, + * alim) + if (nw.lt.0) go to 240 + nz = nz + nw + 110 continue +c----------------------------------------------------------------------- +c h(m,fnu,z) = -fmm*(i/hpi)*(zt**fnu)*k(fnu,-z*zt) +c +c zt=exp(-fmm*hpi*i) = cmplx(0.0,-fmm), fmm=3-2*m, m=1,2 +c----------------------------------------------------------------------- + sgn = dsign(hpi,-fmm) +c----------------------------------------------------------------------- +c calculate exp(fnu*hpi*i) to minimize losses of significance +c when fnu is large +c----------------------------------------------------------------------- + inu = int(sngl(fnu)) + inuh = inu/2 + ir = inu - 2*inuh + arg = (fnu-dble(float(inu-ir)))*sgn + rhpi = 1.0d0/sgn +c zni = rhpi*dcos(arg) +c znr = -rhpi*dsin(arg) + csgni = rhpi*dcos(arg) + csgnr = -rhpi*dsin(arg) + if (mod(inuh,2).eq.0) go to 120 +c znr = -znr +c zni = -zni + csgnr = -csgnr + csgni = -csgni + 120 continue + zti = -fmm + rtol = 1.0d0/tol + ascle = ufl*rtol + do 130 i=1,nn +c str = cyr(i)*znr - cyi(i)*zni +c cyi(i) = cyr(i)*zni + cyi(i)*znr +c cyr(i) = str +c str = -zni*zti +c zni = znr*zti +c znr = str + aa = cyr(i) + bb = cyi(i) + atol = 1.0d0 + if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 135 + aa = aa*rtol + bb = bb*rtol + atol = tol + 135 continue + str = aa*csgnr - bb*csgni + sti = aa*csgni + bb*csgnr + cyr(i) = str*atol + cyi(i) = sti*atol + str = -csgni*zti + csgni = csgnr*zti + csgnr = str + 130 continue + return + 140 continue + if (znr.lt.0.0d0) go to 230 + return + 230 continue + nz=0 + ierr=2 + return + 240 continue + if(nw.eq.(-1)) go to 230 + nz=0 + ierr=5 + return + 260 continue + nz=0 + ierr=4 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbesi(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) +c i-Bessel function,complex bessel function, +c modified bessel function of the first kind +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, zbesi computes an n member sequence of complex +c bessel functions cy(j)=i(fnu+j-1,z) for real, nonnegative +c orders fnu+j-1, j=1,...,n and complex z in the cut plane +c -pi.lt.arg(z).le.pi. on kode=2, zbesi returns the scaled +c functions +c +c cy(j)=exp(-abs(x))*i(fnu+j-1,z) j = 1,...,n , x=real(z) +c +c with the exponential growth removed in both the left and +c right half planes for z to infinity. definitions and notation +c are found in the nbs handbook of mathematical functions +c (ref. 1). +c +c input zr,zi,fnu are double precision +c zr,zi - z=cmplx(zr,zi), -pi.lt.arg(z).le.pi +c fnu - order of initial i function, fnu.ge.0.0d0 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c cy(j)=i(fnu+j-1,z), j=1,...,n +c = 2 returns +c cy(j)=i(fnu+j-1,z)*exp(-abs(x)), j=1,...,n +c n - number of members of the sequence, n.ge.1 +c +c output cyr,cyi are double precision +c cyr,cyi- double precision vectors whose first n components +c contain real and imaginary parts for the sequence +c cy(j)=i(fnu+j-1,z) or +c cy(j)=i(fnu+j-1,z)*exp(-abs(x)) j=1,...,n +c depending on kode, x=real(z) +c nz - number of components set to zero due to underflow, +c nz= 0 , normal return +c nz.gt.0 , last nz components of cy set to zero +c to underflow, cy(j)=cmplx(0.0d0,0.0d0) +c j = n-nz+1,...,n +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, real(z) too +c large on kode=1 +c ierr=3, cabs(z) or fnu+n-1 large - computation done +c but losses of signifcance by argument +c reduction produce less than half of machine +c accuracy +c ierr=4, cabs(z) or fnu+n-1 too large - no computa- +c tion because of complete losses of signifi- +c cance by argument reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c the computation is carried out by the power series for +c small cabs(z), the asymptotic expansion for large cabs(z), +c the miller algorithm normalized by the wronskian and a +c neumann series for imtermediate magnitudes, and the +c uniform asymptotic expansions for i(fnu,z) and j(fnu,z) +c for large orders. backward recurrence is used to generate +c sequences or reduce orders when necessary. +c +c the calculations above are done in the right half plane and +c continued into the left half plane by the formula +c +c i(fnu,z*exp(m*pi)) = exp(m*pi*fnu)*i(fnu,z) real(z).gt.0.0 +c m = +i or -i, i**2=-1 +c +c for negative orders,the formula +c +c i(-fnu,z) = i(fnu,z) + (2/pi)*sin(pi*fnu)*k(fnu,z) +c +c can be used. however,for large orders close to integers, the +c the function changes radically. when fnu is a large positive +c integer,the magnitude of i(-fnu,z)=i(fnu,z) is a large +c negative power of ten. but when fnu is not an integer, +c k(fnu,z) dominates in magnitude with a large positive power of +c ten and the most that the second term can be reduced is by +c unit roundoff from the coefficient. thus, wide changes can +c occur within unit roundoff of a large integer for fnu. here, +c large means fnu.gt.cabs(z). +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z or fnu+n-1 is +c large, losses of significance by argument reduction occur. +c consequently, if either one exceeds u1=sqrt(0.5/ur), then +c losses exceeding half precision are likely and an error flag +c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c if either is larger than u2=0.5/ur, then all significance is +c lost and ierr=4. in order to use the int function, arguments +c must be further restricted not to exceed the largest machine +c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is +c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 +c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision +c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision +c arithmetic respectively. this makes u2 and u3 limiting in +c their respective arithmetics. this means that one can expect +c to retain, in the worst cases on 32 bit machines, no digits +c in single and only 7 digits in double precision arithmetic. +c similar considerations hold for other machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zbinu,i1mach,d1mach +c complex cone,csgn,cw,cy,czero,z,zn + double precision aa, alim, arg, conei, coner, csgni, csgnr, cyi, + * cyr, dig, elim, fnu, fnul, pi, rl, r1m5, str, tol, zi, zni, znr, + * zr, d1mach, az, bb, fn, zabs2, ascle, rtol, atol, sti + integer i, ierr, inu, k, kode, k1,k2,n,nz,nn, i1mach + dimension cyr(n), cyi(n) + data pi /3.14159265358979324d0/ + data coner, conei /1.0d0,0.0d0/ +c + ierr = 0 + nz=0 + if (fnu.lt.0.0d0) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (n.lt.1) ierr=1 + if (ierr.ne.0) return +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0e-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c fnul is the lower boundary of the asymptotic series for large fnu. +c----------------------------------------------------------------------- + tol = dmax1(d1mach(4),1.0d-18) + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + rl = 1.2d0*dig + 3.0d0 + fnul = 10.0d0 + 6.0d0*(dig-3.0d0) +c----------------------------------------------------------------------------- +c test for proper range +c----------------------------------------------------------------------- + az = zabs2(zr,zi) + fn = fnu+dble(float(n-1)) + aa = 0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa = dmin1(aa,bb) + if (az.gt.aa) go to 260 + if (fn.gt.aa) go to 260 + aa = dsqrt(aa) + if (az.gt.aa) ierr=3 + if (fn.gt.aa) ierr=3 + znr = zr + zni = zi + csgnr = coner + csgni = conei + if (zr.ge.0.0d0) go to 40 + znr = -zr + zni = -zi +c----------------------------------------------------------------------- +c calculate csgn=exp(fnu*pi*i) to minimize losses of significance +c when fnu is large +c----------------------------------------------------------------------- + inu = int(sngl(fnu)) + arg = (fnu-dble(float(inu)))*pi + if (zi.lt.0.0d0) arg = -arg + csgnr = dcos(arg) + csgni = dsin(arg) + if (mod(inu,2).eq.0) go to 40 + csgnr = -csgnr + csgni = -csgni + 40 continue + call zbinu(znr, zni, fnu, kode, n, cyr, cyi, nz, rl, fnul, tol, + * elim, alim) + if (nz.lt.0) go to 120 + if (zr.ge.0.0d0) return +c----------------------------------------------------------------------- +c analytic continuation to the left half plane +c----------------------------------------------------------------------- + nn = n - nz + if (nn.eq.0) return + rtol = 1.0d0/tol + ascle = d1mach(1)*rtol*1.0d+3 + do 50 i=1,nn +c str = cyr(i)*csgnr - cyi(i)*csgni +c cyi(i) = cyr(i)*csgni + cyi(i)*csgnr +c cyr(i) = str + aa = cyr(i) + bb = cyi(i) + atol = 1.0d0 + if (dmax1(dabs(aa),dabs(bb)).gt.ascle) go to 55 + aa = aa*rtol + bb = bb*rtol + atol = tol + 55 continue + str = aa*csgnr - bb*csgni + sti = aa*csgni + bb*csgnr + cyr(i) = str*atol + cyi(i) = sti*atol + csgnr = -csgnr + csgni = -csgni + 50 continue + return + 120 continue + if(nz.eq.(-2)) go to 130 + nz = 0 + ierr=2 + return + 130 continue + nz=0 + ierr=5 + return + 260 continue + nz=0 + ierr=4 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbesk(zr, zi, fnu, kode, n, cyr, cyi, nz, ierr) +c k-Bessel function,complex bessel function, +c modified bessel function of the second kind, +c bessel function of the third kind +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, cbesk computes an n member sequence of complex +c bessel functions cy(j)=k(fnu+j-1,z) for real, nonnegative +c orders fnu+j-1, j=1,...,n and complex z.ne.cmplx(0.0,0.0) +c in the cut plane -pi.lt.arg(z).le.pi. on kode=2, cbesk +c returns the scaled k functions, +c +c cy(j)=exp(z)*k(fnu+j-1,z) , j=1,...,n, +c +c which remove the exponential behavior in both the left and +c right half planes for z to infinity. +c +c input zr,zi,fnu are double precision +c zr,zi - z=cmplx(zr,zi), z.ne.cmplx(0.0d0,0.0d0), +c -pi.lt.arg(z).le.pi +c fnu - order of initial k function, fnu.ge.0.0d0 +c n - number of members of the sequence, n.ge.1 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c cy(i)=k(fnu+i-1,z), i=1,...,n +c = 2 returns +c cy(i)=k(fnu+i-1,z)*exp(z), i=1,...,n +c +c output cyr,cyi are double precision +c cyr,cyi- double precision vectors whose first n components +c contain real and imaginary parts for the sequence +c cy(i)=k(fnu+i-1,z), i=1,...,n or +c cy(i)=k(fnu+i-1,z)*exp(z), i=1,...,n +c depending on kode +c nz - number of components set to zero due to underflow. +c nz= 0 , normal return +c nz.gt.0 , first nz components of cy set to zero due +c to underflow, cy(i)=cmplx(0.0d0,0.0d0), +c i=1,...,n when x.ge.0.0. when x.lt.0.0 +c nz states only the number of underflows +c in the sequence. +c +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, fnu is +c too large or cabs(z) is too small or both +c ierr=3, cabs(z) or fnu+n-1 large - computation done +c but losses of signifcance by argument +c reduction produce less than half of machine +c accuracy +c ierr=4, cabs(z) or fnu+n-1 too large - no computa- +c tion because of complete losses of signifi- +c cance by argument reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c equations of the reference are implemented for small orders +c dnu and dnu+1.0 in the right half plane x.ge.0.0. forward +c recurrence generates higher orders. k is continued to the left +c half plane by the relation +c +c k(fnu,z*exp(mp)) = exp(-mp*fnu)*k(fnu,z)-mp*i(fnu,z) +c mp=mr*pi*i, mr=+1 or -1, re(z).gt.0, i**2=-1 +c +c where i(fnu,z) is the i bessel function. +c +c for large orders, fnu.gt.fnul, the k function is computed +c by means of its uniform asymptotic expansions. +c +c for negative orders, the formula +c +c k(-fnu,z) = k(fnu,z) +c +c can be used. +c +c cbesk assumes that a significant digit sinh(x) function is +c available. +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z or fnu+n-1 is +c large, losses of significance by argument reduction occur. +c consequently, if either one exceeds u1=sqrt(0.5/ur), then +c losses exceeding half precision are likely and an error flag +c ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c if either is larger than u2=0.5/ur, then all significance is +c lost and ierr=4. in order to use the int function, arguments +c must be further restricted not to exceed the largest machine +c integer, u3=i1mach(9). thus, the magnitude of z and fnu+n-1 is +c restricted by min(u2,u3). on 32 bit machines, u1,u2, and u3 +c are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single precision +c arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double precision +c arithmetic respectively. this makes u2 and u3 limiting in +c their respective arithmetics. this means that one can expect +c to retain, in the worst cases on 32 bit machines, no digits +c in single and only 7 digits in double precision arithmetic. +c similar considerations hold for other machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zacon,zbknu,zbunk,zuoik,zabs2,i1mach,d1mach +c +c complex cy,z + double precision aa, alim, aln, arg, az, cyi, cyr, dig, elim, fn, + * fnu, fnul, rl, r1m5, tol, ufl, zi, zr, d1mach, zabs2, bb + integer ierr, k, kode, k1, k2, mr, n, nn, nuf, nw, nz, i1mach + dimension cyr(n), cyi(n) +c + ierr = 0 + nz=0 + if (zi.eq.0.0e0 .and. zr.eq.0.0e0) ierr=1 + if (fnu.lt.0.0d0) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (n.lt.1) ierr=1 + if (ierr.ne.0) return + nn = n +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0e-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c fnul is the lower boundary of the asymptotic series for large fnu +c----------------------------------------------------------------------- + tol = dmax1(d1mach(4),1.0d-18) + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + fnul = 10.0d0 + 6.0d0*(dig-3.0d0) + rl = 1.2d0*dig + 3.0d0 +c----------------------------------------------------------------------------- +c test for proper range +c----------------------------------------------------------------------- + az = zabs2(zr,zi) + fn = fnu + dble(float(nn-1)) + aa = 0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa = dmin1(aa,bb) + if (az.gt.aa) go to 260 + if (fn.gt.aa) go to 260 + aa = dsqrt(aa) + if (az.gt.aa) ierr=3 + if (fn.gt.aa) ierr=3 +c----------------------------------------------------------------------- +c overflow test on the last member of the sequence +c----------------------------------------------------------------------- +c ufl = dexp(-elim) + ufl = d1mach(1)*1.0d+3 + if (az.lt.ufl) go to 180 + if (fnu.gt.fnul) go to 80 + if (fn.le.1.0d0) go to 60 + if (fn.gt.2.0d0) go to 50 + if (az.gt.tol) go to 60 + arg = 0.5d0*az + aln = -fn*dlog(arg) + if (aln.gt.elim) go to 180 + go to 60 + 50 continue + call zuoik(zr, zi, fnu, kode, 2, nn, cyr, cyi, nuf, tol, elim, + * alim) + if (nuf.lt.0) go to 180 + nz = nz + nuf + nn = nn - nuf +c----------------------------------------------------------------------- +c here nn=n or nn=0 since nuf=0,nn, or -1 on return from cuoik +c if nuf=nn, then cy(i)=czero for all i +c----------------------------------------------------------------------- + if (nn.eq.0) go to 100 + 60 continue + if (zr.lt.0.0d0) go to 70 +c----------------------------------------------------------------------- +c right half plane computation, real(z).ge.0. +c----------------------------------------------------------------------- + call zbknu(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) + if (nw.lt.0) go to 200 + nz=nw + return +c----------------------------------------------------------------------- +c left half plane computation +c pi/2.lt.arg(z).le.pi and -pi.lt.arg(z).lt.-pi/2. +c----------------------------------------------------------------------- + 70 continue + if (nz.ne.0) go to 180 + mr = 1 + if (zi.lt.0.0d0) mr = -1 + call zacon(zr, zi, fnu, kode, mr, nn, cyr, cyi, nw, rl, fnul, + * tol, elim, alim) + if (nw.lt.0) go to 200 + nz=nw + return +c----------------------------------------------------------------------- +c uniform asymptotic expansions for fnu.gt.fnul +c----------------------------------------------------------------------- + 80 continue + mr = 0 + if (zr.ge.0.0d0) go to 90 + mr = 1 + if (zi.lt.0.0d0) mr = -1 + 90 continue + call zbunk(zr, zi, fnu, kode, mr, nn, cyr, cyi, nw, tol, elim, + * alim) + if (nw.lt.0) go to 200 + nz = nz + nw + return + 100 continue + if (zr.lt.0.0d0) go to 180 + return + 180 continue + nz = 0 + ierr=2 + return + 200 continue + if(nw.eq.(-1)) go to 180 + nz=0 + ierr=5 + return + 260 continue + nz=0 + ierr=4 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zasyi(zr, zi, fnu, kode, n, yr, yi, nz, rl, tol, elim, + * alim) +c geuz for g77 + EXTERNAL zsqrt + EXTERNAL zexp +c Refer to zbesi,zbesk +c +c zasyi computes the i bessel function for real(z).ge.0.0 by +c means of the asymptotic expansion for large cabs(z) in the +c region cabs(z).gt.max(rl,fnu*fnu/2). nz=0 is a normal return. +c nz.lt.0 indicates an overflow on kode=1. +c +c***routines called d1mach,zabs2,zdiv,zexp,zmlt,zsqrt +c +c complex ak1,ck,cone,cs1,cs2,cz,czero,dk,ez,p1,rz,s2,y,z + double precision aa, aez, ak, ak1i, ak1r, alim, arg, arm, atol, + * az, bb, bk, cki, ckr, conei, coner, cs1i, cs1r, cs2i, cs2r, czi, + * czr, dfnu, dki, dkr, dnu2, elim, ezi, ezr, fdn, fnu, pi, p1i, + * p1r, raz, rl, rtpi, rtr1, rzi, rzr, s, sgn, sqk, sti, str, s2i, + * s2r, tol, tzi, tzr, yi, yr, zeroi, zeror, zi, zr, d1mach, zabs2 + integer i, ib, il, inu, j, jl, k, kode, koded, m, n, nn, nz + dimension yr(n), yi(n) + data pi, rtpi /3.14159265358979324d0 , 0.159154943091895336d0 / + data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / +c + nz = 0 + az = zabs2(zr,zi) + arm = 1.0d+3*d1mach(1) + rtr1 = dsqrt(arm) + il = min0(2,n) + dfnu = fnu + dble(float(n-il)) +c----------------------------------------------------------------------- +c overflow test +c----------------------------------------------------------------------- + raz = 1.0d0/az + str = zr*raz + sti = -zi*raz + ak1r = rtpi*str*raz + ak1i = rtpi*sti*raz + call zsqrt(ak1r, ak1i, ak1r, ak1i) + czr = zr + czi = zi + if (kode.ne.2) go to 10 + czr = zeror + czi = zi + 10 continue + if (dabs(czr).gt.elim) go to 100 + dnu2 = dfnu + dfnu + koded = 1 + if ((dabs(czr).gt.alim) .and. (n.gt.2)) go to 20 + koded = 0 + call zexp(czr, czi, str, sti) + call zmlt(ak1r, ak1i, str, sti, ak1r, ak1i) + 20 continue + fdn = 0.0d0 + if (dnu2.gt.rtr1) fdn = dnu2*dnu2 + ezr = zr*8.0d0 + ezi = zi*8.0d0 +c----------------------------------------------------------------------- +c when z is imaginary, the error test must be made relative to the +c first reciprocal power since this is the leading term of the +c expansion for the imaginary part. +c----------------------------------------------------------------------- + aez = 8.0d0*az + s = tol/aez + jl = int(sngl(rl+rl)) + 2 + p1r = zeror + p1i = zeroi + if (zi.eq.0.0d0) go to 30 +c----------------------------------------------------------------------- +c calculate exp(pi*(0.5+fnu+n-il)*i) to minimize losses of +c significance when fnu or n is large +c----------------------------------------------------------------------- + inu = int(sngl(fnu)) + arg = (fnu-dble(float(inu)))*pi + inu = inu + n - il + ak = -dsin(arg) + bk = dcos(arg) + if (zi.lt.0.0d0) bk = -bk + p1r = ak + p1i = bk + if (mod(inu,2).eq.0) go to 30 + p1r = -p1r + p1i = -p1i + 30 continue + do 70 k=1,il + sqk = fdn - 1.0d0 + atol = s*dabs(sqk) + sgn = 1.0d0 + cs1r = coner + cs1i = conei + cs2r = coner + cs2i = conei + ckr = coner + cki = conei + ak = 0.0d0 + aa = 1.0d0 + bb = aez + dkr = ezr + dki = ezi + do 40 j=1,jl + call zdiv(ckr, cki, dkr, dki, str, sti) + ckr = str*sqk + cki = sti*sqk + cs2r = cs2r + ckr + cs2i = cs2i + cki + sgn = -sgn + cs1r = cs1r + ckr*sgn + cs1i = cs1i + cki*sgn + dkr = dkr + ezr + dki = dki + ezi + aa = aa*dabs(sqk)/bb + bb = bb + aez + ak = ak + 8.0d0 + sqk = sqk - ak + if (aa.le.atol) go to 50 + 40 continue + go to 110 + 50 continue + s2r = cs1r + s2i = cs1i + if (zr+zr.ge.elim) go to 60 + tzr = zr + zr + tzi = zi + zi + call zexp(-tzr, -tzi, str, sti) + call zmlt(str, sti, p1r, p1i, str, sti) + call zmlt(str, sti, cs2r, cs2i, str, sti) + s2r = s2r + str + s2i = s2i + sti + 60 continue + fdn = fdn + 8.0d0*dfnu + 4.0d0 + p1r = -p1r + p1i = -p1i + m = n - il + k + yr(m) = s2r*ak1r - s2i*ak1i + yi(m) = s2r*ak1i + s2i*ak1r + 70 continue + if (n.le.2) return + nn = n + k = nn - 2 + ak = dble(float(k)) + str = zr*raz + sti = -zi*raz + rzr = (str+str)*raz + rzi = (sti+sti)*raz + ib = 3 + do 80 i=ib,nn + yr(k) = (ak+fnu)*(rzr*yr(k+1)-rzi*yi(k+1)) + yr(k+2) + yi(k) = (ak+fnu)*(rzr*yi(k+1)+rzi*yr(k+1)) + yi(k+2) + ak = ak - 1.0d0 + k = k - 1 + 80 continue + if (koded.eq.0) return + call zexp(czr, czi, ckr, cki) + do 90 i=1,nn + str = yr(i)*ckr - yi(i)*cki + yi(i) = yr(i)*cki + yi(i)*ckr + yr(i) = str + 90 continue + return + 100 continue + nz = -1 + return + 110 continue + nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbinu(zr, zi, fnu, kode, n, cyr, cyi, nz, rl, fnul, + * tol, elim, alim) +c***refer to zbesh,zbesi,zbesj,zbesk,zairy,zbiry +c +c zbinu computes the i function in the right half z plane +c +c***routines called zabs2,zasyi,zbuni,zmlri,zseri,zuoik,zwrsk +c + double precision alim, az, cwi, cwr, cyi, cyr, dfnu, elim, fnu, + * fnul, rl, tol, zeroi, zeror, zi, zr, zabs2 + integer i, inw, kode, n, nlast, nn, nui, nw, nz + dimension cyr(n), cyi(n), cwr(2), cwi(2) + data zeror,zeroi / 0.0d0, 0.0d0 / +c + nz = 0 + az = zabs2(zr,zi) + nn = n + dfnu = fnu + dble(float(n-1)) + if (az.le.2.0d0) go to 10 + if (az*az*0.25d0.gt.dfnu+1.0d0) go to 20 + 10 continue +c----------------------------------------------------------------------- +c power series +c----------------------------------------------------------------------- + call zseri(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol, elim, alim) + inw = iabs(nw) + nz = nz + inw + nn = nn - inw + if (nn.eq.0) return + if (nw.ge.0) go to 120 + dfnu = fnu + dble(float(nn-1)) + 20 continue + if (az.lt.rl) go to 40 + if (dfnu.le.1.0d0) go to 30 + if (az+az.lt.dfnu*dfnu) go to 50 +c----------------------------------------------------------------------- +c asymptotic expansion for large z +c----------------------------------------------------------------------- + 30 continue + call zasyi(zr, zi, fnu, kode, nn, cyr, cyi, nw, rl, tol, elim, + * alim) + if (nw.lt.0) go to 130 + go to 120 + 40 continue + if (dfnu.le.1.0d0) go to 70 + 50 continue +c----------------------------------------------------------------------- +c overflow and underflow test on i sequence for miller algorithm +c----------------------------------------------------------------------- + call zuoik(zr, zi, fnu, kode, 1, nn, cyr, cyi, nw, tol, elim, + * alim) + if (nw.lt.0) go to 130 + nz = nz + nw + nn = nn - nw + if (nn.eq.0) return + dfnu = fnu+dble(float(nn-1)) + if (dfnu.gt.fnul) go to 110 + if (az.gt.fnul) go to 110 + 60 continue + if (az.gt.rl) go to 80 + 70 continue +c----------------------------------------------------------------------- +c miller algorithm normalized by the series +c----------------------------------------------------------------------- + call zmlri(zr, zi, fnu, kode, nn, cyr, cyi, nw, tol) + if(nw.lt.0) go to 130 + go to 120 + 80 continue +c----------------------------------------------------------------------- +c miller algorithm normalized by the wronskian +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c overflow test on k functions used in wronskian +c----------------------------------------------------------------------- + call zuoik(zr, zi, fnu, kode, 2, 2, cwr, cwi, nw, tol, elim, + * alim) + if (nw.ge.0) go to 100 + nz = nn + do 90 i=1,nn + cyr(i) = zeror + cyi(i) = zeroi + 90 continue + return + 100 continue + if (nw.gt.0) go to 130 + call zwrsk(zr, zi, fnu, kode, nn, cyr, cyi, nw, cwr, cwi, tol, + * elim, alim) + if (nw.lt.0) go to 130 + go to 120 + 110 continue +c----------------------------------------------------------------------- +c increment fnu+nn-1 up to fnul, compute and recur backward +c----------------------------------------------------------------------- + nui = int(sngl(fnul-dfnu)) + 1 + nui = max0(nui,0) + call zbuni(zr, zi, fnu, kode, nn, cyr, cyi, nw, nui, nlast, fnul, + * tol, elim, alim) + if (nw.lt.0) go to 130 + nz = nz + nw + if (nlast.eq.0) go to 120 + nn = nlast + go to 60 + 120 continue + return + 130 continue + nz = -1 + if(nw.eq.(-2)) nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbknu(zr, zi, fnu, kode, n, yr, yi, nz, tol, elim, + * alim) +c geuz for g77 + EXTERNAL zsqrt + EXTERNAL zexp + EXTERNAL zlog +c Refer to zbesi,zbesk,zairy,zbesh +c +c zbknu computes the k bessel function in the right half z plane. +c +c***routines called dgamln,i1mach,d1mach,zkscl,zshch,zuchk,zabs2,zdiv, +c zexp,zlog,zmlt,zsqrt +c + double precision aa, ak, alim, ascle, a1, a2, bb, bk, bry, caz, + * cbi, cbr, cc, cchi, cchr, cki, ckr, coefi, coefr, conei, coner, + * crscr, csclr, cshi, cshr, csi, csr, csrr, cssr, ctwor, + * czeroi, czeror, czi, czr, dnu, dnu2, dpi, elim, etest, fc, fhs, + * fi, fk, fks, fmui, fmur, fnu, fpi, fr, g1, g2, hpi, pi, pr, pti, + * ptr, p1i, p1r, p2i, p2m, p2r, qi, qr, rak, rcaz, rthpi, rzi, + * rzr, r1, s, smui, smur, spi, sti, str, s1i, s1r, s2i, s2r, tm, + * tol, tth, t1, t2, yi, yr, zi, zr, dgamln, d1mach, zabs2, elm, + * celmr, zdr, zdi, as, alas, helim, cyr, cyi + integer i, iflag, inu, k, kflag, kk, kmax, kode, koded, n, nz, + * idum, i1mach, j, ic, inub, nw + dimension yr(n), yi(n), cc(8), cssr(3), csrr(3), bry(3), cyr(2), + * cyi(2) +c complex z,y,a,b,rz,smu,fu,fmu,f,flrz,cz,s1,s2,csh,cch +c complex ck,p,q,coef,p1,p2,cbk,pt,czero,cone,ctwo,st,ez,cs,dk +c + data kmax / 30 / + data czeror,czeroi,coner,conei,ctwor,r1/ + 1 0.0d0 , 0.0d0 , 1.0d0 , 0.0d0 , 2.0d0 , 2.0d0 / + data dpi, rthpi, spi ,hpi, fpi, tth / + 1 3.14159265358979324d0, 1.25331413731550025d0, + 2 1.90985931710274403d0, 1.57079632679489662d0, + 3 1.89769999331517738d0, 6.66666666666666666d-01/ + data cc(1), cc(2), cc(3), cc(4), cc(5), cc(6), cc(7), cc(8)/ + 1 5.77215664901532861d-01, -4.20026350340952355d-02, + 2 -4.21977345555443367d-02, 7.21894324666309954d-03, + 3 -2.15241674114950973d-04, -2.01348547807882387d-05, + 4 1.13302723198169588d-06, 6.11609510448141582d-09/ +c + caz = zabs2(zr,zi) + csclr = 1.0d0/tol + crscr = tol + cssr(1) = csclr + cssr(2) = 1.0d0 + cssr(3) = crscr + csrr(1) = crscr + csrr(2) = 1.0d0 + csrr(3) = csclr + bry(1) = 1.0d+3*d1mach(1)/tol + bry(2) = 1.0d0/bry(1) + bry(3) = d1mach(2) + nz = 0 + iflag = 0 + koded = kode + rcaz = 1.0d0/caz + str = zr*rcaz + sti = -zi*rcaz + rzr = (str+str)*rcaz + rzi = (sti+sti)*rcaz + inu = int(sngl(fnu+0.5d0)) + dnu = fnu - dble(float(inu)) + if (dabs(dnu).eq.0.5d0) go to 110 + dnu2 = 0.0d0 + if (dabs(dnu).gt.tol) dnu2 = dnu*dnu + if (caz.gt.r1) go to 110 +c----------------------------------------------------------------------- +c series for cabs(z).le.r1 +c----------------------------------------------------------------------- + fc = 1.0d0 + call zlog(rzr, rzi, smur, smui, idum) + fmur = smur*dnu + fmui = smui*dnu + call zshch(fmur, fmui, cshr, cshi, cchr, cchi) + if (dnu.eq.0.0d0) go to 10 + fc = dnu*dpi + fc = fc/dsin(fc) + smur = cshr/dnu + smui = cshi/dnu + 10 continue + a2 = 1.0d0 + dnu +c----------------------------------------------------------------------- +c gam(1-z)*gam(1+z)=pi*z/sin(pi*z), t1=1/gam(1-dnu), t2=1/gam(1+dnu) +c----------------------------------------------------------------------- + t2 = dexp(-dgamln(a2,idum)) + t1 = 1.0d0/(t2*fc) + if (dabs(dnu).gt.0.1d0) go to 40 +c----------------------------------------------------------------------- +c series for f0 to resolve indeterminacy for small abs(dnu) +c----------------------------------------------------------------------- + ak = 1.0d0 + s = cc(1) + do 20 k=2,8 + ak = ak*dnu2 + tm = cc(k)*ak + s = s + tm + if (dabs(tm).lt.tol) go to 30 + 20 continue + 30 g1 = -s + go to 50 + 40 continue + g1 = (t1-t2)/(dnu+dnu) + 50 continue + g2 = (t1+t2)*0.5d0 + fr = fc*(cchr*g1+smur*g2) + fi = fc*(cchi*g1+smui*g2) + call zexp(fmur, fmui, str, sti) + pr = 0.5d0*str/t2 + pi = 0.5d0*sti/t2 + call zdiv(0.5d0, 0.0d0, str, sti, ptr, pti) + qr = ptr/t1 + qi = pti/t1 + s1r = fr + s1i = fi + s2r = pr + s2i = pi + ak = 1.0d0 + a1 = 1.0d0 + ckr = coner + cki = conei + bk = 1.0d0 - dnu2 + if (inu.gt.0 .or. n.gt.1) go to 80 +c----------------------------------------------------------------------- +c generate k(fnu,z), 0.0d0 .le. fnu .lt. 0.5d0 and n=1 +c----------------------------------------------------------------------- + if (caz.lt.tol) go to 70 + call zmlt(zr, zi, zr, zi, czr, czi) + czr = 0.25d0*czr + czi = 0.25d0*czi + t1 = 0.25d0*caz*caz + 60 continue + fr = (fr*ak+pr+qr)/bk + fi = (fi*ak+pi+qi)/bk + str = 1.0d0/(ak-dnu) + pr = pr*str + pi = pi*str + str = 1.0d0/(ak+dnu) + qr = qr*str + qi = qi*str + str = ckr*czr - cki*czi + rak = 1.0d0/ak + cki = (ckr*czi+cki*czr)*rak + ckr = str*rak + s1r = ckr*fr - cki*fi + s1r + s1i = ckr*fi + cki*fr + s1i + a1 = a1*t1*rak + bk = bk + ak + ak + 1.0d0 + ak = ak + 1.0d0 + if (a1.gt.tol) go to 60 + 70 continue + yr(1) = s1r + yi(1) = s1i + if (koded.eq.1) return + call zexp(zr, zi, str, sti) + call zmlt(s1r, s1i, str, sti, yr(1), yi(1)) + return +c----------------------------------------------------------------------- +c generate k(dnu,z) and k(dnu+1,z) for forward recurrence +c----------------------------------------------------------------------- + 80 continue + if (caz.lt.tol) go to 100 + call zmlt(zr, zi, zr, zi, czr, czi) + czr = 0.25d0*czr + czi = 0.25d0*czi + t1 = 0.25d0*caz*caz + 90 continue + fr = (fr*ak+pr+qr)/bk + fi = (fi*ak+pi+qi)/bk + str = 1.0d0/(ak-dnu) + pr = pr*str + pi = pi*str + str = 1.0d0/(ak+dnu) + qr = qr*str + qi = qi*str + str = ckr*czr - cki*czi + rak = 1.0d0/ak + cki = (ckr*czi+cki*czr)*rak + ckr = str*rak + s1r = ckr*fr - cki*fi + s1r + s1i = ckr*fi + cki*fr + s1i + str = pr - fr*ak + sti = pi - fi*ak + s2r = ckr*str - cki*sti + s2r + s2i = ckr*sti + cki*str + s2i + a1 = a1*t1*rak + bk = bk + ak + ak + 1.0d0 + ak = ak + 1.0d0 + if (a1.gt.tol) go to 90 + 100 continue + kflag = 2 + a1 = fnu + 1.0d0 + ak = a1*dabs(smur) + if (ak.gt.alim) kflag = 3 + str = cssr(kflag) + p2r = s2r*str + p2i = s2i*str + call zmlt(p2r, p2i, rzr, rzi, s2r, s2i) + s1r = s1r*str + s1i = s1i*str + if (koded.eq.1) go to 210 + call zexp(zr, zi, fr, fi) + call zmlt(s1r, s1i, fr, fi, s1r, s1i) + call zmlt(s2r, s2i, fr, fi, s2r, s2i) + go to 210 +c----------------------------------------------------------------------- +c iflag=0 means no underflow occurred +c iflag=1 means an underflow occurred- computation proceeds with +c koded=2 and a test for on scale values is made during forward +c recursion +c----------------------------------------------------------------------- + 110 continue + call zsqrt(zr, zi, str, sti) + call zdiv(rthpi, czeroi, str, sti, coefr, coefi) + kflag = 2 + if (koded.eq.2) go to 120 + if (zr.gt.alim) go to 290 +c blank line + str = dexp(-zr)*cssr(kflag) + sti = -str*dsin(zi) + str = str*dcos(zi) + call zmlt(coefr, coefi, str, sti, coefr, coefi) + 120 continue + if (dabs(dnu).eq.0.5d0) go to 300 +c----------------------------------------------------------------------- +c miller algorithm for cabs(z).gt.r1 +c----------------------------------------------------------------------- + ak = dcos(dpi*dnu) + ak = dabs(ak) + if (ak.eq.czeror) go to 300 + fhs = dabs(0.25d0-dnu2) + if (fhs.eq.czeror) go to 300 +c----------------------------------------------------------------------- +c compute r2=f(e). if cabs(z).ge.r2, use forward recurrence to +c determine the backward index k. r2=f(e) is a straight line on +c 12.le.e.le.60. e is computed from 2**(-e)=b**(1-i1mach(14))= +c tol where b is the base of the arithmetic. +c----------------------------------------------------------------------- + t1 = dble(float(i1mach(14)-1)) + t1 = t1*d1mach(5)*3.321928094d0 + t1 = dmax1(t1,12.0d0) + t1 = dmin1(t1,60.0d0) + t2 = tth*t1 - 6.0d0 + if (zr.ne.0.0d0) go to 130 + t1 = hpi + go to 140 + 130 continue + t1 = datan(zi/zr) + t1 = dabs(t1) + 140 continue + if (t2.gt.caz) go to 170 +c----------------------------------------------------------------------- +c forward recurrence loop when cabs(z).ge.r2 +c----------------------------------------------------------------------- + etest = ak/(dpi*caz*tol) + fk = coner + if (etest.lt.coner) go to 180 + fks = ctwor + ckr = caz + caz + ctwor + p1r = czeror + p2r = coner + do 150 i=1,kmax + ak = fhs/fks + cbr = ckr/(fk+coner) + ptr = p2r + p2r = cbr*p2r - p1r*ak + p1r = ptr + ckr = ckr + ctwor + fks = fks + fk + fk + ctwor + fhs = fhs + fk + fk + fk = fk + coner + str = dabs(p2r)*fk + if (etest.lt.str) go to 160 + 150 continue + go to 310 + 160 continue + fk = fk + spi*t1*dsqrt(t2/caz) + fhs = dabs(0.25d0-dnu2) + go to 180 + 170 continue +c----------------------------------------------------------------------- +c compute backward index k for cabs(z).lt.r2 +c----------------------------------------------------------------------- + a2 = dsqrt(caz) + ak = fpi*ak/(tol*dsqrt(a2)) + aa = 3.0d0*t1/(1.0d0+caz) + bb = 14.7d0*t1/(28.0d0+caz) + ak = (dlog(ak)+caz*dcos(aa)/(1.0d0+0.008d0*caz))/dcos(bb) + fk = 0.12125d0*ak*ak/caz + 1.5d0 + 180 continue +c----------------------------------------------------------------------- +c backward recurrence loop for miller algorithm +c----------------------------------------------------------------------- + k = int(sngl(fk)) + fk = dble(float(k)) + fks = fk*fk + p1r = czeror + p1i = czeroi + p2r = tol + p2i = czeroi + csr = p2r + csi = p2i + do 190 i=1,k + a1 = fks - fk + ak = (fks+fk)/(a1+fhs) + rak = 2.0d0/(fk+coner) + cbr = (fk+zr)*rak + cbi = zi*rak + ptr = p2r + pti = p2i + p2r = (ptr*cbr-pti*cbi-p1r)*ak + p2i = (pti*cbr+ptr*cbi-p1i)*ak + p1r = ptr + p1i = pti + csr = csr + p2r + csi = csi + p2i + fks = a1 - fk + coner + fk = fk - coner + 190 continue +c----------------------------------------------------------------------- +c compute (p2/cs)=(p2/cabs(cs))*(conjg(cs)/cabs(cs)) for better +c scaling +c----------------------------------------------------------------------- + tm = zabs2(csr,csi) + ptr = 1.0d0/tm + s1r = p2r*ptr + s1i = p2i*ptr + csr = csr*ptr + csi = -csi*ptr + call zmlt(coefr, coefi, s1r, s1i, str, sti) + call zmlt(str, sti, csr, csi, s1r, s1i) + if (inu.gt.0 .or. n.gt.1) go to 200 + zdr = zr + zdi = zi + if(iflag.eq.1) go to 270 + go to 240 + 200 continue +c----------------------------------------------------------------------- +c compute p1/p2=(p1/cabs(p2)*conjg(p2)/cabs(p2) for scaling +c----------------------------------------------------------------------- + tm = zabs2(p2r,p2i) + ptr = 1.0d0/tm + p1r = p1r*ptr + p1i = p1i*ptr + p2r = p2r*ptr + p2i = -p2i*ptr + call zmlt(p1r, p1i, p2r, p2i, ptr, pti) + str = dnu + 0.5d0 - ptr + sti = -pti + call zdiv(str, sti, zr, zi, str, sti) + str = str + 1.0d0 + call zmlt(str, sti, s1r, s1i, s2r, s2i) +c----------------------------------------------------------------------- +c forward recursion on the three term recursion with relation with +c scaling near exponent extremes on kflag=1 or kflag=3 +c----------------------------------------------------------------------- + 210 continue + str = dnu + 1.0d0 + ckr = str*rzr + cki = str*rzi + if (n.eq.1) inu = inu - 1 + if (inu.gt.0) go to 220 + if (n.gt.1) go to 215 + s1r = s2r + s1i = s2i + 215 continue + zdr = zr + zdi = zi + if(iflag.eq.1) go to 270 + go to 240 + 220 continue + inub = 1 + if(iflag.eq.1) go to 261 + 225 continue + p1r = csrr(kflag) + ascle = bry(kflag) + do 230 i=inub,inu + str = s2r + sti = s2i + s2r = ckr*str - cki*sti + s1r + s2i = ckr*sti + cki*str + s1i + s1r = str + s1i = sti + ckr = ckr + rzr + cki = cki + rzi + if (kflag.ge.3) go to 230 + p2r = s2r*p1r + p2i = s2i*p1r + str = dabs(p2r) + sti = dabs(p2i) + p2m = dmax1(str,sti) + if (p2m.le.ascle) go to 230 + kflag = kflag + 1 + ascle = bry(kflag) + s1r = s1r*p1r + s1i = s1i*p1r + s2r = p2r + s2i = p2i + str = cssr(kflag) + s1r = s1r*str + s1i = s1i*str + s2r = s2r*str + s2i = s2i*str + p1r = csrr(kflag) + 230 continue + if (n.ne.1) go to 240 + s1r = s2r + s1i = s2i + 240 continue + str = csrr(kflag) + yr(1) = s1r*str + yi(1) = s1i*str + if (n.eq.1) return + yr(2) = s2r*str + yi(2) = s2i*str + if (n.eq.2) return + kk = 2 + 250 continue + kk = kk + 1 + if (kk.gt.n) return + p1r = csrr(kflag) + ascle = bry(kflag) + do 260 i=kk,n + p2r = s2r + p2i = s2i + s2r = ckr*p2r - cki*p2i + s1r + s2i = cki*p2r + ckr*p2i + s1i + s1r = p2r + s1i = p2i + ckr = ckr + rzr + cki = cki + rzi + p2r = s2r*p1r + p2i = s2i*p1r + yr(i) = p2r + yi(i) = p2i + if (kflag.ge.3) go to 260 + str = dabs(p2r) + sti = dabs(p2i) + p2m = dmax1(str,sti) + if (p2m.le.ascle) go to 260 + kflag = kflag + 1 + ascle = bry(kflag) + s1r = s1r*p1r + s1i = s1i*p1r + s2r = p2r + s2i = p2i + str = cssr(kflag) + s1r = s1r*str + s1i = s1i*str + s2r = s2r*str + s2i = s2i*str + p1r = csrr(kflag) + 260 continue + return +c----------------------------------------------------------------------- +c iflag=1 cases, forward recurrence on scaled values on underflow +c----------------------------------------------------------------------- + 261 continue + helim = 0.5d0*elim + elm = dexp(-elim) + celmr = elm + ascle = bry(1) + zdr = zr + zdi = zi + ic = -1 + j = 2 + do 262 i=1,inu + str = s2r + sti = s2i + s2r = str*ckr-sti*cki+s1r + s2i = sti*ckr+str*cki+s1i + s1r = str + s1i = sti + ckr = ckr+rzr + cki = cki+rzi + as = zabs2(s2r,s2i) + alas = dlog(as) + p2r = -zdr+alas + if(p2r.lt.(-elim)) go to 263 + call zlog(s2r,s2i,str,sti,idum) + p2r = -zdr+str + p2i = -zdi+sti + p2m = dexp(p2r)/tol + p1r = p2m*dcos(p2i) + p1i = p2m*dsin(p2i) + call zuchk(p1r,p1i,nw,ascle,tol) + if(nw.ne.0) go to 263 + j = 3 - j + cyr(j) = p1r + cyi(j) = p1i + if(ic.eq.(i-1)) go to 264 + ic = i + go to 262 + 263 continue + if(alas.lt.helim) go to 262 + zdr = zdr-elim + s1r = s1r*celmr + s1i = s1i*celmr + s2r = s2r*celmr + s2i = s2i*celmr + 262 continue + if(n.ne.1) go to 270 + s1r = s2r + s1i = s2i + go to 270 + 264 continue + kflag = 1 + inub = i+1 + s2r = cyr(j) + s2i = cyi(j) + j = 3 - j + s1r = cyr(j) + s1i = cyi(j) + if(inub.le.inu) go to 225 + if(n.ne.1) go to 240 + s1r = s2r + s1i = s2i + go to 240 + 270 continue + yr(1) = s1r + yi(1) = s1i + if(n.eq.1) go to 280 + yr(2) = s2r + yi(2) = s2i + 280 continue + ascle = bry(1) + call zkscl(zdr,zdi,fnu,n,yr,yi,nz,rzr,rzi,ascle,tol,elim) + inu = n - nz + if (inu.le.0) return + kk = nz + 1 + s1r = yr(kk) + s1i = yi(kk) + yr(kk) = s1r*csrr(1) + yi(kk) = s1i*csrr(1) + if (inu.eq.1) return + kk = nz + 2 + s2r = yr(kk) + s2i = yi(kk) + yr(kk) = s2r*csrr(1) + yi(kk) = s2i*csrr(1) + if (inu.eq.2) return + t2 = fnu + dble(float(kk-1)) + ckr = t2*rzr + cki = t2*rzi + kflag = 1 + go to 250 + 290 continue +c----------------------------------------------------------------------- +c scale by dexp(z), iflag = 1 cases +c----------------------------------------------------------------------- + koded = 2 + iflag = 1 + kflag = 2 + go to 120 +c----------------------------------------------------------------------- +c fnu=half odd integer case, dnu=-0.5 +c----------------------------------------------------------------------- + 300 continue + s1r = coefr + s1i = coefi + s2r = coefr + s2i = coefi + go to 210 +c +c + 310 continue + nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbuni(zr, zi, fnu, kode, n, yr, yi, nz, nui, nlast, + * fnul, tol, elim, alim) +c Refer to zbesi,zbesk +c +c zbuni computes the i bessel function for large cabs(z).gt. +c fnul and fnu+n-1.lt.fnul. the order is increased from +c fnu+n-1 greater than fnul by adding nui and computing +c according to the uniform asymptotic expansion for i(fnu,z) +c on iform=1 and the expansion for j(fnu,z) on iform=2 +c +c***routines called zuni1,zuni2,zabs2,d1mach +c +c complex cscl,cscr,cy,rz,st,s1,s2,y,z + double precision alim, ax, ay, csclr, cscrr, cyi, cyr, dfnu, + * elim, fnu, fnui, fnul, gnu, raz, rzi, rzr, sti, str, s1i, s1r, + * s2i, s2r, tol, yi, yr, zi, zr, zabs2, ascle, bry, c1r, c1i, c1m, + * d1mach + integer i, iflag, iform, k, kode, n, nl, nlast, nui, nw, nz + dimension yr(n), yi(n), cyr(2), cyi(2), bry(3) + nz = 0 + ax = dabs(zr)*1.7321d0 + ay = dabs(zi) + iform = 1 + if (ay.gt.ax) iform = 2 + if (nui.eq.0) go to 60 + fnui = dble(float(nui)) + dfnu = fnu + dble(float(n-1)) + gnu = dfnu + fnui + if (iform.eq.2) go to 10 +c----------------------------------------------------------------------- +c asymptotic expansion for i(fnu,z) for large fnu applied in +c -pi/3.le.arg(z).le.pi/3 +c----------------------------------------------------------------------- + call zuni1(zr, zi, gnu, kode, 2, cyr, cyi, nw, nlast, fnul, tol, + * elim, alim) + go to 20 + 10 continue +c----------------------------------------------------------------------- +c asymptotic expansion for j(fnu,z*exp(m*hpi)) for large fnu +c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i +c and hpi=pi/2 +c----------------------------------------------------------------------- + call zuni2(zr, zi, gnu, kode, 2, cyr, cyi, nw, nlast, fnul, tol, + * elim, alim) + 20 continue + if (nw.lt.0) go to 50 + if (nw.ne.0) go to 90 + str = zabs2(cyr(1),cyi(1)) +c---------------------------------------------------------------------- +c scale backward recurrence, bry(3) is defined but never used +c---------------------------------------------------------------------- + bry(1)=1.0d+3*d1mach(1)/tol + bry(2) = 1.0d0/bry(1) + bry(3) = bry(2) + iflag = 2 + ascle = bry(2) + csclr = 1.0d0 + if (str.gt.bry(1)) go to 21 + iflag = 1 + ascle = bry(1) + csclr = 1.0d0/tol + go to 25 + 21 continue + if (str.lt.bry(2)) go to 25 + iflag = 3 + ascle=bry(3) + csclr = tol + 25 continue + cscrr = 1.0d0/csclr + s1r = cyr(2)*csclr + s1i = cyi(2)*csclr + s2r = cyr(1)*csclr + s2i = cyi(1)*csclr + raz = 1.0d0/zabs2(zr,zi) + str = zr*raz + sti = -zi*raz + rzr = (str+str)*raz + rzi = (sti+sti)*raz + do 30 i=1,nui + str = s2r + sti = s2i + s2r = (dfnu+fnui)*(rzr*str-rzi*sti) + s1r + s2i = (dfnu+fnui)*(rzr*sti+rzi*str) + s1i + s1r = str + s1i = sti + fnui = fnui - 1.0d0 + if (iflag.ge.3) go to 30 + str = s2r*cscrr + sti = s2i*cscrr + c1r = dabs(str) + c1i = dabs(sti) + c1m = dmax1(c1r,c1i) + if (c1m.le.ascle) go to 30 + iflag = iflag+1 + ascle = bry(iflag) + s1r = s1r*cscrr + s1i = s1i*cscrr + s2r = str + s2i = sti + csclr = csclr*tol + cscrr = 1.0d0/csclr + s1r = s1r*csclr + s1i = s1i*csclr + s2r = s2r*csclr + s2i = s2i*csclr + 30 continue + yr(n) = s2r*cscrr + yi(n) = s2i*cscrr + if (n.eq.1) return + nl = n - 1 + fnui = dble(float(nl)) + k = nl + do 40 i=1,nl + str = s2r + sti = s2i + s2r = (fnu+fnui)*(rzr*str-rzi*sti) + s1r + s2i = (fnu+fnui)*(rzr*sti+rzi*str) + s1i + s1r = str + s1i = sti + str = s2r*cscrr + sti = s2i*cscrr + yr(k) = str + yi(k) = sti + fnui = fnui - 1.0d0 + k = k - 1 + if (iflag.ge.3) go to 40 + c1r = dabs(str) + c1i = dabs(sti) + c1m = dmax1(c1r,c1i) + if (c1m.le.ascle) go to 40 + iflag = iflag+1 + ascle = bry(iflag) + s1r = s1r*cscrr + s1i = s1i*cscrr + s2r = str + s2i = sti + csclr = csclr*tol + cscrr = 1.0d0/csclr + s1r = s1r*csclr + s1i = s1i*csclr + s2r = s2r*csclr + s2i = s2i*csclr + 40 continue + return + 50 continue + nz = -1 + if(nw.eq.(-2)) nz=-2 + return + 60 continue + if (iform.eq.2) go to 70 +c----------------------------------------------------------------------- +c asymptotic expansion for i(fnu,z) for large fnu applied in +c -pi/3.le.arg(z).le.pi/3 +c----------------------------------------------------------------------- + call zuni1(zr, zi, fnu, kode, n, yr, yi, nw, nlast, fnul, tol, + * elim, alim) + go to 80 + 70 continue +c----------------------------------------------------------------------- +c asymptotic expansion for j(fnu,z*exp(m*hpi)) for large fnu +c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i +c and hpi=pi/2 +c----------------------------------------------------------------------- + call zuni2(zr, zi, fnu, kode, n, yr, yi, nw, nlast, fnul, tol, + * elim, alim) + 80 continue + if (nw.lt.0) go to 50 + nz = nw + return + 90 continue + nlast = n + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbunk(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, + * alim) +c Refer to zbesk,zbesh +c +c zbunk computes the k bessel function for fnu.gt.fnul. +c according to the uniform asymptotic expansion for k(fnu,z) +c in zunk1 and the expansion for h(2,fnu,z) in zunk2 +c +c***routines called zunk1,zunk2 +c +c complex y,z + double precision alim, ax, ay, elim, fnu, tol, yi, yr, zi, zr + integer kode, mr, n, nz + dimension yr(n), yi(n) + nz = 0 + ax = dabs(zr)*1.7321d0 + ay = dabs(zi) + if (ay.gt.ax) go to 10 +c----------------------------------------------------------------------- +c asymptotic expansion for k(fnu,z) for large fnu applied in +c -pi/3.le.arg(z).le.pi/3 +c----------------------------------------------------------------------- + call zunk1(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, alim) + go to 20 + 10 continue +c----------------------------------------------------------------------- +c asymptotic expansion for h(2,fnu,z*exp(m*hpi)) for large fnu +c applied in pi/3.lt.abs(arg(z)).le.pi/2 where m=+i or -i +c and hpi=pi/2 +c----------------------------------------------------------------------- + call zunk2(zr, zi, fnu, kode, mr, n, yr, yi, nz, tol, elim, alim) + 20 continue + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zmlri(zr, zi, fnu, kode, n, yr, yi, nz, tol) +c geuz for g77 + EXTERNAL zexp + EXTERNAL zlog +c Refer to zbesi,zbesk +c +c zmlri computes the i bessel function for re(z).ge.0.0 by the +c miller algorithm normalized by a neumann series. +c +c***routines called dgamln,d1mach,zabs2,zexp,zlog,zmlt +c +c complex ck,cnorm,cone,ctwo,czero,pt,p1,p2,rz,sum,y,z + double precision ack, ak, ap, at, az, bk, cki, ckr, cnormi, + * cnormr, conei, coner, fkap, fkk, flam, fnf, fnu, pti, ptr, p1i, + * p1r, p2i, p2r, raz, rho, rho2, rzi, rzr, scle, sti, str, sumi, + * sumr, tfnf, tol, tst, yi, yr, zeroi, zeror, zi, zr, dgamln, + * d1mach, zabs2 + integer i, iaz, idum, ifnu, inu, itime, k, kk, km, kode, m, n, nz + dimension yr(n), yi(n) + data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / + scle = d1mach(1)/tol + nz=0 + az = zabs2(zr,zi) + iaz = int(sngl(az)) + ifnu = int(sngl(fnu)) + inu = ifnu + n - 1 + at = dble(float(iaz)) + 1.0d0 + raz = 1.0d0/az + str = zr*raz + sti = -zi*raz + ckr = str*at*raz + cki = sti*at*raz + rzr = (str+str)*raz + rzi = (sti+sti)*raz + p1r = zeror + p1i = zeroi + p2r = coner + p2i = conei + ack = (at+1.0d0)*raz + rho = ack + dsqrt(ack*ack-1.0d0) + rho2 = rho*rho + tst = (rho2+rho2)/((rho2-1.0d0)*(rho-1.0d0)) + tst = tst/tol +c----------------------------------------------------------------------- +c compute relative truncation error index for series +c----------------------------------------------------------------------- + ak = at + do 10 i=1,80 + ptr = p2r + pti = p2i + p2r = p1r - (ckr*ptr-cki*pti) + p2i = p1i - (cki*ptr+ckr*pti) + p1r = ptr + p1i = pti + ckr = ckr + rzr + cki = cki + rzi + ap = zabs2(p2r,p2i) + if (ap.gt.tst*ak*ak) go to 20 + ak = ak + 1.0d0 + 10 continue + go to 110 + 20 continue + i = i + 1 + k = 0 + if (inu.lt.iaz) go to 40 +c----------------------------------------------------------------------- +c compute relative truncation error for ratios +c----------------------------------------------------------------------- + p1r = zeror + p1i = zeroi + p2r = coner + p2i = conei + at = dble(float(inu)) + 1.0d0 + str = zr*raz + sti = -zi*raz + ckr = str*at*raz + cki = sti*at*raz + ack = at*raz + tst = dsqrt(ack/tol) + itime = 1 + do 30 k=1,80 + ptr = p2r + pti = p2i + p2r = p1r - (ckr*ptr-cki*pti) + p2i = p1i - (ckr*pti+cki*ptr) + p1r = ptr + p1i = pti + ckr = ckr + rzr + cki = cki + rzi + ap = zabs2(p2r,p2i) + if (ap.lt.tst) go to 30 + if (itime.eq.2) go to 40 + ack = zabs2(ckr,cki) + flam = ack + dsqrt(ack*ack-1.0d0) + fkap = ap/zabs2(p1r,p1i) + rho = dmin1(flam,fkap) + tst = tst*dsqrt(rho/(rho*rho-1.0d0)) + itime = 2 + 30 continue + go to 110 + 40 continue +c----------------------------------------------------------------------- +c backward recurrence and sum normalizing relation +c----------------------------------------------------------------------- + k = k + 1 + kk = max0(i+iaz,k+inu) + fkk = dble(float(kk)) + p1r = zeror + p1i = zeroi +c----------------------------------------------------------------------- +c scale p2 and sum by scle +c----------------------------------------------------------------------- + p2r = scle + p2i = zeroi + fnf = fnu - dble(float(ifnu)) + tfnf = fnf + fnf + bk = dgamln(fkk+tfnf+1.0d0,idum) - dgamln(fkk+1.0d0,idum) - + * dgamln(tfnf+1.0d0,idum) + bk = dexp(bk) + sumr = zeror + sumi = zeroi + km = kk - inu + do 50 i=1,km + ptr = p2r + pti = p2i + p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) + p2i = p1i + (fkk+fnf)*(rzi*ptr+rzr*pti) + p1r = ptr + p1i = pti + ak = 1.0d0 - tfnf/(fkk+tfnf) + ack = bk*ak + sumr = sumr + (ack+bk)*p1r + sumi = sumi + (ack+bk)*p1i + bk = ack + fkk = fkk - 1.0d0 + 50 continue + yr(n) = p2r + yi(n) = p2i + if (n.eq.1) go to 70 + do 60 i=2,n + ptr = p2r + pti = p2i + p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) + p2i = p1i + (fkk+fnf)*(rzi*ptr+rzr*pti) + p1r = ptr + p1i = pti + ak = 1.0d0 - tfnf/(fkk+tfnf) + ack = bk*ak + sumr = sumr + (ack+bk)*p1r + sumi = sumi + (ack+bk)*p1i + bk = ack + fkk = fkk - 1.0d0 + m = n - i + 1 + yr(m) = p2r + yi(m) = p2i + 60 continue + 70 continue + if (ifnu.le.0) go to 90 + do 80 i=1,ifnu + ptr = p2r + pti = p2i + p2r = p1r + (fkk+fnf)*(rzr*ptr-rzi*pti) + p2i = p1i + (fkk+fnf)*(rzr*pti+rzi*ptr) + p1r = ptr + p1i = pti + ak = 1.0d0 - tfnf/(fkk+tfnf) + ack = bk*ak + sumr = sumr + (ack+bk)*p1r + sumi = sumi + (ack+bk)*p1i + bk = ack + fkk = fkk - 1.0d0 + 80 continue + 90 continue + ptr = zr + pti = zi + if (kode.eq.2) ptr = zeror + call zlog(rzr, rzi, str, sti, idum) + p1r = -fnf*str + ptr + p1i = -fnf*sti + pti + ap = dgamln(1.0d0+fnf,idum) + ptr = p1r - ap + pti = p1i +c----------------------------------------------------------------------- +c the division cexp(pt)/(sum+p2) is altered to avoid overflow +c in the denominator by squaring large quantities +c----------------------------------------------------------------------- + p2r = p2r + sumr + p2i = p2i + sumi + ap = zabs2(p2r,p2i) + p1r = 1.0d0/ap + call zexp(ptr, pti, str, sti) + ckr = str*p1r + cki = sti*p1r + ptr = p2r*p1r + pti = -p2i*p1r + call zmlt(ckr, cki, ptr, pti, cnormr, cnormi) + do 100 i=1,n + str = yr(i)*cnormr - yi(i)*cnormi + yi(i) = yr(i)*cnormi + yi(i)*cnormr + yr(i) = str + 100 continue + return + 110 continue + nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zseri(zr, zi, fnu, kode, n, yr, yi, nz, tol, elim, + * alim) +c geuz for g77 + EXTERNAL zlog +c Refer to zbesi,zbesk +c +c zseri computes the i bessel function for real(z).ge.0.0 by +c means of the power series for large cabs(z) in the +c region cabs(z).le.2*sqrt(fnu+1). nz=0 is a normal return. +c nz.gt.0 means that the last nz components were set to zero +c due to underflow. nz.lt.0 means underflow occurred, but the +c condition cabs(z).le.2*sqrt(fnu+1) was violated and the +c computation must be completed in another routine with n=n-abs(nz). +c +c***routines called dgamln,d1mach,zuchk,zabs2,zdiv,zlog,zmlt +c +c complex ak1,ck,coef,cone,crsc,cscl,cz,czero,hz,rz,s1,s2,y,z + double precision aa, acz, ak, ak1i, ak1r, alim, arm, ascle, atol, + * az, cki, ckr, coefi, coefr, conei, coner, crscr, czi, czr, dfnu, + * elim, fnu, fnup, hzi, hzr, raz, rs, rtr1, rzi, rzr, s, ss, sti, + * str, s1i, s1r, s2i, s2r, tol, yi, yr, wi, wr, zeroi, zeror, zi, + * zr, dgamln, d1mach, zabs2 + integer i, ib, idum, iflag, il, k, kode, l, m, n, nn, nz, nw + dimension yr(n), yi(n), wr(2), wi(2) + data zeror,zeroi,coner,conei / 0.0d0, 0.0d0, 1.0d0, 0.0d0 / +c + nz = 0 + az = zabs2(zr,zi) + if (az.eq.0.0d0) go to 160 + arm = 1.0d+3*d1mach(1) + rtr1 = dsqrt(arm) + crscr = 1.0d0 + iflag = 0 + if (az.lt.arm) go to 150 + hzr = 0.5d0*zr + hzi = 0.5d0*zi + czr = zeror + czi = zeroi + if (az.le.rtr1) go to 10 + call zmlt(hzr, hzi, hzr, hzi, czr, czi) + 10 continue + acz = zabs2(czr,czi) + nn = n + call zlog(hzr, hzi, ckr, cki, idum) + 20 continue + dfnu = fnu + dble(float(nn-1)) + fnup = dfnu + 1.0d0 +c----------------------------------------------------------------------- +c underflow test +c----------------------------------------------------------------------- + ak1r = ckr*dfnu + ak1i = cki*dfnu + ak = dgamln(fnup,idum) + ak1r = ak1r - ak + if (kode.eq.2) ak1r = ak1r - zr + if (ak1r.gt.(-elim)) go to 40 + 30 continue + nz = nz + 1 + yr(nn) = zeror + yi(nn) = zeroi + if (acz.gt.dfnu) go to 190 + nn = nn - 1 + if (nn.eq.0) return + go to 20 + 40 continue + if (ak1r.gt.(-alim)) go to 50 + iflag = 1 + ss = 1.0d0/tol + crscr = tol + ascle = arm*ss + 50 continue + aa = dexp(ak1r) + if (iflag.eq.1) aa = aa*ss + coefr = aa*dcos(ak1i) + coefi = aa*dsin(ak1i) + atol = tol*acz/fnup + il = min0(2,nn) + do 90 i=1,il + dfnu = fnu + dble(float(nn-i)) + fnup = dfnu + 1.0d0 + s1r = coner + s1i = conei + if (acz.lt.tol*fnup) go to 70 + ak1r = coner + ak1i = conei + ak = fnup + 2.0d0 + s = fnup + aa = 2.0d0 + 60 continue + rs = 1.0d0/s + str = ak1r*czr - ak1i*czi + sti = ak1r*czi + ak1i*czr + ak1r = str*rs + ak1i = sti*rs + s1r = s1r + ak1r + s1i = s1i + ak1i + s = s + ak + ak = ak + 2.0d0 + aa = aa*acz*rs + if (aa.gt.atol) go to 60 + 70 continue + s2r = s1r*coefr - s1i*coefi + s2i = s1r*coefi + s1i*coefr + wr(i) = s2r + wi(i) = s2i + if (iflag.eq.0) go to 80 + call zuchk(s2r, s2i, nw, ascle, tol) + if (nw.ne.0) go to 30 + 80 continue + m = nn - i + 1 + yr(m) = s2r*crscr + yi(m) = s2i*crscr + if (i.eq.il) go to 90 + call zdiv(coefr, coefi, hzr, hzi, str, sti) + coefr = str*dfnu + coefi = sti*dfnu + 90 continue + if (nn.le.2) return + k = nn - 2 + ak = dble(float(k)) + raz = 1.0d0/az + str = zr*raz + sti = -zi*raz + rzr = (str+str)*raz + rzi = (sti+sti)*raz + if (iflag.eq.1) go to 120 + ib = 3 + 100 continue + do 110 i=ib,nn + yr(k) = (ak+fnu)*(rzr*yr(k+1)-rzi*yi(k+1)) + yr(k+2) + yi(k) = (ak+fnu)*(rzr*yi(k+1)+rzi*yr(k+1)) + yi(k+2) + ak = ak - 1.0d0 + k = k - 1 + 110 continue + return +c----------------------------------------------------------------------- +c recur backward with scaled values +c----------------------------------------------------------------------- + 120 continue +c----------------------------------------------------------------------- +c exp(-alim)=exp(-elim)/tol=approx. one precision above the +c underflow limit = ascle = d1mach(1)*ss*1.0d+3 +c----------------------------------------------------------------------- + s1r = wr(1) + s1i = wi(1) + s2r = wr(2) + s2i = wi(2) + do 130 l=3,nn + ckr = s2r + cki = s2i + s2r = s1r + (ak+fnu)*(rzr*ckr-rzi*cki) + s2i = s1i + (ak+fnu)*(rzr*cki+rzi*ckr) + s1r = ckr + s1i = cki + ckr = s2r*crscr + cki = s2i*crscr + yr(k) = ckr + yi(k) = cki + ak = ak - 1.0d0 + k = k - 1 + if (zabs2(ckr,cki).gt.ascle) go to 140 + 130 continue + return + 140 continue + ib = l + 1 + if (ib.gt.nn) return + go to 100 + 150 continue + nz = n + if (fnu.eq.0.0d0) nz = nz - 1 + 160 continue + yr(1) = zeror + yi(1) = zeroi + if (fnu.ne.0.0d0) go to 170 + yr(1) = coner + yi(1) = conei + 170 continue + if (n.eq.1) return + do 180 i=2,n + yr(i) = zeror + yi(i) = zeroi + 180 continue + return +c----------------------------------------------------------------------- +c return with nz.lt.0 if cabs(z*z/4).gt.fnu+n-nz-1 complete +c the calculation in cbinu with n=n-iabs(nz) +c----------------------------------------------------------------------- + 190 continue + nz = -nz + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zwrsk(zrr, zri, fnu, kode, n, yr, yi, nz, cwr, cwi, + * tol, elim, alim) +c refer to zbesi,zbesk +c +c zwrsk computes the i bessel function for re(z).ge.0.0 by +c normalizing the i function ratios from zrati by the wronskian +c +c***routines called d1mach,zbknu,zrati,zabs2 +c complex cinu,cscl,ct,cw,c1,c2,rct,st,y,zr + double precision act, acw, alim, ascle, cinui, cinur, csclr, cti, + * ctr, cwi, cwr, c1i, c1r, c2i, c2r, elim, fnu, pti, ptr, ract, + * sti, str, tol, yi, yr, zri, zrr, zabs2, d1mach + integer i, kode, n, nw, nz + dimension yr(n), yi(n), cwr(2), cwi(2) +c----------------------------------------------------------------------- +c i(fnu+i-1,z) by backward recurrence for ratios +c y(i)=i(fnu+i,z)/i(fnu+i-1,z) from crati normalized by the +c wronskian with k(fnu,z) and k(fnu+1,z) from cbknu. +c----------------------------------------------------------------------- + nz = 0 + call zbknu(zrr, zri, fnu, kode, 2, cwr, cwi, nw, tol, elim, alim) + if (nw.ne.0) go to 50 + call zrati(zrr, zri, fnu, n, yr, yi, tol) +c----------------------------------------------------------------------- +c recur forward on i(fnu+1,z) = r(fnu,z)*i(fnu,z), +c r(fnu+j-1,z)=y(j), j=1,...,n +c----------------------------------------------------------------------- + cinur = 1.0d0 + cinui = 0.0d0 + if (kode.eq.1) go to 10 + cinur = dcos(zri) + cinui = dsin(zri) + 10 continue +c----------------------------------------------------------------------- +c on low exponent machines the k functions can be close to both +c the under and overflow limits and the normalization must be +c scaled to prevent over or underflow. cuoik has determined that +c the result is on scale. +c----------------------------------------------------------------------- + acw = zabs2(cwr(2),cwi(2)) + ascle = 1.0d+3*d1mach(1)/tol + csclr = 1.0d0 + if (acw.gt.ascle) go to 20 + csclr = 1.0d0/tol + go to 30 + 20 continue + ascle = 1.0d0/ascle + if (acw.lt.ascle) go to 30 + csclr = tol + 30 continue + c1r = cwr(1)*csclr + c1i = cwi(1)*csclr + c2r = cwr(2)*csclr + c2i = cwi(2)*csclr + str = yr(1) + sti = yi(1) +c----------------------------------------------------------------------- +c cinu=cinu*(conjg(ct)/cabs(ct))*(1.0d0/cabs(ct) prevents +c under- or overflow prematurely by squaring cabs(ct) +c----------------------------------------------------------------------- + ptr = str*c1r - sti*c1i + pti = str*c1i + sti*c1r + ptr = ptr + c2r + pti = pti + c2i + ctr = zrr*ptr - zri*pti + cti = zrr*pti + zri*ptr + act = zabs2(ctr,cti) + ract = 1.0d0/act + ctr = ctr*ract + cti = -cti*ract + ptr = cinur*ract + pti = cinui*ract + cinur = ptr*ctr - pti*cti + cinui = ptr*cti + pti*ctr + yr(1) = cinur*csclr + yi(1) = cinui*csclr + if (n.eq.1) return + do 40 i=2,n + ptr = str*cinur - sti*cinui + cinui = str*cinui + sti*cinur + cinur = ptr + str = yr(i) + sti = yi(i) + yr(i) = cinur*csclr + yi(i) = cinui*csclr + 40 continue + return + 50 continue + nz = -1 + if(nw.eq.(-2)) nz=-2 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + + + + + + + + + subroutine zairy(zr, zi, id, kode, air, aii, nz, ierr) +c geuz for g77 + EXTERNAL zsqrt + EXTERNAL zexp +c Airy function,bessel functions of order one third +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, zairy computes the complex airy function ai(z) or +c its derivative dai(z)/dz on id=0 or id=1 respectively. on +c kode=2, a scaling option cexp(zta)*ai(z) or cexp(zta)* +c dai(z)/dz is provided to remove the exponential decay in +c -pi/3.lt.arg(z).lt.pi/3 and the exponential growth in +c pi/3.lt.abs(arg(z)).lt.pi where zta=(2/3)*z*csqrt(z). +c +c while the airy functions ai(z) and dai(z)/dz are analytic in +c the whole z plane, the corresponding scaled functions defined +c for kode=2 have a cut along the negative real axis. +c +c input zr,zi are double precision +c zr,zi - z=cmplx(zr,zi) +c id - order of derivative, id=0 or id=1 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c ai=ai(z) on id=0 or +c ai=dai(z)/dz on id=1 +c = 2 returns +c ai=cexp(zta)*ai(z) on id=0 or +c ai=cexp(zta)*dai(z)/dz on id=1 where +c zta=(2/3)*z*csqrt(z) +c +c output air,aii are double precision +c air,aii- complex answer depending on the choices for id and +c kode +c nz - underflow indicator +c nz= 0 , normal return +c nz= 1 , ai=cmplx(0.0d0,0.0d0) due to underflow in +c -pi/3.lt.arg(z).lt.pi/3 on kode=1 +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, real(zta) +c too large on kode=1 +c ierr=3, cabs(z) large - computation completed +c losses of signifcance by argument reduction +c produce less than half of machine accuracy +c ierr=4, cabs(z) too large - no computation +c complete loss of accuracy by argument +c reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c +c ai and dai are computed for cabs(z).gt.1.0 from the k bessel +c functions by +c +c ai(z)=c*sqrt(z)*k(1/3,zta) , dai(z)=-c*z*k(2/3,zta) +c c=1.0/(pi*sqrt(3.0)) +c zta=(2/3)*z**(3/2) +c +c with the power series for cabs(z).le.1.0. +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z is large, losses +c of significance by argument reduction occur. consequently, if +c the magnitude of zeta=(2/3)*z**1.5 exceeds u1=sqrt(0.5/ur), +c then losses exceeding half precision are likely and an error +c flag ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c also, if the magnitude of zeta is larger than u2=0.5/ur, then +c all significance is lost and ierr=4. in order to use the int +c function, zeta must be further restricted not to exceed the +c largest integer, u3=i1mach(9). thus, the magnitude of zeta +c must be restricted by min(u2,u3). on 32 bit machines, u1,u2, +c and u3 are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single +c precision arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double +c precision arithmetic respectively. this makes u2 and u3 limit- +c ing in their respective arithmetics. this means that the mag- +c nitude of z cannot exceed 3.1e+4 in single and 2.1e+6 in +c double precision arithmetic. this also means that one can +c expect to retain, in the worst cases on 32 bit machines, +c no digits in single precision and only 7 digits in double +c precision arithmetic. similar considerations hold for other +c machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zacai,zbknu,zexp,zsqrt,i1mach,d1mach +c +c complex ai,cone,csq,cy,s1,s2,trm1,trm2,z,zta,z3 + double precision aa, ad, aii, air, ak, alim, atrm, az, az3, bk, + * cc, ck, coef, conei, coner, csqi, csqr, cyi, cyr, c1, c2, dig, + * dk, d1, d2, elim, fid, fnu, ptr, rl, r1m5, sfac, sti, str, + * s1i, s1r, s2i, s2r, tol, trm1i, trm1r, trm2i, trm2r, tth, zeroi, + * zeror, zi, zr, ztai, ztar, z3i, z3r, d1mach, zabs2, alaz, bb + integer id, ierr, iflag, k, kode, k1, k2, mr, nn, nz, i1mach + dimension cyr(1), cyi(1) + data tth, c1, c2, coef /6.66666666666666667d-01, + * 3.55028053887817240d-01,2.58819403792806799d-01, + * 1.83776298473930683d-01/ + data zeror, zeroi, coner, conei /0.0d0,0.0d0,1.0d0,0.0d0/ +c***first executable statement zairy + ierr = 0 + nz=0 + if (id.lt.0 .or. id.gt.1) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (ierr.ne.0) return + az = zabs2(zr,zi) + tol = dmax1(d1mach(4),1.0d-18) + fid = dble(float(id)) + if (az.gt.1.0d0) go to 70 +c----------------------------------------------------------------------- +c power series for cabs(z).le.1. +c----------------------------------------------------------------------- + s1r = coner + s1i = conei + s2r = coner + s2i = conei + if (az.lt.tol) go to 170 + aa = az*az + if (aa.lt.tol/az) go to 40 + trm1r = coner + trm1i = conei + trm2r = coner + trm2i = conei + atrm = 1.0d0 + str = zr*zr - zi*zi + sti = zr*zi + zi*zr + z3r = str*zr - sti*zi + z3i = str*zi + sti*zr + az3 = az*aa + ak = 2.0d0 + fid + bk = 3.0d0 - fid - fid + ck = 4.0d0 - fid + dk = 3.0d0 + fid + fid + d1 = ak*dk + d2 = bk*ck + ad = dmin1(d1,d2) + ak = 24.0d0 + 9.0d0*fid + bk = 30.0d0 - 9.0d0*fid + do 30 k=1,25 + str = (trm1r*z3r-trm1i*z3i)/d1 + trm1i = (trm1r*z3i+trm1i*z3r)/d1 + trm1r = str + s1r = s1r + trm1r + s1i = s1i + trm1i + str = (trm2r*z3r-trm2i*z3i)/d2 + trm2i = (trm2r*z3i+trm2i*z3r)/d2 + trm2r = str + s2r = s2r + trm2r + s2i = s2i + trm2i + atrm = atrm*az3/ad + d1 = d1 + ak + d2 = d2 + bk + ad = dmin1(d1,d2) + if (atrm.lt.tol*ad) go to 40 + ak = ak + 18.0d0 + bk = bk + 18.0d0 + 30 continue + 40 continue + if (id.eq.1) go to 50 + air = s1r*c1 - c2*(zr*s2r-zi*s2i) + aii = s1i*c1 - c2*(zr*s2i+zi*s2r) + if (kode.eq.1) return + call zsqrt(zr, zi, str, sti) + ztar = tth*(zr*str-zi*sti) + ztai = tth*(zr*sti+zi*str) + call zexp(ztar, ztai, str, sti) + ptr = air*str - aii*sti + aii = air*sti + aii*str + air = ptr + return + 50 continue + air = -s2r*c2 + aii = -s2i*c2 + if (az.le.tol) go to 60 + str = zr*s1r - zi*s1i + sti = zr*s1i + zi*s1r + cc = c1/(1.0d0+fid) + air = air + cc*(str*zr-sti*zi) + aii = aii + cc*(str*zi+sti*zr) + 60 continue + if (kode.eq.1) return + call zsqrt(zr, zi, str, sti) + ztar = tth*(zr*str-zi*sti) + ztai = tth*(zr*sti+zi*str) + call zexp(ztar, ztai, str, sti) + ptr = str*air - sti*aii + aii = str*aii + sti*air + air = ptr + return +c----------------------------------------------------------------------- +c case for cabs(z).gt.1.0 +c----------------------------------------------------------------------- + 70 continue + fnu = (1.0d0+fid)/3.0d0 +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0d-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c----------------------------------------------------------------------- + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + rl = 1.2d0*dig + 3.0d0 + alaz = dlog(az) +c-------------------------------------------------------------------------- +c test for proper range +c----------------------------------------------------------------------- + aa=0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa=dmin1(aa,bb) + aa=aa**tth + if (az.gt.aa) go to 260 + aa=dsqrt(aa) + if (az.gt.aa) ierr=3 + call zsqrt(zr, zi, csqr, csqi) + ztar = tth*(zr*csqr-zi*csqi) + ztai = tth*(zr*csqi+zi*csqr) +c----------------------------------------------------------------------- +c re(zta).le.0 when re(z).lt.0, especially when im(z) is small +c----------------------------------------------------------------------- + iflag = 0 + sfac = 1.0d0 + ak = ztai + if (zr.ge.0.0d0) go to 80 + bk = ztar + ck = -dabs(bk) + ztar = ck + ztai = ak + 80 continue + if (zi.ne.0.0d0) go to 90 + if (zr.gt.0.0d0) go to 90 + ztar = 0.0d0 + ztai = ak + 90 continue + aa = ztar + if (aa.ge.0.0d0 .and. zr.gt.0.0d0) go to 110 + if (kode.eq.2) go to 100 +c----------------------------------------------------------------------- +c overflow test +c----------------------------------------------------------------------- + if (aa.gt.(-alim)) go to 100 + aa = -aa + 0.25d0*alaz + iflag = 1 + sfac = tol + if (aa.gt.elim) go to 270 + 100 continue +c----------------------------------------------------------------------- +c cbknu and cacon return exp(zta)*k(fnu,zta) on kode=2 +c----------------------------------------------------------------------- + mr = 1 + if (zi.lt.0.0d0) mr = -1 + call zacai(ztar, ztai, fnu, kode, mr, 1, cyr, cyi, nn, rl, tol, + * elim, alim) + if (nn.lt.0) go to 280 + nz = nz + nn + go to 130 + 110 continue + if (kode.eq.2) go to 120 +c----------------------------------------------------------------------- +c underflow test +c----------------------------------------------------------------------- + if (aa.lt.alim) go to 120 + aa = -aa - 0.25d0*alaz + iflag = 2 + sfac = 1.0d0/tol + if (aa.lt.(-elim)) go to 210 + 120 continue + call zbknu(ztar, ztai, fnu, kode, 1, cyr, cyi, nz, tol, elim, + * alim) + 130 continue + s1r = cyr(1)*coef + s1i = cyi(1)*coef + if (iflag.ne.0) go to 150 + if (id.eq.1) go to 140 + air = csqr*s1r - csqi*s1i + aii = csqr*s1i + csqi*s1r + return + 140 continue + air = -(zr*s1r-zi*s1i) + aii = -(zr*s1i+zi*s1r) + return + 150 continue + s1r = s1r*sfac + s1i = s1i*sfac + if (id.eq.1) go to 160 + str = s1r*csqr - s1i*csqi + s1i = s1r*csqi + s1i*csqr + s1r = str + air = s1r/sfac + aii = s1i/sfac + return + 160 continue + str = -(s1r*zr-s1i*zi) + s1i = -(s1r*zi+s1i*zr) + s1r = str + air = s1r/sfac + aii = s1i/sfac + return + 170 continue + aa = 1.0d+3*d1mach(1) + s1r = zeror + s1i = zeroi + if (id.eq.1) go to 190 + if (az.le.aa) go to 180 + s1r = c2*zr + s1i = c2*zi + 180 continue + air = c1 - s1r + aii = -s1i + return + 190 continue + air = -c2 + aii = 0.0d0 + aa = dsqrt(aa) + if (az.le.aa) go to 200 + s1r = 0.5d0*(zr*zr-zi*zi) + s1i = zr*zi + 200 continue + air = air + c1*s1r + aii = aii + c1*s1i + return + 210 continue + nz = 1 + air = zeror + aii = zeroi + return + 270 continue + nz = 0 + ierr=2 + return + 280 continue + if(nn.eq.(-1)) go to 270 + nz=0 + ierr=5 + return + 260 continue + ierr=4 + nz=0 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + subroutine zbiry(zr, zi, id, kode, bir, bii, ierr) +c geuz for g77 + EXTERNAL zsqrt +c Airy function,bessel functions of order one third +c Author Amos, Donald E., Sandia National Laboratories +c +c on kode=1, cbiry computes the complex airy function bi(z) or +c its derivative dbi(z)/dz on id=0 or id=1 respectively. on +c kode=2, a scaling option cexp(-axzta)*bi(z) or cexp(-axzta)* +c dbi(z)/dz is provided to remove the exponential behavior in +c both the left and right half planes where +c zta=(2/3)*z*csqrt(z)=cmplx(xzta,yzta) and axzta=abs(xzta). +c +c input zr,zi are double precision +c zr,zi - z=cmplx(zr,zi) +c id - order of derivative, id=0 or id=1 +c kode - a parameter to indicate the scaling option +c kode= 1 returns +c bi=bi(z) on id=0 or +c bi=dbi(z)/dz on id=1 +c = 2 returns +c bi=cexp(-axzta)*bi(z) on id=0 or +c bi=cexp(-axzta)*dbi(z)/dz on id=1 where +c zta=(2/3)*z*csqrt(z)=cmplx(xzta,yzta) +c and axzta=abs(xzta) +c +c output bir,bii are double precision +c bir,bii- complex answer depending on the choices for id and +c kode +c ierr - error flag +c ierr=0, normal return - computation completed +c ierr=1, input error - no computation +c ierr=2, overflow - no computation, real(z) +c too large on kode=1 +c ierr=3, cabs(z) large - computation completed +c losses of signifcance by argument reduction +c produce less than half of machine accuracy +c ierr=4, cabs(z) too large - no computation +c complete loss of accuracy by argument +c reduction +c ierr=5, error - no computation, +c algorithm termination condition not met +c +c bi and dbi are computed for cabs(z).gt.1.0 from the i bessel +c functions by +c +c bi(z)=c*sqrt(z)*( i(-1/3,zta) + i(1/3,zta) ) +c dbi(z)=c * z * ( i(-2/3,zta) + i(2/3,zta) ) +c c=1.0/sqrt(3.0) +c zta=(2/3)*z**(3/2) +c +c with the power series for cabs(z).le.1.0. +c +c in most complex variable computation, one must evaluate ele- +c mentary functions. when the magnitude of z is large, losses +c of significance by argument reduction occur. consequently, if +c the magnitude of zeta=(2/3)*z**1.5 exceeds u1=sqrt(0.5/ur), +c then losses exceeding half precision are likely and an error +c flag ierr=3 is triggered where ur=dmax1(d1mach(4),1.0d-18) is +c double precision unit roundoff limited to 18 digits precision. +c also, if the magnitude of zeta is larger than u2=0.5/ur, then +c all significance is lost and ierr=4. in order to use the int +c function, zeta must be further restricted not to exceed the +c largest integer, u3=i1mach(9). thus, the magnitude of zeta +c must be restricted by min(u2,u3). on 32 bit machines, u1,u2, +c and u3 are approximately 2.0e+3, 4.2e+6, 2.1e+9 in single +c precision arithmetic and 1.3e+8, 1.8e+16, 2.1e+9 in double +c precision arithmetic respectively. this makes u2 and u3 limit- +c ing in their respective arithmetics. this means that the mag- +c nitude of z cannot exceed 3.1e+4 in single and 2.1e+6 in +c double precision arithmetic. this also means that one can +c expect to retain, in the worst cases on 32 bit machines, +c no digits in single precision and only 7 digits in double +c precision arithmetic. similar considerations hold for other +c machines. +c +c the approximate relative error in the magnitude of a complex +c bessel function can be expressed by p*10**s where p=max(unit +c roundoff,1.0e-18) is the nominal precision and 10**s repre- +c sents the increase in error due to argument reduction in the +c elementary functions. here, s=max(1,abs(log10(cabs(z))), +c abs(log10(fnu))) approximately (i.e. s=max(1,abs(exponent of +c cabs(z),abs(exponent of fnu)) ). however, the phase angle may +c have only absolute accuracy. this is most likely to occur when +c one component (in absolute value) is larger than the other by +c several orders of magnitude. if one component is 10**k larger +c than the other, then one can expect only max(abs(log10(p))-k, +c 0) significant digits; or, stated another way, when k exceeds +c the exponent of p, no significant digits remain in the smaller +c component. however, the phase angle retains absolute accuracy +c because, in complex arithmetic with precision p, the smaller +c component will not (as a rule) decrease below p times the +c magnitude of the larger component. in these extreme cases, +c the principal phase angle is on the order of +p, -p, pi/2-p, +c or -pi/2+p. +c +c***routines called zbinu,zabs2,zdiv,zsqrt,d1mach,i1mach +c +c complex bi,cone,csq,cy,s1,s2,trm1,trm2,z,zta,z3 + double precision aa, ad, ak, alim, atrm, az, az3, bb, bii, bir, + * bk, cc, ck, coef, conei, coner, csqi, csqr, cyi, cyr, c1, c2, + * dig, dk, d1, d2, eaa, elim, fid, fmr, fnu, fnul, pi, rl, r1m5, + * sfac, sti, str, s1i, s1r, s2i, s2r, tol, trm1i, trm1r, trm2i, + * trm2r, tth, zi, zr, ztai, ztar, z3i, z3r, d1mach, zabs2 + integer id, ierr, k, kode, k1, k2, nz, i1mach + dimension cyr(2), cyi(2) + data tth, c1, c2, coef, pi /6.66666666666666667d-01, + * 6.14926627446000736d-01,4.48288357353826359d-01, + * 5.77350269189625765d-01,3.14159265358979324d+00/ + data coner, conei /1.0d0,0.0d0/ +c + ierr = 0 + nz=0 + if (id.lt.0 .or. id.gt.1) ierr=1 + if (kode.lt.1 .or. kode.gt.2) ierr=1 + if (ierr.ne.0) return + az = zabs2(zr,zi) + tol = dmax1(d1mach(4),1.0d-18) + fid = dble(float(id)) + if (az.gt.1.0e0) go to 70 +c----------------------------------------------------------------------- +c power series for cabs(z).le.1. +c----------------------------------------------------------------------- + s1r = coner + s1i = conei + s2r = coner + s2i = conei + if (az.lt.tol) go to 130 + aa = az*az + if (aa.lt.tol/az) go to 40 + trm1r = coner + trm1i = conei + trm2r = coner + trm2i = conei + atrm = 1.0d0 + str = zr*zr - zi*zi + sti = zr*zi + zi*zr + z3r = str*zr - sti*zi + z3i = str*zi + sti*zr + az3 = az*aa + ak = 2.0d0 + fid + bk = 3.0d0 - fid - fid + ck = 4.0d0 - fid + dk = 3.0d0 + fid + fid + d1 = ak*dk + d2 = bk*ck + ad = dmin1(d1,d2) + ak = 24.0d0 + 9.0d0*fid + bk = 30.0d0 - 9.0d0*fid + do 30 k=1,25 + str = (trm1r*z3r-trm1i*z3i)/d1 + trm1i = (trm1r*z3i+trm1i*z3r)/d1 + trm1r = str + s1r = s1r + trm1r + s1i = s1i + trm1i + str = (trm2r*z3r-trm2i*z3i)/d2 + trm2i = (trm2r*z3i+trm2i*z3r)/d2 + trm2r = str + s2r = s2r + trm2r + s2i = s2i + trm2i + atrm = atrm*az3/ad + d1 = d1 + ak + d2 = d2 + bk + ad = dmin1(d1,d2) + if (atrm.lt.tol*ad) go to 40 + ak = ak + 18.0d0 + bk = bk + 18.0d0 + 30 continue + 40 continue + if (id.eq.1) go to 50 + bir = c1*s1r + c2*(zr*s2r-zi*s2i) + bii = c1*s1i + c2*(zr*s2i+zi*s2r) + if (kode.eq.1) return + call zsqrt(zr, zi, str, sti) + ztar = tth*(zr*str-zi*sti) + ztai = tth*(zr*sti+zi*str) + aa = ztar + aa = -dabs(aa) + eaa = dexp(aa) + bir = bir*eaa + bii = bii*eaa + return + 50 continue + bir = s2r*c2 + bii = s2i*c2 + if (az.le.tol) go to 60 + cc = c1/(1.0d0+fid) + str = s1r*zr - s1i*zi + sti = s1r*zi + s1i*zr + bir = bir + cc*(str*zr-sti*zi) + bii = bii + cc*(str*zi+sti*zr) + 60 continue + if (kode.eq.1) return + call zsqrt(zr, zi, str, sti) + ztar = tth*(zr*str-zi*sti) + ztai = tth*(zr*sti+zi*str) + aa = ztar + aa = -dabs(aa) + eaa = dexp(aa) + bir = bir*eaa + bii = bii*eaa + return +c----------------------------------------------------------------------- +c case for cabs(z).gt.1.0 +c----------------------------------------------------------------------- + 70 continue + fnu = (1.0d0+fid)/3.0d0 +c----------------------------------------------------------------------- +c set parameters related to machine constants. +c tol is the approximate unit roundoff limited to 1.0e-18. +c elim is the approximate exponential over- and underflow limit. +c exp(-elim).lt.exp(-alim)=exp(-elim)/tol and +c exp(elim).gt.exp(alim)=exp(elim)*tol are intervals near +c underflow and overflow limits where scaled arithmetic is done. +c rl is the lower boundary of the asymptotic expansion for large z. +c dig = number of base 10 digits in tol = 10**(-dig). +c fnul is the lower boundary of the asymptotic series for large fnu. +c----------------------------------------------------------------------- + k1 = i1mach(15) + k2 = i1mach(16) + r1m5 = d1mach(5) + k = min0(iabs(k1),iabs(k2)) + elim = 2.303d0*(dble(float(k))*r1m5-3.0d0) + k1 = i1mach(14) - 1 + aa = r1m5*dble(float(k1)) + dig = dmin1(aa,18.0d0) + aa = aa*2.303d0 + alim = elim + dmax1(-aa,-41.45d0) + rl = 1.2d0*dig + 3.0d0 + fnul = 10.0d0 + 6.0d0*(dig-3.0d0) +c----------------------------------------------------------------------- +c test for range +c----------------------------------------------------------------------- + aa=0.5d0/tol + bb=dble(float(i1mach(9)))*0.5d0 + aa=dmin1(aa,bb) + aa=aa**tth + if (az.gt.aa) go to 260 + aa=dsqrt(aa) + if (az.gt.aa) ierr=3 + call zsqrt(zr, zi, csqr, csqi) + ztar = tth*(zr*csqr-zi*csqi) + ztai = tth*(zr*csqi+zi*csqr) +c----------------------------------------------------------------------- +c re(zta).le.0 when re(z).lt.0, especially when im(z) is small +c----------------------------------------------------------------------- + sfac = 1.0d0 + ak = ztai + if (zr.ge.0.0d0) go to 80 + bk = ztar + ck = -dabs(bk) + ztar = ck + ztai = ak + 80 continue + if (zi.ne.0.0d0 .or. zr.gt.0.0d0) go to 90 + ztar = 0.0d0 + ztai = ak + 90 continue + aa = ztar + if (kode.eq.2) go to 100 +c----------------------------------------------------------------------- +c overflow test +c----------------------------------------------------------------------- + bb = dabs(aa) + if (bb.lt.alim) go to 100 + bb = bb + 0.25d0*dlog(az) + sfac = tol + if (bb.gt.elim) go to 190 + 100 continue + fmr = 0.0d0 + if (aa.ge.0.0d0 .and. zr.gt.0.0d0) go to 110 + fmr = pi + if (zi.lt.0.0d0) fmr = -pi + ztar = -ztar + ztai = -ztai + 110 continue +c----------------------------------------------------------------------- +c aa=factor for analytic continuation of i(fnu,zta) +c kode=2 returns exp(-abs(xzta))*i(fnu,zta) from cbesi +c----------------------------------------------------------------------- + call zbinu(ztar, ztai, fnu, kode, 1, cyr, cyi, nz, rl, fnul, tol, + * elim, alim) + if (nz.lt.0) go to 200 + aa = fmr*fnu + z3r = sfac + str = dcos(aa) + sti = dsin(aa) + s1r = (str*cyr(1)-sti*cyi(1))*z3r + s1i = (str*cyi(1)+sti*cyr(1))*z3r + fnu = (2.0d0-fid)/3.0d0 + call zbinu(ztar, ztai, fnu, kode, 2, cyr, cyi, nz, rl, fnul, tol, + * elim, alim) + cyr(1) = cyr(1)*z3r + cyi(1) = cyi(1)*z3r + cyr(2) = cyr(2)*z3r + cyi(2) = cyi(2)*z3r +c----------------------------------------------------------------------- +c backward recur one step for orders -1/3 or -2/3 +c----------------------------------------------------------------------- + call zdiv(cyr(1), cyi(1), ztar, ztai, str, sti) + s2r = (fnu+fnu)*str + cyr(2) + s2i = (fnu+fnu)*sti + cyi(2) + aa = fmr*(fnu-1.0d0) + str = dcos(aa) + sti = dsin(aa) + s1r = coef*(s1r+s2r*str-s2i*sti) + s1i = coef*(s1i+s2r*sti+s2i*str) + if (id.eq.1) go to 120 + str = csqr*s1r - csqi*s1i + s1i = csqr*s1i + csqi*s1r + s1r = str + bir = s1r/sfac + bii = s1i/sfac + return + 120 continue + str = zr*s1r - zi*s1i + s1i = zr*s1i + zi*s1r + s1r = str + bir = s1r/sfac + bii = s1i/sfac + return + 130 continue + aa = c1*(1.0d0-fid) + fid*c2 + bir = aa + bii = 0.0d0 + return + 190 continue + ierr=2 + nz=0 + return + 200 continue + if(nz.eq.(-1)) go to 190 + nz=0 + ierr=5 + return + 260 continue + ierr=4 + nz=0 + return + end +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + + + + + diff --git a/contrib/bessel/CMakeLists.txt b/contrib/bessel/CMakeLists.txt new file mode 100644 index 0000000000000000000000000000000000000000..357acc318fa53a64c11e9532c4f924c9e8f19212 --- /dev/null +++ b/contrib/bessel/CMakeLists.txt @@ -0,0 +1,15 @@ +# GetDP - Copyright (C) 1997-2020 P. Dular and C. Geuzaine, University of Liege +# +# See the LICENSE.txt file for license information. Please report all +# issues on https://gitlab.onelab.info/getdp/getdp/issues. + +set(SRC + Bessel.cpp +) + +if(ENABLE_BESSEL) + list(APPEND SRC BesselLib.f) +endif(ENABLE_BESSEL) + +file(GLOB HDR RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.h) +append_gmshfem_contrib(Numeric "${SRC};${HDR}") diff --git a/examples/helmholtzFlow/Duct_ABCs/CMakeLists.txt b/examples/helmholtzFlow/Duct_ABCs/CMakeLists.txt deleted file mode 100644 index f01d5714177b61745622f922015d7abd78c1cdcf..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/Duct_ABCs/CMakeLists.txt +++ /dev/null @@ -1,8 +0,0 @@ -cmake_minimum_required(VERSION 3.0 FATAL_ERROR) - -project(demo CXX) - -include(${CMAKE_CURRENT_SOURCE_DIR}/../../../demos.cmake) - -add_executable(demo main.cpp ${EXTRA_INCS}) -target_link_libraries(demo ${EXTRA_LIBS}) diff --git a/examples/helmholtzFlow/Duct_ABCs/main.cpp b/examples/helmholtzFlow/Duct_ABCs/main.cpp deleted file mode 100644 index f1d983ec9c6cb86fe644f0672e5a36dc90f8c302..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/Duct_ABCs/main.cpp +++ /dev/null @@ -1,267 +0,0 @@ -#include "GmshFem.h" -#include "Formulation.h" -#include "gmsh.h" -#include "AnalyticalFunction.h" - -using namespace gmshfem; -using namespace gmshfem::common; -using namespace gmshfem::problem; -using namespace gmshfem::domain; -using namespace gmshfem::field; -using namespace gmshfem::function; -using namespace gmshfem::analytics; -using namespace gmshfem::post; -using namespace gmshfem::equation; - -void meshDuct(const double L, const double H, const double h, const int MeshOrder) -{ - msg::info << " - Duct of length L = " << L << msg::endl; - msg::info << " - Duct of heigth H = " << H << msg::endl; - gmsh::model::add("geometry"); - - // duct definition - gmsh::model::geo::addPoint(L, H, 0., h, 6); - gmsh::model::geo::addPoint(0, H, 0., h, 7); - gmsh::model::geo::addPoint(0, 0, 0., h, 8); - gmsh::model::geo::addPoint(L, 0, 0., h, 9); - - gmsh::model::geo::addLine(6, 7, 5); - gmsh::model::geo::addLine(7, 8, 6); - gmsh::model::geo::addLine(8, 9, 7); - gmsh::model::geo::addLine(9, 6, 8); - gmsh::model::geo::addCurveLoop({5,6,7,8}, 1); - gmsh::model::geo::addPlaneSurface({1}, 1); - gmsh::model::geo::mesh::setTransfiniteSurface(1); - gmsh::model::geo::mesh::setRecombine(1,1); - - // physical groups - gmsh::model::addPhysicalGroup(2, {1}, 1); - gmsh::model::setPhysicalName(2, 3, "omega"); - gmsh::model::addPhysicalGroup(1, {5}, 2); - gmsh::model::setPhysicalName(1, 2, "gammaTop"); - gmsh::model::addPhysicalGroup(1, {6}, 3); - gmsh::model::setPhysicalName(1, 3, "gammaLeft"); - gmsh::model::addPhysicalGroup(1, {7}, 4); - gmsh::model::setPhysicalName(1, 4, "gammaBottom"); - gmsh::model::addPhysicalGroup(1, {8}, 5); - gmsh::model::setPhysicalName(1, 5, "gammaRight"); - - gmsh::model::addPhysicalGroup(0, {6}, 6); - gmsh::model::setPhysicalName(0, 6, "gammaTopCorner"); - gmsh::model::addPhysicalGroup(0, {9}, 7); - gmsh::model::setPhysicalName(0, 7, "gammaBottomCorner"); - - // generate mesh - gmsh::model::geo::synchronize(); - gmsh::model::mesh::generate(2); - gmsh::model::mesh::setOrder(MeshOrder); - gmsh::option::setNumber("Mesh.ElementOrder",MeshOrder); - gmsh::model::mesh::setOrder(MeshOrder); -} - -int main(int argc, char **argv) -{ - //***** - // Problem declaration - //***** - GmshFem gmshFem(argc, argv); - const double pi = 3.14159265358979323846264338327950288; - const std::complex< double > im(0., 1.); - - // numerical parameters - int FEMorder = 8; - gmshFem.userDefinedParameter(FEMorder, "FEMorder"); - std::string gauss = "Gauss"+std::to_string(2*FEMorder+1); - gmshFem.userDefinedParameter(gauss, "gauss"); - - // meshing - double L = 0.5; // duct length - gmshFem.userDefinedParameter(L, "L"); - double H = 0.25; // duct height - gmshFem.userDefinedParameter(H, "H"); - double h = 1./40; // meshsize - gmshFem.userDefinedParameter(h, "h"); - meshDuct(L, H, h, 1); - - // duct problem specifications - std::string problem = "hard"; - gmshFem.userDefinedParameter(problem, "problem"); - double w = 30; // frequency - gmshFem.userDefinedParameter(w, "omega"); - std::vector< unsigned int > n = {3}; // single mode - // std::vector< unsigned int > n = {0,2,4,6,8}; // multiple modes modes - std::vector< double > A(n.size(),1.); // select amplitudes - int N_modes = n.size(); - msg::info << " There are " << N_modes << " input modes " << msg::endl; - - // Choose ABC type - std::string abcName = "Pade"; - gmshFem.userDefinedParameter(abcName, "abcName"); - - // mean flow - const double M = 0.8; - double beta = sqrt(1-M*M); - - std::vector< std::complex< double > > KX(N_modes); - std::vector< double > KY(N_modes), SIGMA(N_modes); - for(unsigned int j = 0; j < n.size(); ++j) { - KY[j] = n[j]*pi/H; - SIGMA[j] = w*w-beta*beta*KY[j]*KY[j]; - if ( SIGMA[j] >=0 ) { - KX[j] = (1/(beta*beta))*(-M*w + sqrt(SIGMA[j])); - msg::info << " Mode " << n[j] << " is propagative " << msg::endl; - if ( w>(beta*KY[j]) && w<KY[j] ) { - msg::info << " Mode " << n[j] << " is inverse upstream ! " << msg::endl; - } - } - else { - KX[j] = (1/(beta*beta))*(-M*w - im* sqrt(abs(SIGMA[j]))); - msg::info << " Mode " << n[j] << " is evanescent " << msg::endl; - } - msg::info << " - propagating wavenumber, kx = " << KX[j] << " of mode " << n[j] << msg::endl; - } - - float PtsByWl = 2*pi*FEMorder*(1+M) / w / h; - msg::info << "********************************" << msg::endl; - msg::info << " - convected Helmholtz duct problem " << msg::endl; - msg::info << " - wave number = " << w << msg::endl; - msg::info << " - FEM basis order = " << FEMorder << "" << msg::endl; - msg::info << " - Approximate dofs by wavelength = " << PtsByWl << "" << msg::endl; - msg::info << "********************************" << msg::endl; - - // declare formulation and FEM domains - std::vector< FieldInterface< std::complex< double > > * > fieldBucket; - Formulation< std::complex< double > > formulation("helmholtzflow"); - - Domain omega(2, 1); - Domain gammaTop(1, 2); - Domain gammaLeft(1, 3); - Domain gammaBottom(1, 4); - Domain gammaRight(1, 5); - Domain gammaTopCorner(0, 6); - Domain gammaBottomCorner(0, 7); - - Field< std::complex< double >, Form::Form0 > v("v", omega | gammaLeft | gammaRight | gammaTop | gammaBottom, FunctionSpaceTypeForm0::HierarchicalH1, FEMorder); - // define analytical solution - Function< std::complex< double >, Degree::Degree0 > *solution = nullptr; - - if(problem == "soft") { - v.addConstraint(gammaTop, 0.); - v.addConstraint(gammaBottom, 0.); - solution = new AnalyticalFunction< helmholtz2D::DuctModeSolutionMulti< std::complex< double > > >(w, M, H, A, n, 0., 0., 1); - } - else { - solution = new AnalyticalFunction< helmholtz2D::DuctModeSolutionMulti< std::complex< double > > >(w, M, H, A, n, 0., 0., 0); - } - solution->activateMemorization(); - - formulation.galerkin(vector< std::complex< double > >(beta*beta, 0., 0.) * grad(dof(v)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omega, gauss); - formulation.galerkin(vector< std::complex< double > >(0., 1., 0.) * grad(dof(v)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(v)), omega, gauss); - formulation.galerkin(vector< std::complex< double > >(im*w*M, 0., 0.) * grad(dof(v)), tf(v), omega, gauss); - formulation.galerkin(-im*w*M*dof(v), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omega, gauss); - formulation.galerkin(- w * w * dof(v), tf(v), omega, gauss); - - // input BC - ScalarFunction< std::complex< double > > Input_modal_sum=0.; - for(unsigned int j = 0; j < n.size(); ++j) { - if(problem == "soft"){ - Input_modal_sum = Input_modal_sum + A[j] * KX[j] * sin( KY[j] * y< std::complex< double > >() ); - } - else if(problem == "hard"){ - Input_modal_sum = Input_modal_sum + A[j] * KX[j] * cos( KY[j] * y< std::complex< double > >() ); - } - else { - msg::error << " this problem is not defined " << msg::endl; - } - } - formulation.galerkin(-beta*beta * im * Input_modal_sum , tf(v), gammaLeft, gauss); - formulation.galerkin(-im * w * M * dof(v), tf(v), gammaLeft, gauss); - - // output BC - if(abcName == "ABC-0") { - msg::info << "Use Sommerfeld ABC." << msg::endl; - const double angle = 0.; - std::complex< double > wM = w*(M-exp(im*angle/2.)) / (beta*beta); //angle=0 -> -k/(1+M); - formulation.galerkin(-beta*beta * im * wM * dof(v), tf(v), gammaRight, gauss); - formulation.galerkin(im * w * M * dof(v), tf(v), gammaRight, gauss); - } - else if(abcName == "ABC-2") { - msg::info << "Use second order ABC." << msg::endl; - const double angle = 0.; - // contribution to the mass and rigidity matrices - std::complex< double > wM = w*(M-cos(angle/2.)) / (beta*beta); - std::complex< double > wK = -exp(-im*angle/2.)/(2*w); - formulation.galerkin(-beta*beta * im * wM * dof(v), tf(v), gammaRight, gauss); - formulation.galerkin( beta*beta * im * wK * grad(dof(v)), grad(tf(v)), gammaRight, gauss); - formulation.galerkin(im * w * M * dof(v), tf(v), gammaRight, gauss); - - /* use DtN eigenvalues instead of Laplace Beltrami operator - std::complex< double > kT = -k + KY[0]*KY[0]/(2*k); - formulation.galerkin(-beta*beta * im * kT * dof(v), tf(v), gammaRight, gauss); - */ - } - else if(abcName == "Pade") { - int padeOrder = 4; - gmshFem.userDefinedParameter(padeOrder, "padeOrder"); - double angle = -pi/4.; - gmshFem.userDefinedParameter(angle, "angle"); - msg::info << "Use Pade ABC of order " << padeOrder << " with angle " << angle << " rad"<< msg::endl; - - const double Np = 2. * padeOrder + 1.; - const std::complex< double > exp1 = std::complex<double>(std::cos(angle),std::sin(angle)); - const std::complex< double > exp2 = std::complex<double>(std::cos(angle/2.),std::sin(angle/2.)); - const std::complex< double > coef = 2./Np; - std::vector< std::complex< double > > c(padeOrder, 0.); - for(int i = 0; i < padeOrder; ++i) { - c[i] = std::tan((i + 1) * pi / Np); - c[i] *= c[i]; - } - - // define the auxiliary fields - std::vector< Field< std::complex< double >, Form::Form0 >* > phi; - Field< std::complex< double >, Form::Form0 >* phis; - for(int i = 0; i < padeOrder; ++i) { - phis = new Field< std::complex< double >, Form::Form0 >("phi_" + std::to_string(i), gammaRight | gammaTopCorner | gammaBottomCorner, FunctionSpaceTypeForm0::HierarchicalH1, FEMorder); - if(problem == "soft") { // impose Dirichlet constraints on the auxiliary fields - phis->addConstraint(gammaTopCorner,0.); - phis->addConstraint(gammaBottomCorner,0.); - } - phi.push_back(phis); - fieldBucket.push_back(phi.back()); - } - - // write the augmented weak form - formulation.galerkin(im * w * exp2 * dof(v), tf(v), gammaRight, gauss); - for(int i = 0; i < padeOrder; ++i) { - // boundary integral terms relating the auxiliary fields - formulation.galerkin(im * w * exp2 * coef * c[i] * dof(*phi[i]), tf(v), gammaRight, gauss); - formulation.galerkin(im * w * exp2 * coef * c[i] * dof(v), tf(v), gammaRight, gauss); - - // coupling of the auxiliary equations - formulation.galerkin( grad(dof(*phi[i])), grad(tf(*phi[i])), gammaRight, gauss); - formulation.galerkin(- (w*w)/(beta*beta) * (exp1 * c[i] + 1.) * dof(*phi[i]), tf(*phi[i]), gammaRight, gauss); - formulation.galerkin(- (w*w)/(beta*beta) * exp1 * (c[i] + 1.) * dof(v), tf(*phi[i]), gammaRight, gauss); - } - } - else if(abcName == "DtN") { - msg::info << "Use analytical DtN." << msg::endl; - formulation.galerkin(beta*beta * im * KX[0] * dof(v), tf(v), gammaRight, gauss); - formulation.galerkin(im * w * M * dof(v), tf(v), gammaRight, gauss); - } - - formulation.pre(); - formulation.assemble(); - formulation.solve(); - save(+v, omega, "v"); - save(*solution, omega, "v_exact"); - save(*solution - v, omega, "error"); - std::complex< double > num = integrate(pow(abs(*solution - v), 2), omega, gauss); - std::complex< double > den = integrate(pow(abs(*solution), 2), omega, gauss); - msg::info << "L_2 error = " << 100.*sqrt(num / den) << " %" << msg::endl; - - for(unsigned int i = 0; i < fieldBucket.size(); ++i) { - delete fieldBucket[i]; - } - - return 0; -} diff --git a/examples/helmholtzFlow/Duct_PMLs/CMakeLists.txt b/examples/helmholtzFlow/Duct_PMLs/CMakeLists.txt deleted file mode 100644 index f01d5714177b61745622f922015d7abd78c1cdcf..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/Duct_PMLs/CMakeLists.txt +++ /dev/null @@ -1,8 +0,0 @@ -cmake_minimum_required(VERSION 3.0 FATAL_ERROR) - -project(demo CXX) - -include(${CMAKE_CURRENT_SOURCE_DIR}/../../../demos.cmake) - -add_executable(demo main.cpp ${EXTRA_INCS}) -target_link_libraries(demo ${EXTRA_LIBS}) diff --git a/examples/helmholtzFlow/Duct_PMLs/main.cpp b/examples/helmholtzFlow/Duct_PMLs/main.cpp deleted file mode 100644 index 32ac8ab8a9f4f9af2e3696f229a505dee81ab2c7..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/Duct_PMLs/main.cpp +++ /dev/null @@ -1,216 +0,0 @@ -#include "GmshFem.h" -#include "Formulation.h" -#include "gmsh.h" -#include "AnalyticalFunction.h" - -using namespace gmshfem; -using namespace gmshfem::common; -using namespace gmshfem::problem; -using namespace gmshfem::domain; -using namespace gmshfem::field; -using namespace gmshfem::function; -using namespace gmshfem::analytics; -using namespace gmshfem::post; -using namespace gmshfem::equation; - -int main(int argc, char **argv) -{ - GmshFem gmshFem(argc, argv); - - double L = 0.5; // duct length - gmshFem.userDefinedParameter(L, "L"); - double H = 0.25; // duct height - gmshFem.userDefinedParameter(H, "H"); - int Npml = 4; // number of PML layers - gmshFem.userDefinedParameter(Npml, "Npml"); - - double h = 2*sqrt(L*H)/50; // meshsize - gmshFem.userDefinedParameter(h, "h"); - int MeshOrder = 1; - gmshFem.userDefinedParameter(MeshOrder, "MeshOrder"); - gmsh::model::add("helmholtzflow"); - - // physical duct - gmsh::model::geo::addPoint(L, H, 0., h, 6); - gmsh::model::geo::addPoint(0, H, 0., h, 7); - gmsh::model::geo::addPoint(0, 0, 0., h, 8); - gmsh::model::geo::addPoint(L, 0, 0., h, 9); - - gmsh::model::geo::addLine(6, 7, 5); - gmsh::model::geo::addLine(7, 8, 6); - gmsh::model::geo::addLine(8, 9, 7); - gmsh::model::geo::addLine(9, 6, 8); - gmsh::model::geo::addCurveLoop({5,6,7,8}, 1); - gmsh::model::geo::addPlaneSurface({1}, 1); - gmsh::model::geo::mesh::setTransfiniteSurface(1); - gmsh::model::geo::mesh::setRecombine(1,1); - - // pml extension - gmsh::model::geo::addPoint(L+Npml*h, H, 0., h, 10); - gmsh::model::geo::addPoint(L+Npml*h, 0, 0., h, 11); - gmsh::model::geo::addLine(6, 10, 12); - gmsh::model::geo::addLine(10, 11, 13); - gmsh::model::geo::addLine(11, 9, 14); - - gmsh::model::geo::addCurveLoop({12,13,14,8}, 2); - gmsh::model::geo::addPlaneSurface({2}, 2); - gmsh::model::geo::mesh::setTransfiniteSurface(2); - gmsh::model::geo::mesh::setRecombine(2,2); - - // physical groups - gmsh::model::addPhysicalGroup(2, {1}, 1); - gmsh::model::setPhysicalName(2, 3, "omega"); - gmsh::model::addPhysicalGroup(1, {5}, 2); - gmsh::model::setPhysicalName(1, 2, "gammaTop"); - gmsh::model::addPhysicalGroup(1, {6}, 3); - gmsh::model::setPhysicalName(1, 3, "gammaLeft"); - gmsh::model::addPhysicalGroup(1, {7}, 4); - gmsh::model::setPhysicalName(1, 4, "gammaBottom"); - gmsh::model::addPhysicalGroup(1, {8}, 5); - gmsh::model::setPhysicalName(1, 5, "gammaRight"); - - // pml groups - gmsh::model::addPhysicalGroup(2, {2}, 6); - gmsh::model::setPhysicalName(2, 6, "omegaPml"); - gmsh::model::addPhysicalGroup(1, {12}, 7); - gmsh::model::setPhysicalName(1, 7, "gammaTopPml"); - gmsh::model::addPhysicalGroup(1, {13}, 8); - gmsh::model::setPhysicalName(1, 8, "gammaRightPml"); - gmsh::model::addPhysicalGroup(1, {14}, 9); - gmsh::model::setPhysicalName(1, 9, "gammaBottomPml"); - - // generate mesh - gmsh::model::geo::synchronize(); - gmsh::model::mesh::generate(2); - //gmsh::write("m.msh"); - gmsh::model::mesh::setOrder(MeshOrder); - - //***** - // Problem declaration - //***** - int FEMorder = 4; - gmshFem.userDefinedParameter(FEMorder, "FEMorder"); - std::string gauss = "Gauss10"; - gmshFem.userDefinedParameter(gauss, "gauss"); - std::string problem = "hard"; - gmshFem.userDefinedParameter(problem, "problem"); - std::string PmlType = "Alternative"; // Lorentz, Classic, Alternative - gmshFem.userDefinedParameter(PmlType, "PmlType"); - - double pi = 3.14159265359; - const double k = 70; - const double M = 0.8; - const int n = 3; - - const std::complex< double > im(0., 1.); - double ky = n*pi/H; - double beta = sqrt(1-M*M); - - double sigma = k*k-beta*beta*ky*ky; - std::complex< double > kx; - if (sigma >= 0) { - kx = (1/(beta*beta))*(-M*k + sqrt(sigma)); - msg::info << " propagative mode " << msg::endl; - } - else { - kx = (1/(beta*beta))*(-M*k - im* sqrt(abs(sigma))); - msg::info << " evanescent mode " << msg::endl; - } - - msg::info << "********************************" << msg::endl; - msg::info << " - convected Helmholtz duct problem " << msg::endl; - msg::info << " - wave number = " << k << msg::endl; - msg::info << " - propagating wavenumber = " << kx << msg::endl; - if ( k>(beta*ky) && k<ky ) - { - msg::info << " - inverse upstream mode ! " << msg::endl; - } - unsigned int pointsByWl = (2*pi*FEMorder/k) / h; - msg::info << " - FEM basis order = " << FEMorder << "" << msg::endl; - msg::info << " - Approximate dofs by wavelength = " << pointsByWl << "" << msg::endl; - msg::info << "********************************" << msg::endl; - - Formulation< std::complex< double > > formulation("helmholtzflow"); - Domain omega(2, 1); - Domain omegaPml(2, 6); - Domain gammaTop(1, 2); - Domain gammaLeft(1, 3); - Domain gammaBottom(1, 4); - Domain gammaRight(1, 5); - Domain gammaTopPml(1, 7); - Domain gammaBottomPml(1, 9); - - Field< std::complex< double >, Form::Form0 > v("v", omega | omegaPml | gammaLeft | gammaRight | gammaTop | gammaBottom | gammaTopPml | gammaBottomPml, FunctionSpaceTypeForm0::HierarchicalH1, FEMorder); - // define analytical solution - Function< std::complex< double >, Degree::Degree0 > *solution = nullptr; - if(problem == "soft"){ - v.addConstraint(gammaTop, 0.); - v.addConstraint(gammaBottom, 0.); - v.addConstraint(gammaBottomPml, 0.); - v.addConstraint(gammaTopPml, 0.); - solution = new AnalyticalFunction< helmholtz2D::DuctModeSolution< std::complex< double > > >(k, M, H, 0., 0., n, 1); - } - else { - solution = new AnalyticalFunction< helmholtz2D::DuctModeSolution< std::complex< double > > >(k, M, H, 0., 0., n, 0); - } - solution->activateMemorization(); - - formulation.galerkin(vector< std::complex< double > >(beta*beta, 0., 0.) * grad(dof(v)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omega, gauss); - formulation.galerkin(vector< std::complex< double > >(0., 1., 0.) * grad(dof(v)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(v)), omega, gauss); - - formulation.galerkin(vector< std::complex< double > >(im*k*M, 0., 0.) * grad(dof(v)), tf(v), omega, gauss); - formulation.galerkin(-im*k*M*dof(v), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omega, gauss); - formulation.galerkin(- k * k * dof(v), tf(v), omega, gauss); - - // input BC - if(problem == "soft"){ - formulation.galerkin(-beta*beta * im * kx * (sin(ky * y< std::complex< double > >())) , tf(v), gammaLeft, gauss); - } - else{ - formulation.galerkin(-beta*beta * im * kx * (cos(ky * y< std::complex< double > >())) , tf(v), gammaLeft, gauss); - } - formulation.galerkin(-im * k * M * dof(v), tf(v), gammaLeft, gauss); - - msg::info << "Use a PML" << msg::endl; - msg::info << "PML formulation: " << PmlType << msg::endl; - const double Lpml = L+Npml*h; - double Sigma0 = 4*beta*beta; - // Bermudez function - ScalarFunction< std::complex< double > > SigmaX = Sigma0/(Lpml - x< std::complex< double > >() ); - ScalarFunction< std::complex< double > > gammaX = 1-(im/k)*SigmaX; - ScalarFunction< std::complex< double > > gammaXinv = 1. / gammaX; - - // Different types of PML formulations - if (PmlType == "Classic"){ - formulation.galerkin(vector< std::complex< double > >(gammaXinv*beta*beta, 0., 0.) * grad(dof(v)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(0., gammaX, 0.) * grad(dof(v)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(im*k*M, 0., 0.) * grad(dof(v)), tf(v), omegaPml, gauss); - formulation.galerkin(-im*k*M*dof(v), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(- gammaX*k*k * dof(v), tf(v), omegaPml, gauss); - } - else if(PmlType == "Lorentz"){ - formulation.galerkin(vector< std::complex< double > >(gammaXinv*beta*beta, 0., 0.) * grad(dof(v)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(0., gammaX, 0.) * grad(dof(v)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(gammaXinv*im*k*M, 0., 0.) * grad(dof(v)), tf(v), omegaPml, gauss); - formulation.galerkin(-gammaXinv*im*k*M*dof(v), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(- k*k*(gammaX-gammaXinv*M*M)/(beta*beta) * dof(v), tf(v), omegaPml, gauss); - } - else if(PmlType == "Alternative"){ - formulation.galerkin(vector< std::complex< double > >(gammaXinv*beta*beta, 0., 0.) * grad(dof(v)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(0., gammaX, 0.) * grad(dof(v)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(v)), omegaPml, gauss); - formulation.galerkin(- gammaX*k*k/(beta*beta) * dof(v), tf(v), omegaPml, gauss); - } - - formulation.pre(); - formulation.assemble(); - formulation.solve(); - save(+v, omega, "v"); - save(+v, omegaPml, "vpml"); - save(*solution, omega, "v_exact"); - save(*solution - v, omega, "error"); - std::complex< double > num = integrate(pow(abs(*solution - v), 2), omega, gauss); - std::complex< double > den = integrate(pow(abs(*solution), 2), omega, gauss); - msg::info << "L_2 error = " << 100.*sqrt(num / den) << " %" << msg::endl; - - return 0; -} diff --git a/examples/helmholtzFlow/FreeField/CMakeLists.txt b/examples/helmholtzFlow/FreeField/CMakeLists.txt deleted file mode 100644 index f01d5714177b61745622f922015d7abd78c1cdcf..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/FreeField/CMakeLists.txt +++ /dev/null @@ -1,8 +0,0 @@ -cmake_minimum_required(VERSION 3.0 FATAL_ERROR) - -project(demo CXX) - -include(${CMAKE_CURRENT_SOURCE_DIR}/../../../demos.cmake) - -add_executable(demo main.cpp ${EXTRA_INCS}) -target_link_libraries(demo ${EXTRA_LIBS}) diff --git a/examples/helmholtzFlow/FreeField/main.cpp b/examples/helmholtzFlow/FreeField/main.cpp deleted file mode 100644 index a63b33ac7d6fb961aceeeca426a2aaa10021a250..0000000000000000000000000000000000000000 --- a/examples/helmholtzFlow/FreeField/main.cpp +++ /dev/null @@ -1,564 +0,0 @@ -#include "GmshFem.h" -#include "Formulation.h" -#include "gmsh.h" -#include "AnalyticalFunction.h" - -using namespace gmshfem; -using namespace gmshfem::common; -using namespace gmshfem::problem; -using namespace gmshfem::domain; -using namespace gmshfem::field; -using namespace gmshfem::function; -using namespace gmshfem::analytics; -using namespace gmshfem::post; -using namespace gmshfem::equation; - -struct Edge -{ - Domain gamma; - Domain corner[2]; -}; - -struct HelmholtzDomain -{ - Domain omega; - Domain gammaPhy; - Domain gammaPml; - Domain omegaPml; - Domain source; - Domain corners; - std::vector< Domain > corner; - std::vector< Edge > edge; -}; - -//*************************************** -// GEOMETRY -//*************************************** - -void meshCircle(GmshFem &gmshFem, HelmholtzDomain &domains, const double R, const double Rpml, const double xs, const double ys, const double lc, bool withPml) -{ - gmsh::model::add("geometry"); - - gmsh::model::geo::addPoint(0., 0., 0., lc, 1); // Center - gmsh::model::geo::addPoint(xs, ys, 0., lc, 100); // Source point - // physical circle - gmsh::model::geo::addPoint(R, 0., 0., lc, 2); - gmsh::model::geo::addPoint(0, R, 0., lc, 3); - gmsh::model::geo::addPoint(-R, 0., 0., lc, 4); - gmsh::model::geo::addPoint(0, -R, 0., lc, 5); - - gmsh::model::geo::addCircleArc(2, 1, 3, 1); - gmsh::model::geo::addCircleArc(3, 1, 4, 2); - gmsh::model::geo::addCircleArc(4, 1, 5, 3); - gmsh::model::geo::addCircleArc(5, 1, 2, 4); - gmsh::model::geo::addCurveLoop({1,2,3,4}, 1); - // surface - gmsh::model::geo::addPlaneSurface({1}, 1); - - if(withPml) { - gmsh::model::geo::addPoint(Rpml, 0., 0., lc, 6); - gmsh::model::geo::addPoint(0, Rpml, 0., lc, 7); - gmsh::model::geo::addPoint(-Rpml, 0., 0., lc, 8); - gmsh::model::geo::addPoint(0, -Rpml, 0., lc, 9); - - gmsh::model::geo::addCircleArc(6, 1, 7, 5); - gmsh::model::geo::addCircleArc(7, 1, 8, 6); - gmsh::model::geo::addCircleArc(8, 1, 9, 7); - gmsh::model::geo::addCircleArc(9, 1, 6, 8); - gmsh::model::geo::addCurveLoop({5,6,7,8}, 2); - gmsh::model::geo::addPlaneSurface({1,2}, 2); - } - gmsh::model::geo::synchronize(); - gmsh::model::mesh::embed(0,{100},2,1); - - // physicals - gmsh::model::addPhysicalGroup(2, {1}, 1); - gmsh::model::setPhysicalName(2, 1, "omega"); - gmsh::model::addPhysicalGroup(1, {1,2,3,4}, 3); - gmsh::model::setPhysicalName(1, 3, "gammaPhy"); - gmsh::model::addPhysicalGroup(0, {100}, 100); - gmsh::model::setPhysicalName(0, 100, "source"); - if(withPml) { - gmsh::model::addPhysicalGroup(2, {2}, 2); - gmsh::model::setPhysicalName(2, 2, "omegaPml"); - gmsh::model::addPhysicalGroup(1, {5,6,7,8}, 4); - gmsh::model::setPhysicalName(1, 4, "gammaPml"); - } - - // generate mesh - gmsh::model::geo::synchronize(); - gmsh::model::mesh::generate(2); - // gmsh::model::mesh::setOrder(2); // T6 elem - // gmsh::write("m.msh"); - - // Domains - domains.omega = Domain(2, 1); - domains.gammaPhy = Domain(1, 3); - domains.source = Domain(0, 100); - - if(withPml) { - domains.omegaPml = Domain(2, 2); - domains.gammaPml = Domain(1, 4); - } -} - -void meshSquare(GmshFem &gmshFem, HelmholtzDomain &domains, const double L, const double Lpml, const double xs, const double ys, const double lc, bool withPml) -{ - gmsh::model::add("geometry"); - - gmsh::model::geo::addPoint(0., 0., 0., lc, 1); // Center - gmsh::model::geo::addPoint(xs, ys, 0., lc, 100); // Source point - - // polygone - gmsh::model::geo::addPoint(L, L, 0., lc, 2); - gmsh::model::geo::addPoint(-L, L, 0., lc, 3); - gmsh::model::geo::addPoint(-L, -L, 0., lc, 4); - gmsh::model::geo::addPoint(L, -L, 0., lc, 5); - - gmsh::model::geo::addLine(2, 3, 1); - gmsh::model::geo::addLine(3, 4, 2); - gmsh::model::geo::addLine(4, 5, 3); - gmsh::model::geo::addLine(5, 2, 4); - - gmsh::model::geo::addCurveLoop({1,2,3,4}, 1); - gmsh::model::geo::addPlaneSurface({1}, 1); - - if(withPml) { - gmsh::model::geo::addPoint(Lpml, Lpml, 0., lc, 6); - gmsh::model::geo::addPoint(-Lpml, Lpml, 0., lc, 7); - gmsh::model::geo::addPoint(-Lpml, -Lpml, 0., lc, 8); - gmsh::model::geo::addPoint(Lpml, -Lpml, 0., lc, 9); - - gmsh::model::geo::addLine(6, 7, 5); - gmsh::model::geo::addLine(7, 8, 6); - gmsh::model::geo::addLine(8, 9, 7); - gmsh::model::geo::addLine(9, 6, 8); - - gmsh::model::geo::addCurveLoop({5,6,7,8}, 2); - gmsh::model::geo::addPlaneSurface({1,2}, 2); - } - gmsh::model::geo::synchronize(); - gmsh::model::mesh::embed(0,{100},2,1); - // physicals - gmsh::model::addPhysicalGroup(2, {1}, 1); - gmsh::model::setPhysicalName(2, 1, "omega"); - gmsh::model::addPhysicalGroup(1, {1,2,3,4}, 3); - gmsh::model::setPhysicalName(1, 3, "gammaPhy"); - gmsh::model::addPhysicalGroup(0, {100}, 100); - gmsh::model::setPhysicalName(0, 100, "source"); - // Physical edges - gmsh::model::addPhysicalGroup(1, {1}, 20); - gmsh::model::setPhysicalName(1, 20, "gammaPhy_top"); - gmsh::model::addPhysicalGroup(1, {2}, 30); - gmsh::model::setPhysicalName(1, 30, "gammaPhy_left"); - gmsh::model::addPhysicalGroup(1, {3}, 40); - gmsh::model::setPhysicalName(1, 40, "gammaPhy_bottom"); - gmsh::model::addPhysicalGroup(1, {4}, 50); - gmsh::model::setPhysicalName(1, 50, "gammaPhy_right"); - // Physical domain corners - gmsh::model::addPhysicalGroup(0, {2}, 2); - gmsh::model::setPhysicalName(0, 2, "UpRightCorner"); - gmsh::model::addPhysicalGroup(0, {3}, 3); - gmsh::model::setPhysicalName(0, 3, "UpLeftCorner"); - gmsh::model::addPhysicalGroup(0, {4}, 4); - gmsh::model::setPhysicalName(0, 4, "BottomLeftCorner"); - gmsh::model::addPhysicalGroup(0, {5}, 5); - gmsh::model::setPhysicalName(0, 5, "BottomRightCorner"); - if(withPml) { - gmsh::model::addPhysicalGroup(2, {2}, 2); - gmsh::model::setPhysicalName(2, 2, "omegaPml"); - gmsh::model::addPhysicalGroup(1, {5,6,7,8}, 4); - gmsh::model::setPhysicalName(1, 4, "gammaPml"); - } - - // generate mesh - gmsh::model::geo::synchronize(); - gmsh::model::mesh::generate(2); - //gmsh::model::mesh::setOrder(2); // T6 elem - // gmsh::write("m.msh"); - - // Domains - domains.omega = Domain(2, 1); - domains.gammaPhy = Domain(1, 3); - domains.source = Domain(0, 100); - - if(withPml) { - domains.omegaPml = Domain(2, 2); - domains.gammaPml = Domain(1, 4); - } - domains.edge.resize(4); - domains.corner.resize(4); - for(int i = 0; i < 4; ++i) { - domains.edge[i].gamma = Domain(1, 10*(i + 2) ); - domains.edge[i].corner[0] = Domain(0, i + 2 ); - domains.edge[i].corner[1] = Domain(0, (i + 1) % 4 + 2 ); - - domains.corner[i] = Domain(0, i + 2); - - domains.corners |= domains.edge[i].corner[0]; - domains.gammaPhy |= domains.edge[i].gamma; - } -} - -//*************************************** -// FORMULATION -//*************************************** - -int main(int argc, char **argv) -{ - GmshFem gmshFem(argc, argv); - - // geometry parameters - int geometry = 0; // 0-circle, 1-square - gmshFem.userDefinedParameter(geometry, "geometry"); - double R = 1.0; // Circle radius or square of size [-R,R] x [-R,R] - gmshFem.userDefinedParameter(R, "R"); - // Point source location - double xs = 0.3; - double ys = 0.2; - gmshFem.userDefinedParameter(xs, "xs"); - gmshFem.userDefinedParameter(ys, "ys"); - msg::info << "Point source located at xs=" << xs << ", ys=" << ys << msg::endl; - - // physical parameters - const double pi = 3.14159265358979323846264338327950288; - const double k = 3 * pi; // free field wavenumber - const std::complex< double > im(0., 1.); - double M = 0.; // Mach number - gmshFem.userDefinedParameter(M, "M"); - double theta = pi/4; // mean flow orientation - gmshFem.userDefinedParameter(theta, "theta"); - msg::info << "Mach number " << M << " oriented at theta=" << theta << " rad" << msg::endl; - - // numerical parameters - int order = 4; // FEM shape function order - gmshFem.userDefinedParameter(order, "order"); - std::string gauss = "Gauss10"; // increase Nr of Gauss points when order > 6 - double lc = 0.03; // mesh size - gmshFem.userDefinedParameter(lc, "lc"); - - // Choose ABC - exterior boundary condition - std::string abcName = "Pade"; // available choices: ABC-0, ABC-2, Pade, pml - gmshFem.userDefinedParameter(abcName, "abcName"); - int Npml; - double Rpml; - if (abcName == "pml") { // PML parameters - Npml = 4; // number of layers - gmshFem.userDefinedParameter(Npml, "Npml"); - Rpml = R+Npml*lc; // extended domain - } - - HelmholtzDomain domains; - - switch (geometry) { - case 0: - meshCircle(gmshFem, domains, R, Rpml, xs, ys, lc, abcName == "pml"); - break; - case 1: - meshSquare(gmshFem, domains, R, Rpml, xs, ys, lc, abcName == "pml"); - break; - default: - msg::error << "geometry not available ! " << msg::endl; - exit(0); - break; - } - - float pointsByWl = (2*pi*order*(1-abs(M)))/(lc*k); - msg::info << " - FEM basis order = " << order << "" << msg::endl; - msg::info << " - Smallest number of dofs by wavelength = " << pointsByWl << "" << msg::endl; - if (pointsByWl < 6) { - msg::warning << " - Less than 6 points per wavelength ! " << msg::endl; - } - - // Mach number projections - double Mx = M*std::cos(theta); - double My = M*std::sin(theta); - // Mach-velocity vector - VectorFunction< std::complex< double > > MM = vector< std::complex< double > > (Mx,My,0.); - // Normal and tangential projections - ScalarFunction< std::complex< double > > Mn = vector< std::complex< double > > (Mx,My,0.)*normal< std::complex< double > >(); - ScalarFunction< std::complex< double > > Mt = vector< std::complex< double > > (Mx,My,0.)*tangent< std::complex< double > >(); - // Parameters for Inverse Lorentz transformation - double beta = sqrt(1-M*M); // Jacobian - double Alphax = 1 + Mx*Mx/(beta*(1+beta)); - double Alphay = 1 + My*My/(beta*(1+beta)); - double K = Mx*My/(beta*(1+beta)); - // Tensor of the Inverse Lorentz transformation - TensorFunction< std::complex< double > > Linv = tensor< std::complex <double > > (beta*Alphay, -beta*K, 0., -beta*K, beta*Alphax,0.,0.,0.,0.); - - std::vector< FieldInterface< std::complex< double > > * > fieldBucket; - Formulation< std::complex< double > > formulation("helmholtzflow"); - Field< std::complex< double >, Form::Form0 > u("u", domains.omega | domains.omegaPml | domains.gammaPhy | domains.gammaPml | domains.corners | domains.source, FunctionSpaceTypeForm0::HierarchicalH1, order); - - // Define analytic solution - Function< std::complex< double >, Degree::Degree0 > *solution = nullptr; - solution = new AnalyticalFunction< helmholtz2D::MonopoleFreeField< std::complex< double > > >(k, M, theta, 1., xs, ys, 0., 0.); - solution->activateMemorization(); - - // convected Helmholz weak form - formulation.galerkin(vector< std::complex< double > >(1-Mx*Mx, -Mx*My, 0.) * grad(dof(u)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(u)), domains.omega, gauss); - formulation.galerkin(vector< std::complex< double > >(-Mx*My, 1-My*My, 0.) * grad(dof(u)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(u)), domains.omega, gauss); - formulation.galerkin(- k * k * dof(u), tf(u), domains.omega, gauss); - formulation.galerkin(dof(u), vector< std::complex< double > >(-im*k*Mx,-im*k*My, 0.) * grad(tf(u)), domains.omega, gauss); - formulation.galerkin(vector< std::complex< double > >(im*k*Mx, im*k*My, 0.) * grad(dof(u)), tf(u), domains.omega, gauss); - - // Source point - formulation.galerkin(-1.,tf(u),domains.source,gauss); - - // Exact DtN: beta_n**2 * kx = - Mn * (k0 - Mt*ky) + sqrt( k0**2 -2*k0*Mt*ky - (1-abs(M))^2 ky**2 ) - if(abcName == "ABC-0") { // zeroth order Taylor approximation - // boundary contributions - formulation.galerkin(im*k*Mn * dof(u), tf(u), domains.gammaPhy, gauss); - formulation.galerkin(Mn*Mt * tangent< std::complex< double > >() * grad(dof(u)), dof(u), domains.gammaPhy, gauss); - // ABC - msg::info << "Use zeroth order ABC" << msg::endl; - formulation.galerkin(im*k*(1-Mn) * dof(u), tf(u), domains.gammaPhy, gauss); - formulation.galerkin(-Mn*Mt * tangent< std::complex< double > >() * grad(dof(u)), dof(u), domains.gammaPhy, gauss); - } - else if (abcName == "ABC-2") { - // boundary contributions - formulation.galerkin(im*k*Mn * dof(u), tf(u), domains.gammaPhy, gauss); - formulation.galerkin(Mn*Mt * tangent< std::complex< double > >() * grad(dof(u)), dof(u), domains.gammaPhy, gauss); - // ABC - msg::info << "Use second order ABC" << msg::endl; - // zeroth order contribution - formulation.galerkin(im*k*(1-Mn) * dof(u), tf(u), domains.gammaPhy, gauss); - // first order contribution - formulation.galerkin( (1-Mn) * Mt * tangent< std::complex< double > >() * grad(dof(u)), dof(u), domains.gammaPhy, gauss); - // second order contribution - formulation.galerkin(- im * (beta*beta) /(2*k) * grad(dof(u)), grad(tf(u)), domains.gammaPhy, gauss); - } - else if (abcName == "Pade") { - int padeOrder = 2; - gmshFem.userDefinedParameter(padeOrder, "padeOrder"); - double angle = -pi/4.; - gmshFem.userDefinedParameter(angle, "angle"); - msg::info << "Use Pade ABC of order " << padeOrder << " with angle " << angle << " rad"<< msg::endl; - - const double Np = 2. * padeOrder + 1.; - const std::complex< double > exp1 = std::complex<double>(std::cos(angle),std::sin(angle)); - const std::complex< double > exp2 = std::complex<double>(std::cos(angle/2.),std::sin(angle/2.)); - const std::complex< double > coef = 2./Np; - std::vector< std::complex< double > > c(padeOrder, 0.); - for(int i = 0; i < padeOrder; ++i) { - c[i] = std::tan((i + 1) * pi / Np); - c[i] *= c[i]; - } - - if(geometry == 0) { - // define the auxiliary fields - std::vector< Field< std::complex< double >, Form::Form0 >* > phi; - for(int i = 0; i < padeOrder; ++i) { - phi.push_back(new Field< std::complex< double >, Form::Form0 >("phi_" + std::to_string(i), domains.gammaPhy, FunctionSpaceTypeForm0::HierarchicalH1, order)); - fieldBucket.push_back(phi.back()); - } - - // write the augmented weak form - approximation of the square-root - formulation.galerkin( im * k * exp2 * dof(u), tf(u), domains.gammaPhy, gauss); - for(int i = 0; i < padeOrder; ++i) { - // boundary integral terms relating the auxiliary fields - formulation.galerkin( im * k * exp2 * coef * c[i] * dof(*phi[i]), tf(u), domains.gammaPhy, gauss); - formulation.galerkin( im * k * exp2 * coef * c[i] * dof(u), tf(u), domains.gammaPhy, gauss); - - // coupling of the auxiliary equations - formulation.galerkin(- (beta*beta) * grad(dof(*phi[i])), grad(tf(*phi[i])), domains.gammaPhy, gauss); - formulation.galerkin(- 2. * im * k * Mt * tangent< std::complex< double > >() * grad(dof(*phi[i])), tf(*phi[i]), domains.gammaPhy, gauss); - formulation.galerkin( (k*k) * (exp1 * c[i] + 1.) * dof(*phi[i]), tf(*phi[i]), domains.gammaPhy, gauss); - formulation.galerkin( (k*k) * exp1 * (c[i] + 1.) * dof(u), tf(*phi[i]), domains.gammaPhy, gauss); - } - } - else if(geometry == 1) { - // define the auxilary fields - std::vector< Field< std::complex< double >, Form::Form0 > * > phi[4]; - for(int x = 0; x < 4; ++x) { - for(int i = 0; i < padeOrder; ++i) { - phi[x].push_back(new Field< std::complex< double >, Form::Form0 >("phi_" + std::to_string(i) + "^" + std::to_string(x), domains.edge[x].gamma | domains.edge[x].corner[0] | domains.edge[x].corner[1], FunctionSpaceTypeForm0::HierarchicalH1,order)); - fieldBucket.push_back(phi[x].back()); - } - } - - formulation.galerkin( im * k * exp2 * dof(u), tf(u), domains.gammaPhy, gauss); - for(int x = 0; x < 4; ++x) { - for(int i = 0; i < padeOrder; ++i) { - // Boundary conditions - formulation.galerkin( im * k * exp2 * coef * c[i] * dof(*phi[x][i]), tf(u), domains.edge[x].gamma, gauss); - formulation.galerkin( im * k * exp2 * coef * c[i] * dof(u), tf(u), domains.edge[x].gamma, gauss); - - // Auxiliary equations - formulation.galerkin(- (beta*beta) * grad(dof(*phi[x][i])), grad(tf(*phi[x][i])), domains.edge[x].gamma, gauss); - formulation.galerkin(- 2. * im * k * Mt * tangent< std::complex< double > >() * grad(dof(*phi[x][i])), tf(*phi[x][i]), domains.edge[x].gamma, gauss); - formulation.galerkin( (k*k) * (exp1 * c[i] + 1.) * dof(*phi[x][i]), tf(*phi[x][i]), domains.edge[x].gamma, gauss); - formulation.galerkin( (k*k) * exp1 * (c[i] + 1.) * dof(u), tf(*phi[x][i]), domains.edge[x].gamma, gauss); - } - } - - bool withCorner = true; - gmshFem.userDefinedParameter(withCorner, "withCorner"); - std::string CornerStrategy = "Sommerfeld"; // Sommerfeld or HABC - gmshFem.userDefinedParameter(CornerStrategy, "CornerStrategy"); - - if(withCorner) { - msg::info << "with corner treatment" << msg::endl; - msg::info << "use " << CornerStrategy << " condition at corners" << msg::endl; - // define the corner fields - std::vector< std::vector< std::vector< Field< std::complex< double >, Form::Form0 > * > > > corner_phi(4); - for(int k = 0; k < 4; ++k) { - corner_phi[k].resize(padeOrder); - for(int i = 0; i < padeOrder; ++i) { - for(int j = 0; j < padeOrder; ++j) { - corner_phi[k][i].push_back(new Field< std::complex< double >, Form::Form0 >("corner_phi_(" + std::to_string(i) + ", " + std::to_string(j) + ")^(" + std::to_string(k) + ")", domains.corner[k], FunctionSpaceTypeForm0::HierarchicalH1,order)); - fieldBucket.push_back(corner_phi[k][i].back()); - } - } - } - - for(int ci = 0; ci < 4; ++ci) { - int x = ci; - int y = (ci - 1 < 0 ? 4 - 1 : ci - 1); - for(int i = 0; i < padeOrder; ++i) { - if (CornerStrategy == "Sommerfeld"){ - // strategy 1 - Sommerfeld condition at corners - formulation.galerkin(- im * k * dof(*phi[x][i]), tf(*phi[x][i]), domains.corner[ci], gauss); - formulation.galerkin(- im * k * dof(*phi[y][i]), tf(*phi[y][i]), domains.corner[ci], gauss); - } - - else if (CornerStrategy == "HABC") { - // strategy 2 - HABC at corners - formulation.galerkin(- im * k * exp2 * dof(*phi[x][i]), tf(*phi[x][i]), domains.corner[ci], gauss); - formulation.galerkin(- im * k * exp2 * dof(*phi[y][i]), tf(*phi[y][i]), domains.corner[ci], gauss); - for(int j = 0; j < padeOrder; ++j) { - // Auxiliary equations for corner - formulation.galerkin( (exp1*c[i] + exp1*c[j] + 1.) * dof(*corner_phi[ci][i][j]), tf(*corner_phi[ci][i][j]), domains.corner[ci], gauss); - formulation.galerkin( exp1 * (c[j] + 1.) * dof(*phi[x][i]), tf(*corner_phi[ci][i][j]), domains.corner[ci], gauss); - formulation.galerkin( exp1 * (c[i] + 1.) * dof(*phi[y][j]), tf(*corner_phi[ci][i][j]), domains.corner[ci], gauss); - - // Corner conditions - formulation.galerkin(- im * k * exp2 * coef * c[j] * dof(*phi[x][i]), tf(*phi[x][i]), domains.corner[ci], gauss); - formulation.galerkin(- im * k * exp2 * coef * c[j] * dof(*phi[y][i]), tf(*phi[y][i]), domains.corner[ci], gauss); - formulation.galerkin(- im * k * exp2 * coef * c[j] * dof(*corner_phi[ci][i][j]), tf(*phi[x][i]), domains.corner[ci], gauss); - formulation.galerkin(- im * k * exp2 * coef * c[j] * dof(*corner_phi[ci][j][i]), tf(*phi[y][i]), domains.corner[ci], gauss); - } - } - else { - msg::error << "Corner strategy not available !" << msg::endl; - exit(0); - } - } - } - } - } - } - else if (abcName == "pml") { - msg::info << "Use a PML with " << Npml << " layers" << msg::endl; - double Sigma0 = beta; - ScalarFunction< std::complex< double > > det_J; - TensorFunction< std::complex< double > > J_PML_inv_T; - const double Wpml = Rpml - R; - if (geometry == 0) { - msg::info << "stabilized PML - circular domain" << msg::endl; - msg::info << "use unbounded absorbing function with sigma_0 = " << Sigma0 << msg::endl; - ScalarFunction< std::complex< double > > cosT = x< std::complex< double > >() / r2d< std::complex< double > >(); - ScalarFunction< std::complex< double > > sinT = y< std::complex< double > >() / r2d< std::complex< double > >(); - ScalarFunction< std::complex< double > > dampingProfileR = Sigma0 / (Wpml - (r2d< std::complex< double > >() - R)); - ScalarFunction< std::complex< double > > dampingProfileInt = -Sigma0*ln((Wpml - (r2d< std::complex< double > >() - R)) / Wpml); - ScalarFunction< std::complex< double > > gamma = 1. - im * dampingProfileR / k; - ScalarFunction< std::complex< double > > gamma_hat = 1. - im * (1. / r2d< std::complex< double > >()) * dampingProfileInt / k; - det_J = gamma * gamma_hat; - J_PML_inv_T = tensor< std::complex <double > >(cosT/gamma,sinT/gamma,0.,-sinT/gamma_hat,cosT/gamma_hat,0.,0.,0.,0.); - } - else if (geometry == 1) { - msg::info << "stabilized PML - square domain" << msg::endl; - msg::info << "use unbounded absorbing function with sigma_0 = " << Sigma0 << msg::endl; - ScalarFunction< std::complex< double > > SigmaX = heaviside(abs(x< std::complex< double > >()) - R ) * Sigma0/(Rpml - abs(x< std::complex< double > >()) ); - ScalarFunction< std::complex< double > > gammaX = 1-(im/k)*SigmaX; - ScalarFunction< std::complex< double > > SigmaY = heaviside(abs(y< std::complex< double > >()) - R ) * Sigma0/(Rpml - abs(y< std::complex< double > >()) ); - ScalarFunction< std::complex< double > > gammaY = 1-(im/k)*SigmaY; - det_J = gammaX * gammaY; - J_PML_inv_T = tensor< std::complex <double > >(1./gammaX,0.,0.,0.,1./gammaY,0.,0.,0.,0.); - - /* - msg::info << "classical PML - square domain - unstable ! " << msg::endl; - formulation.galerkin(vector< std::complex< double > >((gammaY/gammaX)*(1-Mx*Mx), -Mx*My, 0.) * grad(dof(u)), vector< std::complex< double > >(1., 0., 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(-Mx*My, (gammaX/gammaY)*(1-My*My), 0.) * grad(dof(u)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin(dof(u), vector< std::complex< double > >(-gammaY*im*k*Mx,-gammaX*im*k*My, 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin(vector< std::complex< double > >(gammaY*im*k*Mx, gammaX*im*k*My, 0.) * grad(dof(u)), tf(u), domains.omegaPml, gauss); - formulation.galerkin(- k*k* gammaX*gammaY * dof(u), tf(u), domains.omegaPml, gauss); - */ - - /* - msg::info << "Alternative stable PML - square domain only " << msg::endl; - ScalarFunction< std::complex< double > > Ax = (gammaY/gammaX)*(1-Mx*Mx); - std::complex< double > Cx =-im*k*Mx*( 1 - (My*My)/(1-Mx*Mx) ) / (beta*beta); - double Ka = -Mx*My/(1-Mx*Mx); - ScalarFunction< std::complex< double > > Ay = (gammaX/gammaY)*( 1 - (My*My)/(1-Mx*Mx) ); - std::complex< double > Cy = -im*k*My/(beta*beta); - - // modified bilinear term in dx - formulation.galerkin( Ax * vector< std::complex< double > >(1. , Ka, 0.) * grad(dof(u)), vector< std::complex< double > >(1., Ka, 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin( Ax * Cx * dof(u), vector< std::complex< double > >(1., Ka, 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin( Ax * (-Cx) * vector< std::complex< double > >(1. , Ka, 0.) * grad(dof(u)), tf(u), domains.omegaPml, gauss); - formulation.galerkin( Ax * Cx * (-Cx) *dof(u), tf(u), domains.omegaPml, gauss); - // modified bilinear term in dy - formulation.galerkin( Ay * vector< std::complex< double > >(0. , 1., 0.) * grad(dof(u)), vector< std::complex< double > >(0., 1., 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin( Ay * Cy * dof(u), vector< std::complex< double > >(0., 1., 0.) * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin( Ay * vector< std::complex< double > >(0. , -Cy, 0.) * grad(dof(u)), tf(u), domains.omegaPml, gauss); - formulation.galerkin( Ay * Cy * (-Cy) *dof(u), tf(u), domains.omegaPml, gauss); - // - formulation.galerkin(- k*k/(beta*beta) * gammaX*gammaY * dof(u), tf(u), domains.omegaPml, gauss); - */ - } - // build vector and matrix for the weak form - VectorFunction< std::complex< double > > J_PML_inv_T_M = J_PML_inv_T * MM; - TensorFunction< std::complex< double > > J_PML_Linv = J_PML_inv_T * Linv; - // stabilized PML weak form - valid for a general domain - formulation.galerkin( det_J * J_PML_Linv*grad(dof(u)) , J_PML_Linv*grad(tf(u)) , domains.omegaPml, gauss); - - formulation.galerkin(+ k*k/(beta*beta) * det_J * J_PML_inv_T_M * dof(u) , J_PML_inv_T_M * tf(u), domains.omegaPml, gauss); - formulation.galerkin(+ im*k/beta* det_J * J_PML_Linv * grad(dof(u)), J_PML_inv_T_M * tf(u), domains.omegaPml, gauss); - - formulation.galerkin(- im*k/beta* det_J * J_PML_inv_T_M * dof(u), J_PML_Linv * grad(tf(u)), domains.omegaPml, gauss); - formulation.galerkin(- k*k/(beta*beta) * det_J * dof(u), tf(u), domains.omegaPml, gauss); - } - else { - msg::error << "ABC Type not available !" << msg::endl; - exit(0); - } - - // solve - formulation.pre(); - formulation.assemble(); - formulation.solve(); - - // compute the projection of the analytic solution on the FEM basis - best FEM approximation - Formulation< std::complex< double > > projection("helmholtzflow"); - Field< std::complex< double >, Form::Form0 > uP("uP", domains.omega, FunctionSpaceTypeForm0::HierarchicalH1, order); - projection.galerkin( -dof(uP), tf(uP), domains.omega, gauss); - projection.galerkin( *solution, tf(uP), domains.omega, gauss); - - msg::info << "Compute best approximation... " << msg::endl; - projection.pre(); - projection.assemble(); - projection.solve(); - - // save results and compute errors - save(+u, domains.omega, "u"); - save(+uP, domains.omega, "uP"); - if (abcName == "pml"){ - save(+u, domains.omegaPml, "u_pml"); - } - save(*solution, domains.omega, "u_exact"); - save(*solution - u, domains.omega, "error"); - - std::complex< double > num = integrate(pow(abs(*solution - u), 2), domains.omega, gauss); - std::complex< double > numP = integrate(pow(abs(*solution - uP), 2), domains.omega, gauss); - std::complex< double > den = integrate(pow(abs(*solution), 2), domains.omega, gauss); - msg::info << "L_2 error = " << 100.*sqrt(num / den) << " %" << msg::endl; - msg::info << "Best L_2 error = " << 100.*sqrt(numP / den) << " %" << msg::endl; - msg::warning << "L_2 error should exclude neighbourhood elements to the point source" << msg::endl; - - for(unsigned int i = 0; i < fieldBucket.size(); ++i) { - delete fieldBucket[i]; - } - - return 0; -} diff --git a/demos/hierarchical/helmholtzDuctHeteroX/CMakeLists.txt b/examples/helmholtzFlow/helmholtzDuctHeteroX/CMakeLists.txt similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroX/CMakeLists.txt rename to examples/helmholtzFlow/helmholtzDuctHeteroX/CMakeLists.txt diff --git a/demos/hierarchical/helmholtzDuctHeteroX/main.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroX/main.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroX/main.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroX/main.cpp diff --git a/demos/hierarchical/helmholtzDuctHeteroX/main_loop_length.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroX/main_loop_length.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroX/main_loop_length.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroX/main_loop_length.cpp diff --git a/demos/hierarchical/helmholtzDuctHeteroX/main_loop_omega.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroX/main_loop_omega.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroX/main_loop_omega.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroX/main_loop_omega.cpp diff --git a/demos/hierarchical/helmholtzDuctHeteroY/CMakeLists.txt b/examples/helmholtzFlow/helmholtzDuctHeteroY/CMakeLists.txt similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroY/CMakeLists.txt rename to examples/helmholtzFlow/helmholtzDuctHeteroY/CMakeLists.txt diff --git a/demos/hierarchical/helmholtzDuctHeteroY/main.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroY/main.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroY/main.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroY/main.cpp diff --git a/demos/hierarchical/helmholtzDuctHeteroY/main_loop_length.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroY/main_loop_length.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroY/main_loop_length.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroY/main_loop_length.cpp diff --git a/demos/hierarchical/helmholtzDuctHeteroY/main_loop_omega.cpp b/examples/helmholtzFlow/helmholtzDuctHeteroY/main_loop_omega.cpp similarity index 100% rename from demos/hierarchical/helmholtzDuctHeteroY/main_loop_omega.cpp rename to examples/helmholtzFlow/helmholtzDuctHeteroY/main_loop_omega.cpp diff --git a/demos/hierarchical/helmholtzflow/Duct_ABCs/main_omega.cpp b/examples/helmholtzFlow/helmholtzflow/Duct_ABCs/main_omega.cpp similarity index 100% rename from demos/hierarchical/helmholtzflow/Duct_ABCs/main_omega.cpp rename to examples/helmholtzFlow/helmholtzflow/Duct_ABCs/main_omega.cpp diff --git a/demos/hierarchical/helmholtzflow/Duct_HeteroX/CMakeLists.txt b/examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/CMakeLists.txt similarity index 100% rename from demos/hierarchical/helmholtzflow/Duct_HeteroX/CMakeLists.txt rename to examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/CMakeLists.txt diff --git a/demos/hierarchical/helmholtzflow/Duct_HeteroX/main.cpp b/examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/main.cpp similarity index 100% rename from demos/hierarchical/helmholtzflow/Duct_HeteroX/main.cpp rename to examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/main.cpp diff --git a/demos/hierarchical/helmholtzflow/Duct_HeteroX/main_loop_omega.cpp b/examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/main_loop_omega.cpp similarity index 100% rename from demos/hierarchical/helmholtzflow/Duct_HeteroX/main_loop_omega.cpp rename to examples/helmholtzFlow/helmholtzflow/Duct_HeteroX/main_loop_omega.cpp diff --git a/demos/hierarchical/helmholtzflow/FlowPastCylinder/CMakeLists.txt b/examples/helmholtzFlow/helmholtzflow/FlowPastCylinder/CMakeLists.txt similarity index 100% rename from demos/hierarchical/helmholtzflow/FlowPastCylinder/CMakeLists.txt rename to examples/helmholtzFlow/helmholtzflow/FlowPastCylinder/CMakeLists.txt diff --git a/demos/hierarchical/helmholtzflow/FlowPastCylinder/main.cpp b/examples/helmholtzFlow/helmholtzflow/FlowPastCylinder/main.cpp similarity index 100% rename from demos/hierarchical/helmholtzflow/FlowPastCylinder/main.cpp rename to examples/helmholtzFlow/helmholtzflow/FlowPastCylinder/main.cpp diff --git a/demos/hierarchical/helmholtzflow/FreeField/runTests_circle.sh b/examples/helmholtzFlow/helmholtzflow/FreeField/runTests_circle.sh similarity index 100% rename from demos/hierarchical/helmholtzflow/FreeField/runTests_circle.sh rename to examples/helmholtzFlow/helmholtzflow/FreeField/runTests_circle.sh diff --git a/demos/hierarchical/helmholtzflow/FreeField/runTests_square.sh b/examples/helmholtzFlow/helmholtzflow/FreeField/runTests_square.sh similarity index 100% rename from demos/hierarchical/helmholtzflow/FreeField/runTests_square.sh rename to examples/helmholtzFlow/helmholtzflow/FreeField/runTests_square.sh