C ALGORITHM 788, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 4, December, 1998, P. 395--417. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/Makefile # Doc/README # Fortran77/ # Fortran77/Drivers/ # Fortran77/Drivers/Dp/ # Fortran77/Drivers/Dp/RES1 # Fortran77/Drivers/Dp/RES2 # Fortran77/Drivers/Dp/data1 # Fortran77/Drivers/Dp/data2 # Fortran77/Drivers/Dp/driver1.f # Fortran77/Drivers/Dp/driver2.f # Fortran77/Src/ # Fortran77/Src/Dp/ # Fortran77/Src/Dp/d1mach.f # Fortran77/Src/Dp/drchlt.f # Fortran77/Src/Dp/lasys.f # Fortran77/Src/Dp/neuman.f # Fortran77/Src/Dp/rfft_pack.f # This archive created: Thu Mar 25 10:54:25 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' FFLAGS= -sloppy -C -d5 -g -temp=/tmp -u FC=epcf90 OBJS = d1mach.o lasys.o rfft_pack.o neuman : $(OBJS) neuman.o driver1.o $(FC) $(FFLAGS) $(OBJS) neuman.o driver1.o -o driver1 driver1 < data1 drchlt : $(OBJS) drchlt.o driver2.o $(FC) $(FFLAGS) $(OBJS) drchlt.o driver2.o -o driver2 driver2 < data2 SHAR_EOF fi # end of overwriting check if test -f 'README' then echo shar: will not over-write existing file "'README'" else cat << SHAR_EOF > 'README' SOLVING LAPLACE'S EQUATION IN TWO DIMENSIONS USING BOUNDARY INTEGRAL EQUATIONS This is a very brief discussion of the programs "drchlt.f" and "neuman.f", for solving the Dirichlet problem and the Neumann problem for Laplace's equation in two dimensions. For complete details, see the following associated paper. K. Atkinson & Y. Jeon, "Automatic boundary integral equation programs for the planar Laplace equation", ACM Transactions on Mathematical Software. The featured programs are named "drchlt.f" and "neuman.f", and the associated test driver programs are named "drchlt_driver.f" and "neuman_driver.f". You will also need the files "d1mach.f" and "lasys.f", with the latter containing needed codes from LAPACK. If you have access to LAPACK separately, you do not need "lasys.f". For "neuman.f", you will need in addition the file "rfft_pack.f". These files are all provided here. The program "d1mach.f", as given, is configured for the workstations given later in this document; and it may need to be reconfigured for other machines. The most up-to-date version of "d1mach.f" can be obtained from the Netlib archive at the web site http://www.netlib.ornl.gov All of our programs are written in Fortran in double precision. Two sample input data files are included, and they are identifiable with the suffix "data". The corresponding output files are also given, and they are easily identifiable from their names and the suffix "ans.orig". The programs have been compiled and run on 4 types of workstations and also under MS Fortran on a PC. The workstations used are as follows. SGI O2 Fortran 90 HP C200 Fortran 90 HP 720 Fortran 90 IBM RS/6000 Fortran 77 The output files supplied by the authors were computed on the HP C200. The programs were compiled and linked with the default options for the Hewlett-Packard Fortran 90 compiler. For additional information on the use of these programs, please feel free to contact the authors at the following e_mail addresses: Kendall-Atkinson@uiowa.edu yjeon@madang.ajou.ac.kr In addition, see the web site URL http://www.math.uiowa.edu/~atkinson/laplace.html Corrections and updates will be noted here. Date of current code: 7 April 1998 SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Fortran77' then mkdir 'Fortran77' fi cd 'Fortran77' if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'RES1' then echo shar: will not over-write existing file "'RES1'" else cat << SHAR_EOF > 'RES1' BOUNDARY PARAMETERS: A= 1.0000 B= 4.0000 EPS= 1.000D-07 BOUNDARY FUNCTION 3 CURVE 1 NTHETA= 5 NR= 10 IE= 0 IER= 0 In the following table, ERROR is the true error; The magnitude of PREDERR is the predicted error bound; and if PREDERR is negative, the desired error tolerance is predicted to have not been attained. The variable IBD denotes if (X,Y) is inside D [IBD=0] or on the boundary [IBD=1]. IBD X Y U(X,Y) ERROR PREDERR 0 0.0000 0.0000 1.1440208673D-13 1.14D-13 2.96D-14 0 0.1900 0.0000 2.0924959477D-01 5.55D-16 8.77D-13 0 0.3600 0.0000 4.3332943506D-01 3.89D-16 2.06D-10 0 0.5100 0.0000 6.6529117906D-01 1.67D-15 2.56D-08 0 0.6400 0.0000 8.9648085218D-01 1.11D-16 7.34D-12 0 0.7500 0.0000 1.1170000166D+00 4.44D-16 9.01D-09 0 0.8400 0.0000 1.3163670541D+00 3.11D-15 5.07D-11 0 0.9100 0.0000 1.4843224505D+00 6.66D-16 2.00D-12 0 0.9600 0.0000 1.6116964174D+00 8.44D-15 1.34D-11 0 0.9900 0.0000 1.6912344980D+00 3.38D-14 3.41D-12 1 1.0000 0.0000 1.7182818285D+00 0.00D+00 2.77D-15 0 0.0587 0.7228 -2.0469487441D-01 4.94D-15 2.65D-08 0 0.1112 1.3695 -7.7655693670D-01 7.77D-16 4.73D-14 0 0.1576 1.9402 -1.4226420363D+00 1.78D-15 3.37D-14 0 0.1978 2.4347 -1.9266704296D+00 3.77D-15 1.35D-12 0 0.2318 2.8532 -2.2087406009D+00 1.78D-15 6.11D-12 0 0.2596 3.1956 -2.2944914041D+00 8.88D-16 1.28D-09 0 0.2812 3.4618 -2.2573711548D+00 3.11D-15 1.03D-13 0 0.2967 3.6521 -2.1738442389D+00 4.88D-15 5.63D-09 0 0.3059 3.7662 -2.1015176945D+00 1.73D-14 1.65D-12 1 0.3090 3.8042 -2.0738340411D+00 8.88D-16 2.33D-15 0 -0.1537 0.4467 -2.2663004842D-01 3.14D-15 4.58D-08 0 -0.2912 0.8464 -5.0476166660D-01 3.33D-16 3.69D-13 0 -0.4126 1.1991 -7.5957897819D-01 3.33D-16 2.46D-11 0 -0.5178 1.5047 -9.6066331475D-01 1.11D-16 2.14D-09 0 -0.6068 1.7634 -1.1043191110D+00 2.22D-16 1.70D-12 0 -0.6796 1.9750 -1.1993112501D+00 1.55D-15 8.60D-10 0 -0.7362 2.1395 -1.2579373089D+00 3.77D-15 6.58D-11 0 -0.7767 2.2571 -1.2914549179D+00 1.02D-14 1.47D-10 0 -0.8009 2.3276 -1.3082336320D+00 2.80D-14 1.21D-11 1 -0.8090 2.3511 -1.3132763127D+00 1.33D-15 5.66D-15 0 -0.1537 -0.4467 -2.2663004842D-01 3.36D-15 4.58D-08 0 -0.2912 -0.8464 -5.0476166660D-01 3.33D-16 3.70D-13 0 -0.4126 -1.1991 -7.5957897819D-01 4.44D-16 2.46D-11 0 -0.5178 -1.5047 -9.6066331475D-01 1.33D-15 2.14D-09 0 -0.6068 -1.7634 -1.1043191110D+00 2.00D-15 1.69D-12 0 -0.6796 -1.9750 -1.1993112501D+00 1.33D-15 8.60D-10 0 -0.7362 -2.1395 -1.2579373089D+00 3.11D-15 6.58D-11 0 -0.7767 -2.2571 -1.2914549179D+00 5.33D-15 1.47D-10 0 -0.8009 -2.3276 -1.3082336320D+00 3.13D-14 1.21D-11 1 -0.8090 -2.3511 -1.3132763127D+00 0.00D+00 4.55D-15 0 0.0587 -0.7228 -2.0469487441D-01 5.00D-15 2.65D-08 0 0.1112 -1.3695 -7.7655693670D-01 7.77D-16 4.55D-14 0 0.1576 -1.9402 -1.4226420363D+00 4.44D-16 3.73D-14 0 0.1978 -2.4347 -1.9266704296D+00 6.66D-16 1.36D-12 0 0.2318 -2.8532 -2.2087406009D+00 0.00D+00 6.11D-12 0 0.2596 -3.1956 -2.2944914041D+00 1.33D-15 1.28D-09 0 0.2812 -3.4618 -2.2573711548D+00 4.44D-15 1.07D-13 0 0.2967 -3.6521 -2.1738442389D+00 4.44D-16 5.63D-09 0 0.3059 -3.7662 -2.1015176945D+00 6.22D-15 1.63D-12 1 0.3090 -3.8042 -2.0738340411D+00 4.44D-16 4.10D-15 SHAR_EOF fi # end of overwriting check if test -f 'RES2' then echo shar: will not over-write existing file "'RES2'" else cat << SHAR_EOF > 'RES2' BOUNDARY PARAMETERS: A= 1.0000 B= 4.0000 EPS= 1.000D-09 BOUNDARY FUNCTION 3 CURVE 1 NTHETA= 5 NR= 10 IE= 0 THE ERROR TEST IS NORMAL IER= 0 In the following table, ERROR is the true error; The magnitude of PREDERR is the predicted error bound; and if PREDERR is negative, the desired error tolerance is predicted to have not been attained. X Y U(X,Y) ERROR PREDERR 0.0000 0.0000 1.0000000000D+00 2.22D-16 2.22D-13 0.1736 0.0000 1.1895245851D+00 2.66D-15 7.03D-13 0.3306 0.0000 1.3917730536D+00 -2.22D-15 5.49D-11 0.4711 0.0000 1.6017141190D+00 -2.89D-15 2.15D-13 0.5950 0.0000 1.8131058651D+00 2.22D-15 4.43D-13 0.7025 0.0000 2.0187516773D+00 -4.44D-16 1.33D-10 0.7934 0.0000 2.2108751437D+00 4.44D-16 2.54D-13 0.8678 0.0000 2.3815906268D+00 5.33D-15 2.36D-10 0.9256 0.0000 2.5234318864D+00 0.00D+00 9.38D-12 0.9669 0.0000 2.6298903380D+00 1.55D-14 1.56D-11 0.9917 0.0000 2.6959092653D+00 -3.39D-13 1.15D-12 0.0536 0.6602 8.3336333791D-01 2.00D-15 2.23D-13 0.1022 1.2576 3.4124353140D-01 6.11D-16 3.43D-13 0.1456 1.7921 -2.5386733760D-01 1.17D-15 8.21D-13 0.1839 2.2637 -7.6769646438D-01 -3.33D-16 1.69D-12 0.2171 2.6724 -1.1081694840D+00 -1.11D-15 1.00D-11 0.2452 3.0182 -1.2681280369D+00 1.33D-15 1.45D-10 0.2682 3.3012 -1.2909333548D+00 -1.55D-15 2.16D-13 0.2860 3.5213 -1.2363390417D+00 -4.44D-16 5.80D-12 0.2988 3.6785 -1.1585602228D+00 -6.66D-15 9.43D-13 0.3065 3.7728 -1.0968392662D+00 -2.82D-14 2.23D-13 -0.1404 0.4080 7.9765558239D-01 2.22D-16 2.15D-13 -0.2674 0.7772 5.4557117332D-01 3.33D-16 2.25D-13 -0.3811 1.1076 3.0524098036D-01 2.93D-12 9.33D-11 -0.4814 1.3990 1.0561887151D-01 -1.25D-16 1.95D-12 -0.5683 1.6516 -4.5739476198D-02 8.33D-17 2.25D-13 -0.6419 1.8654 -1.5280364396D-01 -1.39D-16 4.98D-12 -0.7020 2.0402 -2.2419541205D-01 -4.16D-16 2.29D-13 -0.7488 2.1763 -2.6915682458D-01 -2.22D-15 2.12D-10 -0.7823 2.2734 -2.9555873393D-01 1.37D-14 2.92D-10 -0.8023 2.3317 -3.0912844495D-01 -5.27D-15 2.42D-11 -0.1404 -0.4080 7.9765558239D-01 3.33D-16 2.15D-13 -0.2674 -0.7772 5.4557117332D-01 4.44D-16 2.25D-13 -0.3811 -1.1076 3.0524098036D-01 2.93D-12 9.33D-11 -0.4814 -1.3990 1.0561887151D-01 2.08D-16 1.95D-12 -0.5683 -1.6516 -4.5739476198D-02 -1.25D-16 2.25D-13 -0.6419 -1.8654 -1.5280364396D-01 -1.39D-16 4.98D-12 -0.7020 -2.0402 -2.2419541205D-01 -2.50D-16 2.29D-13 -0.7488 -2.1763 -2.6915682458D-01 -1.67D-15 2.12D-10 -0.7823 -2.2734 -2.9555873393D-01 1.47D-14 2.92D-10 -0.8023 -2.3317 -3.0912844495D-01 -3.22D-15 2.42D-11 0.0536 -0.6602 8.3336333791D-01 7.77D-16 2.23D-13 0.1022 -1.2576 3.4124353140D-01 6.11D-16 3.43D-13 0.1456 -1.7921 -2.5386733760D-01 1.11D-16 8.21D-13 0.1839 -2.2637 -7.6769646438D-01 -2.00D-15 1.69D-12 0.2171 -2.6724 -1.1081694840D+00 4.44D-16 1.00D-11 0.2452 -3.0182 -1.2681280369D+00 4.44D-16 1.45D-10 0.2682 -3.3012 -1.2909333548D+00 -2.22D-15 2.16D-13 0.2860 -3.5213 -1.2363390417D+00 -4.44D-16 5.80D-12 0.2988 -3.6785 -1.1585602228D+00 4.44D-16 9.43D-13 0.3065 -3.7728 -1.0968392662D+00 1.24D-14 2.25D-13 SHAR_EOF fi # end of overwriting check if test -f 'data1' then echo shar: will not over-write existing file "'data1'" else cat << SHAR_EOF > 'data1' n n 1 1 4 1.0E-7 0 3 5 10 n SHAR_EOF fi # end of overwriting check if test -f 'data2' then echo shar: will not over-write existing file "'data2'" else cat << SHAR_EOF > 'data2' n n 1 1 4 1.0E-9 0 0 3 5 10 n SHAR_EOF fi # end of overwriting check if test -f 'driver1.f' then echo shar: will not over-write existing file "'driver1.f'" else cat << SHAR_EOF > 'driver1.f' C C TITLE: TEST DRIVER PROGRAM FOR NEUMAN C ------------------------------------- C C This program is used to test the subroutine "NEUMAN" which C solves interior and exterior Neumann problems for Laplace's C equation on a planar region D. C C The subroutine NEUMAN solves exterior Neumann problems C by means of a standard indirect boundary integral equation C reformulation, one based on representing the solution as a C single layer potential. C C For the interior Neumann problem, the problem is first C reformulated as an exterior Neumann problem by means of the C Kelvin transformation, and this new problem is solved as for C the exterior case. C C This program is limited to problems on simply connected C regions D with a smooth boundary curve C. C C * THE USER SUPPLIED SUBROUTINES: C C FUNCTION BDYFCN : This defines the boundary data, the exterior C normal derivative of the unknown potential. C For the present test program, BDYFCN is C generated from GVFCN. C SUBROUTINE GVFCN : This contains a set of test functions, all C potential functions. This also includes their C first order partial derivatives. The subroutine C BDYFCN calls this routine. C SUBROUTINE CURVE : This defines a set of test curves. C C ***** THE SUBROUTINES AND FUNCTIONS CALLED BY SUBROUTINE NEUMAN C C SUBROUTINE EVALU : This subroutine evaluates the single layer C potential by using the density function C evaluated in subroutine INTEQN. C SUBROUTINE FUCOEF: This subroutine evaluates the Fourier C coefficients of the density function by C using the FFT subroutines. This is used C only if the solution is needed on the C boundary. C FUNCTION FUEVAL : This subroutine evaluates the singular part C of the single layer potential when it is C evaluated at boundary points. C SUBROUTINE INTEQN: This subroutine generates the density C function. C SUBROUTINE NEWCUR: This subroutine defines a transformed curve C when we solve the interior Neumann problem C by calling subroutine KVTRNF. C SUBROUTINE KVTRNF: This defines the Kelvin transformation. C SUBROUTINES DGESV & DGECON: LAPACK subroutines for LU C decomposition and condition number C evaluation. C FFT SUBROUTINES : Modified version of selected FFTPACK C subroutines for the Fast Fourier Transform. C The package FFTPACK was written by Paul C Swarztrauber of NCAR. C FUNCTION D1MACH : Subroutine which defines the machine unit round. C C **************************************************************** C FOLLOWING ARE THE PARAMETERS THAT MUST BE SUPPLIED BY USERS. C IN THIS TEST PROGRAM, THEY ARE REQUESTED INTERACTIVELY FROM C THE USER. C C IE This parameter should be 0 or 1. C IE=0 for the interior Neumann problem. C IE=1 for the exterior Neumann problem. C IDBG The debug parameter. DBG=Y produces an output C with the debugging information. DBG=N produces a C standard answer file. C NUMCUR The index of the boundary curve C in subroutine CURVE. C NUMCUR=1 for an ellipse C NUMCUR=2 for a limacon C NUMCUR=3 for the ovals of Cassini C A,B Parameters used in defining the curve C. C NUMF The index of the test functions in subroutine GVFCN. C Indices 1, 2, and 3 are test cases for solving the C interior Neumann problem; and index 4 is for the C test case for solving the exterior Neumann problem. C EPS The absolute error tolerance on the solution of the C Neumann problem. C DPTS The two dimensional double precision array in which C are stored the points at which the harmonic function C is to be evaluated. Each column denotes a new point C at which the solution is to be evaluated. For the C definition, see below in the definition of DPTS C given in this main program. Also, see the C introductory statements of NEUMAN. See the example C below in this test driver program for setting up C DPTS, especially the distinction between specifying C points on the boundary and points off the boundary. C *** NOTE *** In this test program, our method of C creating DPTS assumes that the region inside of C the curve is starlike with respect to the origin. C MAXDPTS This is the maximum number of points that can be C stored in DPTS. It is to be set in the PARAMETER C statement given below. C NTHETA, NR The parameters used in defining the test points in C the array DPTS, at which the solution is evaluated. C NTHETA will be the number of angular subdivisions, C and NR is the number of radial subdivisions. C Boundary points are included in this test case. C NEUMAN.ANS The name of the output file. C C The subroutine NEUMAN requires two working storage arrays, C WORK and IWORK of respective dimensions NWORK and MWORK. C These are set by users, as follows. C C WORK A double precision work array. It dimension C should be at least 10,000. If the array DPTS C contains points close to the boundary, then C the dimension should be increased accordingly, C to obtain accurate numerical integrations for C the potential approximations at such points. C A dimension of 300,000 will allow for very C accurate potential evaluations, even near to C to the boundary. See the discussion of NWORK, C the dimension of WORK, below in the introductory C comments of SUBROUTINE NEUMAN. C IWORK The integer array. Its dimension should be at C least C MWORK = SQRT(NWORK + 49)+ 8 C where NWORK is the dimension of WORK. C DOUBLE PRECISION A,B,TRUE,CLNGTH,D2X,D2Y,DX,DY,EPS,ERR,F,FNR, + FX,FY,HTHETA,R,THETA,X,Y,FR INTEGER MWORK,NWORK,NUMCUR,NUMF,I,IBD,IBEG,IE,IER,II,ILOW, + IOUT,IUP,J,NP,NPTS,NR,NTHETA,TML_IN,TML_OUT,I_FILE, + INP, IDBG INTEGER MAXDPTS, MAXFFT DOUBLE PRECISION ONE PARAMETER (MAXDPTS=200,MAXFFT=1024) PARAMETER (MWORK=600,NWORK=300000) PARAMETER (ONE=1.0D0) DOUBLE PRECISION DPTS(4,MAXDPTS),ERROR(MAXDPTS),U(MAXDPTS), * WORK(NWORK) INTEGER IWORK(MWORK) CHARACTER TYN EXTERNAL BDYFCN,CURVE,GVFCN,NEUMAN INTRINSIC ABS,ATAN,FLOAT COMMON/BLKCUR/A,B,NUMCUR COMMON/BLKF/NUMF COMMON/DUMMY/WORK C C ************************************************************ C The standard input and output unit numbers: DATA TML_IN/5/,TML_OUT/6/ C The output unit number for results from this program, to be C stored in the file "neuman.ans": DATA I_FILE/8/ C ************************************************************ C C INITIALIZATION CLNGTH = 8.0D0*ATAN(1.0D0) IBEG = 0 INP = TML_IN PRINT *, 'DO YOU WANT THE OUTPUT DIRECTED TO THE TERMINAL? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IOUT = TML_OUT ELSE IOUT = I_FILE OPEN(IOUT,FILE='res1') END IF C PRINT *, 'DO YOU WANT A DEBUGGING OUTPUT? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IDBG = 1 ELSE IDBG = 0 END IF C C INPUT PROBLEM PARAMETERS. 20 PRINT *,'CURVE DEFINING PARAMETERS; NUMCUR, A, B ?' PRINT *,'CHOOSE 1, WITH A,B > 0 FOR AN ELLIPSE' PRINT *,'CHOOSE 2, WITH 0 < A < 1, B > 0 FOR A LIMACON' PRINT *,'CHOOSE 3, WITH A > 1, B > 0 FOR A CASSINI' PRINT *,'CHOOSE 4, WITH ARBITRARY A, B FOR AN AMEOBA' READ (INP,*) NUMCUR,A,B C C CHECK THE INPUT PARAMETERS. IF (NUMCUR .EQ. 1) THEN IF (A .GT. 0. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 2) THEN IF (0. .LT. A .AND. A .LT. 1. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 3) THEN IF (A .GT. 1. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 4) THEN GO TO 30 ELSE GO TO 25 END IF 25 PRINT *, 'GIVE THE CURVE-DEFINING PARAMETERS AGAIN.' PRINT *, 'SOMETHING WAS WRONG WITH THE PREVIOUS VALUES.' GO TO 20 30 PRINT *,'GIVE THE ERROR TOLERANCE EPS?' READ (INP,*) EPS C 40 PRINT *,'GIVE IE=0 FOR AN INTERIOR PROBLEM.' PRINT *,'GIVE IE=1 FOR AN EXTERIOR PROBLEM.' PRINT *,'WHAT IS IE?' READ (INP,*) IE C PRINT *,'SPECIFY THE TEST FUNCTION INDEX NUMBF?,' PRINT *,'FOR IE=0, CHOOSE NUMF = 1, 2, OR 3' PRINT *,'FOR IE=1, CHOOSE NUMF = 4' READ (INP,*) NUMF C IF(IE .EQ. 0 .AND. NUMF .GE. 1 .AND. NUMF .LE. 3) GO TO 50 IF(IE .EQ. 1 .AND. NUMF .EQ. 4) GO TO 50 PRINT *, 'GIVE IE AND NUMF, AGAIN.' GO TO 40 C 50 PRINT *,'PARAMETERS N_THETA AND N_R ARE USED TO DEFINE A SET' PRINT *,'OF MESH POINTS INTERIOR TO D, AT WHICH THE POTENTIAL' PRINT *,'U IS TO BE EVALUATED.' PRINT *,'GIVE N_THETA AND N_R' READ (INP,*) NTHETA,NR C WRITE (IOUT,9000) A,B,EPS,NUMF,NUMCUR,NTHETA,NR,IE C C SET UP POINTS (X,Y) AT WHICH POTENTIAL SOLUTION U IS C TO BE EVALUATED. C IE=0 ASSIGNS THE POINTS IN THE INTERIOR OF THE CURVE C. C IE=1 ASSIGNS THE POINTS IN THE EXTERIOR OF THE CURVE C. C C IF (X,Y) IS A BOUNDARY POINT, THEN C DPTS(1,I)=X, DPTS(2,I)=Y, DPTS(3,I)=S, AND DPTS(4,I)=1. C HERE S IS A PARAMETER WHICH IS USED FOR THE PARAMETRIZATION C OF THE CURVE C. C IF (X,Y) IS A NON BOUNDARY POINT, THEN C DPTS(1,I)=X, DPTS(2,I)=Y, DPTS(4,I)=0 C AND DPTS(3,I) NEED NOT BE SET. C IF(IE .EQ. 0) THEN C IT IS AN INTERIOR PROBLEM, AND CHOOSE (0,0) AS THE C FIRST POINT. DPTS(1,1) = 0.D0 DPTS(2,1) = 0.D0 DPTS(4,1) = 0.D0 ELSE C IT IS AN EXTERIOR PROBLEM, AND CHOOSE A POINT SUFFICIENTLY C AWAY FROM THE BOUNDARY FOR THE FIRST POINT. DPTS(1,1) = 10000.D0 DPTS(2,1) = 10000.D0 DPTS(4,1) = 0.D0 END IF C C THE FOLLOWING SETUP OF DPTS ASSUMES THAT THE INTERIOR OF C IS C STARLIKE WITH RESPECT TO THE ORIGIN (0,0). HTHETA = CLNGTH/NTHETA NP = 1 FNR = NR ILOW = 1 IUP = NTHETA DO II = ILOW,IUP I = II - 1 THETA = I*HTHETA CALL CURVE(THETA,X,Y,DX,DY,D2X,D2Y) DO J = 1,NR NP = NP + 1 C CHECK WHETHER A SUFFICIENT WORK STORAGE IS GIVEN C FOR THE ARRAY DPTS. IF(NP .GT. MAXDPTS) THEN PRINT *,' MORE WORK SPACE IS NEEDED FOR THE ARRAY DTPS.' PRINT *,' INCREASE MAXDPTS AND RECOMPILE THE PROGRAM.' STOP END IF FR = FLOAT(J)/FNR R=2*FR - FR*FR IF(IE .EQ. 1) R = ONE/R DPTS(1,NP) = R*X DPTS(2,NP) = R*Y DPTS(3,NP) = THETA IF(J .EQ. NR) THEN DPTS(4,NP) = 1 ELSE DPTS(4,NP) = 0 END IF END DO END DO NPTS = NP C CALL NEUMAN(IOUT,IDBG,IE,BDYFCN,CURVE,CLNGTH,DPTS,NPTS,IBEG, + EPS,WORK,IWORK,NWORK,MWORK,MAXFFT,U,ERROR,IER) C C PRINT RESULTS. C WRITE (IOUT,9010) IER WRITE (IOUT,9020) WRITE (IOUT,9030) C COMPARE THE GIVEN TEST FUNCTION AND THE APPROXIMATING SOLUTION. DO I = 1,NPTS X = DPTS(1,I) Y = DPTS(2,I) IBD = DPTS(4,I) CALL GVFCN(X,Y,F,FX,FY) TRUE = F ERR = ABS(TRUE-U(I)) WRITE (IOUT,9050) IBD,X,Y,U(I),ERR,ERROR(I) END DO C PRINT *, ' ' PRINT *, 'THE CALCULATION IS COMPLETE. DO YOU WISH TO' PRINT *, 'CONTINUE WITH ANOTHER CALCULATION? (Y/N)' READ(INP,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN PRINT *, 'DO WANT TO USE THE SAME CURVE AND BOUNDARY' PRINT *, 'FUNCTION AGAIN, BUT WITH DIFFERENT VALUES OF' PRINT *, 'NR AND NTHETA? (Y/N)' READ(INP,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IBEG = 1 GO TO 50 ELSE IBEG = 0 GO TO 20 END IF ELSE IF (IOUT .EQ. I_FILE) CLOSE(IOUT) STOP END IF C 9000 FORMAT (/,/,' BOUNDARY PARAMETERS: A=',F7.4,3X,'B=',F7.4,/, + ' EPS=',1PD11.3,5X,'BOUNDARY FUNCTION ',I1,5X,'CURVE ', + I1,/,' NTHETA=',I3,3X,'NR=',I3,3X,'IE=',I3,/) 9010 FORMAT (' IER=',I2) 9020 FORMAT (/,'In the following table, ERROR is the true error;',/, + 'The magnitude of PREDERR is the predicted error bound;',/, + 'and if PREDERR is negative, the desired error tolerance',/, + 'is predicted to have not been attained. The variable',/, + 'IBD denotes if (X,Y) is inside D [IBD=0] or on the',/, + 'boundary [IBD=1].',/) 9030 FORMAT(/,' IBD',7X,'X',11X,'Y',10X,'U(X,Y)',11X,'ERROR',6X, + 'PREDERR',/) 9050 FORMAT (I3,F11.4,F12.4,1PD20.10,D12.2,D12.2) END C DOUBLE PRECISION FUNCTION BDYFCN(S) C -------------------------------- C C Define the Neumann data on the boundary, using subroutine GVFCN, C which defines the test harmonic functions. C DOUBLE PRECISION D2X,D2Y,DX,DY,F,FX,FY,S,X,Y EXTERNAL CURVE,GVFCN INTRINSIC SQRT C CALL CURVE(S,X,Y,DX,DY,D2X,D2Y) CALL GVFCN(X,Y,F,FX,FY) BDYFCN = (FX*DY-FY*DX)/SQRT(DX*DX+DY*DY) RETURN END C SUBROUTINE GVFCN(X,Y,F,FX,FY) C ---------------- C C This program defines the test functions and their first order C partial derivatives. C DOUBLE PRECISION F,FX,FY,X,Y INTEGER NUMF INTRINSIC COS,EXP,SIN COMMON /BLKF/NUMF C GO TO (10,20,30,40) NUMF 10 F = X**2 - Y**2 FX = 2.D0*X FY = -2.D0*Y RETURN 20 F = X FX = 1.D0 FY = 0.D0 RETURN 30 F = EXP(X)*COS(Y) - 1.D0 FX = EXP(X)*COS(Y) FY = -EXP(X)*SIN(Y) RETURN 40 F = X/ (X*X+Y*Y) FX = (Y*Y-X*X)/ (X*X+Y*Y)**2 FY = -2.D0*X*Y/ (X*X+Y*Y)**2 RETURN END SUBROUTINE CURVE(S,X,Y,DX,DY,D2X,D2Y) C ---------------- C C This program defines the boundary of the region C, along C with its first and second derivatives with respect to the C parameterization variables. The curves are an ellipse, C limacon, and the Ovals of Cassini. C DOUBLE PRECISION A,B,D2X,D2Y,DX,DY,S,X,Y INTEGER NUMCUR DOUBLE PRECISION CS,CS2,D2R,DR,EC,ES,R,SN,SN2 INTRINSIC COS,EXP,SIN,SQRT COMMON /BLKCUR/A,B,NUMCUR GO TO (10,20,40,50) NUMCUR C C DEFINE AN ELLIPSE. 10 CS = COS(S) SN = SIN(S) X = A*CS Y = B*SN DX = -A*SN DY = B*CS D2X = -X D2Y = -Y RETURN C C DEFINE A LIMACON. C CHOOSE 0 .LE. A .LT. 1, 0 .LT. B. C GRAPH CENTERED AT ORIGIN, BETWEEN X=-1 AND X=1, C SYMMETRIC ABOUT THE X-AXIS. 20 CS = COS(S) SN = SIN(S) R = 1.0 + A*CS DR = -A*SN D2R = -A*CS X = R*CS - A Y = B*R*SN 30 DY = B* (DR*SN+R*CS) D2Y = B* (SN* (D2R-R)+2.0D0*DR*CS) DX = DR*CS - R*SN D2X = (D2R-R)*CS - 2.0D0*DR*SN RETURN C C DEFINE THE OVALS OF CASSINI. C CHOOSE A .GT. 1, B .GT. 0. 40 CS = COS(S) SN = SIN(S) CS2 = CS*CS - SN*SN SN2 = 2.0D0*SN*CS R = SQRT(CS2+SQRT(A-SN2*SN2)) DR = -R*SN2/ (R*R-CS2) D2R = - (2.0D0*CS2*R+ (2.0D0*R*DR+3.0D0*SN2)*DR)/ (R*R-CS2) X = R*CS Y = B*R*SN GO TO 30 C C DEFINE AN "AMOEBA" BOUNDARY. 50 CS = COS(S) SN = SIN(S) CS2 = CS*CS - SN*SN SN2 = 2.0D0*SN*CS EC = EXP(CS) ES = EXP(SN) R = EC*CS2*CS2 + ES*SN2*SN2 X = R*CS Y = R*SN DR = -EC*(SN*CS2*CS2 + 4.0D0*CS2*SN2) * +ES*(4.0D0*CS2*SN2 + CS*SN2*SN2) D2R = EC*(-8*CS2*CS2 - CS*CS2*CS2 + CS2*CS2*SN*SN * + 8*CS2*SN*SN2 + 8*SN2*SN2) * +ES*(8*CS2*CS2 +8*CS*CS2*SN2 - 8*SN2*SN2 * + CS*CS*SN2*SN2 - SN*SN2*SN2) DY = DR*SN+R*CS D2Y = SN* (D2R-R)+2.0D0*DR*CS DX = DR*CS - R*SN D2X = (D2R-R)*CS - 2.0D0*DR*SN RETURN END C C************************************************************** C THIS IS THE END OF THE USER SUPPLIED INFORMATION. C************************************************************** SHAR_EOF fi # end of overwriting check if test -f 'driver2.f' then echo shar: will not over-write existing file "'driver2.f'" else cat << SHAR_EOF > 'driver2.f' C TITLE: TEST DRIVER PROGRAM FOR DRCHLT C ------------------------------------- C C This program is used to test the subroutine "DRCHLT" which C solves interior and exterior Dirichlet problems for Laplace's C equation on a planar region D. C C The subroutine DRCHLT solves interior Dirichlet problems C by means of a standard indirect boundary integral equation C reformulation, one based on representing the solution as a C double layer potential. C C For the exterior Dirichlet problem, the problem is first C reformulated as an interior Dirichlet problem by means of the C Kelvin transformation, and this new problem is solved as for C the interior case. C C This program is limited to problems on simply connected C regions D with a smooth boundary curve C. C C ***** THE USER SUPPLIED SUBROUTINES: C C FUNCTION BDYFCN : This defines the boundary data. C SUBROUTINE CURVE : This defines a set of test curves. C C ***** THE SUBROUTINES INCLUDED IN THE SUBROUTINE DRCHLT C C SUBROUTINE EVALU : This subroutine evaluates the double layer C potential by using the density function C evaluated in subroutine INTEQN. C SUBROUTINE INTEQN: This subroutine generates the density C function. C SUBROUTINE NEWCUR: This subroutine defines a transformed curve C when we solve the exterior Dirichlet problem C by calling subroutine KVTRNF. C SUBROUTINE KVTRNF: This defines the Kelvin transformation. C SUBROUTINES DGESV & DGECON: LAPACK subroutines for LU C decomposition and condition number C evaluation. C FUNCTION D1MACH : Subroutine which defines the machine unit C round. C C ************************************************************* C FOLLOWING ARE THE PARAMETERS THAT MUST BE SUPPLIED BY USERS. C IN THIS TEST PROGRAM, THEY ARE REQUESTED INTERACTIVELY FROM C THE USER. C c IE This parameter should be 0 or 1. C IE=0 for the interior Dirichlet problem. C IE=1 for the exterior Dirichlet problem. C IDBG The debug parameter. DBG=Y produces an output C with the debugging information. DBG=N produces a C shortcut answer file. C NUMCUR The index of the boundary curve C in subroutine CURVE. C NUMCUR=1 for an ellipse C NUMCUR=2 for a limacon C NUMCUR=3 for the ovals of Cassini C A,B Parameters used in defining the curve C. C NUMBF The index of the test functions in BDYFCN. C Indices 1, 2, and 3 are test cases for solving the C interior Dirichlet problem; and indices 4 AND 5 C are test cases for solving the exterior Dirichlet C problem. C EPS The absolute error tolerance on the solution of the C Dirichlet problem. C R_FORM This specifies (indirectly) the form of error test to C to be used in subroutines INTEQN and EVALU. C If R_FORM=0, then we use a "normal" error test. This C attempts to measure the rate of convergence of the C approximates and to use that in predicting the error. C If R_FORM=1, then we assume the approximates are C converging at a very slow rate. Use this with more C ill-behaved solution functions and boundaries. C NTHETA, NR The parameters used in defining the test points in C the array DPTS, at which the solution is evaluated. C NTHETA will be the number of angular subdivisions, C and NR is the number of radial subdivisions C DRCHLT.ANS The name of the output file. C C The subroutine DRCHLT requires two working storage arrays, C WORK and IWORK of respective dimensions NWORK and MWORK. C These are set by users, as follows. C C WORK A double precision work array. It dimension C should be at least 5,000. If the array DPTS C contains points close to the boundary, then C the dimension should be increased accordingly, C to obtain accurate numerical integrations for C the potential approximations at such points. C A dimension of 300,000 will allow for very C accurate potential evaluations, even near to C to the boundary. See the discussion of NWORK, C the dimension of WORK, below in the introductory C comments of SUBROUTINE DRCHLT. C IWORK The integer array. Its dimension should be at C least C MWORK = SQRT(NWORK + 36)-6 C where NWORK is the dimension of WORK. C C INTEGER NUMBF,NUMCUR,NWORK,MWORK,TML_IN,TML_OUT,IDBG INTEGER I,IBEG,IE,IER,II,ILOW,IOUT,IUP,J,NP,NPTS,NR,NTHETA, * R_FORM,I_FILE,MAXDPTS DOUBLE PRECISION A,ANS,B,BDYFCN,CLNGTH,D2X,D2Y,DX,DY,EPS,ERR, + FNR,HTHETA,R,THETA,X,Y CHARACTER TYN, RFC*12 PARAMETER(MAXDPTS=200) PARAMETER(NWORK=300000, MWORK=600) DOUBLE PRECISION DPTS(2,MAXDPTS),ERROR(MAXDPTS),U(MAXDPTS), + WORK(NWORK) INTEGER IWORK(MWORK) EXTERNAL BDYFCN,CURVE,DRCHLT INTRINSIC ATAN,FLOAT COMMON /BLKBF/NUMBF COMMON /BLKCUR/A,B,NUMCUR COMMON /DUMMY/WORK C ************************************************************ C The standard input and output unit numbers: DATA TML_IN/5/,TML_OUT/6/ C The output unit number for results from this program, to be C stored in the file "drchlt.ans": DATA I_FILE/8/ C ************************************************************ C C INITIALIZATION CLNGTH = 8.0D0*ATAN(1.0D0) IBEG = 0 C PRINT *, 'DO YOU WANT THE OUTPUT DIRECTED TO THE TERMINAL? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IOUT = TML_OUT ELSE IOUT = I_FILE OPEN(IOUT,FILE='res2') END IF C PRINT *, 'DO YOU WANT A DEBUGGING OUTPUT? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IDBG = 1 ELSE IDBG = 0 END IF C C INPUT PROBLEM PARAMETERS. C C READ PROBLEM PARAMETERS FOR A NEW CURVE AND BOUNDARY FUNCTION. 20 PRINT *,'CURVE DEFINING PARAMETERS; NUMCUR, A, B ?' PRINT *,'CHOOSE 1, WITH A,B > 0 FOR AN ELLIPSE' PRINT *,'CHOOSE 2, WITH 0 < A < 1, B > 0 FOR A LIMACON' PRINT *,'CHOOSE 3, WITH A > 1, B > 0 FOR A CASSINI' PRINT *,'CHOOSE 4, WITH ANY A AND B, FOR THE AMOEBA' READ (TML_IN,*) NUMCUR,A,B C C CHECK THE INPUT PARAMETERS. IF (NUMCUR .EQ. 1) THEN IF (A .GT. 0. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 2) THEN IF (0. .LT. A .AND. A .LT. 1. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 3) THEN IF (A .GT. 1. .AND. B .GT. 0.) THEN GO TO 30 ELSE GO TO 25 END IF ELSE IF (NUMCUR .EQ. 4) THEN GO TO 30 ELSE GO TO 25 END IF 25 PRINT *, 'GIVE THE CURVE-DEFINING PARAMETERS AGAIN.' GO TO 20 C 30 PRINT *,'GIVE THE ERROR TOLERANCE EPS?' READ (TML_IN,*) EPS C PRINT *,'IS THE ERROR TEST TO BE "NORMAL" (GIVE 0) OR' PRINT *,'"CONSERVATIVE" (GIVE 1)?' READ (TML_IN,*) R_FORM C 40 PRINT *,'GIVE IE=0 FOR AN INTERIOR PROBLEM.' PRINT *,'GIVE IE=1 FOR AN EXTERIOR PROBLEM.' PRINT *,'WHAT IS IE?' READ (TML_IN,*) IE C PRINT *,'SPECIFY THE TEST FUNCTION INDEX NUMBF?,' PRINT *,'FOR IE=0, CHOOSE NUMBF = 1, 2, OR 3' PRINT *,'FOR IE=1, CHOOSE NUMBF = 4 OR 5' READ (TML_IN,*) NUMBF C C CHECK THE INPUT PARAMETERS. IF(IE .EQ. 0 .AND. 1 .LE. NUMBF .AND. NUMBF .LE. 3) GO TO 50 IF(IE .EQ. 1 .AND. 4 .LE. NUMBF .AND. NUMBF .LE. 5) GO TO 50 PRINT *, 'GIVE IE AND NUMBF, AGAIN' GO TO 40 C 50 PRINT *,'PARAMETERS N_THETA AND N_R ARE USED TO DEFINE A SET' PRINT *,'OF MESH POINTS INTERIOR TO D, AT WHICH THE POTENTIAL' PRINT *,'U IS TO BE EVALUATED.' PRINT *,'GIVE N_THETA AND N_R' READ (TML_IN,*) NTHETA,NR C IF(R_FORM .EQ. 0) THEN RFC = 'NORMAL' ELSE RFC = 'CONSERVATIVE' END IF WRITE (IOUT,FMT=9000) A,B,EPS,NUMBF,NUMCUR,NTHETA,NR,IE,RFC C C SET UP POINTS (X,Y) AT WHICH POTENTIAL SOLUTION U IS C TO BE EVALUATED. C IE=0 ASSIGNS THE POINTS IN THE INTERIOR OF THE CURVE C. C IE=1 ASSIGNS THE POINTS IN THE EXTERIOR OF THE CURVE C. C IF (IE .EQ. 0) THEN C IF IT IS AN INTERIOR PROBLEM, CHOOSE (0,0) AS THE FIRST POINT. DPTS(1,1) = 0.0D0 DPTS(2,1) = 0.0D0 ELSE C IF IT IS AN EXTERIOR PROBLEM, CHOOSE A POINT SUFFICIENTLY AWAY C FROM THE BOUNDARY FOR THE FIRST POINT. DPTS(1,1) = 100.D0 DPTS(2,1) = 100.D0 END IF HTHETA = CLNGTH/NTHETA NP = 1 FNR = NR+1 ILOW = 1 IUP = NTHETA DO II = ILOW,IUP I = II - 1 THETA = I*HTHETA CALL CURVE(THETA,X,Y,DX,DY,D2X,D2Y) DO J = 1,NR NP = NP + 1 R = FLOAT(J)/FNR R = R* (2.0-R) IF (IE .EQ. 1) R = 1/R DPTS(1,NP) = R*X DPTS(2,NP) = R*Y END DO END DO C NPTS = NP C CHECK WHETHER A SUFFICIENT WORK STORAGE IS GIVEN FOR C THE ARRAY DPTS. IF (NPTS .GT. MAXDPTS) THEN PRINT *,'MORE WORK SPACE IS NEEDED FOR THE ARRAY DPTS.' PRINT *,'INCREASE MAXDPTS TO AT LEAST NPTS=',NPTS STOP END IF C CALL DRCHLT(IOUT,IDBG,IBEG,IE,BDYFCN,CURVE,CLNGTH,DPTS,NPTS,EPS, + R_FORM,WORK,IWORK,NWORK,MWORK,U,ERROR,IER) C C PRINT RESULTS. C WRITE (IOUT,FMT=9010) IER IF (IER. LT. 0) STOP WRITE (IOUT,FMT=9020) WRITE (IOUT,FMT=9030) DO I = 1,NPTS X = DPTS(1,I) Y = DPTS(2,I) ANS = BDYFCN(X,Y) ERR = ANS - U(I) WRITE (IOUT,FMT=9050) X,Y, U(I),ERR,ERROR(I) END DO PRINT *, ' ' PRINT *, 'THE CALCULATION IS COMPLETE. DO YOU WISH TO' PRINT *, 'CONTINUE WITH ANOTHER CALCULATION? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN PRINT *, 'DO WANT TO USE THE SAME CURVE AND BOUNDARY' PRINT *, 'FUNCTION AGAIN, BUT WITH DIFFERENT VALUES OF' PRINT *, 'NR AND NTHETA? (Y/N)' READ(*,'(A1)') TYN IF((TYN .EQ. 'Y') .OR. (TYN .EQ. 'y')) THEN IBEG = 1 GO TO 50 ELSE IBEG = 0 GO TO 20 END IF ELSE IF (IOUT .EQ. I_FILE) CLOSE(IOUT) STOP END IF 9000 FORMAT (/,/,' BOUNDARY PARAMETERS: A=',F7.4,3X,'B=',F7.4,/, + ' EPS=',1PD11.3,5X,'BOUNDARY FUNCTION ',I1,5X,'CURVE ', + I1,/,' NTHETA=',I3,3X,'NR=',I3,3X,'IE=',I3,/, + ' THE ERROR TEST IS ',A12,/) 9010 FORMAT (//,' IER=',I2) 9020 FORMAT (/,'In the following table, ERROR is the true error;',/, + 'The magnitude of PREDERR is the predicted error bound;',/, + 'and if PREDERR is negative, the desired error tolerance',/, + 'is predicted to have not been attained.',/) 9030 FORMAT (/,7X,'X',11X,'Y',10X,'U(X,Y)',11X,'ERROR',6X,'PREDERR',/) 9050 FORMAT (F10.4,F12.4,1PD20.10,D12.2,D12.2) END DOUBLE PRECISION FUNCTION BDYFCN(X,Y) C -------------------------------- C C This function defines the test Dirichlet boundary data. It C also defines the true solutions to the associated Dirichlet C boundary value problem. C DOUBLE PRECISION X,Y,RSQ INTEGER NUMBF INTRINSIC COS,EXP COMMON /BLKBF/NUMBF C C DEFINE THE BOUNDARY FUNCTIONS. C GO TO (10,20,30,40,50) NUMBF C 10 BDYFCN = 1.0D0 RETURN 20 BDYFCN = X RETURN 30 BDYFCN = EXP(X)*COS(Y) RETURN 40 RSQ = X*X+Y*Y BDYFCN = X/RSQ RETURN 50 RSQ = X*X+Y*Y BDYFCN = EXP(X/RSQ)*COS(Y/RSQ) RETURN END SUBROUTINE CURVE(S,X,Y,DX,DY,D2X,D2Y) C ---------------- C C This program defines the boundary of the region C, along C with its first and second derivatives with respect to the C parameterization variables. The curves are an ellipse, C limacon, and the Ovals of Cassini. C DOUBLE PRECISION A,B,D2X,D2Y,DX,DY,S,X,Y INTEGER NUMCUR DOUBLE PRECISION CS,CS2,D2R,DR,R,SN,SN2,EC,ES INTRINSIC COS,EXP,SIN,SQRT COMMON /BLKCUR/A,B,NUMCUR GO TO (10,20,40,50) NUMCUR C C DEFINE AN ELLIPSE. 10 CS = COS(S) SN = SIN(S) X = A*CS Y = B*SN DX = -A*SN DY = B*CS D2X = -X D2Y = -Y RETURN C C DEFINE A LIMACON. C CHOOSE 0 .LE. A .LT. 1, 0 .LT. B. C GRAPH CENTERED AT ORIGIN, BETWEEN X=-1 AND X=1, C SYMMETRIC ABOUT THE X-AXIS. 20 CS = COS(S) SN = SIN(S) R = 1.0 + A*CS DR = -A*SN D2R = -A*CS X = R*CS - A Y = B*R*SN 30 DY = B* (DR*SN+R*CS) D2Y = B* (SN* (D2R-R)+2.0D0*DR*CS) DX = DR*CS - R*SN D2X = (D2R-R)*CS - 2.0D0*DR*SN RETURN C C DEFINE THE OVALS OF CASSINI. C CHOOSE A .GT. 1, B .GT. 0. 40 CS = COS(S) SN = SIN(S) CS2 = CS*CS - SN*SN SN2 = 2.0D0*SN*CS R = SQRT(CS2+SQRT(A-SN2*SN2)) DR = -R*SN2/ (R*R-CS2) D2R = - (2.0D0*CS2*R+ (2.0D0*R*DR+3.0D0*SN2)*DR)/ (R*R-CS2) X = R*CS Y = B*R*SN GO TO 30 C C DEFINE AN "AMOEBA" BOUNDARY. 50 CS = COS(S) SN = SIN(S) CS2 = CS*CS - SN*SN SN2 = 2.0D0*SN*CS EC = EXP(CS) ES = EXP(SN) R = EC*CS2*CS2 + ES*SN2*SN2 X = R*CS Y = R*SN DR = -EC*(SN*CS2*CS2 + 4.0D0*CS2*SN2) + +ES*(4.0D0*CS2*SN2 + CS*SN2*SN2) D2R = EC*(-8*CS2*CS2 - CS*CS2*CS2 + CS2*CS2*SN*SN + + 8*CS2*SN*SN2 + 8*SN2*SN2) + +ES*(8*CS2*CS2 +8*CS*CS2*SN2 - 8*SN2*SN2 + + CS*CS*SN2*SN2 - SN*SN2*SN2) DY = DR*SN+R*CS D2Y = SN* (D2R-R)+2.0D0*DR*CS DX = DR*CS - R*SN D2X = (D2R-R)*CS - 2.0D0*DR*SN RETURN END C******************************************************************* C THIS IS THE END OF USER SUPPLIED INFORMATION C******************************************************************* SHAR_EOF fi # end of overwriting check cd .. cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test -f 'd1mach.f' then echo shar: will not over-write existing file "'d1mach.f'" else cat << SHAR_EOF > 'd1mach.f' DOUBLE PRECISION FUNCTION D1MACH(I) INTEGER I C C DOUBLE-PRECISION MACHINE CONSTANTS C C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C C D1MACH( 5) = LOG10(B) C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. C C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), ONE OF THE FIRST C TWO SETS OF CONSTANTS BELOW SHOULD BE APPROPRIATE. C C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC C DOUBLE PRECISION DMACH(5) C 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 IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T C 3B SERIES AND MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T C PC 7300), IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST. C DATA SMALL(1),SMALL(2) / 1048576, 0 / DATA LARGE(1),LARGE(2) / 2146435071, -1 / DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / DATA DIVER(1),DIVER(2) / 1018167296, 0 / DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 /, SC/987/ C C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES AND 8087-BASED C MICROS, SUCH AS THE IBM PC AND AT&T 6300, IN WHICH THE LEAST C SIGNIFICANT BYTE IS STORED FIRST. C C DATA SMALL(1),SMALL(2) / 0, 1048576 / C DATA LARGE(1),LARGE(2) / -1, 2146435071 / C DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / C DATA DIVER(1),DIVER(2) / 0, 1018167296 / C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /, SC/987/ C C MACHINE CONSTANTS FOR AMDAHL MACHINES. C C DATA SMALL(1),SMALL(2) / 1048576, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / C DATA DIVER(1),DIVER(2) / 873463808, 0 / C DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 /, SC/987/ C C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / 00564000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C C DATA LARGE(1) / 37757777777777777777B / C DATA LARGE(2) / 37157777777777777774B / C C DATA RIGHT(1) / 15624000000000000000B / C DATA RIGHT(2) / 00000000000000000000B / C C DATA DIVER(1) / 15634000000000000000B / C DATA DIVER(2) / 00000000000000000000B / C C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B /, SC/987/ C C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / O"00564000000000000000" / C DATA SMALL(2) / O"00000000000000000000" / C C DATA LARGE(1) / O"37757777777777777777" / C DATA LARGE(2) / O"37157777777777777774" / C C DATA RIGHT(1) / O"15624000000000000000" / C DATA RIGHT(2) / O"00000000000000000000" / C C DATA DIVER(1) / O"15634000000000000000" / C DATA DIVER(2) / O"00000000000000000000" / C C DATA LOG10(1) / O"17164642023241175717" / C DATA LOG10(2) / O"16367571421742254654" /, SC/987/ C C MACHINE CONSTANTS FOR CONVEX C-1 C C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /, SC/987/ C C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. C C DATA SMALL(1) / 201354000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C C DATA LARGE(1) / 577767777777777777777B / C DATA LARGE(2) / 000007777777777777776B / C C DATA RIGHT(1) / 376434000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C C DATA DIVER(1) / 376444000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B /, SC/987/ C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - C STATIC DMACH(5) C C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ C DATA LOG10/40423K,42023K,50237K,74776K/, SC/987/ C C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / C DATA LOG10(1),LOG10(2) / '23210115, '10237777 /, SC/987/ C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C 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 THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /, SC/987/ C C MACHINE CONSTANTS FOR THE INTERDATA 8/32 C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. C C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. C C DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / C DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / C DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' /, SC/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /, SC/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C 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 DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA SMALL(3),SMALL(4) / 0, 0 / C C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA LARGE(3),LARGE(4) / -1, -1 / C C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA RIGHT(3),RIGHT(4) / 0, 0 / C C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA DIVER(3),DIVER(4) / 0, 0 / C C DATA LOG10(1),LOG10(2) / 16282, 8346 / C DATA LOG10(3),LOG10(4) / -31493, -12296 /, SC/987/ C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA SMALL(3),SMALL(4) / O000000, O000000 / C C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA LARGE(3),LARGE(4) / O177777, O177777 / C C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / C C DATA DIVER(1),DIVER(2) / O022400, O000000 / C DATA DIVER(3),DIVER(4) / O000000, O000000 / C C DATA LOG10(1),LOG10(2) / O037632, O020232 / C DATA LOG10(3),LOG10(4) / O102373, O147770 /, SC/987/ C C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS C WITH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, C SUPPLIED BY IGOR BRAY. C C DATA SMALL(1),SMALL(2) / :10000000000, :00000100001 / C DATA LARGE(1),LARGE(2) / :17777777777, :37777677775 / C DATA RIGHT(1),RIGHT(2) / :10000000000, :00000000122 / C DATA DIVER(1),DIVER(2) / :10000000000, :00000000123 / C DATA LOG10(1),LOG10(2) / :11504046501, :07674600177 /, SC/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 C 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 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 MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA LARGE(1),LARGE(2) / -32769, -1 / C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA LOG10(1),LOG10(2) / 546979738, -805796613 /, SC/987/ C C MACHINE CONSTANTS FOR THE VAX-11 WITH C FORTRAN IV-PLUS COMPILER C C DATA SMALL(1),SMALL(2) / Z00000080, Z00000000 / C DATA LARGE(1),LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z00002480, Z00000000 / C DATA DIVER(1),DIVER(2) / Z00002500, Z00000000 / C DATA LOG10(1),LOG10(2) / Z209A3F9A, ZCFF884FB /, SC/987/ C C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2 C C DATA SMALL(1),SMALL(2) / '80'X, '0'X / C DATA LARGE(1),LARGE(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / C DATA RIGHT(1),RIGHT(2) / '2480'X, '0'X / C DATA DIVER(1),DIVER(2) / '2500'X, '0'X / C DATA LOG10(1),LOG10(2) / '209A3F9A'X, 'CFF884FB'X /, SC/987/ C C *** ISSUE STOP 779 IF ALL DATA STATEMENTS ARE COMMENTED... IF (SC .NE. 987) STOP 779 C/6S C IF (I .LT. 1 .OR. I .GT. 5) C 1 CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2) C/7S C D1MACH = DMACH(I) RETURN C END SHAR_EOF fi # end of overwriting check if test -f 'drchlt.f' then echo shar: will not over-write existing file "'drchlt.f'" else cat << SHAR_EOF > 'drchlt.f' SUBROUTINE DRCHLT(IOUT,IDBG,IBEG,IE,BDYFCN,CURVE,B,DPTS,NPTS, + EPS0,R_FORM,WORK,IWORK,NWORK,MWORK,UVEC, + ERROR,IER) C ----------------- C C This program will solve the interior and exterior Dirichlet C problems for Laplace's equation on a simply-connected region D C with smooth boundary C. It is assumed that C is at least two C times continuously differentiable. To define a boundary, the user C must supply a parametric form of the external routine CURVE with C parameter range [0,B]. The routine CURVE must also produce the C first and second derivatives on the curve as defined below. The C boundary condition must be given by the routine BDYFCN. C C INPUT PARAMETERS: C C IOUT Input. C The output unit number. C IDBG Input. C The debugging parameter. C =0 produces a shortcut output. C =1 produces a debugging output. C IBEG Input. C =0 means this is a first call on DRCHLT for this C particular curve C, boundary function BDYFCN, and C error tolerance EPS. C =1 means that DRCHLT has been called previously for C this choice of parameters, and the solution U is C desired at a new set of points in DPTS. For such a C call on DRCHLT, change only DPTS, NPTS, AND IBEG. Do C not change any other input variable. C IE Input. C =0 for the interior Dirichlet problem. C =1 for the exterior Dirichlet problem. C BDYFCN External function. C Inputs : x,y C Outputs: BDYFCN C This is a function of two variables X,Y. It gives C the value of the harmonic function U on the C boundary curve C. C CURVE External subroutine. C Inputs : s C Outputs: X,Y,DX,DY,D2X,D2Y C This is a subroutine which defines the boundary C curve C. The calling sequence for it is C CALL CURVE(S,X,Y,DX,DY,D2X,D2Y) C The variable S is the parameterization variable for C the curve C. (X,Y) is the point on the curve C corresponding to the variable S. DX,DY,D2X,D2Y are C the first and second derivatives of X(S) and Y(S), C respectively. C B Input. C The limits of the variable S in defining the curve C C are 0 .LE. S .LE. B C DPTS User supplied array. C This is a two dimensional array specifying the points C at which the harmonic function U is to be evaluated. C The dimension statement for DPTS is C DIMENSION DPTS(2,NPTS) C The point #J is given by C X(J)=DPTS(1,J), Y(J)=DPTS(2,J) C NPTS Input. C This is the number of points in DPTS. It must be C greater than zero. C EPS0 Input. C The desired absolute error tolerance in the solution U. C R_FORM Input. C This specifies the way in which the variable RATE C is to be defined in the routines INTEQN and EVALU. C =0 means we use the "normal" way to define RATE C based on estimating the rate of convergence in the C approximates calculated to date. C =1 means we use a "conservative" error test C in which RATE=0.5 and the approximates are assumed to C have a very slow rate of convergence. Use this for C more ill-behaved problems and boundaries. C WORK Real work array C Temporary work space. This vector should have a C dimension NWORK of at least 5,000. If some points of C DPTS are close to the boundary, then the dimension of C WORK should be increased further. A dimension of C NWORK=300,000 will allow a great many problems to be C treated very accurately. For more details on C computing the needed dimension NWORK for WORK, see C the discussion in the driver program for DRCHLT or C the accompanying paper. C IWORK Integer work array C Temporary integer work space. It will be used as C pivot and work array in LAPACK. C NWORK Input. C Dimension of WORK. NWORK = 300,000 will solve a lot of C problems very accurately. See the preceding discussion C of WORK and the general discussion of NWORK given below. C MWORK Input. C Dimension of IWORK. It is dependendent of NWORK. C MWORK .GE. (SQRT(NWORK+36)-6). C UVEC Output vector. C On exit, it will contain the approximate value of the C solution function U(X(I),Y(I)) at the points (X(I),Y(I)) C given in DPTS. C ERROR Output. C This is an output vector containing predicted error C bounds for the solutions given in the vector UVEC. C The element UVEC(J) is the approximate solution at C the # J point of DPTS, and ERROR(J) is a predicted C error bound. If the desired error EPS was not C attained, then the sign of ERROR(J) is made negative C for such a solution value. Otherwise the sign of C ERROR(J) is positive. C IER Output. C = 1 means some or all of the solution values in UVEC C may not satisfy the error tolerance EPS. C = 0 means the program was completed satisfactorily. C =-1 means EPSO < 0. C =-2 means NWORK < 0 or MWORK < SQRT(NWORK*36) - 6. C =-3 means B .LE. 0. C =-4 means IE or IBEG are out of range. C =-5 means NPTS<=0, an error. C C *** Defining NWORK, the dimension of WORK *** C Introduce variables MAXSYS and MAXMES. MAXSYS represents C the maximum order of the linear system to be solved in C subroutine INTEQN; and MAXMES represents the maximum number C of mesh points of C at which the double layer density C function is to be evaluated. MAXFFT represents the maximum C degree of the Fourier expansion to be produced for the C approximate density function. As examples, C MAXSYS=512, MAXMES=8192 C will solve many problems very accurately. We define NWORK by C NWORK=MAX(MAXSYS**2+12*MAXSYS,7*MAXMES) C The program assumes C MAXSYS .GE. 64, MAXMES .GE. 128 C and you should set NWORK accordingly. These defaults can be C changed by re-setting the respective parameters N_0 and M_0 C in the routines EVALU and INTEQN, respectively. As can be C noted from the numbers given, these parameters should be C chosen as powers of 2. C C *** SOURCES OF INFORMATION *** C C For additional information on this program, see the paper C C K. Atkinson & Y. Jeon, "Automatic boundary integral equation C programs for the planar Laplace equation", ACM Transactions on C Mathematical Software. C C The authors can be contacted at the respective e_mail addresses: C Kendall-Atkinson@uiowa.edu C yjeon@madang.ajou.ac.kr C C The web site for this program is located at the URL C http://www.math.uiowa.edu/~atkinson/laplace.html C C DATE OF LAST CHANGES TO THIS CODE: 7 April 1998 C C ================= END OF INTRODUCTORY REMARKS =================== C INTEGER IBEG,IDBG,IE,IER,IOUT,MWORK,NPTS,NWORK,R_FORM DOUBLE PRECISION DPTS(2,NPTS),ERROR(NPTS),UVEC(NPTS),WORK(NWORK) INTEGER IWORK(MWORK) DOUBLE PRECISION B,BDYFCN,EPS0 EXTERNAL BDYFCN,CURVE C C LOCAL VARIABLES DOUBLE PRECISION D1MACH,EP,EPS,FIW,FL,FN,RHOERR,U100 DOUBLE PRECISION ZERO,TWO,SIX,SEVEN INTEGER I,ID2,ID3,ID4,ID5,ID6,ID7,ID8,ID9,ID10,IEE,IER1,IER2,II, + J,K,LB,LD1,LD2,LD3,LD4,LD5,LD6,LD7,LU,NB,NFINAL,NU INTEGER LBASE(7),NBASE(10) EXTERNAL D1MACH,EVALU,INTEQN INTRINSIC FLOAT,LOG,MAX0,SIGN,SQRT DATA ZERO/0.0D0/, TWO/2.0D0/, SIX/6.0D0/, SEVEN/7.0D0/ C C TEST THE INPUT PARAMETERS. C IF (EPS0 .LE. 0) THEN IER = -1 RETURN END IF IF (NWORK .LE. 0 .OR. + MWORK .LE. (SQRT(NWORK+SIX*SIX) - SIX)) THEN IER = -2 RETURN END IF IF (B .LE. ZERO) THEN IER = -3 RETURN END IF IF ( (IE .LT. 0 .OR. IE .GT. 1) .OR. + (IBEG .LT. 0 .OR. IBEG .GT. 1) ) THEN IER = -4 RETURN END IF IF( NPTS .LE. 0) THEN IER = -5 RETURN END IF C C SET MACHINE DEPENDENT CONSTANT. U100 IS 100 TIMES C MACHINE UNIT ROUND. U100 = 100*D1MACH(4) EPS = EPS0 IF (IBEG .EQ. 1) GO TO 10 EP = EPS/TWO C OBTAIN VALUE OF NUPPER FOR USE IN INTEQN FIW = NWORK FN = SQRT(FIW+SIX*SIX) - SIX IEE = LOG(FN)/LOG(TWO) NU = 2**IEE C BREAK UP WORK INTO VECTORS AND MATRIX FOR USE IN INTEQ. C PRODUCE RELATIVE ADDRESSES WITHIN WORK OF RHO,X,...,D2Y, C OLDRHO,Z. NBASE(1) = 1 NBASE(2) = 1 + NU*NU DO I = 3,10 NBASE(I) = NBASE(I-1) + NU END DO ID2 = NBASE(2) ID3 = NBASE(3) ID4 = NBASE(4) ID5 = NBASE(5) ID6 = NBASE(6) ID7 = NBASE(7) ID8 = NBASE(8) ID9 = NBASE(9) ID10 = NBASE(10) C CALL INTEQN(IOUT,IDBG,IE,B,EP,R_FORM,BDYFCN,CURVE,NU,WORK(ID2), + RHOERR,NFINAL,WORK(ID3),WORK(ID4),WORK(ID5), + WORK(ID6),WORK(ID7),WORK(ID8),WORK(ID9),IWORK, + WORK(ID10),WORK(1),IER1) IF (IDBG .EQ. 1) THEN WRITE (IOUT,FMT=9000) NFINAL,RHOERR,IER1 WRITE (IOUT,FMT=9010) DO I = 1,NFINAL WRITE (IOUT,FMT=9020) WORK(ID3+I-1),WORK(ID4+I-1), + WORK(ID2+I-1) END DO END IF C IF (IER1 .EQ. 1) EP = RHOERR C OBTAIN LUPPER FOR USE IN EVALU. FL = FIW/SEVEN IEE = LOG(FL)/LOG(TWO) + U100 LU = 2**IEE C OBTAIN RELATIVE ADDRESSES FOR BREAKING UP WORK FOR USE C IN EVALU. LBASE(1) = 1 DO I = 2,7 LBASE(I) = LBASE(I-1) + LU END DO LD1 = LBASE(1) LD2 = LBASE(2) LD3 = LBASE(3) LD4 = LBASE(4) LD5 = LBASE(5) LD6 = LBASE(6) LD7 = LBASE(7) C MOVE RHO,X,Y,...,D2Y AROUND IN WORK, LENGTHEN EACH OF THEM. DO I = 1,7 IF (LBASE(I)+NFINAL-1 .GE. NBASE(I+2)) THEN DO K = I,7 II = I + 7 - K LB = LBASE(II) - 1 NB = NBASE(II+1) - 1 DO J = 1,NFINAL WORK(LB+J) = WORK(NB+J) END DO END DO GO TO 10 END IF LB = LBASE(I) - 1 NB = NBASE(I+1) - 1 DO J = 1,NFINAL WORK(LB+J) = WORK(NB+J) END DO END DO C 10 CALL EVALU(IOUT,IDBG,IBEG,IE,B,BDYFCN,CURVE,NFINAL,WORK(LD1), + EP,R_FORM,WORK(LD2),WORK(LD3),WORK(LD4),WORK(LD5), + WORK(LD6),WORK(LD7),LU,DPTS,NPTS,UVEC,ERROR,IER2) C IER = MAX0(IER1,IER2) DO I = 1,NPTS ERROR(I) = ERROR(I) + SIGN(RHOERR, ERROR(I)) END DO IF (IER1 .EQ. 0) RETURN DO I = 1,NPTS IF (ERROR(I) .GT. ZERO) ERROR(I) = -ERROR(I) END DO RETURN 9000 FORMAT (/,' FROM SUBROUTINE DRCHLT: SUBROUTINE INTEQN RESULTS.', + /,' NFINAL=',I3,5X, 'RHOERR=',1P,E8.2,5X,'IER1=',I1,/) 9010 FORMAT (6X,'X',14X,'Y',19X,'RHO') 9020 FORMAT (1P,D12.4,D15.4,D25.12) END SUBROUTINE EVALU(IOUT,IDBG,IBEG,IE,B,BDYFCN,CURVE,N,RHO,EPS, + R_FORM,X,Y,DX,DY,D2X,D2Y,LU,DPTS,NP, + U,ERROR,IER) C ---------------- C C This program evaluates the double layer potential U at the C given points in DPTS. The input is the density function RHO, C and DPTS at which U is evaluated. RHO is evaluated in the C subroutine INTEQN. These results are stored in U, along C with the predicted error bound in ERROR. The desired error C tolerance is EPS. If the desired error bound is not attained, C then the corresponding entry in ERROR is made negative. Its C magnitude is still an estimated error bound. C C IOUT Input. C The output unit number, to the file DRCHLT.ANS C IDBG Input. C The dubugging parameter. C =0 produces a shortcut output file. C =1 produces a debugging output. C IBEG Input. C =0 means this is a first call on DRCHLT for this C particular curve C, boundary function BDYFCN, and C error tolerance EPS. C =1 means that DRCHLT has been called previously for C this choice of parameters, and the solution U is C desired at a new set of points in DPTS. For such a C call on DRCHLT, change only DPTS, NPTS, and IBEG. C Do not change any other input variable. C IE Input. C =0 for the interior Dirichlet problem. C =1 for the exterior Dirichlet problem. C CURVE External subroutine. C This program defines the curve of the boundary C. C B Input. C For the parameterization of C defined in CURVE, C the parameterization interval is [0,B]. C BDYFCN External subroutine. C This program defines the Dirichlet data on the C boundary. C N Input. C This is NFINAL as output from the subroutine INTEQ. C RHO Input. C An array which contains the value of the double C layer density function defining U. C EPS Input. C The user-supplied absolute error tolerance. C R_FORM Input. C This specifies the way in which the variable RATE C is to be defined. C If R_FORM=0, we use the "normal" way to define RATE C based on estimating the rate of convergence in the C approximates calculated to date. C If R_FORM=1, then we use a "conservative" error test C in which RATE=0.5 and the approximates are assumed to C have a very slow rate of convergence. Use this for C more ill-behaved problems and boundaries. C X,Y Inputs. C Two arrays containing a sequence of points c (X(I),Y(I)) produced by calling the subroutine C NEWCUR. They correspond to an even subdivision C of the parameterization interval [0,B]. C DX,DY Inputs. C The derivative values corresponding to the points C given in X,Y. C D2X,D2Y Inputs. C The second derivative values corresponding to the C points given in X,Y. C LU Input. C The upper bound of the size of the arrays X,Y,DX,DY, C D2X,D2Y,RHO. C DPTS Input. C This is a two-dimensional array which supplies the C points at which U is to be evaluated. C NP Input C This is the number of points in DPTS. C U Output. C An output array which contains U(P) for points P C given in DPTS. C ERROR Output. C An output array which contains the predicted error C bound for the corresponding entries in U. C IER Output. C =0 means the program was completed satisfactorily. C =1 means some or all of the solution values in U do C not satisfy the error tolerance EPS. C INTEGER IBEG,IDBG,IE,IER,IOUT,LU,N,NP,R_FORM DOUBLE PRECISION DPTS(2,NP),X(LU),Y(LU),DX(LU),DY(LU),D2X(LU), + D2Y(LU),ERROR(NP),RHO(LU),U(NP) DOUBLE PRECISION D1MACH,B,BDYFCN,EPS EXTERNAL BDYFCN,CURVE C C LOCAL VARIABLES DOUBLE PRECISION AIT,BIT,CMIN,CUT,D2F,DF,DIFF,DISTPQ,DNORM,ERR, + FCNK,FCNM,FCNU,H,MESH,OLDIFF,OLDU,ONE,PASTRT, + PI,PROD,PX,PY,Q,QD2X,QD2Y,QDX,QDY,QSPD,QX,QY,R, + RATE,RTLOW,RTUP,S,SB,SLOPE,SONE,SUM,SZERO,T1,T2, + TQX,TQY,TR,TWO,TX,TY,VALUE,ZERO,PARM INTEGER I,ITR,J,JL,JM,JMIN,JSTEP,JU,K,KH,KSTEP,L,LD,LDM1,LOOP, + LOOP1,LOOP2,M_0,M2 PARAMETER (M_0=32) C C M_0/2 DENOTES THE INITIAL NUMBER OF INTEGRATION NODES TO BE USED C IN THE EVALUATION OF THE DOUBLE LAYER POTENTIAL, AND IT WILL ALSO C BE PERFORMED WITH M_0 NODES, SO THAT THE VALUE OF NWORK IN THE C CALLING PROGRAM NEEDS TO BE SET ACCORDINGLY. ALWAYS SET M_0 TO C BE A POWER OF 2. C DOUBLE PRECISION SQUARE(M_0) EXTERNAL NEWCUR INTRINSIC ABS,MAX,MIN,MIN0 DATA ZERO/0.0D0/,ONE/1.0D0/,RTUP/0.5D0/,RTLOW/.1D0/,CUT/.01D0/, + TWO/2.0D0/ C C DATA 'PI' PI=4.D0*ATAN(1.D0) C C INITIALIZE. LD IS THE RUNNING DIMENSION OF RHO,X,...,D2Y. IF (IBEG .EQ. 0) LD = N IER = 0 IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9000) C BEGIN LOOP TO EVALUATE U AT POINTS P IN DPTS. DO I = 1,NP PX = DPTS(1,I) PY = DPTS(2,I) C IF (IDBG .EQ. 1) THEN WRITE (IOUT,FMT=9010) I,DPTS(1,I),DPTS(2,I),LD END IF C C IF IT IS THE EXTERIOR PROBLEM, CHANGE THE DPTS BY USING C THE KELVIN TRANSFORMATION. IF (IE .EQ. 1) THEN R = PX*PX + PY*PY PX = PX/R PY = PY/R END IF C C BEGIN THE CALCULATION OF THE POINT Q OF C WHICH IS CLOSEST TO P. C SEARCH USING M2 EVENLY SPACED POINTS OF C, GIVEN IN X,Y, AT C STEPS OF JSTEP. INITIALLY CALCULATE SQUARES OF APPROPRIATE C ANGELS. M2 = MIN0(LD,M_0) JSTEP = LD/M2 DO J = 1,M2 JM = J*JSTEP T1 = X(JM) - PX T2 = Y(JM) - PY SQUARE(J) = T1*T1 + T2*T2 END DO CMIN = 1.0D50 DO J = 1,M2 IF (SQUARE(J) .LT. CMIN) THEN CMIN = SQUARE(J) JMIN = J END IF END DO C THE POINT (X(K),Y(K)),K=JSTEP*JMIN, IS CLOSEST TO AMONG ALL C M2 POINTS SEARCHED. JM = JMIN*JSTEP T1 = X(JM) - PX T2 = Y(JM) - PY PROD = ((T1*DX(JM)+T2*DY(JM))**2)/ + (CMIN* (DX(JM)**2+DY(JM)**2)) IF (PROD .GT. CUT) THEN IF (IDBG .EQ. 1) THEN WRITE(IOUT,*) 'STEP 1 FOR FINDING Q FAILED. PROD=', + PROD END IF GO TO 10 END IF C THIS POINT IS ACCEPTABLY CLOSE, AND WILL BE CALLED Q. C EVALUATE RHO AT Q AND SAVE. VALUE = RHO(JSTEP*JMIN) Q = B/LD*(JSTEP*JMIN) C FOR AN EXTERIOR PROBLEM, OBTAIN THE CORRESPONDING POINT ON THE C GIVEN CURVE USING THE KELVIN TRANSFORMATION. R = X(JM)*X(JM) + Y(JM)*Y(JM) TR = ONE IF (IE .EQ. 1) TR = ONE/R QX = TR*X(JM) QY = TR*Y(JM) IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9020) QX,QY,VALUE GO TO 60 C LOOK MORE CAREFULLY AT THE POINTS IN X,Y FOR A CLOSEST POINT. C INITIALLY, SELECT AN INTERVAL IN WHICH TO SEARCH. 10 IF (JMIN .EQ. M2) THEN JMIN = JMIN*JSTEP JL = JMIN - JSTEP + 1 JU = JMIN DO J = JL,JU T1 = X(J) - PX T2 = Y(J) - PY DNORM = T1*T1 + T2*T2 IF (DNORM .LT. CMIN) THEN CMIN = DNORM JMIN = J END IF END DO JL = 1 JU = JSTEP ELSE JMIN = JMIN*JSTEP JL = JMIN - JSTEP + 1 JU = JMIN + JSTEP - 1 END IF DO J = JL,JU T1 = X(J) - PX T2 = Y(J) - PY DNORM = T1*T1 + T2*T2 IF (DNORM .LT. CMIN) THEN CMIN = DNORM JMIN = J END IF END DO T1 = X(JMIN) - PX T2 = Y(JMIN) - PY PROD = ((T1*DX(JMIN)+T2*DY(JMIN))**2)/ + (CMIN* (DX(JMIN)**2+DY(JMIN)**2)) IF (PROD .GT. CUT) THEN IF (IDBG .EQ. 1) THEN WRITE(IOUT,*) 'STEP 2 FOR FINDING Q FAILED. + PROD=', PROD END IF GO TO 20 END IF C THIS POINT Q=(X,Y) IS ACCEPTABLY CLOSE TO P. EVALUATE RHO AT Q. VALUE = RHO(JMIN) Q = B/LD*JMIN C FOR AN EXTERIOR PROBLEM, OBTAIN A CORRESPONDING POINTS ON THE C GIVEN CURVE USING THE KELVIN TRANSFORMATION. TR = ONE R = X(JMIN)*X(JMIN) + Y(JMIN)*Y(JMIN) IF (IE .EQ. 1) TR = ONE/R QX = TR*X(JMIN) QY = TR*Y(JMIN) IF(IDBG .EQ. 1) WRITE (IOUT,FMT=9030) QX,QY,VALUE GO TO 60 C NO ACCEPTABLE POINT Q FOUND ON C USING THE VECTORS X,Y. C BEGIN ITERATION METHOD. 20 H = B/LD SB = JMIN*H SZERO = SB LOOP = 0 QX = X(JMIN) QY = Y(JMIN) QDX = DX(JMIN) QDY = DY(JMIN) QD2X = D2X(JMIN) QD2Y = D2Y(JMIN) T1 = QX - PX T2 = QY - PY C ITERATION LOOP. 30 DF = TWO* (T1*QDX+T2*QDY) D2F = TWO* (QDX**2+QDY**2+T1*QD2X+T2*QD2Y) SONE = SZERO - DF/D2F LOOP = LOOP + 1 CALL NEWCUR(IE,CURVE,SONE,QX,QY,QDX,QDY,QD2X,QD2Y) T1 = QX - PX T2 = QY - PY PROD = ((T1*QDX+T2*QDY)**2)/ ((T1*T1+T2*T2)* + (QDX*QDX+QDY*QDY)) IF (IDBG .EQ. 1) THEN WRITE(IOUT,*)'STEP 3 FOR FINDING Q. PROD=', PROD END IF IF (PROD .LE. CUT) THEN Q=SONE GO TO 50 END IF C THE NEW POINT (QX,QY) IS NOT SUFFICIENTLY CLOSE. CHECK FOR C POSSIBLE DIVERGENCE OF ITERATION. IF ((SB-H .GT. SONE) .OR. (SB+H .LT. SONE)) GO TO 40 C CONTINUE ITERATION. SZERO = SONE GO TO 30 C PRIMARY ITERATION IS DIVERGING. GO TO A METHOD GUARANTEED C TO CONVERGE, THE BISECTION METHOD 40 AIT = SB - H BIT = SB + H C BEGINNING OF ITERATION LOOP. WE LIMIT THE NUMBER OF ITERATION C TO A CERTAIN NUMBER( HERE 10) DO ITR = 1,10 Q = (AIT+BIT)/2.0 LOOP = LOOP + 1 CALL NEWCUR(IE,CURVE,Q,QX,QY,QDX,QDY,QD2X,QD2Y) T1 = QX - PX T2 = QY - PY SLOPE = T1*QDX + T2*QDY PROD = (SLOPE*SLOPE)/ ((T1*T1+T2*T2)* (QDX*QDX+QDY*QDY)) IF (IDBG .EQ. 1) WRITE(IOUT,*)'STEP 4 FOR FINDING Q. + PROD=', PROD IF (PROD .LE. CUT) THEN PARM=Q GO TO 50 END IF SLOPE = 2.0*SLOPE IF (SLOPE .LT. ZERO) THEN AIT = Q ELSE BIT = Q END IF END DO C THE ITERATION IS IN A TIGHT LOOP. SOMETHING IS WRONG ABOUT C CURVE. FOR THE EXTERIOR PROBLEM, OBTAIN A CORRESPONDING POINT C ON GIVEN CURVE. IF (IE .EQ. 1) THEN R = QX*QX + QY*QY QX = QX/R QY = QY/R END IF IF(IDBG.EQ.1) WRITE (IOUT,FMT=9040) Q,QX,QY C A SUFFICIENTLY ACCURATE CLOSEST POINT TO P HAS BEEN FOUND, AND C NOW EVALUATE RHO AT THIS POINT, USING THE NYSTROM INTERPOLATION C FORMULA. 50 SUM = ZERO KSTEP = LD/N DO K = KSTEP,LD,KSTEP T1 = X(K) - QX T2 = Y(K) - QY SUM = SUM + RHO(K)* (DY(K)*T1-DX(K)*T2)/ (T1*T1+T2*T2) END DO TQX = QX TQY = QY C FOR AN EXTERIOR PROBLEM, USE THE KELVIN TRANSFORMATION TO OBTAIN C THE CORRESPONDING POINT ON THE GIVEN CURVE. IF (IE .EQ. 1) THEN R = QX**2 + QY**2 TQX = QX/R TQY = QY/R END IF VALUE = - (BDYFCN(TQX,TQY)+KSTEP*H*SUM)/PI C IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9050) TQX,TQY,VALUE,LOOP C CLOSEST POINT Q AND THE VALUE OF RHO AT Q HAVE BEEN CALCULATED. C NOW BEGIN EVALUATION OF U(PX,PY) USING NUMERICAL INTEGRATION. C INITIALIZE, AND BEGIN WITH M_0/2 NODES. C 60 CALL NEWCUR(IE,CURVE,Q,QX,QY,QDX,QDY,QD2X,QD2Y) DISTPQ = SQRT((PX-QX)*(PX-QX) + (PY-QY)*(PY-QY)) QSPD = SQRT(QDX*QDX+QDY*QDY) RATE = RTUP PASTRT = RTUP L = M_0/2 LOOP1 = 1 LOOP2 = 1 C CALCULATE NUMERICAL INTEGRAL WITH L SUBDIVISIONS OF (0,B). 70 SUM = ZERO KSTEP = LD/L DO K = KSTEP,LD,KSTEP T1 = X(K) - PX T2 = Y(K) - PY FCNM = (DY(K)*T1-DX(K)*T2)/ (T1*T1+T2*T2) SUM = SUM + FCNM* (RHO(K)-VALUE) END DO FCNU = -TWO*PI*VALUE - (B/L)*SUM IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9060) FCNU,L,LD IF (LOOP1 .EQ. 1) GO TO 100 C ESTIMATE ERROR IN FCNU. DIFF = ABS(FCNU-OLDU) IF (LOOP1 .EQ. 2) GO TO 80 C UPDATE RATE OF CONVERGENCE OF NUMERICAL INTEGRATION. IF(R_FORM .EQ. 0) THEN C THE FOLLOWING IS A SOPHISTICATED ERROR ESTIMATOR, C USUALLY REASONABLY ACCURATE. RATE = MAX(PASTRT,RTLOW,MIN(RTUP,ABS(DIFF/OLDIFF))) ELSE C THE FOLLOWING IS A CONSERVATIVE ERROR ESTIMATOR. RATE = RTUP END IF PASTRT = MIN(RTUP,ABS(DIFF/OLDIFF)) 80 ERR = (RATE/ (ONE-RATE))*DIFF IF(IDBG .EQ. 1) WRITE (IOUT,FMT=9070) ERR,RATE C IF (ERR .GT. EPS) GO TO 90 IF (ERR .EQ. ZERO) THEN ERR = D1MACH(4) OLDIFF = ERR END IF C FOR A POINT CLOSE TO THE BOUNDARY, ITERATE TWO MORE TIMES. MESH = QSPD*B/L IF ((MESH .GT. DISTPQ) .AND. (LOOP2 .LE. 2)) THEN LOOP2 = LOOP2 + 1 GO TO 90 END IF C THE VALUE OF FCNU IS SUFFICIENTLY ACCURATE. U(I) = FCNU ERROR(I) = ERR GO TO 120 C FCNU IS NOT SUFFICIENTLY ACCURATE. C RE-INITIALIZE FOR ANOTHER NUMERICAL INTEGRATION. 90 OLDIFF = DIFF IF(OLDIFF .EQ. ZERO) OLDIFF = D1MACH(4) 100 OLDU = FCNU LOOP1 = LOOP1 + 1 L = 2*L IF (L .LE. LD) GO TO 70 C NOT SUFFICIENT VALUES IN RHO. THUS VALUES OF RHO ON A FINER C MESH MUST BE CREATED. LD = 2*LD IF (LD .GT. LU) GO TO 110 C THERE IS SUFFICIENT SPACE IN RHO,X,Y,...,D2Y FOR AN INCREASED SUB- C DIVISION OF (0,B). C MOVE OLD VALUES OF RHO,...,D2Y TO MAKE ROOM FOR NEW VALUES. DO J = 2,LD,2 K = LD + 2 - J KH = K/2 RHO(K) = RHO(KH) X(K) = X(KH) Y(K) = Y(KH) DX(K) = DX(KH) DY(K) = DY(KH) D2X(K) = D2X(KH) D2Y(K) = D2Y(KH) END DO C PRODUCE NEW CURVE PARAMETERS FOR FINER SUBDIVISION. H = B/LD LDM1 = LD - 1 DO J = 1,LDM1,2 S = J*H CALL NEWCUR(IE,CURVE,S,X(J),Y(J),DX(J),DY(J),D2X(J), + D2Y(J)) END DO C PRODUCE NEW VALUES OF RHO. H = B/N KSTEP = LD/N DO J = 1,LDM1,2 SUM = ZERO DO K = KSTEP,LD,KSTEP T1 = X(K) - X(J) T2 = Y(K) - Y(J) FCNK = (DY(K)*T1-DX(K)*T2)/ (T1*T1+T2*T2) SUM = SUM + FCNK*RHO(K) END DO C FOR AN EXTERIOR PROBLEM, USE THE KELVIN TRANSFORMATION. TX = X(J) TY = Y(J) IF (IE .EQ. 1) THEN R = X(J)*X(J) + Y(J)*Y(J) TX = X(J)/R TY = Y(J)/R END IF RHO(J) = - (BDYFCN(TX,TY)+H*SUM)/PI END DO GO TO 70 C THE UPPER LIMITS FOR RHO,X,Y,...,D2Y HAVE BEEN REACHED. C MARK ERROR BOUND ACCORDINGLY AND CONTINUE ONTO NEXT POINT P. 110 ERROR(I) = -ERR U(I) = FCNU IER = 1 LD = LD/2 120 END DO RETURN 9000 FORMAT (/,' FROM SUBROUTINE EVALU.',/) 9010 FORMAT (/,' I=',I3,4X,'PX=',1P,D11.4,3X,'PY=',D11.4,5X,'LD=',I6) 9020 FORMAT (' QSTAGE1. QX=',1P,D11.4,3X,'QY=',D11.4,3X,'RHO=', + D20.12) 9030 FORMAT (' QSTAGE2. QX=',1P,D11.4,3X,'QY=',D11.4,3X,'RHO=', + D20.12) 9040 FORMAT (' PROD IS NOT CONVERGING TO ZERO IN LOOP BEGINNING AT + 112',/,' Q=',1P,D11.4,5X,'QX=',D11.4,5X,'QY=',/) C9050 FORMAT (' QSTAGE3. QX=',1P,D11.4,3X,'QY=',D11.4,3X,'RHO=', C + D20.12,3X,'LOOPS=',I1) 9060 FORMAT (' NUM INT =',1P,E20.12,5X,'L=',I6,5X,'LD=',I6) 9070 FORMAT (' ERROR=',1P,D20.12,5X,'RATE=',D11.4) END SUBROUTINE INTEQN(IOUT,IDBG,IE,B,EPS,R_FORM,BDYFCN,CURVE,NUPPER, + RHO,ERROR,NFINAL,X,Y,DX,DY,D2X,D2Y, + OLDRHO,IWORK,WORK,KERMAT,IER) C ----------------- C C This program solves the second kind boundary integral equation C which arises from solving the interior Dirichlet problem as a C double layer potential. C C The integral equation is solved using Nystrom's method with C the rectangular rule as the quadrature rule. The resulting C linear system is solved directly using LAPACK routines. C C The output is the double layer density function RHO. This C is to be found with such accuracy that the resulting harmonic C function has an accuracy of EPS. C C This routine assumes the boundary C is at least two times C continuously differentiable. The boundary C is defined by C the subroutine CURVE. C C The present routine calculates with the rectangular rule for C N=4,8,16,... until a sufficiently accurate value of RHO is C obtained. This is subject to N .LE. NUPPER, with the latter C based on the size of the vector WORK supplied by the user in C calling DRCHLT. C C IOUT Input. C The output unit number, to the file DRCHLT.ANS C IDBG Input. C The debugging parameter. C =0 produces a shortcut output. C =1 produces a debugging output. C IE Input. C =0 for the interior Dirichlet problem. C =1 for the exterior Dirichlet problem. C CURVE Input. C This program defines the curve of the boundary C. C B Input. C For the parameterization of C defined in CURVE, C the parameterization interval is [0,B]. C EPS Input. C The user-supplied error tolerance. C R_FORM Input. C This specifies the way in which the variable RATE C is to be defined. C If R_FORM=0, we use the "normal" way to define RATE C based on estimating the rate of convergence in the C approximates calculated to date. C If R_FORM=1, then we use a "conservative" error test C in which RATE=0.5 and the approximates are assumed to C have a very slow rate of convergence. Use this for C more ill-behaved problems and boundaries. C BDYFCN Input. C This program defines the Dirichlet data on the C boundary. C NUPPER Input. C This is the upper bound for the size of linear C system that can be constructed and solved. C RHO Output. C An array which contains the value of the double C layer density function defining U. C ERROR Output. C An output array which contains the predicted error C bound for the corresponding entries in U. C NFINAL Output. C This is the dimension of the final linear system C constructed in solving for RHO. C X,Y Output. C Two arrays containing a sequence of points c (X(I),Y(I)) produced by calling the subroutine C NEWCUR. They correspond to an even subdivision C of the parameterization interval [0,B]. C DX,DY Output. C The derivative values corresponding to the points C given in X,Y. C D2X,D2Y Output. C The second derivative values corresponding to the C points given in X,Y. C OLDRHO Output. C An array containing the preceding value of RHO, C also produced in this program. C IWORK Integer work space C This is an array for pivoting used for the subroutines C in LAPACK. C WORK Real work space. C A work array for the subroutines in LAPACK. C KERMAT Output. C This is array contains the linear system associated C with the Nystrom method. C IER Output. C =0 means the program was completed satisfactorily. C =1 means some or all of the solution values in U do C not satisfy the error tolerance EPS. C INTEGER IDBG,IE,IER,INFO,IOUT,NFINAL,NUPPER,R_FORM DOUBLE PRECISION D2X(NUPPER),D2Y(NUPPER),DX(NUPPER),DY(NUPPER), + KERMAT(NUPPER,NUPPER),OLDRHO(NUPPER), + RHO(NUPPER),X(NUPPER),Y(NUPPER),WORK(4*NUPPER) INTEGER IWORK(NUPPER) DOUBLE PRECISION D1MACH,RTLOW,B,BDYFCN,EPS,ERROR EXTERNAL BDYFCN,CURVE C C LOCAL VARIABLES. DOUBLE PRECISION DIFF,DIST,H,OLDIFF,ONE,PI,R,RATE,RCOND, + RTUP,SUM,SUMAX,T1,T2,TWO,TX,TY,ZERO INTEGER I,J,JH,N,NM1,N_0,NRHS EXTERNAL NEWCUR INTRINSIC ABS,MAX PARAMETER (N_0 = 32) DATA RTLOW/.1D0/,RTUP/.5D0/,ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/, + NRHS/1/ C C THE PARAMETER N_0 GIVES THE INITIAL NUMBER OF QUADRATURE POINTS C USED IN THE APPROXIMATION OF THE INTEGRAL EQUATION. THE EQUATION C WILL ALSO BE SOLVED WITH 2*N_0 NODES. IN THE PROGRAM CALLING C NEUMAN, THE PARAMETER NWORK SHOULD BE SET ACCORDING. ALWAYS SET C N_0 TO BE A POWER OF 2. C C DATA 'PI' PI = 4.D0*ATAN(1.D0) C INITIAL CASE, N=N_0. INITIALIZE PARAMETERS. IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9000) N = N_0 RATE = RTUP C DEFINE STEPSIZE AND POINTS ON CURVE. H = B/N DO I = 1,N CALL NEWCUR(IE,CURVE,I*H,X(I),Y(I),DX(I),DY(I),D2X(I), + D2Y(I)) END DO GO TO 20 C DEFINE H AND POINTS ON CURVE FOR CONTINUING LOOP ON N. 10 H = B/N DO I = 2,N,2 J = N + 2 - I JH = J/2 X(J) = X(JH) Y(J) = Y(JH) DX(J) = DX(JH) DY(J) = DY(JH) D2X(J) = D2X(JH) D2Y(J) = D2Y(JH) END DO NM1 = N - 1 DO I = 1,NM1,2 CALL NEWCUR(IE,CURVE,I*H,X(I),Y(I),DX(I),DY(I),D2X(I), + D2Y(I)) END DO C SET UP MATRIX EQUATION. 20 DO I = 1,N RHO(I) = BDYFCN(X(I),Y(I)) IF (IE .EQ. 1) THEN C FOR AN EXTERIOR DIRICHLET PROBLEM, EVALUATE THE BOUNDARY DATA C ON THE ORIGINALLY GIVEN CURVE BY USING THE KELVIN C TRANSFORMATION. R = X(I)*X(I) + Y(I)*Y(I) TX = X(I)/R TY = Y(I)/R RHO(I) = BDYFCN(TX,TY) END IF DO J = 1,N IF (I .EQ. J) THEN C DEFINE KERNEL FOR T(I) = T(J). T1 = DX(I) T2 = DY(I) DIST = T1*T1 + T2*T2 KERMAT(I,I) = -PI - H* (T1*D2Y(I)-T2*D2X(I))/ + (TWO*DIST) ELSE C DEFINE KERNEL FOR T(I) .NE. T(J) T1 = X(J) - X(I) T2 = Y(J) - Y(I) DIST = T1*T1 + T2*T2 KERMAT(I,J) = -H* (DY(J)*T1-DX(J)*T2)/DIST END IF END DO END DO IF (N .EQ. N_0) THEN SUMAX = 1.D0 GO TO 30 END IF C CALCULATE PI+NORM(INTEGRAL OPERATOR). SUMAX = ZERO DO I = 1,N SUM = ZERO DO J = 1,N IF (I .EQ. J) THEN SUM = SUM + ABS(PI+KERMAT(I,I)) + PI ELSE SUM = SUM + ABS(KERMAT(I,J)) END IF END DO SUMAX = MAX(SUMAX,SUM) END DO 30 CALL DGESV(N,NRHS,KERMAT,NUPPER,IWORK,RHO,NUPPER,INFO) CALL DGECON('I',N,KERMAT,NUPPER,SUMAX,RCOND,WORK,IWORK,INFO) IF(RCOND .EQ. ZERO) RCOND = D1MACH(4) IF (IDBG .EQ. 1) WRITE(IOUT,9030) ONE/RCOND IF (N .EQ. N_0) GO TO 60 C CALCULATE NORM OF RHO-OLDRHO. DIFF = ZERO DO I = 2,N,2 DIFF = MAX(DIFF,ABS(RHO(I)-OLDRHO(I/2))) END DO IF (N .EQ. 2*N_0) GO TO 40 C MEASURE RATE OF CONVERGENCE. RATE = DIFF/OLDIFF IF(RATE .GE. ONE) THEN IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9020) N,ERROR,EPS IF (2*N .GT. NUPPER) THEN C EXIT FOR UNSUCCESSFUL RETURN. IER = 1 NFINAL = N RETURN ELSE GO TO 50 END IF END IF IF(R_FORM .EQ. 0) THEN C THE FOLLOWING IS A SOPHISTICATED ERROR ESTIMATOR, C USUALLY REASONABLY ACCURATE. RATE=MAX(RTLOW,MIN(RATE,RTUP)) ELSE C THE FOLLOWING USES A RATE THAT ASSUMES THE RATE OF C CONVERGENCE IS PROPORTIONAL TO 1/N. IT IS A CONSERVATIVE, C BUT SAFER, CHOICE. RATE = RTUP END IF C ESTIMATE ERROR IN RHO. 40 ERROR = (ONE/RCOND)*(SUMAX)*DIFF*RATE/ (ONE-RATE) IF (IDBG .EQ. 1) WRITE (IOUT,FMT=9010) N,RATE,ERROR,DIFF,SUMAX IF (ERROR .LE. EPS) THEN C EXIT FOR SUCCESSFUL RETURN. NFINAL = N IER = 0 RETURN ELSE IF (2*N .GT. NUPPER) THEN C EXIT FOR UNSUCCESSFUL RETURN. IER = 1 NFINAL = N RETURN END IF C PREPARE FOR ANOTHER LOOP ON N. 50 OLDIFF = DIFF IF(OLDIFF .EQ. ZERO) OLDIFF = D1MACH(4) 60 DO I = 1,N OLDRHO(I) = RHO(I) END DO N = 2*N GO TO 10 9000 FORMAT (/,' FROM SUBROUTINE INTEQN',/) 9010 FORMAT (' N=',I3,3X,'RATE=',1P,D8.2,3X,'ERROR=',D8.2,3X,'DIFF=', + D8.2,3X,'SUMAX=',D8.2) 9020 FORMAT (' N=',I3,3X,'RATE > 1',25X,'ERROR=',1PD8.2,3X, + 'EPS=',D8.2) 9030 FORMAT (/,' CONDITION NUMBER = ',1PD8.2) END SUBROUTINE KVTRNF(X,Y,DX,DY,D2X,D2Y,T,DT,D2T) C ----------------- C C Define the Kelvin transformation. C C INPUTS: X, Y, DX, DY, D2X, D2Y C OUTPUTS: T, DT, D2T C DOUBLE PRECISION D2T,D2X,D2Y,DIST,DT,DX,DY,T,X,Y DIST = X*X + Y*Y T = X/DIST DT = (DX* (Y*Y-X*X)-2*X*Y*DY)/ (DIST*DIST) D2T = D2X* (Y**4-X**4) - 2*X*DIST* (DY*DY+DX*DX+Y*D2Y) D2T = D2T - 4* (X*DX+Y*DY)* (DX* (Y*Y-X*X)-2*X*Y*DY) D2T = D2T/DIST**3 RETURN END SUBROUTINE NEWCUR(IE,CURVE,S,X,Y,DX,DY,D2X,D2Y) C ----------------- C C If IE=0, the resulting curve C will be the same as that C defined in the subroutine CURVE. C If IE=1, the resulting curve will be that produced by C applying the Kelvin transformation to the original C boundary curve C. C C INPUTS: IE, S C EXTERNAL SUROUTINE: CURVE C OUTPUTS: X, Y, DX, DY, D2X, D2Y C DOUBLE PRECISION D2TX,D2TY,D2X,D2Y,DTX,DTY,DX,DY,S,TX,TY,X,Y INTEGER IE EXTERNAL CURVE,KVTRNF CALL CURVE(S,X,Y,DX,DY,D2X,D2Y) IF (IE .EQ. 1) THEN CALL KVTRNF(X,Y,DX,DY,D2X,D2Y,TX,DTX,D2TX) CALL KVTRNF(Y,X,DY,DX,D2Y,D2X,TY,DTY,D2TY) X = TX Y = TY DX = DTX DY = DTY D2X = D2TX D2Y = D2TY END IF RETURN END SHAR_EOF fi # end of overwriting check if test -f 'lasys.f' then echo shar: will not over-write existing file "'lasys.f'" else cat << SHAR_EOF > 'lasys.f' SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGESV computes the solution to a real system of linear equations * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * * The LU decomposition with partial pivoting and row interchanges is * used to factor A as * A = P * L * U, * where P is a permutation matrix, L is unit lower triangular, and U is * upper triangular. The factored form of A is then used to solve the * system of equations A * X = B. * * Arguments * ========= * * N (input) INTEGER * The number of linear equations, i.e., the order of the * matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the N-by-N coefficient matrix A. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N-by-NRHS matrix of right hand side matrix B. * On exit, if INFO = 0, the N-by-NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, so the solution could not be computed. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DGETRF, DGETRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESV ', -INFO ) RETURN END IF * * Compute the LU factorization of A. * CALL DGETRF( N, N, A, LDA, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) END IF RETURN * * End of DGESV * END SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DGETRF computes an LU factorization of a general M-by-N matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 3 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN * * Use unblocked code. * CALL DGETF2( M, N, A, LDA, IPIV, INFO ) ELSE * * Use blocked code. * DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) * * Factor diagonal and subdiagonal blocks and test for exact * singularity. * CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) * * Adjust INFO and the pivot indices. * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE * * Apply interchanges to columns 1:J-1. * CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF( J+JB.LE.N ) THEN * * Apply interchanges to columns J+JB:N. * CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) * * Compute block row of U. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), $ LDA ) IF( J+JB.LE.M ) THEN * * Update trailing submatrix. * CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), $ LDA ) END IF END IF 20 CONTINUE END IF RETURN * * End of DGETRF * END SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, IX * .. * .. External Subroutines .. EXTERNAL DSWAP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF * RETURN * * End of DLASWP * END SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DGETF2 computes an LU factorization of a general m-by-n matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 2 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the m by n matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, JP * .. * .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. * JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) IPIV( J ) = JP IF( A( JP, J ).NE.ZERO ) THEN * * Apply the interchange to columns 1:N. * IF( JP.NE.J ) $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) * * Compute elements J+1:M of J-th column. * IF( J.LT.M ) $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) * ELSE IF( INFO.EQ.0 ) THEN * INFO = J END IF * IF( J.LT.MIN( M, N ) ) THEN * * Update trailing submatrix. * CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, $ A( J+1, J+1 ), LDA ) END IF 10 CONTINUE RETURN * * End of DGETF2 * END SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of DGEMM . * END SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DTRSM solves one of the matrix equations * * op( A )*X = alpha*B, or X*op( A ) = alpha*B, * * where alpha is a scalar, X and B are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on B. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*B. * * SIDE = 'R' or 'r' X*op( A ) = alpha*B. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the right-hand side matrix B, and on exit is * overwritten by the solution matrix X. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*inv( A )*B. * IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE * * Form B := alpha*inv( A' )*B. * IF( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*inv( A ). * IF( UPPER )THEN DO 210, J = 1, N IF( ALPHA.NE.ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE END IF DO 190, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE END IF 190 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE END IF 210 CONTINUE ELSE DO 260, J = N, 1, -1 IF( ALPHA.NE.ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE END IF DO 240, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE END IF 240 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE END IF 260 CONTINUE END IF ELSE * * Form B := alpha*B*inv( A' ). * IF( UPPER )THEN DO 310, K = N, 1, -1 IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE END IF DO 290, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE END IF 290 CONTINUE IF( ALPHA.NE.ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE END IF 310 CONTINUE ELSE DO 360, K = 1, N IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE END IF DO 340, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE END IF 340 CONTINUE IF( ALPHA.NE.ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE END IF 360 CONTINUE END IF END IF END IF * RETURN * * End of DTRSM . * END INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV is called from the LAPACK routines to choose problem-dependent * parameters for the local environment. See ISPEC for a description of * the parameters. * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set * the tuning parameters for their particular machine using the option * and problem size information in the arguments. * * This routine will not function correctly if it is converted to all * lower case. Converting it to all upper case is allowed. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or * lower case. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. Executable Statements .. * GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF * C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) * GO TO ( 110, 200, 300 ) ISPEC * 110 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN * 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN * 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN * 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * * End of ILAENV * END subroutine dswap (n,dx,incx,dy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i + 1) dx(i + 1) = dy(i + 1) dy(i + 1) = dtemp dtemp = dx(i + 2) dx(i + 2) = dy(i + 2) dy(i + 2) = dtemp 50 continue return end SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of DGER . * END SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGETRS solves a system of linear equations * A * X = B or A' * X = B * with a general N-by-N matrix A using the LU factorization computed * by DGETRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLASWP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A * X = B. * * Apply row interchanges to the right hand sides. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) * * Solve L*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A' * X = B. * * Solve U'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, $ A, LDA, B, LDB ) * * Apply row interchanges to the solution vectors. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF * RETURN * * End of DGETRS * END SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * January 31, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dmax integer i,incx,ix,n c idamax = 0 if( n.lt.1 .or. incx.le.0 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 dmax = dabs(dx(1)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision da,dx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da*dx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DGECON estimates the reciprocal of the condition number of a general * real matrix A, in either the 1-norm or the infinity-norm, using * the LU factorization computed by DGETRF. * * An estimate is obtained for norm(inv(A)), and the reciprocal of the * condition number is computed as * RCOND = 1 / ( norm(A) * norm(inv(A)) ). * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies whether the 1-norm condition number or the * infinity-norm condition number is required: * = '1' or 'O': 1-norm; * = 'I': Infinity-norm. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ANORM (input) DOUBLE PRECISION * If NORM = '1' or 'O', the 1-norm of the original matrix A. * If NORM = 'I', the infinity-norm of the original matrix A. * * RCOND (output) DOUBLE PRECISION * The reciprocal of the condition number of the matrix A, * computed as RCOND = 1/(norm(A) * norm(inv(A))). * * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * IWORK (workspace) INTEGER array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLACON, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGECON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.EQ.ZERO ) THEN RETURN END IF * SMLNUM = DLAMCH( 'Safe minimum' ) * * Estimate the norm of inv(A). * AINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * * Multiply by inv(L). * CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) * * Multiply by inv(U). * CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) ELSE * * Multiply by inv(U'). * CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) * * Multiply by inv(L'). * CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) END IF * * Divide X by 1/(SL*SU) if doing so will not cause overflow. * SCALE = SL*SU NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) $ GO TO 20 CALL DRSCL( N, SCALE, WORK, 1 ) END IF GO TO 10 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * 20 CONTINUE RETURN * * End of DGECON * END SUBROUTINE DRSCL( N, SA, SX, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SA * .. * .. Array Arguments .. DOUBLE PRECISION SX( * ) * .. * * Purpose * ======= * * DRSCL multiplies an n-element real vector x by the real scalar 1/a. * This is done without overflow or underflow as long as * the final result x/a does not overflow or underflow. * * Arguments * ========= * * N (input) INTEGER * The number of components of the vector x. * * SA (input) DOUBLE PRECISION * The scalar a which is used to divide each component of x. * SA must be >= 0, or the subroutine will divide by zero. * * SX (input/output) DOUBLE PRECISION array, dimension * (1+(N-1)*abs(INCX)) * The n-element vector x. * * INCX (input) INTEGER * The increment between successive values of the vector SX. * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL DONE DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Initialize the denominator to SA and the numerator to 1. * CDEN = SA CNUM = ONE * 10 CONTINUE CDEN1 = CDEN*SMLNUM CNUM1 = CNUM / BIGNUM IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN * * Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. * MUL = SMLNUM DONE = .FALSE. CDEN = CDEN1 ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN * * Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. * MUL = BIGNUM DONE = .FALSE. CNUM = CNUM1 ELSE * * Multiply X by CNUM / CDEN and return. * MUL = CNUM / CDEN DONE = .TRUE. END IF * * Scale the vector X by MUL * CALL DSCAL( N, MUL, SX, INCX ) * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DRSCL * END SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ) DOUBLE PRECISION V( * ), X( * ) * .. * * Purpose * ======= * * DLACON estimates the 1-norm of a square, real matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) DOUBLE PRECISION array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) DOUBLE PRECISION array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * and DLACON must be re-called with all the other parameters * unchanged. * * ISGN (workspace) INTEGER array, dimension (N) * * EST (output) DOUBLE PRECISION * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to DLACON, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from DLACON, KASE will again be 0. * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named SONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 110 CONTINUE JLAST = J J = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN END * * End of DLACON SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. * * Purpose * ======= * * DLATRS solves one of the triangular systems * * A *x = s*b or A'*x = s*b * * with scaling to prevent overflow. Here A is an upper or lower * triangular matrix, A' denotes the transpose of A, x and b are * n-element vectors, and s is a scaling factor, usually less than * or equal to 1, chosen so that the components of x will be less than * the overflow threshold. If the unscaled problem will not cause * overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A * is singular (A(j,j) = 0 for some j), then s is set to 0 and a * non-trivial solution to A*x = 0 is returned. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower triangular. * = 'U': Upper triangular * = 'L': Lower triangular * * TRANS (input) CHARACTER*1 * Specifies the operation applied to A. * = 'N': Solve A * x = s*b (No transpose) * = 'T': Solve A'* x = s*b (Transpose) * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A is unit triangular. * = 'N': Non-unit triangular * = 'U': Unit triangular * * NORMIN (input) CHARACTER*1 * Specifies whether CNORM has been set or not. * = 'Y': CNORM contains the column norms on entry * = 'N': CNORM is not set on entry. On exit, the norms will * be computed and stored in CNORM. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The triangular matrix A. If UPLO = 'U', the leading n by n * upper triangular part of the array A contains the upper * triangular matrix, and the strictly lower triangular part of * A is not referenced. If UPLO = 'L', the leading n by n lower * triangular part of the array A contains the lower triangular * matrix, and the strictly upper triangular part of A is not * referenced. If DIAG = 'U', the diagonal elements of A are * also not referenced and are assumed to be 1. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max (1,N). * * X (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the right hand side b of the triangular system. * On exit, X is overwritten by the solution vector x. * * SCALE (output) DOUBLE PRECISION * The scaling factor s for the triangular system * A * x = s*b or A'* x = s*b. * If SCALE = 0, the matrix A is singular or badly scaled, and * the vector x is an exact or approximate solution to A*x = 0. * * CNORM (input or output) DOUBLE PRECISION array, dimension (N) * * If NORMIN = 'Y', CNORM is an input argument and CNORM(j) * contains the norm of the off-diagonal part of the j-th column * of A. If TRANS = 'N', CNORM(j) must be greater than or equal * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) * must be greater than or equal to the 1-norm. * * If NORMIN = 'N', CNORM is an output argument and CNORM(j) * returns the 1-norm of the offdiagonal part of the j-th column * of A. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * Further Details * ======= ======= * * A rough bound on x is computed; if that is less than overflow, DTRSV * is called, otherwise, specific code is used which checks for possible * overflow or divide-by-zero at every operation. * * A columnwise scheme is used for solving A*x = b. The basic algorithm * if A is lower triangular is * * x[1:n] := b[1:n] * for j = 1, ..., n * x(j) := x(j) / A(j,j) * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] * end * * Define bounds on the components of x after j iterations of the loop: * M(j) = bound on x[1:j] * G(j) = bound on x[j+1:n] * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. * * Then for iteration j+1 we have * M(j+1) <= G(j) / | A(j+1,j+1) | * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) * * where CNORM(j+1) is greater than or equal to the infinity-norm of * column j+1 of A, not counting the diagonal. Hence * * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) * 1<=i<=j * and * * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) * 1<=i< j * * Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the * reciprocal of the largest M(j), j=1,..,n, is larger than * max(underflow, 1/overflow). * * The bound on x(j) is also used to determine when a step in the * columnwise method can be performed without fear of overflow. If * the computed bound is greater than a large constant, x is scaled to * prevent overflow, but if the bound overflows, x is set to 0, x(j) to * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. * * Similarly, a row-wise scheme is used to solve A'*x = b. The basic * algorithm for A upper triangular is * * for j = 1, ..., n * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) * end * * We simultaneously compute two bounds * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j * M(j) = bound on x(i), 1<=i<=j * * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. * Then the bound on x(j) is * * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | * * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) * 1<=i<=j * * and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater * than max(underflow, 1/overflow). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine DTRSV can be used. * J = IDAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A' * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL DSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 100 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 100 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL DSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IDAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IDAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF END IF 110 CONTINUE * ELSE * * Solve A' * x = b * DO 160 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call DDOT to perform the dot product. * IF( UPPER ) THEN SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = J + 1, N SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 150 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A'*x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 150 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) 160 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of DLATRS * END subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end double precision function ddot(n,dx,incx,dy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy 10 continue ddot = dtemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dx(i)*dy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 50 continue 60 ddot = dtemp return end subroutine dcopy(n,dx,incx,dy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 dy(i) = dx(i) dy(i + 1) = dx(i + 1) dy(i + 2) = dx(i + 2) dy(i + 3) = dx(i + 3) dy(i + 4) = dx(i + 4) dy(i + 5) = dx(i + 5) dy(i + 6) = dx(i + 6) 50 continue return end SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRSV . * END double precision function dasum(n,dx,incx) c c takes the sum of the absolute values. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dtemp integer i,incx,m,mp1,n,nincx c dasum = 0.0d0 dtemp = 0.0d0 if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dtemp = dtemp + dabs(dx(i)) 10 continue dasum = dtemp return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,6) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dabs(dx(i)) 30 continue if( n .lt. 6 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,6 dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) 50 continue 60 dasum = dtemp return end DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH * .. * * Purpose * ======= * * DLAMCH determines double precision machine parameters. * * Arguments * ========= * * CMACH (input) CHARACTER*1 * Specifies the value to be returned by DLAMCH: * = 'E' or 'e', DLAMCH := eps * = 'S' or 's , DLAMCH := sfmin * = 'B' or 'b', DLAMCH := base * = 'P' or 'p', DLAMCH := eps*base * = 'N' or 'n', DLAMCH := t * = 'R' or 'r', DLAMCH := rnd * = 'M' or 'm', DLAMCH := emin * = 'U' or 'u', DLAMCH := rmin * = 'L' or 'l', DLAMCH := emax * = 'O' or 'o', DLAMCH := rmax * * where * * eps = relative machine precision * sfmin = safe minimum, such that 1/sfmin does not overflow * base = base of the machine * prec = eps*base * t = number of (base) digits in the mantissa * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise * emin = minimum exponent before (gradual) underflow * rmin = underflow threshold - base**(emin-1) * emax = largest exponent before overflow * rmax = overflow threshold - (base**emax)*(1-eps) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAMC2 * .. * .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF * DLAMCH = RMACH RETURN * * End of DLAMCH * END * ************************************************************************ * SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T * .. * * Purpose * ======= * * DLAMC1 determines the machine parameters given by BETA, T, RND, and * IEEE1. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * IEEE1 (output) LOGICAL * Specifies whether rounding appears to be done in the IEEE * 'round to nearest' style. * * Further Details * =============== * * The routine is based on the routine ENVRON by Malcolm and * incorporates suggestions by Gentleman and Marovich. See * * Malcolm M. A. (1972) Algorithms to reveal properties of * floating-point arithmetic. Comms. of the ACM, 15, 949-951. * * Gentleman W. M. and Marovich S. B. (1974) More on algorithms * that reveal properties of floating point arithmetic units. * Comms. of the ACM, 17, 276-277. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, * IEEE1, T and RND. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * Compute a = 2.0**m with the smallest positive integer m such * that * * fl( a + 1.0 ) = a. * A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( C.EQ.ONE ) THEN A = 2*A C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 10 END IF *+ END WHILE * * Now compute b = 2.0**m with the smallest positive integer m * such that * * fl( a + b ) .gt. a. * B = 1 C = DLAMC3( A, B ) * *+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( C.EQ.A ) THEN B = 2*B C = DLAMC3( A, B ) GO TO 20 END IF *+ END WHILE * * Now compute the base. a and c are neighbouring floating point * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so * their difference is beta. Adding 0.25 to c is to ensure that it * is truncated to beta and not ( beta - 1 ). * QTR = ONE / 4 SAVEC = C C = DLAMC3( C, -A ) LBETA = C + QTR * * Now determine whether rounding or chopping occurs, by adding a * bit less than beta/2 and a bit more than beta/2 to a. * B = LBETA F = DLAMC3( B / 2, -B / 100 ) C = DLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = DLAMC3( B / 2, B / 100 ) C = DLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. * * Try and decide whether rounding is done in the IEEE 'round to * nearest' style. B/2 is half a unit in the last place of the two * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit * zero, and SAVEC is odd. Thus adding B/2 to A should not change * A, but adding B/2 to SAVEC should change SAVEC. * T1 = DLAMC3( B / 2, A ) T2 = DLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND * * Now find the mantissa, t. It should be the integer part of * log to the base beta of a, however it is safer to determine t * by powering. So we find t as the smallest positive integer for * which * * fl( beta**t + 1.0 ) = 1.0. * LT = 0 A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( C.EQ.ONE ) THEN LT = LT + 1 A = A*LBETA C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 30 END IF *+ END WHILE * END IF * BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN * * End of DLAMC1 * END * ************************************************************************ * SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T DOUBLE PRECISION EPS, RMAX, RMIN * .. * * Purpose * ======= * * DLAMC2 determines the machine parameters specified in its argument * list. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * EPS (output) DOUBLE PRECISION * The smallest positive number such that * * fl( 1.0 - EPS ) .LT. 1.0, * * where fl denotes the computed value. * * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow occurs. * * RMIN (output) DOUBLE PRECISION * The smallest normalized number for the machine, given by * BASE**( EMIN - 1 ), where BASE is the floating point value * of BETA. * * EMAX (output) INTEGER * The maximum exponent before overflow occurs. * * RMAX (output) DOUBLE PRECISION * The largest positive number for the machine, given by * BASE**EMAX * ( 1 - EPS ), where BASE is the floating point * value of BETA. * * Further Details * =============== * * The computation of EPS is based on a routine PARANOIA by * W. Kahan of the University of California at Berkeley. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. External Subroutines .. EXTERNAL DLAMC1, DLAMC4, DLAMC5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 * * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of * BETA, T, RND, EPS, EMIN and RMIN. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. * CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) * * Start to find EPS. * B = LBETA A = B**( -LT ) LEPS = A * * Try some tricks to see whether or not this is the correct EPS. * B = TWO / 3 HALF = ONE / 2 SIXTH = DLAMC3( B, -HALF ) THIRD = DLAMC3( SIXTH, SIXTH ) B = DLAMC3( THIRD, -HALF ) B = DLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS * LEPS = 1 * *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = DLAMC3( HALF, -C ) B = DLAMC3( HALF, C ) C = DLAMC3( HALF, -B ) B = DLAMC3( HALF, C ) GO TO 10 END IF *+ END WHILE * IF( A.LT.LEPS ) $ LEPS = A * * Computation of EPS complete. * * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). * Keep dividing A by BETA until (gradual) underflow occurs. This * is detected when we cannot recover the previous A. * RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = DLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = DLAMC3( ONE, SMALL ) CALL DLAMC4( NGPMIN, ONE, LBETA ) CALL DLAMC4( NGNMIN, -ONE, LBETA ) CALL DLAMC4( GPMIN, A, LBETA ) CALL DLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. * IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN * ( Non twos-complement machines, no gradual underflow; * e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. * ( Non twos-complement machines, with gradual underflow; * e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) * ( Twos-complement machines, no gradual underflow; * e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT * ( Twos-complement machines with gradual underflow; * no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF *** * * Assume IEEE arithmetic if we found denormalised numbers above, * or if arithmetic seems to round in the IEEE style, determined * in routine DLAMC1. A true IEEE machine should have both things * true; however, faulty machines may have one or the other. * IEEE = IEEE .OR. LIEEE1 * * Compute RMIN by successive division by BETA. We could compute * RMIN as BASE**( EMIN - 1 ), but some machines underflow during * this computation. * LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE * * Finally, call DLAMC5 to compute EMAX and RMAX. * CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF * BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX * RETURN * 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) * * End of DLAMC2 * END * ************************************************************************ * DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. * * Purpose * ======= * * DLAMC3 is intended to force A and B to be stored prior to doing * the addition of A and B , for use in situations where optimizers * might hold one of these in a register. * * Arguments * ========= * * A, B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== * * .. Executable Statements .. * DLAMC3 = A + B * RETURN * * End of DLAMC3 * END * ************************************************************************ * SUBROUTINE DLAMC4( EMIN, START, BASE ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN DOUBLE PRECISION START * .. * * Purpose * ======= * * DLAMC4 is a service routine for DLAMC2. * * Arguments * ========= * * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. * * START (input) DOUBLE PRECISION * The starting point for determining EMIN. * * BASE (input) INTEGER * The base of the machine. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Executable Statements .. * A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = DLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = DLAMC3( A / BASE, ZERO ) C1 = DLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = DLAMC3( A*RBASE, ZERO ) C2 = DLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF *+ END WHILE * RETURN * * End of DLAMC4 * END * ************************************************************************ * SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P DOUBLE PRECISION RMAX * .. * * Purpose * ======= * * DLAMC5 attempts to compute RMAX, the largest machine floating-point * number, without overflow. It assumes that EMAX + abs(EMIN) sum * approximately to a power of 2. It will fail on machines where this * assumption does not hold, for example, the Cyber 205 (EMIN = -28625, * EMAX = 28718). It will also fail if the value supplied for EMIN is * too large (i.e. too close to zero), probably with overflow. * * Arguments * ========= * * BETA (input) INTEGER * The base of floating-point arithmetic. * * P (input) INTEGER * The number of base BETA digits in the mantissa of a * floating-point value. * * EMIN (input) INTEGER * The minimum exponent before (gradual) underflow. * * IEEE (input) LOGICAL * A logical flag specifying whether or not the arithmetic * system is thought to comply with the IEEE standard. * * EMAX (output) INTEGER * The largest exponent before overflow * * RMAX (output) DOUBLE PRECISION * The largest machine floating-point number. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP DOUBLE PRECISION OLDY, RECBAS, Y, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * First compute LEXP and UEXP, two powers of 2 that bound * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum * approximately to the bound that is closest to abs(EMIN). * (EMAX is the exponent of the required number RMAX). * LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF * * Now -LEXP is less than or equal to EMIN, and -UEXP is greater * than or equal to EMIN. EXBITS is the number of bits needed to * store the exponent. * IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF * * EXPSUM is the exponent range, approximately equal to * EMAX - EMIN + 1 . * EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P * * NBITS is the total number of bits needed to store a * floating-point number. * IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN * * Either there are an odd number of bits used to store a * floating-point number, which is unlikely, or some bits are * not used in the representation of numbers, which is possible, * (e.g. Cray machines) or the mantissa has an implicit bit, * (e.g. IEEE machines, Dec Vax machines), which is perhaps the * most likely. We have to assume the last alternative. * If this is true, then we need to reduce EMAX by one because * there must be some way of representing zero in an implicit-bit * system. On machines like Cray, we are reducing EMAX by one * unnecessarily. * EMAX = EMAX - 1 END IF * IF( IEEE ) THEN * * Assume we are on an IEEE machine which reserves one exponent * for infinity and NaN. * EMAX = EMAX - 1 END IF * * Now create RMAX, the largest machine number, which should * be equal to (1.0 - BETA**(-P)) * BETA**EMAX . * * First compute 1.0 - BETA**(-P), being careful that the * result is less than 1.0 . * RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = DLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY * * Now multiply by BETA**EMAX to get RMAX. * DO 30 I = 1, EMAX Y = DLAMC3( Y*BETA, ZERO ) 30 CONTINUE * RMAX = Y RETURN * * End of DLAMC5 * END SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL * .. * * Purpose * ======= * * DLABAD takes as input the values computed by SLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and * redefine the underflow and overflow limits to be the square roots of * the values computed by DLAMCH. This subroutine is needed because * DLAMCH does not compensate for poor arithmetic in the upper half of * the exponent range, as is found on a Cray. * * Arguments * ========= * * SMALL (input/output) DOUBLE PRECISION * On entry, the underflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of SMALL, otherwise unchanged. * * LARGE (input/output) DOUBLE PRECISION * On entry, the overflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of LARGE, otherwise unchanged. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END SHAR_EOF fi # end of overwriting check if test -f 'neuman.f' then echo shar: will not over-write existing file "'neuman.f'" else cat << SHAR_EOF > 'neuman.f' SUBROUTINE NEUMAN(IOUT,IDBG,IE,BDYFCN,CURVE,B,DPTS,NPTS,IBEG,EPS0, + WORK,IWORK,NWORK,MWORK,MAXFFT,UVEC,ERROR,IER) C ----------------- C C This program will solve the interior and exterior Neumann C problems for Laplace's equation on a simply-connected region D C with smooth boundary C. It is assumed that C is at least two C times continuously differentiable. To define a boundary, the user C must supply a parametric form of the external routine CURVE with C parameter range [0,B]. The routine CURVE must also produce the C first and second derivatives on the curve as defined below. The C boundary condition must be given by the routine BDYFCN. C C SUBROUTINE PARAMETERS: C IOUT Input. C The output unit number. C IDBG Input. C The debugging parameter. C =0 produces a standard output. C =1 produces a debugging output. C IE Input C =0 for the interior Neumann problem. C =1 for the exterior Neumann problem. C BDYFCN External function. C Inputs : X,Y C Outputs: BDYFCN C This is a function of two variables X,Y. It gives C the value of the normal derivative of the unknown C harmonic function U on the boundary curve C. This C is a user supplied function. C CURVE External subroutine. C Inputs : S C Outputs: X,Y,DX,DY,D2X,D2Y C This is a subroutine which defines the boundary C curve C. The calling sequence for it is C CALL CURVE(S,X,Y,DX,DY,D2X,D2Y) C The variable S is the parameterization variable for C the curve C. (X,Y) is the point on the curve C corresponding to the variable S. DX,DY,D2X,D2Y are C the first and second derivatives of X(S) and Y(S), C respectively. The routine CURVE is supplied by the user. C B Input. C The limits of the variable S in defining the curve C C are 0 .LE. S .LE. B C DPTS Input array. C This is a two dimensional array specifying the points C at which the harmonic function U is to be evaluated, C with each column denoting a distinct point. The C dimension statement for DPTS is C DIMENSION DPTS(4,NPTS) C For point #J, its coordinates have the following C meaning: C X=DPTS(1,J), Y=DPTS(2,J) C S=DPTS(3,J), IBD=DPTS(4,J) C If (X,Y) is not on the boundary C, S need not be C set and the user must set IBD=0. C If (X,Y) is on the boundary, we need S to be the C parameter on [0,B] corresponding to (X,Y); and the C user must set IBD=1. C NPTS Input. C This is the number of points in DPTS. It must be C greater than zero. C IBEG Input. C =0 means this is a first call on NEUMAN for this C particular curve C, boundary function BDYFCN, and C error tolerance EPS. C =1 means that NEUMAN has been called previously for C this choice of parameters, and the solution U is C desired at a new set of points in DPTS. For such a C call on NEUMAN, change only DPTS, NPTS, and IBEG. C DO NOT CHANGE any other input variable. C EPS0 Input. C The desired error tolerance in the solution U. C WORK Input. C Temporary work space. This vector should have a C dimension NWORK of at least 10,000. If some points of C DPTS are close to the boundary, then the dimension of C WORK should be increased further. A dimension of C NWORK=300,000 will allow a wide variety of problems C to be treated very accurately. C NWORK Input. C Dimension of WORK. See the preceding discussion of WORK C and the general discussion of NWORK given below. C IWORK Input. C Temporary work space for integer variables. It is used C as the pivot array in LU fcatorization by LAPACK C subroutines in the subroutine INTEQN. It is also used C in the subroutine EVALU for the FFT routines. C MWORK Input. C Dimension of IWORK. C MWORK .GE. (SQRT(NWORK+49) + 8 ) C MAXFFT Input. C Maximum dimension of FFT. C MAXFFT .GE. (2*SQRT(NWORK + 49) - 14 ) C is desirable to solve many problems accurately. C UVEC Output. C This is an output vector. On exit, component #I will C contain the approximate value of the solution function C U(X(I),Y(I)) at the points (X(I),Y(I)) given in DPTS. C ERROR Output. C This is an output vector containing predicted error C bounds for the solutions given in the vector UVEC. C The element UVEC(J) is the approximate solution at C the # J point of DPTS, and ERROR(J) is a predicted C error bound. If the desired error EPS was not C attained, then the sign of ERROR(J) is made negative C for such a solution value. Otherwise the sign of C ERROR(J) is positive. C IER Output. C = 1 means some or all of the solution values in UVEC C may not satisfy the error tolerance EPS. C = 0 means the program was completed satisfactorily. C =-1 means EPS0 < 0. C =-2 means NWORK < 0 or MWORK < (SQRT(NWORK+49)+8). C =-3 means B .LE. 0. C =-4 means IE or IBEG are out of range. C =-5 means NPTS<=0, an error. C =-6 means MAXFFT < M_0, where M_0 is defined below. C C *** Defining NWORK, the dimension of WORK *** C Introduce variables MAXSYS and MAXMES. MAXSYS represents C the maximum order of the linear system to be solved in C subroutine INTEQN; and MAXMES represents the maximum number C of mesh points of C at which the single layer density C function is to be evaluated. MAXFFT represents the maximum C degree of the Fourier expansion to be produced for the C approximate density function. As examples, C MAXSYS=512, MAXMES=8192, MAXFFT = 1024 C will solve many problems very accurately. We define NWORK by C NWORK=MAX(MAXSYS**2+14*MAXSYS,8*MAXMES+4*MAXFFT) C The program assumes C MAXSYS .GE. 64, MAXMES .GE. 128, MAXFFT .GE. 128 C and you should set NWORK accordingly. These defaults can be C changed by re-setting the respective parameters N_0 and M_0, C as described below. In particular, C MAXSYS .GE. 4*N_0, MAXMES .GE. 4*M_0, MAXFFT .GE. M_0 C C *** THE PROGRAM PARAMETERS K_0, M_0 and N_0 *** C N_0 Denotes the initial number of quadrature points used in the C approximation of the integral equation in the subroutine INTEQN. C K_0 and M_0 denote the initial degree of the FFT and the initial C number of integration nodes in the subroutine EVALU. Always set C M_0 and N_0 to be a power of 2, and K_0=N_0 is desirable. C C *** SOURCES OF INFORMATION *** C C For additional information on this program, see the paper C C K. Atkinson & Y. Jeon, "Automatic boundary integral equation C programs for the planar Laplace equation", ACM Transactions on C Mathematical Software. C C The authors can be contacted at the respective e_mail addresses: C Kendall-Atkinson@uiowa.edu C yjeon@madang.ajou.ac.kr C C The web site for this program is located at the URL C http://www.math.uiowa.edu/~atkinson/laplace.html C C DATE OF LAST CHANGES TO THIS CODE: 7 April 1998 C C ================= END OF INTRODUCTORY REMARKS =================== C INTEGER IBEG,IDBG,IE,IER,IOUT,MAXFFT,MWORK,NPTS,NWORK DOUBLE PRECISION DPTS(4,NPTS),ERROR(NPTS),UVEC(NPTS),WORK(NWORK) INTEGER IWORK(MWORK) DOUBLE PRECISION B,BDYFCN,EPS0 EXTERNAL BDYFCN,CURVE C C LOCAL VARIABLES DOUBLE PRECISION LBASE(11),NBASE(11) DOUBLE PRECISION ZERO,TWO,SEVEN,EGHT DOUBLE PRECISION D1MACH,EP,EPS,FIW,FL,FN,RHOERR,U100 INTEGER I,J,K,II,ID2,ID3,ID4,ID5,ID6,ID7,ID8,ID9,ID10, + ID11,IEE,IER1,IER2,K_0,LB,LD1,LD2,LD3,LD4,LD5, + LD6,LD7,LD8,LD9,LD10,LD11,LU,M_0,N_0,NB,NFINAL, + NFFT,NU EXTERNAL D1MACH,EVALU,INTEQN INTRINSIC FLOAT,LOG,MAX,SIGN,SQRT COMMON /MACHCN/U100 COMMON /BLKEVL/K_0,M_0 COMMON /BLKINT/N_0 DATA ZERO/0.0D0/,TWO/2.0D0/,SEVEN/7.D0/,EGHT/8.0D0/ K_0 = 16 M_0 = 32 N_0 = 16 C C TEST THE INPUT PARAMETERS. C IF (EPS0 .LE. 0) THEN IER = -1 RETURN END IF IF (NWORK .LE. 0 .OR. MWORK .LT. + SQRT(FLOAT((NWORK+49)+8)) ) THEN IER = -2 RETURN END IF IF (B .LE. ZERO) THEN IER = -3 RETURN END IF IF ( (IE .LT. 0 .OR. IE .GT. 1) .OR. + (IBEG .LT. 0 .OR. IBEG .GT. 1) ) THEN IER = -4 RETURN END IF IF( NPTS .LE. 0) THEN IER = -5 RETURN END IF IF (MAXFFT .LT. M_0) THEN IER = -6 RETURN END IF C SET MACHINE DEPENDENT CONSTANT. U100 IS 100 TIMES C MACHINE UNIT ROUND. U100 = 100*D1MACH(4) EPS = EPS0 C IF(IBEG .EQ. 1) GO TO 10 EP = EPS/TWO C OBTAIN VALUE OF NUPPER FOR USE IN INTEQN FIW = NWORK FN = SQRT(FIW + SEVEN*SEVEN) - SEVEN IEE = LOG(FN)/LOG(TWO) + U100 NU = 2**IEE C BREAK UP WORK INTO VECTORS AND MATRICES FOR USE IN INTEQN. C PRODUCE RELATIVE ADDRESSES WITHIN WORK OF RHO,X,...,D2Y,OLDRHO. NBASE(1) = 1 NBASE(2) = 1 + NU*NU DO I = 3,11 NBASE(I) = NBASE(I-1) + NU END DO ID2 = NBASE(2) ID3 = NBASE(3) ID4 = NBASE(4) ID5 = NBASE(5) ID6 = NBASE(6) ID7 = NBASE(7) ID8 = NBASE(8) ID9 = NBASE(9) ID10 = NBASE(10) ID11 = NBASE(11) C CALL INTEQN(IOUT,IDBG,IE,CURVE,B,EP,BDYFCN,NU,WORK(ID2),RHOERR, + NFINAL,WORK(ID3),WORK(ID4),WORK(ID5),WORK(ID6), + WORK(ID7),WORK(ID8),WORK(ID9),WORK(ID10), + WORK(ID11),IWORK(16),WORK(1),IER1) IF (IDBG .EQ. 1) THEN WRITE (IOUT,9000) NFINAL,RHOERR,IER1 WRITE (IOUT,9010) DO I = 1,NFINAL WRITE (IOUT,9020) WORK(ID3+I-1),WORK(ID4+I-1),WORK(ID2+I-1) END DO END IF C IF (IER1 .EQ. 1) EP = RHOERR C OBTAIN LUPPER FOR USE IN EVALU. NFFT =MIN(4*NFINAL,MAXFFT) FL = (FIW-4.D0*NFFT)/EGHT IEE = LOG(FL)/LOG(TWO) + U100 LU = 2**IEE C OBTAIN RELATIVE ADDRESSES FOR BREAKING UP WORK FOR USE C IN EVALU. LBASE(1) = 1 DO I = 2,9 LBASE(I) = LBASE(I-1) + LU END DO LBASE(10)=LBASE(9) + NFFT LBASE(11)=LBASE(10) + NFFT LD1 = LBASE(1) LD2 = LBASE(2) LD3 = LBASE(3) LD4 = LBASE(4) LD5 = LBASE(5) LD6 = LBASE(6) LD7 = LBASE(7) LD8 = LBASE(8) LD9 = LBASE(9) LD10 = LBASE(10) LD11 = LBASE(11) C MOVE RHO,X,Y,...,D2Y,SPD AROUND IN WORK, LENGTHENING EACH OF C THEM. DO I = 1,8 IF(LBASE(I)+NFINAL-1 .GE. NBASE(I+2)) THEN DO K = I,8 II = I + 8 - K LB = LBASE(II) - 1 NB = NBASE(II+1) - 1 DO J = 1,NFINAL WORK(LB+J) = WORK(NB+J) END DO END DO GO TO 10 END IF LB = LBASE(I) - 1 NB = NBASE(I+1) - 1 DO J = 1,NFINAL WORK(LB+J) = WORK(NB+J) END DO END DO C 10 CALL EVALU(IOUT,IDBG,IE,CURVE,B,BDYFCN,NFINAL,WORK(LD1),EP, + WORK(LD2),WORK(LD3),WORK(LD4),WORK(LD5),WORK(LD6), + WORK(LD7),WORK(LD8),NFFT,WORK(LD9),WORK(LD10), + WORK(LD11),IWORK(1),LU,DPTS,NPTS,IBEG,UVEC,ERROR, + IER2) C IER = MAX(IER1,IER2) DO I = 1,NPTS ERROR(I) = ERROR(I) + SIGN(RHOERR,ERROR(I)) END DO IF(IER1 .EQ. 0) RETURN DO I = 1,NPTS IF (ERROR(I) .GT. ZERO) ERROR(I) = -ERROR(I) END DO RETURN 9000 FORMAT (/,' FROM NEUMAN: RESULTS FROM SUBROUTINE INTEQN.', + /,' NFINAL=',I3,5X,'RHOERR=',1P,E8.2,5X,'IER1=',I1,/) 9010 FORMAT (6X,'X',14X,'Y',19X,'RHO') 9020 FORMAT (1P,D12.4,D15.4,D25.12) END C SUBROUTINE EVALU(IOUT,IDBG,IE,CURVE,B,BDYFCN,N,RHO,EPS, + X,Y,DX,DY,D2X,D2Y,SPD,NF,RFFT,OLDFFT,W, + IFAC,LU,DPTS,NP,IBEG,U,ERROR,IER) C ---------------- C C This program evaluates the single layer potential U at the C given points in DPTS. The input is the density function RHO, C and DPTS at which U is evaluated. RHO is evaluated in the C subroutine INTEQN. These results are stored in U, along C with the predicted error bound in ERROR. The desired error C tolerance is EPS. If the desired error bound is not attained, C then the corresponding entry in ERROR is made negative. Its C magnitude is still an estimated error bound. C C IOUT Input. C The output unit number. C IDBG Input. C The debugging parameter. C = 0 produces a standard ouput. C = 1 produces a debugging parameter. C IE Input. C =0 for the interior Neumann problem. C =1 for the exterior Neumann problem. C CURVE External subroutine. C This program defines the curve of the boundary C. C B Input. C For the parameterization of C defined in CURVE, C the parameterization interval is [0,B]. C BDYFCN Input. C This program defines the Neumann data on the C boundary. C N Input. C This is NFINAL as output from the subroutine INTEQ. C RHO Input. C An array which contains the value of the single C layer density function defining U. C EPS Input. C The user-supplied absolute error tolerance. C X,Y Input. C Two arrays containing a sequence of points C (X(I),Y(I)) produced by calling the subroutine C NEWCUR. They correspond to an even subdivision C of the parameterization interval [0,B]. C DX,DY Input. C The derivative values corresponding to the points C given in X,Y. C D2X,D2Y Input. C The second derivative values corresponding to the C points given in X,Y. C SPD Input. C An array which contains SQRT(DX*DX+DY*DY). C NF Input. C The size of the array RFFT. NF .GE. 2*N. C RFFT Output. C An array which contains the discrete Fourier C coefficients of RHO. C W Input. C A work array which is needed in the fft subroutine. C IFAC Input. C An integer array which is needed in the fft subroutine. C LU Input. C The upper bound on the size of the arrays X,Y,DX,DY, C D2X,D2Y,SPD,RHO. C DPTS Input. C This is a two dimensional array which supplies the C points at which U is to be evaluated. C NP Input. C This is the number of points in DPTS. C IBEG Input. C =0 means this is a first call on NEUMAN for this C particular curve C, boundary function BDYFCN, and C error tolerance EPS. C =1 means that NEUMAN has been called previously for C this choice of parameters, and the solution U is C desired at a new set of points in DPTS. For such a C call on NEUMAN, change only DPTS, NPTS, and IBEG. C Do not change any other input variable. C U Output. C An output array which contains U(P) for points P C given in DPTS. C ERROR Output. C An output array which contains the predicted error C bound for the corresponding entries in U. C IER Output. C =0 means the program was completed satisfactorily. C =1 means some or all of the solution values in U do C not satisfy the error tolerance EPS. C INTEGER IBEG,IE,IER,IOUT,LU,N,NF,NP DOUBLE PRECISION D2X(LU),D2Y(LU),DPTS(4,NP),DX(LU),DY(LU), + ERROR(NP),OLDFFT(NF),RFFT(NF),RHO(LU),SPD(LU), + U(NP),W(2*NF),X(LU),Y(LU) INTEGER IFAC(15) DOUBLE PRECISION D1MACH,B,BDYFCN,EPS EXTERNAL BDYFCN,CURVE C C LOCAL VARIABLES DOUBLE PRECISION BDCON,DIFF,DIST,ERR,ERRFFT,FCNK,FCNM,FCNU,FUEVAL, + H,HH,OLDIFF,OLDU,ORHO,PASTRT,PI,PX,PY, + R,RATIO,RATE,RTLOW,RTUP,S,SINE,COEF,COSN,SING, + SUM,T1,T2,THETA,TT,U100 DOUBLE PRECISION ZERO,ONE,TWO,FOUR INTEGER I,IBD,J,K,KH,KK,KSTEP,K_0,L,LB,LD,LDM1,LOOP,M_0, + IDBG, JH, JLOOP EXTERNAL FUCOEF,NEWCUR,FUEVAL INTRINSIC ABS,LOG,MAX,MIN,SIN,SQRT COMMON /MACHCN/U100 COMMON /BLKEVL/K_0,M_0 DATA ZERO/0.0D0/,ONE/1.0D0/,FOUR/4.D0/,RTUP/0.5D0/, + RTLOW/.1D0/,TWO/2.0D0/ C C K_0 IS THE INITIAL DEGREE OF THE FOURIER SERIES EXPANSION TO BE C USED IN THE APPROXIMATION OF THE DENSITY FUNCTION. C M_0 DENOTES THE INITIAL NUMBER OF INTEGRATION NODES TO BE USED C IN THE EVALUATION OF THE SINGLE LAYER POTENTIAL. THESE OPERATIONS C WILL ALSO BE PERFORMED WITH THE PARAMETER 2*K_0 and 2*M_0, SO THAT C THE VALUE OF NWORK IN THE CALLING PROGRAM NEEDS TO BE SET C ACCORDINGLY. ALWAYS SET K_0 AND M_0 TO BE A POWER OF 2. C C STAGE 1: EVALUATE THE FOURIER COEFFICIENTS OF RHO. C INITIALIZE. LD IS THE RUNNING DIMENSION OF RHO,X,...,D2Y. LB C IS THE RUNNING DIMENSION OF THE FOURIER COEFFICIENT VECTOR RFFT. C LB CAN BE AS BIG AS NF, WHERE NF IS INPUT FROM NEUMAN AND IS C SET TO BE MIN(4*NFINAL,MAXFFT) WITH MAXFFT SET BY THE USER ON C CALLING SUBROUTINE NEUMAN. C C DATA 'PI' PI = FOUR*ATAN(ONE) IF (IDBG .EQ. 1) THEN WRITE(IOUT,9000) WRITE(IOUT,9010) END IF IF (IBEG .GT. 0) GO TO 40 RATE = RTUP LD = N LB = K_0 LOOP = 1 DO I = 1,LD RHO(I) = RHO(I)*SPD(I) END DO PASTRT=RTUP C EVALUATE THE FOURIER COEFFICIENTS OF RHO*SPD FOR LATER USE. C FIRST ASSIGN THE INTERPOLATING POINTS TO RFFT. AFTER C CALLING FUCOEF, RFFT CONTAINS THE THE FOURIER COEFFICIENTS. 10 KSTEP = LD/LB DO J = 1, LB-1 JH = J*KSTEP RFFT(J+1) = RHO(JH) END DO RFFT(1) = RHO(LD) CALL FUCOEF(LB,RFFT,W,IFAC) DIFF = ZERO IF (LOOP .EQ. 1) GO TO 20 C ESTIMATE THE ERROR IN THE FFT DO I = 1, LB/2 COEF = ONE/I IF (I .LT. LB/4) THEN COSN = RFFT(2*I) -OLDFFT(2*I) SINE = RFFT(2*I+1) -OLDFFT(2*I+1) ELSE IF (I. EQ. LB/4) THEN COSN = RFFT(2*I) - OLDFFT(2*I)/2 SINE = RFFT(2*I+1) ELSE IF (I .LT. LB/2) THEN COSN = RFFT(2*I) SINE = RFFT(2*I+1) ELSE COSN = RFFT(LB)/2 SINE = ZERO END IF DIFF = DIFF + TWO*COEF*SQRT(COSN*COSN + SINE*SINE) END DO IF (LOOP .EQ. 2) GO TO 20 C UPDATE THE RATE OF CONVERGENCE OF THE FFT RATE = MAX(PASTRT,RTLOW,MIN(RTUP,ABS(DIFF/OLDIFF))) PASTRT = MIN(RTUP,ABS(DIFF/OLDIFF)) ERRFFT = RATE/(ONE-RATE)*DIFF IF (IDBG .EQ. 1) THEN WRITE(IOUT, 9020) LB, LD,DIFF, ERRFFT, RATE END IF IF (ERRFFT .LT. EPS/20) GO TO 30 20 OLDIFF = MAX(D1MACH(4), DIFF) DO I = 1, LB OLDFFT(I) = RFFT(I) END DO LB = 2*LB LOOP = LOOP + 1 IF ((LB .LE. LD) .AND. (LB .LE. NF)) GO TO 10 C AN INSUFFICIENT NUMBER OF VALUES IN RHO. THUS VALUES OF RHO ON C A FINER MESH MUST BE CREATED. LD = 2*LD IF (LD .GT. NF) THEN LD = LD/2 LB = LB/2 LOOP = LOOP - 1 GO TO 30 END IF C THERE IS SUFFICIENT SPACE IN RHO,X,Y,...,D2Y FOR AN C INCREASED SUB-DIVISION OF (0,B). MOVE OLD VALUES OF C RHO,...,D2Y TO MAKE ROOM FOR NEW VALUES. DO J = 2,LD,2 K = LD + 2 - J KH = K/2 RHO(K) = RHO(KH) X(K) = X(KH) Y(K) = Y(KH) DX(K) = DX(KH) DY(K) = DY(KH) D2X(K) = D2X(KH) D2Y(K) = D2Y(KH) SPD(K) = SPD(KH) END DO C PRODUCE NEW CURVE PARAMETERS FOR FINER SUBDIVISION. H = B/LD LDM1 = LD - 1 DO J = 1, LDM1, 2 S = J*H CALL NEWCUR(IE,CURVE,S,X(J),Y(J),DX(J),DY(J),D2X(J), + D2Y(J)) SPD(J) = SQRT(DX(J)*DX(J)+DY(J)*DY(J)) END DO C PRODUCE NEW VALUES OF RHO. HH = B/N KSTEP = LD/N DO J = 1,LDM1,2 SUM = ZERO DO K = KSTEP,LD,KSTEP T1 = X(J) - X(K) T2 = Y(J) - Y(K) FCNK = (DY(J)*T1-DX(J)*T2)/ ((T1*T1+T2*T2)*SPD(J)) SUM = SUM + FCNK*RHO(K) END DO IF(IE .EQ. 1) THEN C FOR THE EXTERIOR PROBLEM BDCON = BDYFCN(J*H) ELSE C FOR THE INTERIOR PROBLEM R = X(J)**2 + Y(J)**2 BDCON = -ONE/R*BDYFCN(J*H) END IF ORHO = - (BDCON+HH*SUM)/PI RHO(J) = ORHO*SPD(J) END DO GO TO 10 30 CONTINUE IF (IDBG .EQ. 1) THEN WRITE(IOUT,9030) WRITE(IOUT,9040) RFFT(1) WRITE(IOUT,9050) (I, RFFT(2*I), RFFT(2*I +1),I=1,LB/2-1) WRITE(IOUT,9060) LB/2, RFFT(LB) WRITE(IOUT,9070) END IF C C STAGE2: BEGIN LOOP TO EVALUATE U AT POINTS P IN DPTS. C 40 IER = 0 DO I = 1,NP PX = DPTS(1,I) PY = DPTS(2,I) IBD = DPTS(4,I) IF (IBD.NE.0) THETA = DPTS(3,I) C IF IT IS AN INTERIOR PROBLEM. CHANGE THE DPTS BY USING C KELVIN TRANSFORMATION. IF DPTS=(0,0), THEN ASSIGN SOME BIG C NUMBERS FOR (PX,PY). IF(IE .EQ. 0) THEN R = PX*PX + PY*PY IF(R .LT. U100) THEN R = U100 PX = 1.D0/R PY = 1.D0/R ELSE PX = PX/R PY = PY/R END IF END IF IF (IDBG .EQ. 1) THEN WRITE (IOUT,9080) I,DPTS(1,I),DPTS(2,I),THETA,IBD,LD END IF C C NOW BEGIN EVALUATION OF U(PX,PY) USING NUMERICAL INTEGRATION. C INITIALIZE, AND BEGIN WITH M_0 NODES. RATE = RTUP L = M_0 LOOP = 1 JLOOP = 1 PASTRT = RTUP C CALCULATE NUMERICAL INTEGRAL WITH L SUBDIVISIONS OF (0,B). 50 SUM = ZERO KSTEP = LD/L H = B/L DO K = KSTEP,LD,KSTEP KK = K/KSTEP S = KK*H T1 = X(K) - PX T2 = Y(K) - PY DIST = SQRT(T1*T1+T2*T2) C IF DPTS IS A BOUNDARY POINT(IBD=1), THE INTEGRAND HAS A C SINGULARITY AT S=THETA. DIVIDE THE INTEGRAND INTO TWO PARTS. C FCNM IS THE SMOOTH PART, AND SING IS THE SINGULAR PART. IF(IBD .EQ. 1) THEN IF(THETA .EQ. S) THEN TT = SQRT(DX(K)*DX(K)+DY(K)*DY(K)) FCNM = LOG(TT) ELSE TT = DIST/ABS(TWO*SIN((THETA-S)/TWO)) FCNM = LOG(TT) END IF ELSE FCNM = LOG(DIST) END IF FCNM = -FCNM*RHO(K) SUM = SUM + FCNM END DO IF(IBD .EQ. 1) THEN SING = PI*FUEVAL(B,THETA,RFFT,LB) ELSE SING = ZERO END IF FCNU = H*SUM + SING IF (IDBG. EQ. 1) THEN WRITE (IOUT,9090) FCNU,L,LD END IF IF(LOOP .EQ. 1) GO TO 80 C ESTIMATE ERROR IN FCNU. DIFF = ABS(FCNU-OLDU) IF(LOOP .EQ. 2) GO TO 60 C UPDATE RATE OF CONVERGENCE OF NUMERICAL INTEGRATION. RATIO = ABS(DIFF/OLDIFF) C RATE=MAX(PASTRT,RTLOW,MIN(RTUP,RATIO)) PASTRT = MIN(RTUP,RATIO) 60 ERR = (RATE/ (ONE-RATE))*DIFF IF (IDBG. EQ. 1) THEN WRITE (IOUT,9100) DIFF,ERR,RATE END IF IF (ERR .GT. EPS) GO TO 70 C THE VALUE OF FCNU IS SUFFICIENTLY ACCURATE. U(I) = FCNU ERROR(I) = ERR IF (IBD .EQ. 1) THEN ERROR(I) = ERR + ERRFFT IF (ERROR(I) .GT. EPS) THEN ERROR(I) = -ERROR(I) IER = 1 END IF END IF GO TO 100 C FCNU IS NOT SUFFICIENTLY ACCURATE. C RE-INITIALIZE FOR ANOTHER NUMERICAL INTEGRATION. 70 OLDIFF = MAX(DIFF,D1MACH(4)) 80 OLDU = FCNU LOOP = LOOP + 1 L = 2*L IF(L .LE. LD) GO TO 50 C NOT SUFFICIENT VALUES IN RHO. THUS VALUES OF RHO ON A FINER C MESH MUST BE CREATED. LD = 2*LD IF(LD .GT. LU) GO TO 90 C THERE IS SUFFICIENT SPACE IN RHO,X,Y,...,D2Y FOR AN C INCREASED SUB-DIVISION OF (0,B). MOVE OLD VALUES OF C RHO,...,D2Y TO MAKE ROOM FOR NEW VALUES. DO J = 2,LD,2 K = LD + 2 - J KH = K/2 RHO(K) = RHO(KH) X(K) = X(KH) Y(K) = Y(KH) DX(K) = DX(KH) DY(K) = DY(KH) D2X(K) = D2X(KH) D2Y(K) = D2Y(KH) SPD(K) = SPD(KH) END DO C PRODUCE NEW CURVE PARAMETERS FOR FINER SUBDIVISION. H = B/LD LDM1 = LD - 1 DO J = 1,LDM1,2 S = J*H CALL NEWCUR(IE,CURVE,S,X(J),Y(J),DX(J),DY(J),D2X(J),D2Y(J)) SPD(J) = SQRT(DX(J)*DX(J)+DY(J)*DY(J)) END DO C PRODUCE NEW VALUES OF RHO. HH = B/N KSTEP = LD/N DO J = 1,LDM1,2 SUM = ZERO DO K = KSTEP,LD,KSTEP T1 = X(J) - X(K) T2 = Y(J) - Y(K) FCNK = (DY(J)*T1-DX(J)*T2)/ ((T1*T1+T2*T2)*SPD(J)) SUM = SUM + FCNK*RHO(K) END DO IF(IE .EQ. 1) THEN C FOR THE EXTERIOR PROBLEM BDCON = BDYFCN(J*H) ELSE C FOR THE INTERIOR PROBLEM R = X(J)**2 + Y(J)**2 BDCON = -ONE/R*BDYFCN(J*H) END IF ORHO = - (BDCON+HH*SUM)/PI RHO(J) = ORHO*SPD(J) END DO GO TO 50 C THE UPPER LIMITS FOR RHO,X,Y,...,D2Y HAVE BEEN REACHED. C MARK ERROR BOUND ACCORDINGLY AND CONTINUE ONTO NEXT POINT P. 90 ERROR(I) = -ERR U(I) = FCNU IER = 1 LD = LD/2 ERROR(I) = - ERR IF (IBD .EQ. 1) ERROR(I) = - (ERR + ERRFFT) 100 END DO RETURN 9000 FORMAT (/,' FROM SUBROUTINE EVALU.',/) 9010 FORMAT (/,' STAGE 1: FOURIER COEFFICIENTS.',/) 9020 FORMAT (' LB =', I4, 3X, 'LD = ', I4, 3X, 'DIFF =', 1PD9.2, 3X, * 'ERROR =', D9.2, 3X, 'RATE =', 1D9.2) 9030 FORMAT (/,10X,'COEFF. OF COSINE',11X,'COEFF. OF SINE') 9040 FORMAT (/,2X,' 0',3X,E20.12) 9050 FORMAT (1X, I3,3X,E20.12,5X,E20.12) 9060 FORMAT (1X, I3,3X,E20.12) 9070 FORMAT (/,'STAGE2: EVALUATE U(P)', /) 9080 FORMAT (/,' I=',I2,3X,'PX=',1PD11.4,3X,'PY=',D11.4,3X, + 'THETA=',D11.4,3X,'IBD=',I1,3X,'LD=',I5) 9090 FORMAT (' NUM INT =',1P,E20.12,5X,'L=',I6,5X,'LD=',I6) 9100 FORMAT (5X,'DIFF=',1PE9.2,5X,' ERROR=',D9.2,5X,'RATE=',D11.4) END C SUBROUTINE FUCOEF(N,R,W,IFAC) C ----------------- C C This generates approximate Fourier coefficients for RHO, C with the calculations done with an FFT program. C C The input is R(1),R(2),...R(N), which contain RHO at N evenly C space points in the interval [0,2*pi], with R(i) = i*2*pi/N. C The output is R(1)...R(2*N), which contains the Fourier C coefficients. The array W is workspace for the FFT. C C Inputs: N, R, W, IFAC C Outputs: R C INTEGER J,N DOUBLE PRECISION R(N),W(2*N) INTEGER IFAC(15) EXTERNAL DRFFTF,DRFFTI C CALL DRFFTI(N,W,IFAC) CALL DRFFTF(N,R,W,IFAC) DO 20 J = 1,N R(J) = R(J)/FLOAT(N) 20 CONTINUE RETURN END DOUBLE PRECISION FUNCTION FUEVAL(B,S,R,N) C --------------------------------- C C Evaluate the singular part of the integral for the single C layer potential, evaluated at points on the boundary curve C. C The input are the Fourier coefficients R(1)...R(N) which is C evaluated in subroutine FUCOEF. C C Inputs: B, S, R, N C Output: FUEVAL C INTEGER I,M,N DOUBLE PRECISION R(N) DOUBLE PRECISION B,COEF,COSN,S,SINE,PI INTRINSIC COS,SIN,ATAN C PI = 4.D0*ATAN(1.D0) M = N/2 SINE = 0.D0 COSN = 0.D0 DO 10 I = 1,M-1 COEF = 1.D0/I COSN = COSN + COEF*R(2*I)*COS(I*S*2*PI/B) SINE = SINE + COEF*R(2*I+1)*SIN(I*S*2*PI/B) 10 CONTINUE FUEVAL= 2.D0*(-SINE + COSN) + R(N)*COS(M*S*2*PI/B)/M RETURN END C SUBROUTINE INTEQN(IOUT,IDBG,IE,CURVE,B,EPS,BDYFCN,NUPPER,RHO, + ERROR,NFINAL,X,Y,DX,DY,D2X,D2Y,SPD,OLDRHO, + WORK,IWORK,KERMAT,IER) C ----------------- C C This program solves the second kind boundary integral equation C which arises from solving the exterior Neumann problem as a C single layer potential. C C The integral equation is solved using Nystrom's method with C the rectangular rule as the quadrature rule. The resulting C linear system is solved directly using LINPACK routines. C C The output is the single layer density function RHO. This C is to be found with such accuracy that the resulting harmonic C function has an accuracy of EPS. C C This routine assumes the boundary C is at least two times C continuously differentiable. The boundary C is defined by C the subroutine CURVE. C C The present routine calculates with the rectangular rule for C N=4,8,16,... until a sufficiently accurate value of RHO is C obtained. This is subject to N .LE. NUPPER, with the latter C based on the size of the vector WORK supplied by the user in C calling NEUMAN. C C IOUT Input. C The output unit number, to the file NEUMAN.ANS C IDBG Input. C The debugging parameter. C = 0 produces a standard ouput. C = 1 produces a debugging parameter. C IE Input. C =0 for the interior Neumann problem. C =1 for the exterior Neumann problem. C CURVE External subroutine. C This program defines the curve of the boundary C. C B Input. C For the parameterization of C defined in CURVE, C the parameterization interval is [0,B]. C EPS Input. C The user-supplied absolute error tolerance. C BDYFCN External function. C This program defines the Neumann data on the boundary. C NUPPER Input. C This is the upper bound for the size of linear C system that can be constructed and solved. C RHO Output. C An array which contains the value of the single C layer density function defining U. C ERROR Output. C This is the predicted error estimate for RHO. C NFINAL Output. C This is the dimension of the final linear system C constructed in solving for RHO. C X,Y Output. C Two arrays containing a sequence of points c (X(I),Y(I)) produced by calling the subroutine C NEWCUR. They correspond to an even subdivision C of the parameterization interval [0,B]. C DX,DY Output. C The derivative values corresponding to the points C given in X,Y. C D2X,D2Y Output. C The second derivative values corresponding to the C points given in X,Y. C SPD Output. C An array which contains SQRT(DX*DX+DY*DY). C OLDRHO Output. C An array containing the preceding value of RHO, C also produced in this program. C WORK Output. C This is a work array used in the LAPACK routine. C IWORK Output. C This is an array for pivoting used in the LAPACK routine. C KERMAT Output. C This is array contains the linear system associated C with the Nystrom method. C IER Output. C =0 means the program was completed satisfactorily. C =1 means the desired error uniform error bound EPS C for the solution RHO was not attained. C INTEGER IE,IER,INFO,IOUT,NFINAL,NUPPER DOUBLE PRECISION D2X(NUPPER),D2Y(NUPPER),DX(NUPPER),DY(NUPPER), + KERMAT(NUPPER,NUPPER),OLDRHO(NUPPER), + RHO(NUPPER),SPD(NUPPER), + X(NUPPER),Y(NUPPER) DOUBLE PRECISION D1MACH,B,BDYFCN,EPS,ERROR EXTERNAL BDYFCN,CURVE,NEWCUR C C VARIABLES FOR THE LAPACK ROUTINES. DOUBLE PRECISION WORK(4*NUPPER) INTEGER IWORK(NUPPER), NRHS, IDBG C C LOCAL VARIABLES DOUBLE PRECISION DIFF,DIST,H,OLDIFF,PI,R,RATE,RCOND, + RTLOW,RTUP,SUM,SUMAX,T1,T2 DOUBLE PRECISION ZERO, ONE, TWO, FOUR INTEGER I,J,JH,N,NM1,N_0 INTRINSIC ABS,LOG,MAX,MIN,SQRT COMMON /BLKINT/N_0 DATA RTLOW/.1D0/,RTUP/.5D0/,ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/, + FOUR/4.D0/, NRHS/1/ C C THE PARAMETER N_0 GIVES THE INITIAL NUMBER OF QUADRATURE POINTS C USED IN THE APPROXIMATION OF THE INTEGRAL EQUATION. THE EQUATION C WILL ALSO BE SOLVED WITH 2*N_0 NODES. IN THE PROGRAM CALLING C NEUMAN, THE PARAMETER NWORK SHOULD BE SET ACCORDING. ALWAYS SET C N_0 TO BE A POWER OF 2. C C INITIAL CASE, N=N_0. INITIALIZE PARAMETERS. IF (IDBG .EQ. 1) THEN WRITE (IOUT,9000) END IF C DATA 'PI' PI = FOUR*ATAN(ONE) N = N_0 RATE = RTUP C DEFINE STEPSIZE AND POINTS ON CURVE. H = B/N DO I = 1,N CALL NEWCUR(IE,CURVE,I*H,X(I),Y(I),DX(I),DY(I),D2X(I), + D2Y(I)) SPD(I) = SQRT(DX(I)*DX(I)+DY(I)*DY(I)) END DO GO TO 20 C DEFINE H AND POINTS ON CURVE FOR CONTINUING LOOP ON N. 10 H = B/N DO I = 2,N,2 J = N + 2 - I JH = J/2 X(J) = X(JH) Y(J) = Y(JH) DX(J) = DX(JH) DY(J) = DY(JH) D2X(J) = D2X(JH) D2Y(J) = D2Y(JH) SPD(J) = SPD(JH) END DO NM1 = N - 1 DO I = 1,NM1,2 CALL NEWCUR(IE,CURVE,I*H,X(I),Y(I),DX(I),DY(I),D2X(I), + D2Y(I)) SPD(I) = SQRT(DX(I)*DX(I)+DY(I)*DY(I)) END DO C SET UP MATRIX EQUATION, AND EVALUATE THE MAXIMUM NORM OF C SINGLE LAYER POTENTIAL TO BE USED IN ERROR ESTIMATE. C HERE 'SUM' REPRESENTS THE NORM. 20 SUMAX = ZERO DO I = 1,N IF(IE .EQ. 1) THEN C BOUNDARY CONDITION FOR THE EXTERIOR PROBLEM RHO(I) = BDYFCN(I*H) ELSE C BOUNDARY CONDITION FOR THE INTERIOR PROBLEM R = X(I)**2 + Y(I)**2 RHO(I) = -ONE/R*BDYFCN(I*H) END IF SUM = ZERO DO J = 1,N IF(I .EQ. J) THEN C DEFINE KERNEL FOR T(I) = T(J). T1 = DX(I) T2 = DY(I) DIST = T1*T1 + T2*T2 KERMAT(I,I) = -PI - H* (T1*D2Y(I)-T2*D2X(I))/ + (TWO*DIST) ELSE C DEFINE KERNEL FOR T(I) .NE. T(J) T1 = X(I) - X(J) T2 = Y(I) - Y(J) DIST = T1*T1 + T2*T2 KERMAT(I,J) = -H* (DY(I)*T1-DX(I)*T2)*SPD(J)/ + (SPD(I)*DIST) SUM = SUM + ABS(LOG(DIST))*SPD(J) END IF SUM = H*SUM END DO SUMAX = MAX(SUMAX,SUM) END DO C SOLVE LINEAR SYSTEM. CALL DGESV(N,NRHS,KERMAT,NUPPER,IWORK,RHO,NUPPER,INFO) CALL DGECON('I',N,KERMAT,NUPPER,SUMAX,RCOND,WORK, + IWORK,INFO) IF(N .EQ. N_0) GO TO 40 C CALCULATE NORM OF RHO-OLDRHO. DIFF = ZERO DO I = 2,N,2 DIFF = MAX(DIFF,ABS(RHO(I)-OLDRHO(I/2))) END DO IF(N .EQ. 2*N_0) GO TO 30 C MEASURE RATE OF CONVERGENCE. RATE = DIFF/OLDIFF RATE = MAX(RTLOW,MIN(RATE,RTUP)) C ESTIMATE ERROR IN RHO. 30 ERROR = (ONE/RCOND)*SUM*DIFF*RATE/ (ONE-RATE) IF (IDBG .EQ. 1) THEN WRITE(IOUT,9010) N,DIFF,ERROR END IF IF(ERROR .LE. EPS) THEN C EXIT FOR SUCCESSFUL RETURN. NFINAL = N IER = 0 RETURN ELSE IF (2*N .GT. NUPPER) THEN C EXIT FOR UNSUCCESSFUL RETURN. IER = 1 NFINAL = N RETURN END IF C PREPARE FOR ANOTHER LOOP ON N. OLDIFF = MAX(DIFF,D1MACH(4)) 40 DO I = 1,N OLDRHO(I) = RHO(I) END DO N = 2*N GO TO 10 9000 FORMAT (/,' FROM SUBROUTINE INTEQN') 9010 FORMAT (' N=',I3,5X,'DIFF=',1PD8.2,5X,'ERROR=',D8.2) END C SUBROUTINE NEWCUR(IE,CURVE,S,X,Y,DX,DY,D2X,D2Y) C ----------------- C C Define a new curve if the given problem is an interior C Neumann problem(IE=0), using the Kelvin transformation. C C Inputs: IE, S C External subroutine: CURVE C Outputs: X, Y, X, Y, DX, DY, D2X, D2Y C DOUBLE PRECISION D2X,D2Y,DX,DY,S,X,Y INTEGER IE EXTERNAL CURVE, KVTRNF DOUBLE PRECISION D2TX,D2TY,DTX,DTY,TX,TY CALL CURVE(S,X,Y,DX,DY,D2X,D2Y) IF (IE .EQ. 0) THEN CALL KVTRNF(X,Y,DX,DY,D2X,D2Y,TX,DTX,D2TX) CALL KVTRNF(Y,X,DY,DX,D2Y,D2X,TY,DTY,D2TY) X = TX Y = TY DX = DTX DY = DTY D2X = D2TX D2Y = D2TY END IF RETURN END C SUBROUTINE KVTRNF(X,Y,DX,DY,D2X,D2Y,TX,TDX,TD2X) C ----------------- C C Define the Kelvin transformation. If we disposition C X's and Y's, we have TY, TDY, TD2Y which are the C transformed values of Y, DY, D2Y. C C Inputs: X, Y, DX, DY, D2X, D2Y C Outputs: TX, TDX, TD2X C DOUBLE PRECISION D2X,D2Y,DX,DY,TD2X,TDX,TX,X,Y DOUBLE PRECISION DIST,T1,T2,XS,YS XS = X*X YS = Y*Y DIST = XS + YS TX = X/DIST TDX = (DX* (YS-XS)-2.D0*X*Y*DY)/ (DIST*DIST) T1 = D2X* (YS*YS-XS*XS) - 2.D0*X* (XS+YS)* (DY*DY+DX*DX+Y*D2Y) T2 = -4.D0* (X*DX+Y*DY)* (DX* (YS-XS)-2.D0*X*Y*DY) TD2X = (T1+T2)/DIST**3 RETURN END SHAR_EOF fi # end of overwriting check if test -f 'rfft_pack.f' then echo shar: will not over-write existing file "'rfft_pack.f'" else cat << SHAR_EOF > 'rfft_pack.f' C THESE ARE SUBROUTINES FOR CALCULATING THE REAL FAST FOURIER C FORWARD TRANSFORMATION. THESE ROUTINE ARE TAKEN FROM THE C PACK FFTPACK WRITTEN BY PAUL SWARZTRAUBER OF THE NATIONAL C CENTER FOR ATMOSPHERIC RESEARCH. SUBROUTINE DRFFTI (N,WSAVE,IFAC) DOUBLE PRECISION WSAVE(*) INTEGER IFAC(*), N IF (N .EQ. 1) RETURN CALL DRFFTI1 (N,WSAVE(N+1),IFAC) RETURN END SUBROUTINE DRFFTI1 (N,WA,IFAC) INTEGER K1, I1, II DOUBLE PRECISION WA(*) INTEGER IFAC(*),N, NTRYH(4) C LOCAL VARIABLES DOUBLE PRECISION ARG,ARGH,ARGLD,FI,PI INTEGER I,IB,IDO,IP,IPM,IS,J,L1,L2,LD,NF,NFM1,NL,NQ,NR,NTRY INTRINSIC ATAN, COS DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ C DATA 'PI' PI=4.0D0*ATAN(1.0D0) NL = N NF = 0 J = 0 101 J = J+1 IF (J-4) 102,102,103 102 NTRY = NTRYH(J) GO TO 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ IF (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ IF (NTRY .NE. 2) GO TO 107 IF (NF .EQ. 1) GO TO 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 CONTINUE IFAC(3) = 2 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF ARGH = 2.D0*PI/FLOAT(N) IS = 0 NFM1 = NF-1 L1 = 1 IF (NFM1 .EQ. 0) RETURN DO 110 K1=1,NFM1 IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IPM = IP-1 DO 109 J=1,IPM LD = LD+L1 I = IS ARGLD = FLOAT(LD)*ARGH FI = 0.D0 DO 108 II=3,IDO,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 CONTINUE IS = IS+IDO 109 CONTINUE L1 = L2 110 CONTINUE RETURN END SUBROUTINE DRFFTF (N,R,WSAVE,IFAC) DOUBLE PRECISION R(*),WSAVE(*) INTEGER IFAC(*),N IF (N .EQ. 1) RETURN CALL DRFFTF1 (N,R,WSAVE,WSAVE(N+1),IFAC) RETURN END SUBROUTINE DRFFTF1 (N,C,CH,WA,IFAC) DOUBLE PRECISION CH(*),C(*),WA(*) INTEGER IFAC(*),N,K1 C LOCAL VARIABLES INTEGER I,IX2,IX3,IX4,IDO,IDL1,IP,IW,KH,L1,L2,NA,NF NF = IFAC(2) NA = 1 L2 = N IW = N DO 111 K1=1,NF KH = NF-K1 IP = IFAC(KH+3) L1 = L2/IP IDO = N/L2 IDL1 = IDO*L1 IW = IW-(IP-1)*IDO NA = 1-NA IF (IP .NE. 4) GO TO 102 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL DRADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 110 101 CALL DRADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) GO TO 110 102 IF (IP .NE. 2) GO TO 104 IF (NA .NE. 0) GO TO 103 CALL DRADF2 (IDO,L1,C,CH,WA(IW)) GO TO 110 103 CALL DRADF2 (IDO,L1,CH,C,WA(IW)) GO TO 110 104 IF (IP .NE. 3) GO TO 106 IX2 = IW+IDO IF (NA .NE. 0) GO TO 105 CALL DRADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 110 105 CALL DRADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) GO TO 110 106 IF (IP .NE. 5) GO TO 108 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 107 CALL DRADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 107 CALL DRADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 108 IF (IDO .EQ. 1) NA = 1-NA IF (NA .NE. 0) GO TO 109 CALL DRADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) NA = 1 GO TO 110 109 CALL DRADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) NA = 0 110 L2 = L1 111 CONTINUE IF (NA .EQ. 1) RETURN DO 112 I=1,N C(I) = CH(I) 112 CONTINUE RETURN END SUBROUTINE DRADF2 (IDO,L1,CC,CH,WA1) INTEGER IDO,L1 DOUBLE PRECISION CH(IDO,2,L1),CC(IDO,L1,2),WA1(*) C LOCAL VARIABLES DOUBLE PRECISION TI2,TR2 INTEGER I,IC,IDP2,K DO 101 K=1,L1 CH(1,1,K) = CC(1,K,1)+CC(1,K,2) CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 DO 104 K=1,L1 DO 103 I=3,IDO,2 IC = IDP2-I TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(1,2,K) = -CC(IDO,K,2) CH(IDO,1,K) = CC(IDO,K,1) 106 CONTINUE 107 RETURN END SUBROUTINE DRADF3 (IDO,L1,CC,CH,WA1,WA2) INTEGER IDO,L1 DOUBLE PRECISION CH(IDO,3,L1),CC(IDO,L1,3),WA1(*),WA2(*) C LOCAL VARIABLES DOUBLE PRECISION CR2,DR2,DI2,DR3,DI3,TAUR,TAUI,TI2,TI3,TR2,TR3 INTEGER IDP2,IC,K,I, CI2 INTRINSIC SQRT C DATA 'TAUR, TAUI' TAUR = -.5D0 TAUI = SQRT(3.D0)/2.D0 DO 101 K=1,L1 CR2 = CC(1,K,2)+CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2 CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE DRADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) INTEGER IDO,L1 DOUBLE PRECISION CC(IDO,L1,4),CH(IDO,4,L1),WA1(*),WA2(*),WA3(*) C LOCAL VARIABLES DOUBLE PRECISION HSQT2,CI2,CI3,CI4,CR2,CR3,CR4,TI1,TI2,TI3,TI4, + TR1,TR2,TR3,TR4 INTEGER IC,IDP2,K,I INTRINSIC SQRT HSQT2 = SQRT(2.D0)/2.D0 DO 101 K=1,L1 TR1 = CC(1,K,2)+CC(1,K,4) TR2 = CC(1,K,1)+CC(1,K,3) CH(1,1,K) = TR1+TR2 CH(IDO,4,K) = TR2-TR1 CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) CH(1,3,K) = CC(1,K,4)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 DO 104 K=1,L1 DO 103 I=3,IDO,2 IC = IDP2-I CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 CONTINUE DO 106 K=1,L1 TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) CH(IDO,1,K) = TR1+CC(IDO,K,1) CH(IDO,3,K) = CC(IDO,K,1)-TR1 CH(1,2,K) = TI1-CC(IDO,K,3) CH(1,4,K) = TI1+CC(IDO,K,3) 106 CONTINUE 107 RETURN END SUBROUTINE DRADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) INTEGER IDO,L1 DOUBLE PRECISION CC(IDO,L1,5),CH(IDO,5,L1), + WA1(*),WA2(*),WA3(*),WA4(*) C LOCAL VARIABLES DOUBLE PRECISION CI2,CI3,CI4,CI5,CR2,CR3,CR4,CR5,DI2, + DI3,DI4,DI5,DR2,DR3,DR4,DR5,PI,TI11,TI12,TI2,TI3, + TI4, TI5, TR11,TR12,TR2,TR3,TR4,TR5 INTEGER IC,IDP2,K,I C C DATA FOR 'PI, TR11, TI11, TR12, TI12' PI = 4.D0*ATAN(1.0 D0) TR11 = COS( 2.D0*PI/5.D0) TI11 = COS(PI/10.D0) TR12 = -COS(PI/5.D0) TI12 = COS(3.D0*PI/10.D0) C DO 101 K=1,L1 CR2 = CC(1,K,5)+CC(1,K,2) CI5 = CC(1,K,5)-CC(1,K,2) CR3 = CC(1,K,4)+CC(1,K,3) CI4 = CC(1,K,4)-CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2+CR3 CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 CH(1,3,K) = TI11*CI5+TI12*CI4 CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 CH(1,5,K) = TI12*CI5-TI11*CI4 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE DRADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) INTEGER IDO,IDL1,IP,L1 DOUBLE PRECISION CH(IDO,L1,IP),CC(IDO,IP,L1),C1(IDO,L1,IP), + C2(IDL1,IP),CH2(IDL1,IP),WA(*) C LOCAL VARIABLES DOUBLE PRECISION AI1,AI2,AR1,AR1H,AR2,AR2H,ARG,DC2,DCP, + DS2,DSP,PI INTEGER I,IDIJ,IDP2,IK,IPPH,IPP2,IS,J,J2,JC,LC,NBD,K, + L, IC C DATA 'PI' PI=4.0D0*ATAN(1.0D0) ARG = 2.0D0*PI/FLOAT(IP) DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 IPP2 = IP+2 IDP2 = IDO+2 NBD = (IDO-1)/2 IF (IDO .EQ. 1) GO TO 119 DO 101 IK=1,IDL1 CH2(IK,1) = C2(IK,1) 101 CONTINUE DO 103 J=2,IP DO 102 K=1,L1 CH(1,K,J) = C1(1,K,J) 102 CONTINUE 103 CONTINUE IF (NBD .GT. L1) GO TO 107 IS = -IDO DO 106 J=2,IP IS = IS+IDO IDIJ = IS DO 105 I=3,IDO,2 IDIJ = IDIJ+2 DO 104 K=1,L1 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 104 CONTINUE 105 CONTINUE 106 CONTINUE GO TO 111 107 IS = -IDO DO 110 J=2,IP IS = IS+IDO DO 109 K=1,L1 IDIJ = IS DO 108 I=3,IDO,2 IDIJ = IDIJ+2 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 108 CONTINUE 109 CONTINUE 110 CONTINUE 111 IF (NBD .LT. L1) GO TO 115 DO 114 J=2,IPPH JC = IPP2-J DO 113 K=1,L1 DO 112 I=3,IDO,2 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 112 CONTINUE 113 CONTINUE 114 CONTINUE GO TO 121 115 DO 118 J=2,IPPH JC = IPP2-J DO 117 I=3,IDO,2 DO 116 K=1,L1 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 116 CONTINUE 117 CONTINUE 118 CONTINUE GO TO 121 119 DO 120 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 120 CONTINUE 121 DO 123 J=2,IPPH JC = IPP2-J DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) 122 CONTINUE 123 CONTINUE C AR1 = 1.0D0 AI1 = 0.0D0 DO 127 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 124 IK=1,IDL1 CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) CH2(IK,LC) = AI1*C2(IK,IP) 124 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 126 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 125 IK=1,IDL1 CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE DO 129 J=2,IPPH DO 128 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+C2(IK,J) 128 CONTINUE 129 CONTINUE C IF (IDO .LT. L1) GO TO 132 DO 131 K=1,L1 DO 130 I=1,IDO CC(I,1,K) = CH(I,K,1) 130 CONTINUE 131 CONTINUE GO TO 135 132 DO 134 I=1,IDO DO 133 K=1,L1 CC(I,1,K) = CH(I,K,1) 133 CONTINUE 134 CONTINUE 135 DO 137 J=2,IPPH JC = IPP2-J J2 = J+J DO 136 K=1,L1 CC(IDO,J2-2,K) = CH(1,K,J) CC(1,J2-1,K) = CH(1,K,JC) 136 CONTINUE 137 CONTINUE IF (IDO .EQ. 1) RETURN IF (NBD .LT. L1) GO TO 141 DO 140 J=2,IPPH JC = IPP2-J J2 = J+J DO 139 K=1,L1 DO 138 I=3,IDO,2 IC = IDP2-I CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 138 CONTINUE 139 CONTINUE 140 CONTINUE RETURN 141 DO 144 J=2,IPPH JC = IPP2-J J2 = J+J DO 143 I=3,IDO,2 IC = IDP2-I DO 142 K=1,L1 CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 142 CONTINUE 143 CONTINUE 144 CONTINUE RETURN END SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. # End of shell archive exit 0